8 unshift(@INC, $FindBin::Bin . '/../modules/override'); # Use our own versions of various modules (e.g. YAML).
9 push (@INC, $FindBin::Bin . '/..'); # '.' will be removed from @INC soon.
12 use CGI qw( -no_xhtml);
15 use Digest::MD5 qw(md5_hex);
16 use English qw( -no_match_vars );
18 use List::MoreUtils qw(apply none uniq);
19 use List::UtilsBy qw(partition_by);
21 use Rose::DB::Object 0.809;
28 use SL::InstanceConfiguration;
32 use SL::DB::Helper::ALL;
33 use SL::DB::Helper::Mappings;
35 chdir($FindBin::Bin . '/..');
37 my %blacklist = SL::DB::Helper::Mappings->get_blacklist;
38 my %package_names = SL::DB::Helper::Mappings->get_package_names;
44 our $script = __FILE__;
47 $OUTPUT_AUTOFLUSH = 1;
48 $Data::Dumper::Sortkeys = 1;
50 our $meta_path = "SL/DB/MetaSetup";
51 our $manager_path = "SL/DB/Manager";
55 # Maps column names in tables to foreign key relationship names. For
58 # »follow_up_access« contains a column named »who«. Rose normally
59 # names the resulting relationship after the class the target table
60 # uses. In this case the target table is »employee« and the
61 # corresponding class SL::DB::Employee. The resulting relationship
62 # would be named »employee«.
64 # In order to rename this relationship we have to map »who« to
66 # follow_up_access => { who => 'granted_by' },
68 our %foreign_key_name_map = (
70 oe => { payment_id => 'payment_terms', },
71 ar => { payment_id => 'payment_terms', },
72 ap => { payment_id => 'payment_terms', },
74 orderitems => { parts_id => 'part', trans_id => 'order', },
75 delivery_order_items => { parts_id => 'part' },
76 invoice => { parts_id => 'part' },
77 follow_ups => { created_for_user => 'created_for_employee', created_by => 'created_by_employee', },
78 follow_up_access => { who => 'with_access', what => 'to_follow_ups_by', },
80 periodic_invoices_configs => { oe_id => 'order', email_recipient_contact_id => 'email_recipient_contact' },
81 reconciliation_links => { acc_trans_id => 'acc_trans' },
83 assembly => { parts_id => 'part', id => 'assembly_part' },
84 assortment_items => { parts_id => 'part' },
86 dunning => { trans_id => 'invoice', fee_interest_ar_id => 'fee_interest_invoice' },
92 SL::LxOfficeConf->read;
94 my $client = $config{client} || $::lx_office_conf{devel}{client};
95 my $new_client = $config{new_client};
97 if (!$client && !$new_client) {
98 error("No client found in config. Please provide a client:");
102 $::lxdebug = LXDebug->new();
103 $::lxdebug->disable_sub_tracing;
104 $::locale = Locale->new("de");
106 $::instance_conf = SL::InstanceConfiguration->new;
107 $form->{script} = 'rose_meta_data.pl';
110 $::auth = SL::Auth->new(unit_tests_database => 1);
112 drop_and_create_test_database();
114 $::auth = SL::Auth->new();
117 if (!$::auth->set_client($client)) {
118 error("No client with ID or name '$client' found in config. Please provide a client:");
122 foreach (($meta_path, $manager_path)) {
127 sub fix_relationship_names {
128 my ($domain, $table, $fkey_text) = @_;
130 if ($fkey_text !~ m/key_columns \s+ => \s+ \{ \s+ ['"]? ( [^'"\s]+ ) /x) {
131 die "fix_relationship_names: could not extract the key column for domain/table $domain/$table; foreign key definition text:\n${fkey_text}\n";
134 my $column_name = $1;
135 my %changes = map { %{$_} } grep { $_ } ($foreign_key_name_map{$domain}->{ALL}, $foreign_key_name_map{$domain}->{$table});
137 if (my $desired_name = $changes{$column_name}) {
138 $fkey_text =~ s/^ \s\s [^\s]+ \b/ ${desired_name}/msx;
145 my ($domain, $table, $package) = @_;
147 ($schema, $table) = split(m/\./, $table) if $table =~ m/\./;
148 $package = ucfirst($package || $table);
149 $package =~ s/_+(.)/uc($1)/ge;
150 my $meta_file = "${meta_path}/${package}.pm";
151 my $mngr_file = "${manager_path}/${package}.pm";
152 my $file = "SL/DB/${package}.pm";
154 my $schema_str = $schema ? <<CODE : '';
155 __PACKAGE__->meta->schema('$schema');
159 package SL::DB::AUTO::$package;
160 use parent qw(SL::DB::Object);
162 __PACKAGE__->meta->table('$table');
164 __PACKAGE__->meta->auto_initialize;
169 error("Error in execution for table '$table'");
170 error("'$EVAL_ERROR'") unless $config{quiet};
174 my %args = (indent => 2, use_setup => 0);
176 my $definition = "SL::DB::AUTO::$package"->meta->perl_class_definition(%args);
177 $definition =~ s/\n+__PACKAGE__->meta->initialize;\n+/\n\n/;
178 $definition =~ s/::AUTO::/::/g;
181 # Sort column definitions alphabetically
182 if ($definition =~ m/__PACKAGE__->meta->columns\( \n (.+?) \n \);/msx) {
183 my ($start, $end) = ($-[1], $+[1]);
184 my $sorted_columns = join "\n", sort split m/\n/, $1;
185 substr $definition, $start, $end - $start, $sorted_columns;
189 my $foreign_key_definition = "SL::DB::AUTO::$package"->meta->perl_foreign_keys_definition(%args);
190 $foreign_key_definition =~ s/::AUTO::/::/g;
192 if ($foreign_key_definition && ($definition =~ /\Q$foreign_key_definition\E/)) {
193 # These positions refer to the whole setup call, not just the
194 # parameters/actual relationship definitions.
195 my ($start, $end) = ($-[0], $+[0]);
197 # Match the function parameters = the actual relationship
199 next unless $foreign_key_definition =~ m/\(\n(.+)\n\)/s;
201 my ($list_start, $list_end) = ($-[0], $+[0]);
203 # Split the whole chunk on double new lines. The resulting
204 # elements are one relationship each. Then fix the relationship
205 # names and sort them by their new names.
206 my @new_foreign_keys = sort map { fix_relationship_names($domain, $table, $_) } split m/\n\n/m, $1;
208 # Replace the function parameters = the actual relationship
209 # definitions with the new ones.
210 my $sorted_foreign_keys = "(\n" . join("\n\n", @new_foreign_keys) . "\n)";
211 substr $foreign_key_definition, $list_start, $list_end - $list_start, $sorted_foreign_keys;
213 # Replace the whole setup call in the auto-generated output with
215 substr $definition, $start, $end - $start, $foreign_key_definition;
218 $definition =~ s/(meta->table.*)\n/$1\n$schema_str/m if $schema;
219 $definition =~ s{^use base}{use parent}m;
221 my $full_definition = <<CODE;
222 # This file has been auto-generated. Do not modify it; it will be overwritten
223 # by $::script automatically.
227 my $meta_definition = <<CODE;
228 # This file has been auto-generated only because it didn't exist.
229 # Feel free to modify it at will; it will not be overwritten automatically.
231 package SL::DB::${package};
235 use SL::DB::MetaSetup::${package};
236 use SL::DB::Manager::${package};
238 __PACKAGE__->meta->initialize;
243 my $file_exists = -f $meta_file;
245 my $old_size = -s $meta_file;
246 my $orig_file = do { local(@ARGV, $/) = ($meta_file); <> };
247 my $old_md5 = md5_hex($orig_file);
248 my $new_size = length $full_definition;
249 my $new_md5 = md5_hex($full_definition);
250 if ($old_size == $new_size && $old_md5 eq $new_md5) {
251 notice("No changes in $meta_file, skipping.") unless $config{quiet};
255 show_diff(\$orig_file, \$full_definition) if $config{show_diff};
258 if (!$config{nocommit}) {
259 open my $out, ">", $meta_file || die;
260 print $out $full_definition;
263 notice("File '$meta_file' " . ($file_exists ? 'updated' : 'created') . " for table '$table'");
267 if (!$config{nocommit}) {
268 open my $out, ">", $file || die;
269 print $out $meta_definition;
272 notice("File '$file' created as well.");
274 return if -f $mngr_file;
276 if (!$config{nocommit}) {
277 open my $out, ">", $mngr_file || die;
279 # This file has been auto-generated only because it didn't exist.
280 # Feel free to modify it at will; it will not be overwritten automatically.
282 package SL::DB::Manager::${package};
286 use parent qw(SL::DB::Helper::Manager);
288 sub object_class { 'SL::DB::${package}' }
290 __PACKAGE__->make_manager_methods;
296 notice("File '$mngr_file' created as well.");
302 'client=s' => \ my $client,
303 'test-client' => \ my $use_test_client,
306 'no-commit|dry-run' => \ my $nocommit,
307 help => sub { pod2usage(verbose => 99, sections => 'NAME|SYNOPSIS|OPTIONS') },
308 quiet => \ my $quiet,
312 $options->{client} = $client;
313 $options->{new_client} = $use_test_client;
314 $options->{all} = $all;
315 $options->{db} = $db;
316 $options->{nocommit} = $nocommit;
317 $options->{quiet} = $quiet;
318 $options->{color} = -t STDOUT ? 1 : 0;
321 if (eval { require Text::Diff; 1 }) {
322 $options->{show_diff} = 1;
324 error('Could not load Text::Diff. Sorry, no diffs for you.');
330 my ($text_a, $text_b) = @_;
337 Text::Diff::diff($text_a, $text_b, { OUTPUT => sub {
338 for (split /\n/, $_[0]) {
339 if ($config{color}) {
340 print colored($_, $colors{substr($_, 0, 1)}), $/;
349 pod2usage(verbose => 99, sections => 'SYNOPSIS');
352 sub list_all_tables {
355 my @schemas = (undef, uniq apply { s{\..*}{} } grep { m{\.} } keys %{ $package_names{KIVITENDO} });
358 foreach my $schema (@schemas) {
359 $db->schema($schema);
360 push @tables, map { $schema ? "${schema}.${_}" : $_ } $db->list_tables;
369 my %tables_by_domain;
371 my @domains = $config{db} ? (uc $config{db}) : sort keys %package_names;
373 foreach my $domain (@domains) {
374 my $db = SL::DB::create(undef, $domain);
375 $tables_by_domain{$domain} = [ grep { my $table = $_; none { $_ eq $table } @{ $blacklist{$domain} } } list_all_tables($db) ];
380 %tables_by_domain = partition_by {
381 my ($domain, $table) = split m{:};
382 $table ? uc($domain) : 'KIVITENDO';
385 foreach my $tables (values %tables_by_domain) {
386 s{.*:}{} for @{ $tables };
390 error("You specified neither --all nor any specific tables.");
394 return %tables_by_domain;
398 print STDERR colored(shift, 'red'), $/;
405 sub check_errors_in_package_names {
406 foreach my $domain (sort keys %package_names) {
407 my @both = grep { $package_names{$domain}->{$_} } @{ $blacklist{$domain} || [] };
410 print "Error: domain '$domain': The following table names are present in both the black list and the package name hash: ", join(' ', sort @both), "\n";
415 sub drop_and_create_test_database {
416 my $db_cfg = $::lx_office_conf{'testing/database'} || die 'testing/database missing';
419 'dbi:Pg:dbname=' . $db_cfg->{template} . ';host=' . $db_cfg->{host} . ';port=' . $db_cfg->{port},
422 SL::DBConnect->get_options,
426 my $dbh_template = SL::DBConnect->connect(@dbi_options) || BAIL_OUT("No database connection to the template database: " . $DBI::errstr);
427 my $auth_dbh = $::auth->dbconnect(1);
430 notice("Database exists; dropping");
431 $auth_dbh->disconnect;
433 dbh_do($dbh_template, "DROP DATABASE \"" . $db_cfg->{db} . "\"", message => "Database could not be dropped");
436 notice("Creating database");
438 dbh_do($dbh_template, "CREATE DATABASE \"" . $db_cfg->{db} . "\" TEMPLATE \"" . $db_cfg->{template} . "\" ENCODING 'UNICODE'", message => "Database could not be created");
439 $dbh_template->disconnect;
441 notice("Creating initial schema");
444 'dbi:Pg:dbname=' . $db_cfg->{db} . ';host=' . $db_cfg->{host} . ';port=' . $db_cfg->{port},
447 SL::DBConnect->get_options(PrintError => 0, PrintWarn => 0),
450 my $dbh = SL::DBConnect->connect(@dbi_options) || BAIL_OUT("Database connection failed: " . $DBI::errstr);
451 $::auth->{dbh} = $dbh;
452 my $dbupdater = SL::DBUpgrade2->new(form => $::form, return_on_error => 1, silent => 1);
453 my $coa = 'Germany-DATEV-SKR03EU';
455 apply_dbupgrade($dbupdater, $dbh, "sql/lx-office.sql");
456 apply_dbupgrade($dbupdater, $dbh, "sql/${coa}-chart.sql");
458 dbh_do($dbh, qq|UPDATE defaults SET coa = '${coa}', accounting_method = 'cash', profit_determination = 'income', inventory_system = 'periodic', curr = 'EUR'|);
459 dbh_do($dbh, qq|CREATE TABLE schema_info (tag TEXT, login TEXT, itime TIMESTAMP DEFAULT now(), PRIMARY KEY (tag))|);
461 notice("Creating initial auth schema");
463 $dbupdater = SL::DBUpgrade2->new(form => $::form, return_on_error => 1, auth => 1);
464 apply_dbupgrade($dbupdater, $dbh, 'sql/auth_db.sql');
466 apply_upgrades(auth => 1, dbh => $dbh);
470 notice("Creating client, user, group and employee");
472 dbh_do($dbh, qq|DELETE FROM auth.clients|);
473 dbh_do($dbh, qq|INSERT INTO auth.clients (id, name, dbhost, dbport, dbname, dbuser, dbpasswd, is_default) VALUES (1, 'Unit-Tests', ?, ?, ?, ?, ?, TRUE)|,
474 bind => [ @{ $db_cfg }{ qw(host port db user password) } ]);
475 dbh_do($dbh, qq|INSERT INTO auth."user" (id, login) VALUES (1, 'unittests')|);
476 dbh_do($dbh, qq|INSERT INTO auth."group" (id, name) VALUES (1, 'Vollzugriff')|);
477 dbh_do($dbh, qq|INSERT INTO auth.clients_users (client_id, user_id) VALUES (1, 1)|);
478 dbh_do($dbh, qq|INSERT INTO auth.clients_groups (client_id, group_id) VALUES (1, 1)|);
479 dbh_do($dbh, qq|INSERT INTO auth.user_group (user_id, group_id) VALUES (1, 1)|);
482 default_printer_id => '',
483 template_format => '',
485 email => 'unit@tester',
487 dateformat => 'dd.mm.yy',
488 show_form_details => '',
489 name => 'Unit Tester',
491 hide_cvar_search_options => '',
492 numberformat => '1.000,00',
497 stylesheet => 'lx-office-erp.css',
498 mandatory_departments => 0,
502 my $sth = $dbh->prepare(qq|INSERT INTO auth.user_config (user_id, cfg_key, cfg_value) VALUES (1, ?, ?)|) || BAIL_OUT($dbh->errstr);
503 dbh_do($dbh, $sth, bind => [ $_, $config{$_} ]) for sort keys %config;
506 $sth = $dbh->prepare(qq|INSERT INTO auth.group_rights (group_id, "right", granted) VALUES (1, ?, TRUE)|) || BAIL_OUT($dbh->errstr);
507 dbh_do($dbh, $sth, bind => [ $_ ]) for sort $::auth->all_rights;
510 dbh_do($dbh, qq|INSERT INTO employee (id, login, name) VALUES (1, 'unittests', 'Unit Tester')|);
512 $::auth->set_client(1) || BAIL_OUT("\$::auth->set_client(1) failed");
513 %::myconfig = $::auth->read_user(login => 'unittests');
515 apply_upgrades(dbh => $dbh);
520 my $dbupdater = SL::DBUpgrade2->new(form => $::form, return_on_error => 1, auth => $params{auth});
521 my @unapplied_scripts = $dbupdater->unapplied_upgrade_scripts($params{dbh});
523 my $all = @unapplied_scripts;
525 for my $script (@unapplied_scripts) {
527 print "\rUpgrade $i/$all";
528 apply_dbupgrade($dbupdater, $params{dbh}, $script);
533 sub apply_dbupgrade {
534 my ($dbupdater, $dbh, $control_or_file) = @_;
536 my $file = ref($control_or_file) ? ("sql/Pg-upgrade2" . ($dbupdater->{auth} ? "-auth" : "") . "/$control_or_file->{file}") : $control_or_file;
537 my $control = ref($control_or_file) ? $control_or_file : undef;
539 my $error = $dbupdater->process_file($dbh, $file, $control);
541 die("Error applying $file: $error") if $error;
545 my ($dbh, $query, %params) = @_;
548 return if $query->execute(@{ $params{bind} || [] });
552 return if $dbh->do($query, undef, @{ $params{bind} || [] });
554 die($params{message} . ": " . $dbh->errstr) if $params{message};
555 die("Query failed: " . $dbh->errstr . " ; query: $query");
558 parse_args(\%config);
560 check_errors_in_package_names();
562 my %tables_by_domain = make_tables();
564 foreach my $domain (keys %tables_by_domain) {
565 my @tables = @{ $tables_by_domain{$domain} };
566 my @unknown_tables = grep { !$package_names{$domain}->{$_} } @tables;
567 if (@unknown_tables) {
568 error("The following tables do not have entries in \%SL::DB::Helper::Mappings::${domain}_package_names: " . join(' ', sort @unknown_tables));
572 process_table($domain, $_, $package_names{$domain}->{$_}) for @tables;
583 rose_auto_create_model - mana Rose::DB::Object classes for kivitendo
587 scripts/rose_auto_create_model.pl OPTIONS TARGET
589 # use other client than devel.client
590 scripts/rose_auto_create_model.pl --test-client TARGET
591 scripts/rose_auto_create_model.pl --client name-or-id TARGET
595 scripts/rose_auto_create_model.pl --all [--db db]
597 # updates only customer table, login taken from config
598 scripts/rose_auto_create_model.pl customer
600 # updates only parts table, package will be Part
601 scripts/rose_auto_create_model.pl parts=Part
603 # try to update parts, but don't do it. tell what would happen in detail
604 scripts/rose_auto_create_model.pl --no-commit parts
608 Rose::DB::Object comes with a nice function named auto initialization with code
609 generation. The documentation of Rose describes it like this:
611 I<[...] auto-initializing metadata at runtime by querying the database has many
612 caveats. An alternate approach is to query the database for metadata just once,
613 and then generate the equivalent Perl code which can be pasted directly into
614 the class definition in place of the call to auto_initialize.>
616 I<Like the auto-initialization process itself, perl code generation has a
617 convenient wrapper method as well as separate methods for the individual parts.
618 All of the perl code generation methods begin with "perl_", and they support
619 some rudimentary code formatting options to help the code conform to you
620 preferred style. Examples can be found with the documentation for each perl_*
623 I<This hybrid approach to metadata population strikes a good balance between
624 upfront effort and ongoing maintenance. Auto-generating the Perl code for the
625 initial class definition saves a lot of tedious typing. From that point on,
626 manually correcting and maintaining the definition is a small price to pay for
627 the decreased start-up cost, the ability to use the class in the absence of a
628 database connection, and the piece of mind that comes from knowing that your
629 class is stable, and won't change behind your back in response to an "action at
630 a distance" (i.e., a database schema update).>
632 Unfortunately this reads easier than it is, since classes need to go into the
633 right package and directory, certain stuff needs to be adjusted and table names
634 need to be translated into their class names. This script will wrap all that
635 behind a few simple options.
637 In the most basic version, just give it a login and a table name, and it will
638 load the schema information for this table and create the appropriate class
639 files, or update them if already present.
641 Each table has three associated files. A C<SL::DB::MetaSetup::*>
642 class, which is a perl version of the schema definition, a
643 C<SL::DB::*> class file and a C<SL::DB::Manager::*> manager class
644 file. The first one will be updated if the schema changes, the second
645 and third ones will only be created if it they do not exist.
647 =head1 DATABASE NAMES AND TABLES
649 If you want to generate the data for specific tables only then you
650 have to list them on the command line. The format is
651 C<db-name:table-name>. The part C<db-name:> is optional and defaults
652 to C<KIVITENDO:> – which means the tables in the default kivitendo
655 Valid database names are keys in the hash returned by
656 L<SL::DB::Helper::Mappings/get_package_names>.
662 =item C<--test-client, -t>
664 Use the C<testing/database> to create a new testing database, and connect to
665 the first client there. Overrides C<client>.
667 If neither C<test-client> nor C<client> are set, the config key C<devel/client>
670 =item C<--client, -c CLIENT>
672 Provide a client whose database settings are used. C<CLIENT> can be either a
673 database ID or a client's name.
675 If neither C<test-client> nor C<client> are set, the config key C<devel/client>
680 Process all tables from the database. Only those that are blacklistes in
681 L<SL::DB::Helper::Mappings> are excluded.
685 In combination with C<--all> causes all tables in the specific
686 database to be processed, not in all databases.
688 =item C<--no-commit, -n>
692 Do not write back generated files. This will do everything as usual but not
693 actually modify any file.
697 Displays diff for selected file, if file is present and newer file is
698 different. Beware, does not imply C<--no-commit>.
706 Does not print extra information, such as skipped files that were not
707 changed and errors where the auto initialization failed.
717 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>,
718 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>