6 unshift @INC, "modules/override"; # Use our own versions of various modules (e.g. YAML).
7 push @INC, "modules/fallback"; # Only use our own versions of modules if there's no system version.
10 use CGI qw( -no_xhtml);
13 use Digest::MD5 qw(md5_hex);
14 use English qw( -no_match_vars );
16 use List::MoreUtils qw(none);
17 use List::UtilsBy qw(partition_by);
19 use Rose::DB::Object 0.809;
26 use SL::InstanceConfiguration;
30 use SL::DB::Helper::ALL;
31 use SL::DB::Helper::Mappings;
33 my %blacklist = SL::DB::Helper::Mappings->get_blacklist;
34 my %package_names = SL::DB::Helper::Mappings->get_package_names;
40 our $script = __FILE__;
43 $OUTPUT_AUTOFLUSH = 1;
44 $Data::Dumper::Sortkeys = 1;
46 our $meta_path = "SL/DB/MetaSetup";
47 our $manager_path = "SL/DB/Manager";
51 # Maps column names in tables to foreign key relationship names. For
54 # »follow_up_access« contains a column named »who«. Rose normally
55 # names the resulting relationship after the class the target table
56 # uses. In this case the target table is »employee« and the
57 # corresponding class SL::DB::Employee. The resulting relationship
58 # would be named »employee«.
60 # In order to rename this relationship we have to map »who« to
62 # follow_up_access => { who => 'granted_by' },
64 our %foreign_key_name_map = (
66 oe => { payment_id => 'payment_terms', },
67 ar => { payment_id => 'payment_terms', },
68 ap => { payment_id => 'payment_terms', },
70 orderitems => { parts_id => 'part', trans_id => 'order', },
71 delivery_order_items => { parts_id => 'part' },
72 invoice => { parts_id => 'part' },
73 follow_ups => { created_for_user => 'created_for', created_by => 'created_by', },
74 follow_up_access => { who => 'with_access', what => 'to_follow_ups_by', },
76 periodic_invoices_configs => { oe_id => 'order' },
77 reconciliation_links => { acc_trans_id => 'acc_trans' },
83 SL::LxOfficeConf->read;
85 my $client = $config{client} || $::lx_office_conf{devel}{client};
86 my $new_client = $config{new_client};
88 if (!$client && !$new_client) {
89 error("No client found in config. Please provide a client:");
93 $::lxdebug = LXDebug->new();
94 $::lxdebug->disable_sub_tracing;
95 $::locale = Locale->new("de");
97 $::instance_conf = SL::InstanceConfiguration->new;
98 $form->{script} = 'rose_meta_data.pl';
101 $::auth = SL::Auth->new(unit_tests_database => 1);
103 drop_and_create_test_database();
105 $::auth = SL::Auth->new();
108 if (!$::auth->set_client($client)) {
109 error("No client with ID or name '$client' found in config. Please provide a client:");
113 foreach (($meta_path, $manager_path)) {
118 sub fix_relationship_names {
119 my ($domain, $table, $fkey_text) = @_;
121 if ($fkey_text !~ m/key_columns \s+ => \s+ \{ \s+ ['"]? ( [^'"\s]+ ) /x) {
122 die "fix_relationship_names: could not extract the key column for domain/table $domain/$table; foreign key definition text:\n${fkey_text}\n";
125 my $column_name = $1;
126 my %changes = map { %{$_} } grep { $_ } ($foreign_key_name_map{$domain}->{ALL}, $foreign_key_name_map{$domain}->{$table});
128 if (my $desired_name = $changes{$column_name}) {
129 $fkey_text =~ s/^ \s\s [^\s]+ \b/ ${desired_name}/msx;
136 my ($domain, $table, $package) = @_;
138 ($schema, $table) = split(m/\./, $table) if $table =~ m/\./;
139 $package = ucfirst($package || $table);
140 $package =~ s/_+(.)/uc($1)/ge;
141 my $meta_file = "${meta_path}/${package}.pm";
142 my $mngr_file = "${manager_path}/${package}.pm";
143 my $file = "SL/DB/${package}.pm";
145 my $schema_str = $schema ? <<CODE : '';
146 __PACKAGE__->meta->schema('$schema');
150 package SL::DB::AUTO::$package;
152 use base qw(SL::DB::Object);
154 __PACKAGE__->meta->table('$table');
156 __PACKAGE__->meta->auto_initialize;
161 error("Error in execution for table '$table'");
162 error("'$EVAL_ERROR'") unless $config{quiet};
166 my %args = (indent => 2, use_setup => 0);
168 my $definition = "SL::DB::AUTO::$package"->meta->perl_class_definition(%args);
169 $definition =~ s/\n+__PACKAGE__->meta->initialize;\n+/\n\n/;
170 $definition =~ s/::AUTO::/::/g;
173 # Sort column definitions alphabetically
174 if ($definition =~ m/__PACKAGE__->meta->columns\( \n (.+?) \n \);/msx) {
175 my ($start, $end) = ($-[1], $+[1]);
176 my $sorted_columns = join "\n", sort split m/\n/, $1;
177 substr $definition, $start, $end - $start, $sorted_columns;
181 my $foreign_key_definition = "SL::DB::AUTO::$package"->meta->perl_foreign_keys_definition(%args);
182 $foreign_key_definition =~ s/::AUTO::/::/g;
184 if ($foreign_key_definition && ($definition =~ /\Q$foreign_key_definition\E/)) {
185 # These positions refer to the whole setup call, not just the
186 # parameters/actual relationship definitions.
187 my ($start, $end) = ($-[0], $+[0]);
189 # Match the function parameters = the actual relationship
191 next unless $foreign_key_definition =~ m/\(\n(.+)\n\)/s;
193 my ($list_start, $list_end) = ($-[0], $+[0]);
195 # Split the whole chunk on double new lines. The resulting
196 # elements are one relationship each. Then fix the relationship
197 # names and sort them by their new names.
198 my @new_foreign_keys = sort map { fix_relationship_names($domain, $table, $_) } split m/\n\n/m, $1;
200 # Replace the function parameters = the actual relationship
201 # definitions with the new ones.
202 my $sorted_foreign_keys = "(\n" . join("\n\n", @new_foreign_keys) . "\n)";
203 substr $foreign_key_definition, $list_start, $list_end - $list_start, $sorted_foreign_keys;
205 # Replace the whole setup call in the auto-generated output with
207 substr $definition, $start, $end - $start, $foreign_key_definition;
210 $definition =~ s/(meta->table.*)\n/$1\n$schema_str/m if $schema;
212 my $full_definition = <<CODE;
213 # This file has been auto-generated. Do not modify it; it will be overwritten
214 # by $::script automatically.
218 my $meta_definition = <<CODE;
219 # This file has been auto-generated only because it didn't exist.
220 # Feel free to modify it at will; it will not be overwritten automatically.
222 package SL::DB::${package};
226 use SL::DB::MetaSetup::${package};
227 use SL::DB::Manager::${package};
229 __PACKAGE__->meta->initialize;
234 my $file_exists = -f $meta_file;
236 my $old_size = -s $meta_file;
237 my $orig_file = do { local(@ARGV, $/) = ($meta_file); <> };
238 my $old_md5 = md5_hex($orig_file);
239 my $new_size = length $full_definition;
240 my $new_md5 = md5_hex($full_definition);
241 if ($old_size == $new_size && $old_md5 eq $new_md5) {
242 notice("No changes in $meta_file, skipping.") unless $config{quiet};
246 show_diff(\$orig_file, \$full_definition) if $config{show_diff};
249 if (!$config{nocommit}) {
250 open my $out, ">", $meta_file || die;
251 print $out $full_definition;
254 notice("File '$meta_file' " . ($file_exists ? 'updated' : 'created') . " for table '$table'");
258 if (!$config{nocommit}) {
259 open my $out, ">", $file || die;
260 print $out $meta_definition;
263 notice("File '$file' created as well.");
265 return if -f $mngr_file;
267 if (!$config{nocommit}) {
268 open my $out, ">", $mngr_file || die;
270 # This file has been auto-generated only because it didn't exist.
271 # Feel free to modify it at will; it will not be overwritten automatically.
273 package SL::DB::Manager::${package};
277 use SL::DB::Helper::Manager;
278 use base qw(SL::DB::Helper::Manager);
280 sub object_class { 'SL::DB::${package}' }
282 __PACKAGE__->make_manager_methods;
288 notice("File '$mngr_file' created as well.");
294 'client=s' => \ my $client,
295 'test-client' => \ my $use_test_client,
298 'no-commit|dry-run' => \ my $nocommit,
299 help => sub { pod2usage(verbose => 99, sections => 'NAME|SYNOPSIS|OPTIONS') },
300 quiet => \ my $quiet,
304 $options->{client} = $client;
305 $options->{new_client} = $use_test_client;
306 $options->{all} = $all;
307 $options->{db} = $db;
308 $options->{nocommit} = $nocommit;
309 $options->{quiet} = $quiet;
310 $options->{color} = -t STDOUT ? 1 : 0;
313 if (eval { require Text::Diff; 1 }) {
314 $options->{show_diff} = 1;
316 error('Could not load Text::Diff. Sorry, no diffs for you.');
322 my ($text_a, $text_b) = @_;
329 Text::Diff::diff($text_a, $text_b, { OUTPUT => sub {
330 for (split /\n/, $_[0]) {
331 if ($config{color}) {
332 print colored($_, $colors{substr($_, 0, 1)}), $/;
341 pod2usage(verbose => 99, sections => 'SYNOPSIS');
345 my %tables_by_domain;
347 my @domains = $config{db} ? (uc $config{db}) : sort keys %package_names;
349 foreach my $domain (@domains) {
350 my $db = SL::DB::create(undef, $domain);
351 $tables_by_domain{$domain} = [ grep { my $table = $_; none { $_ eq $table } @{ $blacklist{$domain} } } $db->list_tables ];
356 %tables_by_domain = partition_by {
357 my ($domain, $table) = split m{:};
358 $table ? uc($domain) : 'KIVITENDO';
361 foreach my $tables (values %tables_by_domain) {
362 s{.*:}{} for @{ $tables };
366 error("You specified neither --all nor any specific tables.");
370 return %tables_by_domain;
374 print STDERR colored(shift, 'red'), $/;
381 sub check_errors_in_package_names {
382 foreach my $domain (sort keys %package_names) {
383 my @both = grep { $package_names{$domain}->{$_} } @{ $blacklist{$domain} || [] };
386 print "Error: domain '$domain': The following table names are present in both the black list and the package name hash: ", join(' ', sort @both), "\n";
391 sub drop_and_create_test_database {
392 my $db_cfg = $::lx_office_conf{'testing/database'} || die 'testing/database missing';
395 'dbi:Pg:dbname=' . $db_cfg->{template} . ';host=' . $db_cfg->{host} . ';port=' . $db_cfg->{port},
398 SL::DBConnect->get_options,
402 my $dbh_template = SL::DBConnect->connect(@dbi_options) || BAIL_OUT("No database connection to the template database: " . $DBI::errstr);
403 my $auth_dbh = $::auth->dbconnect(1);
406 notice("Database exists; dropping");
407 $auth_dbh->disconnect;
409 dbh_do($dbh_template, "DROP DATABASE \"" . $db_cfg->{db} . "\"", message => "Database could not be dropped");
414 notice("Creating database");
416 dbh_do($dbh_template, "CREATE DATABASE \"" . $db_cfg->{db} . "\" TEMPLATE \"" . $db_cfg->{template} . "\" ENCODING 'UNICODE'", message => "Database could not be created");
417 $dbh_template->disconnect;
419 notice("Creating initial schema");
422 'dbi:Pg:dbname=' . $db_cfg->{db} . ';host=' . $db_cfg->{host} . ';port=' . $db_cfg->{port},
425 SL::DBConnect->get_options(PrintError => 0, PrintWarn => 0),
428 my $dbh = SL::DBConnect->connect(@dbi_options) || BAIL_OUT("Database connection failed: " . $DBI::errstr);
429 $::auth->{dbh} = $dbh;
430 my $dbupdater = SL::DBUpgrade2->new(form => $::form, return_on_error => 1, silent => 1);
431 my $coa = 'Germany-DATEV-SKR03EU';
433 apply_dbupgrade($dbupdater, $dbh, "sql/lx-office.sql");
434 apply_dbupgrade($dbupdater, $dbh, "sql/${coa}-chart.sql");
436 dbh_do($dbh, qq|UPDATE defaults SET coa = '${coa}', accounting_method = 'cash', profit_determination = 'income', inventory_system = 'periodic', curr = 'EUR'|);
437 dbh_do($dbh, qq|CREATE TABLE schema_info (tag TEXT, login TEXT, itime TIMESTAMP DEFAULT now(), PRIMARY KEY (tag))|);
439 notice("Creating initial auth schema");
441 $dbupdater = SL::DBUpgrade2->new(form => $::form, return_on_error => 1, auth => 1);
442 apply_dbupgrade($dbupdater, $dbh, 'sql/auth_db.sql');
444 apply_upgrades(auth => 1, dbh => $dbh);
446 notice("Creating client, user, group and employee");
448 dbh_do($dbh, qq|DELETE FROM auth.clients|);
449 dbh_do($dbh, qq|INSERT INTO auth.clients (id, name, dbhost, dbport, dbname, dbuser, dbpasswd, is_default) VALUES (1, 'Unit-Tests', ?, ?, ?, ?, ?, TRUE)|,
450 bind => [ @{ $db_cfg }{ qw(host port db user password) } ]);
451 dbh_do($dbh, qq|INSERT INTO auth."user" (id, login) VALUES (1, 'unittests')|);
452 dbh_do($dbh, qq|INSERT INTO auth."group" (id, name) VALUES (1, 'Vollzugriff')|);
453 dbh_do($dbh, qq|INSERT INTO auth.clients_users (client_id, user_id) VALUES (1, 1)|);
454 dbh_do($dbh, qq|INSERT INTO auth.clients_groups (client_id, group_id) VALUES (1, 1)|);
455 dbh_do($dbh, qq|INSERT INTO auth.user_group (user_id, group_id) VALUES (1, 1)|);
458 default_printer_id => '',
459 template_format => '',
461 email => 'unit@tester',
463 dateformat => 'dd.mm.yy',
464 show_form_details => '',
465 name => 'Unit Tester',
467 hide_cvar_search_options => '',
468 numberformat => '1.000,00',
474 stylesheet => 'lx-office-erp.css',
475 mandatory_departments => 0,
479 my $sth = $dbh->prepare(qq|INSERT INTO auth.user_config (user_id, cfg_key, cfg_value) VALUES (1, ?, ?)|) || BAIL_OUT($dbh->errstr);
480 dbh_do($dbh, $sth, bind => [ $_, $config{$_} ]) for sort keys %config;
483 $sth = $dbh->prepare(qq|INSERT INTO auth.group_rights (group_id, "right", granted) VALUES (1, ?, TRUE)|) || BAIL_OUT($dbh->errstr);
484 dbh_do($dbh, $sth, bind => [ $_ ]) for sort $::auth->all_rights;
487 dbh_do($dbh, qq|INSERT INTO employee (id, login, name) VALUES (1, 'unittests', 'Unit Tester')|);
489 $::auth->set_client(1) || BAIL_OUT("\$::auth->set_client(1) failed");
490 %::myconfig = $::auth->read_user(login => 'unittests');
492 apply_upgrades(dbh => $dbh);
497 my $dbupdater = SL::DBUpgrade2->new(form => $::form, return_on_error => 1, auth => $params{auth});
498 my @unapplied_scripts = $dbupdater->unapplied_upgrade_scripts($params{dbh});
500 my $all = @unapplied_scripts;
502 for my $script (@unapplied_scripts) {
504 print "\rUpgrade $i/$all";
505 apply_dbupgrade($dbupdater, $params{dbh}, $script);
510 sub apply_dbupgrade {
511 my ($dbupdater, $dbh, $control_or_file) = @_;
513 my $file = ref($control_or_file) ? ("sql/Pg-upgrade2" . ($dbupdater->{auth} ? "-auth" : "") . "/$control_or_file->{file}") : $control_or_file;
514 my $control = ref($control_or_file) ? $control_or_file : undef;
516 my $error = $dbupdater->process_file($dbh, $file, $control);
518 die("Error applying $file: $error") if $error;
522 my ($dbh, $query, %params) = @_;
525 return if $query->execute(@{ $params{bind} || [] });
529 return if $dbh->do($query, undef, @{ $params{bind} || [] });
531 die($params{message} . ": " . $dbh->errstr) if $params{message};
532 die("Query failed: " . $dbh->errstr . " ; query: $query");
535 parse_args(\%config);
537 check_errors_in_package_names();
539 my %tables_by_domain = make_tables();
541 foreach my $domain (keys %tables_by_domain) {
542 my @tables = @{ $tables_by_domain{$domain} };
543 my @unknown_tables = grep { !$package_names{$domain}->{$_} } @tables;
544 if (@unknown_tables) {
545 error("The following tables do not have entries in \%SL::DB::Helper::Mappings::${domain}_package_names: " . join(' ', sort @unknown_tables));
549 process_table($domain, $_, $package_names{$domain}->{$_}) for @tables;
560 rose_auto_create_model - mana Rose::DB::Object classes for kivitendo
564 scripts/rose_auto_create_model.pl OPTIONS TARGET
566 # use other client than devel.client
567 scripts/rose_auto_create_model.pl --test-client TARGET
568 scripts/rose_auto_create_model.pl --client name-or-id TARGET
572 scripts/rose_auto_create_model.pl --all [--db db]
574 # updates only customer table, login taken from config
575 scripts/rose_auto_create_model.pl customer
577 # updates only parts table, package will be Part
578 scripts/rose_auto_create_model.pl parts=Part
580 # try to update parts, but don't do it. tell what would happen in detail
581 scripts/rose_auto_create_model.pl --no-commit parts
585 Rose::DB::Object comes with a nice function named auto initialization with code
586 generation. The documentation of Rose describes it like this:
588 I<[...] auto-initializing metadata at runtime by querying the database has many
589 caveats. An alternate approach is to query the database for metadata just once,
590 and then generate the equivalent Perl code which can be pasted directly into
591 the class definition in place of the call to auto_initialize.>
593 I<Like the auto-initialization process itself, perl code generation has a
594 convenient wrapper method as well as separate methods for the individual parts.
595 All of the perl code generation methods begin with "perl_", and they support
596 some rudimentary code formatting options to help the code conform to you
597 preferred style. Examples can be found with the documentation for each perl_*
600 I<This hybrid approach to metadata population strikes a good balance between
601 upfront effort and ongoing maintenance. Auto-generating the Perl code for the
602 initial class definition saves a lot of tedious typing. From that point on,
603 manually correcting and maintaining the definition is a small price to pay for
604 the decreased start-up cost, the ability to use the class in the absence of a
605 database connection, and the piece of mind that comes from knowing that your
606 class is stable, and won't change behind your back in response to an "action at
607 a distance" (i.e., a database schema update).>
609 Unfortunately this reads easier than it is, since classes need to go into the
610 right package and directory, certain stuff needs to be adjusted and table names
611 need to be translated into their class names. This script will wrap all that
612 behind a few simple options.
614 In the most basic version, just give it a login and a table name, and it will
615 load the schema information for this table and create the appropriate class
616 files, or update them if already present.
618 Each table has three associated files. A C<SL::DB::MetaSetup::*>
619 class, which is a perl version of the schema definition, a
620 C<SL::DB::*> class file and a C<SL::DB::Manager::*> manager class
621 file. The first one will be updated if the schema changes, the second
622 and third ones will only be created if it they do not exist.
624 =head1 DATABASE NAMES AND TABLES
626 If you want to generate the data for specific tables only then you
627 have to list them on the command line. The format is
628 C<db-name:table-name>. The part C<db-name:> is optional and defaults
629 to C<KIVITENDO:> – which means the tables in the default kivitendo
632 Valid database names are keys in the hash returned by
633 L<SL::DB::Helper::Mappings/get_package_names>.
639 =item C<--test-client, -t>
641 Use the C<testing/database> to create a new testing database, and connect to
642 the first client there. Overrides C<client>.
644 If neither C<test-client> nor C<client> are set, the config key C<devel/client>
647 =item C<--client, -c CLIENT>
649 Provide a client whose database settings are used. C<CLIENT> can be either a
650 database ID or a client's name.
652 If neither C<test-client> nor C<client> are set, the config key C<devel/client>
657 Process all tables from the database. Only those that are blacklistes in
658 L<SL::DB::Helper::Mappings> are excluded.
662 In combination with C<--all> causes all tables in the specific
663 database to be processed, not in all databases.
665 =item C<--no-commit, -n>
669 Do not write back generated files. This will do everything as usual but not
670 actually modify any file.
674 Displays diff for selected file, if file is present and newer file is
675 different. Beware, does not imply C<--no-commit>.
683 Does not print extra information, such as skipped files that were not
684 changed and errors where the auto initialization failed.
694 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>,
695 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>