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' },
90 SL::LxOfficeConf->read;
92 my $client = $config{client} || $::lx_office_conf{devel}{client};
93 my $new_client = $config{new_client};
95 if (!$client && !$new_client) {
96 error("No client found in config. Please provide a client:");
100 $::lxdebug = LXDebug->new();
101 $::lxdebug->disable_sub_tracing;
102 $::locale = Locale->new("de");
104 $::instance_conf = SL::InstanceConfiguration->new;
105 $form->{script} = 'rose_meta_data.pl';
108 $::auth = SL::Auth->new(unit_tests_database => 1);
110 drop_and_create_test_database();
112 $::auth = SL::Auth->new();
115 if (!$::auth->set_client($client)) {
116 error("No client with ID or name '$client' found in config. Please provide a client:");
120 foreach (($meta_path, $manager_path)) {
125 sub fix_relationship_names {
126 my ($domain, $table, $fkey_text) = @_;
128 if ($fkey_text !~ m/key_columns \s+ => \s+ \{ \s+ ['"]? ( [^'"\s]+ ) /x) {
129 die "fix_relationship_names: could not extract the key column for domain/table $domain/$table; foreign key definition text:\n${fkey_text}\n";
132 my $column_name = $1;
133 my %changes = map { %{$_} } grep { $_ } ($foreign_key_name_map{$domain}->{ALL}, $foreign_key_name_map{$domain}->{$table});
135 if (my $desired_name = $changes{$column_name}) {
136 $fkey_text =~ s/^ \s\s [^\s]+ \b/ ${desired_name}/msx;
143 my ($domain, $table, $package) = @_;
145 ($schema, $table) = split(m/\./, $table) if $table =~ m/\./;
146 $package = ucfirst($package || $table);
147 $package =~ s/_+(.)/uc($1)/ge;
148 my $meta_file = "${meta_path}/${package}.pm";
149 my $mngr_file = "${manager_path}/${package}.pm";
150 my $file = "SL/DB/${package}.pm";
152 my $schema_str = $schema ? <<CODE : '';
153 __PACKAGE__->meta->schema('$schema');
157 package SL::DB::AUTO::$package;
158 use parent qw(SL::DB::Object);
160 __PACKAGE__->meta->table('$table');
162 __PACKAGE__->meta->auto_initialize;
167 error("Error in execution for table '$table'");
168 error("'$EVAL_ERROR'") unless $config{quiet};
172 my %args = (indent => 2, use_setup => 0);
174 my $definition = "SL::DB::AUTO::$package"->meta->perl_class_definition(%args);
175 $definition =~ s/\n+__PACKAGE__->meta->initialize;\n+/\n\n/;
176 $definition =~ s/::AUTO::/::/g;
179 # Sort column definitions alphabetically
180 if ($definition =~ m/__PACKAGE__->meta->columns\( \n (.+?) \n \);/msx) {
181 my ($start, $end) = ($-[1], $+[1]);
182 my $sorted_columns = join "\n", sort split m/\n/, $1;
183 substr $definition, $start, $end - $start, $sorted_columns;
187 my $foreign_key_definition = "SL::DB::AUTO::$package"->meta->perl_foreign_keys_definition(%args);
188 $foreign_key_definition =~ s/::AUTO::/::/g;
190 if ($foreign_key_definition && ($definition =~ /\Q$foreign_key_definition\E/)) {
191 # These positions refer to the whole setup call, not just the
192 # parameters/actual relationship definitions.
193 my ($start, $end) = ($-[0], $+[0]);
195 # Match the function parameters = the actual relationship
197 next unless $foreign_key_definition =~ m/\(\n(.+)\n\)/s;
199 my ($list_start, $list_end) = ($-[0], $+[0]);
201 # Split the whole chunk on double new lines. The resulting
202 # elements are one relationship each. Then fix the relationship
203 # names and sort them by their new names.
204 my @new_foreign_keys = sort map { fix_relationship_names($domain, $table, $_) } split m/\n\n/m, $1;
206 # Replace the function parameters = the actual relationship
207 # definitions with the new ones.
208 my $sorted_foreign_keys = "(\n" . join("\n\n", @new_foreign_keys) . "\n)";
209 substr $foreign_key_definition, $list_start, $list_end - $list_start, $sorted_foreign_keys;
211 # Replace the whole setup call in the auto-generated output with
213 substr $definition, $start, $end - $start, $foreign_key_definition;
216 $definition =~ s/(meta->table.*)\n/$1\n$schema_str/m if $schema;
217 $definition =~ s{^use base}{use parent}m;
219 my $full_definition = <<CODE;
220 # This file has been auto-generated. Do not modify it; it will be overwritten
221 # by $::script automatically.
225 my $meta_definition = <<CODE;
226 # This file has been auto-generated only because it didn't exist.
227 # Feel free to modify it at will; it will not be overwritten automatically.
229 package SL::DB::${package};
233 use SL::DB::MetaSetup::${package};
234 use SL::DB::Manager::${package};
236 __PACKAGE__->meta->initialize;
241 my $file_exists = -f $meta_file;
243 my $old_size = -s $meta_file;
244 my $orig_file = do { local(@ARGV, $/) = ($meta_file); <> };
245 my $old_md5 = md5_hex($orig_file);
246 my $new_size = length $full_definition;
247 my $new_md5 = md5_hex($full_definition);
248 if ($old_size == $new_size && $old_md5 eq $new_md5) {
249 notice("No changes in $meta_file, skipping.") unless $config{quiet};
253 show_diff(\$orig_file, \$full_definition) if $config{show_diff};
256 if (!$config{nocommit}) {
257 open my $out, ">", $meta_file || die;
258 print $out $full_definition;
261 notice("File '$meta_file' " . ($file_exists ? 'updated' : 'created') . " for table '$table'");
265 if (!$config{nocommit}) {
266 open my $out, ">", $file || die;
267 print $out $meta_definition;
270 notice("File '$file' created as well.");
272 return if -f $mngr_file;
274 if (!$config{nocommit}) {
275 open my $out, ">", $mngr_file || die;
277 # This file has been auto-generated only because it didn't exist.
278 # Feel free to modify it at will; it will not be overwritten automatically.
280 package SL::DB::Manager::${package};
284 use parent qw(SL::DB::Helper::Manager);
286 sub object_class { 'SL::DB::${package}' }
288 __PACKAGE__->make_manager_methods;
294 notice("File '$mngr_file' created as well.");
300 'client=s' => \ my $client,
301 'test-client' => \ my $use_test_client,
304 'no-commit|dry-run' => \ my $nocommit,
305 help => sub { pod2usage(verbose => 99, sections => 'NAME|SYNOPSIS|OPTIONS') },
306 quiet => \ my $quiet,
310 $options->{client} = $client;
311 $options->{new_client} = $use_test_client;
312 $options->{all} = $all;
313 $options->{db} = $db;
314 $options->{nocommit} = $nocommit;
315 $options->{quiet} = $quiet;
316 $options->{color} = -t STDOUT ? 1 : 0;
319 if (eval { require Text::Diff; 1 }) {
320 $options->{show_diff} = 1;
322 error('Could not load Text::Diff. Sorry, no diffs for you.');
328 my ($text_a, $text_b) = @_;
335 Text::Diff::diff($text_a, $text_b, { OUTPUT => sub {
336 for (split /\n/, $_[0]) {
337 if ($config{color}) {
338 print colored($_, $colors{substr($_, 0, 1)}), $/;
347 pod2usage(verbose => 99, sections => 'SYNOPSIS');
350 sub list_all_tables {
353 my @schemas = (undef, uniq apply { s{\..*}{} } grep { m{\.} } keys %{ $package_names{KIVITENDO} });
356 foreach my $schema (@schemas) {
357 $db->schema($schema);
358 push @tables, map { $schema ? "${schema}.${_}" : $_ } $db->list_tables;
367 my %tables_by_domain;
369 my @domains = $config{db} ? (uc $config{db}) : sort keys %package_names;
371 foreach my $domain (@domains) {
372 my $db = SL::DB::create(undef, $domain);
373 $tables_by_domain{$domain} = [ grep { my $table = $_; none { $_ eq $table } @{ $blacklist{$domain} } } list_all_tables($db) ];
378 %tables_by_domain = partition_by {
379 my ($domain, $table) = split m{:};
380 $table ? uc($domain) : 'KIVITENDO';
383 foreach my $tables (values %tables_by_domain) {
384 s{.*:}{} for @{ $tables };
388 error("You specified neither --all nor any specific tables.");
392 return %tables_by_domain;
396 print STDERR colored(shift, 'red'), $/;
403 sub check_errors_in_package_names {
404 foreach my $domain (sort keys %package_names) {
405 my @both = grep { $package_names{$domain}->{$_} } @{ $blacklist{$domain} || [] };
408 print "Error: domain '$domain': The following table names are present in both the black list and the package name hash: ", join(' ', sort @both), "\n";
413 sub drop_and_create_test_database {
414 my $db_cfg = $::lx_office_conf{'testing/database'} || die 'testing/database missing';
417 'dbi:Pg:dbname=' . $db_cfg->{template} . ';host=' . $db_cfg->{host} . ';port=' . $db_cfg->{port},
420 SL::DBConnect->get_options,
424 my $dbh_template = SL::DBConnect->connect(@dbi_options) || BAIL_OUT("No database connection to the template database: " . $DBI::errstr);
425 my $auth_dbh = $::auth->dbconnect(1);
428 notice("Database exists; dropping");
429 $auth_dbh->disconnect;
431 dbh_do($dbh_template, "DROP DATABASE \"" . $db_cfg->{db} . "\"", message => "Database could not be dropped");
434 notice("Creating database");
436 dbh_do($dbh_template, "CREATE DATABASE \"" . $db_cfg->{db} . "\" TEMPLATE \"" . $db_cfg->{template} . "\" ENCODING 'UNICODE'", message => "Database could not be created");
437 $dbh_template->disconnect;
439 notice("Creating initial schema");
442 'dbi:Pg:dbname=' . $db_cfg->{db} . ';host=' . $db_cfg->{host} . ';port=' . $db_cfg->{port},
445 SL::DBConnect->get_options(PrintError => 0, PrintWarn => 0),
448 my $dbh = SL::DBConnect->connect(@dbi_options) || BAIL_OUT("Database connection failed: " . $DBI::errstr);
449 $::auth->{dbh} = $dbh;
450 my $dbupdater = SL::DBUpgrade2->new(form => $::form, return_on_error => 1, silent => 1);
451 my $coa = 'Germany-DATEV-SKR03EU';
453 apply_dbupgrade($dbupdater, $dbh, "sql/lx-office.sql");
454 apply_dbupgrade($dbupdater, $dbh, "sql/${coa}-chart.sql");
456 dbh_do($dbh, qq|UPDATE defaults SET coa = '${coa}', accounting_method = 'cash', profit_determination = 'income', inventory_system = 'periodic', curr = 'EUR'|);
457 dbh_do($dbh, qq|CREATE TABLE schema_info (tag TEXT, login TEXT, itime TIMESTAMP DEFAULT now(), PRIMARY KEY (tag))|);
459 notice("Creating initial auth schema");
461 $dbupdater = SL::DBUpgrade2->new(form => $::form, return_on_error => 1, auth => 1);
462 apply_dbupgrade($dbupdater, $dbh, 'sql/auth_db.sql');
464 apply_upgrades(auth => 1, dbh => $dbh);
468 notice("Creating client, user, group and employee");
470 dbh_do($dbh, qq|DELETE FROM auth.clients|);
471 dbh_do($dbh, qq|INSERT INTO auth.clients (id, name, dbhost, dbport, dbname, dbuser, dbpasswd, is_default) VALUES (1, 'Unit-Tests', ?, ?, ?, ?, ?, TRUE)|,
472 bind => [ @{ $db_cfg }{ qw(host port db user password) } ]);
473 dbh_do($dbh, qq|INSERT INTO auth."user" (id, login) VALUES (1, 'unittests')|);
474 dbh_do($dbh, qq|INSERT INTO auth."group" (id, name) VALUES (1, 'Vollzugriff')|);
475 dbh_do($dbh, qq|INSERT INTO auth.clients_users (client_id, user_id) VALUES (1, 1)|);
476 dbh_do($dbh, qq|INSERT INTO auth.clients_groups (client_id, group_id) VALUES (1, 1)|);
477 dbh_do($dbh, qq|INSERT INTO auth.user_group (user_id, group_id) VALUES (1, 1)|);
480 default_printer_id => '',
481 template_format => '',
483 email => 'unit@tester',
485 dateformat => 'dd.mm.yy',
486 show_form_details => '',
487 name => 'Unit Tester',
489 hide_cvar_search_options => '',
490 numberformat => '1.000,00',
495 stylesheet => 'lx-office-erp.css',
496 mandatory_departments => 0,
500 my $sth = $dbh->prepare(qq|INSERT INTO auth.user_config (user_id, cfg_key, cfg_value) VALUES (1, ?, ?)|) || BAIL_OUT($dbh->errstr);
501 dbh_do($dbh, $sth, bind => [ $_, $config{$_} ]) for sort keys %config;
504 $sth = $dbh->prepare(qq|INSERT INTO auth.group_rights (group_id, "right", granted) VALUES (1, ?, TRUE)|) || BAIL_OUT($dbh->errstr);
505 dbh_do($dbh, $sth, bind => [ $_ ]) for sort $::auth->all_rights;
508 dbh_do($dbh, qq|INSERT INTO employee (id, login, name) VALUES (1, 'unittests', 'Unit Tester')|);
510 $::auth->set_client(1) || BAIL_OUT("\$::auth->set_client(1) failed");
511 %::myconfig = $::auth->read_user(login => 'unittests');
513 apply_upgrades(dbh => $dbh);
518 my $dbupdater = SL::DBUpgrade2->new(form => $::form, return_on_error => 1, auth => $params{auth});
519 my @unapplied_scripts = $dbupdater->unapplied_upgrade_scripts($params{dbh});
521 my $all = @unapplied_scripts;
523 for my $script (@unapplied_scripts) {
525 print "\rUpgrade $i/$all";
526 apply_dbupgrade($dbupdater, $params{dbh}, $script);
531 sub apply_dbupgrade {
532 my ($dbupdater, $dbh, $control_or_file) = @_;
534 my $file = ref($control_or_file) ? ("sql/Pg-upgrade2" . ($dbupdater->{auth} ? "-auth" : "") . "/$control_or_file->{file}") : $control_or_file;
535 my $control = ref($control_or_file) ? $control_or_file : undef;
537 my $error = $dbupdater->process_file($dbh, $file, $control);
539 die("Error applying $file: $error") if $error;
543 my ($dbh, $query, %params) = @_;
546 return if $query->execute(@{ $params{bind} || [] });
550 return if $dbh->do($query, undef, @{ $params{bind} || [] });
552 die($params{message} . ": " . $dbh->errstr) if $params{message};
553 die("Query failed: " . $dbh->errstr . " ; query: $query");
556 parse_args(\%config);
558 check_errors_in_package_names();
560 my %tables_by_domain = make_tables();
562 foreach my $domain (keys %tables_by_domain) {
563 my @tables = @{ $tables_by_domain{$domain} };
564 my @unknown_tables = grep { !$package_names{$domain}->{$_} } @tables;
565 if (@unknown_tables) {
566 error("The following tables do not have entries in \%SL::DB::Helper::Mappings::${domain}_package_names: " . join(' ', sort @unknown_tables));
570 process_table($domain, $_, $package_names{$domain}->{$_}) for @tables;
581 rose_auto_create_model - mana Rose::DB::Object classes for kivitendo
585 scripts/rose_auto_create_model.pl OPTIONS TARGET
587 # use other client than devel.client
588 scripts/rose_auto_create_model.pl --test-client TARGET
589 scripts/rose_auto_create_model.pl --client name-or-id TARGET
593 scripts/rose_auto_create_model.pl --all [--db db]
595 # updates only customer table, login taken from config
596 scripts/rose_auto_create_model.pl customer
598 # updates only parts table, package will be Part
599 scripts/rose_auto_create_model.pl parts=Part
601 # try to update parts, but don't do it. tell what would happen in detail
602 scripts/rose_auto_create_model.pl --no-commit parts
606 Rose::DB::Object comes with a nice function named auto initialization with code
607 generation. The documentation of Rose describes it like this:
609 I<[...] auto-initializing metadata at runtime by querying the database has many
610 caveats. An alternate approach is to query the database for metadata just once,
611 and then generate the equivalent Perl code which can be pasted directly into
612 the class definition in place of the call to auto_initialize.>
614 I<Like the auto-initialization process itself, perl code generation has a
615 convenient wrapper method as well as separate methods for the individual parts.
616 All of the perl code generation methods begin with "perl_", and they support
617 some rudimentary code formatting options to help the code conform to you
618 preferred style. Examples can be found with the documentation for each perl_*
621 I<This hybrid approach to metadata population strikes a good balance between
622 upfront effort and ongoing maintenance. Auto-generating the Perl code for the
623 initial class definition saves a lot of tedious typing. From that point on,
624 manually correcting and maintaining the definition is a small price to pay for
625 the decreased start-up cost, the ability to use the class in the absence of a
626 database connection, and the piece of mind that comes from knowing that your
627 class is stable, and won't change behind your back in response to an "action at
628 a distance" (i.e., a database schema update).>
630 Unfortunately this reads easier than it is, since classes need to go into the
631 right package and directory, certain stuff needs to be adjusted and table names
632 need to be translated into their class names. This script will wrap all that
633 behind a few simple options.
635 In the most basic version, just give it a login and a table name, and it will
636 load the schema information for this table and create the appropriate class
637 files, or update them if already present.
639 Each table has three associated files. A C<SL::DB::MetaSetup::*>
640 class, which is a perl version of the schema definition, a
641 C<SL::DB::*> class file and a C<SL::DB::Manager::*> manager class
642 file. The first one will be updated if the schema changes, the second
643 and third ones will only be created if it they do not exist.
645 =head1 DATABASE NAMES AND TABLES
647 If you want to generate the data for specific tables only then you
648 have to list them on the command line. The format is
649 C<db-name:table-name>. The part C<db-name:> is optional and defaults
650 to C<KIVITENDO:> – which means the tables in the default kivitendo
653 Valid database names are keys in the hash returned by
654 L<SL::DB::Helper::Mappings/get_package_names>.
660 =item C<--test-client, -t>
662 Use the C<testing/database> to create a new testing database, and connect to
663 the first client there. Overrides C<client>.
665 If neither C<test-client> nor C<client> are set, the config key C<devel/client>
668 =item C<--client, -c CLIENT>
670 Provide a client whose database settings are used. C<CLIENT> can be either a
671 database ID or a client's name.
673 If neither C<test-client> nor C<client> are set, the config key C<devel/client>
678 Process all tables from the database. Only those that are blacklistes in
679 L<SL::DB::Helper::Mappings> are excluded.
683 In combination with C<--all> causes all tables in the specific
684 database to be processed, not in all databases.
686 =item C<--no-commit, -n>
690 Do not write back generated files. This will do everything as usual but not
691 actually modify any file.
695 Displays diff for selected file, if file is present and newer file is
696 different. Beware, does not imply C<--no-commit>.
704 Does not print extra information, such as skipped files that were not
705 changed and errors where the auto initialization failed.
715 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>,
716 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>