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(apply none uniq);
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_employee', created_by => 'created_by_employee', },
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;
151 use parent qw(SL::DB::Object);
153 __PACKAGE__->meta->table('$table');
155 __PACKAGE__->meta->auto_initialize;
160 error("Error in execution for table '$table'");
161 error("'$EVAL_ERROR'") unless $config{quiet};
165 my %args = (indent => 2, use_setup => 0);
167 my $definition = "SL::DB::AUTO::$package"->meta->perl_class_definition(%args);
168 $definition =~ s/\n+__PACKAGE__->meta->initialize;\n+/\n\n/;
169 $definition =~ s/::AUTO::/::/g;
172 # Sort column definitions alphabetically
173 if ($definition =~ m/__PACKAGE__->meta->columns\( \n (.+?) \n \);/msx) {
174 my ($start, $end) = ($-[1], $+[1]);
175 my $sorted_columns = join "\n", sort split m/\n/, $1;
176 substr $definition, $start, $end - $start, $sorted_columns;
180 my $foreign_key_definition = "SL::DB::AUTO::$package"->meta->perl_foreign_keys_definition(%args);
181 $foreign_key_definition =~ s/::AUTO::/::/g;
183 if ($foreign_key_definition && ($definition =~ /\Q$foreign_key_definition\E/)) {
184 # These positions refer to the whole setup call, not just the
185 # parameters/actual relationship definitions.
186 my ($start, $end) = ($-[0], $+[0]);
188 # Match the function parameters = the actual relationship
190 next unless $foreign_key_definition =~ m/\(\n(.+)\n\)/s;
192 my ($list_start, $list_end) = ($-[0], $+[0]);
194 # Split the whole chunk on double new lines. The resulting
195 # elements are one relationship each. Then fix the relationship
196 # names and sort them by their new names.
197 my @new_foreign_keys = sort map { fix_relationship_names($domain, $table, $_) } split m/\n\n/m, $1;
199 # Replace the function parameters = the actual relationship
200 # definitions with the new ones.
201 my $sorted_foreign_keys = "(\n" . join("\n\n", @new_foreign_keys) . "\n)";
202 substr $foreign_key_definition, $list_start, $list_end - $list_start, $sorted_foreign_keys;
204 # Replace the whole setup call in the auto-generated output with
206 substr $definition, $start, $end - $start, $foreign_key_definition;
209 $definition =~ s/(meta->table.*)\n/$1\n$schema_str/m if $schema;
210 $definition =~ s{^use base}{use parent}m;
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 parent qw(SL::DB::Helper::Manager);
279 sub object_class { 'SL::DB::${package}' }
281 __PACKAGE__->make_manager_methods;
287 notice("File '$mngr_file' created as well.");
293 'client=s' => \ my $client,
294 'test-client' => \ my $use_test_client,
297 'no-commit|dry-run' => \ my $nocommit,
298 help => sub { pod2usage(verbose => 99, sections => 'NAME|SYNOPSIS|OPTIONS') },
299 quiet => \ my $quiet,
303 $options->{client} = $client;
304 $options->{new_client} = $use_test_client;
305 $options->{all} = $all;
306 $options->{db} = $db;
307 $options->{nocommit} = $nocommit;
308 $options->{quiet} = $quiet;
309 $options->{color} = -t STDOUT ? 1 : 0;
312 if (eval { require Text::Diff; 1 }) {
313 $options->{show_diff} = 1;
315 error('Could not load Text::Diff. Sorry, no diffs for you.');
321 my ($text_a, $text_b) = @_;
328 Text::Diff::diff($text_a, $text_b, { OUTPUT => sub {
329 for (split /\n/, $_[0]) {
330 if ($config{color}) {
331 print colored($_, $colors{substr($_, 0, 1)}), $/;
340 pod2usage(verbose => 99, sections => 'SYNOPSIS');
343 sub list_all_tables {
346 my @schemas = (undef, uniq apply { s{\..*}{} } grep { m{\.} } keys %{ $package_names{KIVITENDO} });
349 foreach my $schema (@schemas) {
350 $db->schema($schema);
351 push @tables, map { $schema ? "${schema}.${_}" : $_ } $db->list_tables;
360 my %tables_by_domain;
362 my @domains = $config{db} ? (uc $config{db}) : sort keys %package_names;
364 foreach my $domain (@domains) {
365 my $db = SL::DB::create(undef, $domain);
366 $tables_by_domain{$domain} = [ grep { my $table = $_; none { $_ eq $table } @{ $blacklist{$domain} } } list_all_tables($db) ];
371 %tables_by_domain = partition_by {
372 my ($domain, $table) = split m{:};
373 $table ? uc($domain) : 'KIVITENDO';
376 foreach my $tables (values %tables_by_domain) {
377 s{.*:}{} for @{ $tables };
381 error("You specified neither --all nor any specific tables.");
385 return %tables_by_domain;
389 print STDERR colored(shift, 'red'), $/;
396 sub check_errors_in_package_names {
397 foreach my $domain (sort keys %package_names) {
398 my @both = grep { $package_names{$domain}->{$_} } @{ $blacklist{$domain} || [] };
401 print "Error: domain '$domain': The following table names are present in both the black list and the package name hash: ", join(' ', sort @both), "\n";
406 sub drop_and_create_test_database {
407 my $db_cfg = $::lx_office_conf{'testing/database'} || die 'testing/database missing';
410 'dbi:Pg:dbname=' . $db_cfg->{template} . ';host=' . $db_cfg->{host} . ';port=' . $db_cfg->{port},
413 SL::DBConnect->get_options,
417 my $dbh_template = SL::DBConnect->connect(@dbi_options) || BAIL_OUT("No database connection to the template database: " . $DBI::errstr);
418 my $auth_dbh = $::auth->dbconnect(1);
421 notice("Database exists; dropping");
422 $auth_dbh->disconnect;
424 dbh_do($dbh_template, "DROP DATABASE \"" . $db_cfg->{db} . "\"", message => "Database could not be dropped");
429 notice("Creating database");
431 dbh_do($dbh_template, "CREATE DATABASE \"" . $db_cfg->{db} . "\" TEMPLATE \"" . $db_cfg->{template} . "\" ENCODING 'UNICODE'", message => "Database could not be created");
432 $dbh_template->disconnect;
434 notice("Creating initial schema");
437 'dbi:Pg:dbname=' . $db_cfg->{db} . ';host=' . $db_cfg->{host} . ';port=' . $db_cfg->{port},
440 SL::DBConnect->get_options(PrintError => 0, PrintWarn => 0),
443 my $dbh = SL::DBConnect->connect(@dbi_options) || BAIL_OUT("Database connection failed: " . $DBI::errstr);
444 $::auth->{dbh} = $dbh;
445 my $dbupdater = SL::DBUpgrade2->new(form => $::form, return_on_error => 1, silent => 1);
446 my $coa = 'Germany-DATEV-SKR03EU';
448 apply_dbupgrade($dbupdater, $dbh, "sql/lx-office.sql");
449 apply_dbupgrade($dbupdater, $dbh, "sql/${coa}-chart.sql");
451 dbh_do($dbh, qq|UPDATE defaults SET coa = '${coa}', accounting_method = 'cash', profit_determination = 'income', inventory_system = 'periodic', curr = 'EUR'|);
452 dbh_do($dbh, qq|CREATE TABLE schema_info (tag TEXT, login TEXT, itime TIMESTAMP DEFAULT now(), PRIMARY KEY (tag))|);
454 notice("Creating initial auth schema");
456 $dbupdater = SL::DBUpgrade2->new(form => $::form, return_on_error => 1, auth => 1);
457 apply_dbupgrade($dbupdater, $dbh, 'sql/auth_db.sql');
459 apply_upgrades(auth => 1, dbh => $dbh);
461 notice("Creating client, user, group and employee");
463 dbh_do($dbh, qq|DELETE FROM auth.clients|);
464 dbh_do($dbh, qq|INSERT INTO auth.clients (id, name, dbhost, dbport, dbname, dbuser, dbpasswd, is_default) VALUES (1, 'Unit-Tests', ?, ?, ?, ?, ?, TRUE)|,
465 bind => [ @{ $db_cfg }{ qw(host port db user password) } ]);
466 dbh_do($dbh, qq|INSERT INTO auth."user" (id, login) VALUES (1, 'unittests')|);
467 dbh_do($dbh, qq|INSERT INTO auth."group" (id, name) VALUES (1, 'Vollzugriff')|);
468 dbh_do($dbh, qq|INSERT INTO auth.clients_users (client_id, user_id) VALUES (1, 1)|);
469 dbh_do($dbh, qq|INSERT INTO auth.clients_groups (client_id, group_id) VALUES (1, 1)|);
470 dbh_do($dbh, qq|INSERT INTO auth.user_group (user_id, group_id) VALUES (1, 1)|);
473 default_printer_id => '',
474 template_format => '',
476 email => 'unit@tester',
478 dateformat => 'dd.mm.yy',
479 show_form_details => '',
480 name => 'Unit Tester',
482 hide_cvar_search_options => '',
483 numberformat => '1.000,00',
489 stylesheet => 'lx-office-erp.css',
490 mandatory_departments => 0,
494 my $sth = $dbh->prepare(qq|INSERT INTO auth.user_config (user_id, cfg_key, cfg_value) VALUES (1, ?, ?)|) || BAIL_OUT($dbh->errstr);
495 dbh_do($dbh, $sth, bind => [ $_, $config{$_} ]) for sort keys %config;
498 $sth = $dbh->prepare(qq|INSERT INTO auth.group_rights (group_id, "right", granted) VALUES (1, ?, TRUE)|) || BAIL_OUT($dbh->errstr);
499 dbh_do($dbh, $sth, bind => [ $_ ]) for sort $::auth->all_rights;
502 dbh_do($dbh, qq|INSERT INTO employee (id, login, name) VALUES (1, 'unittests', 'Unit Tester')|);
504 $::auth->set_client(1) || BAIL_OUT("\$::auth->set_client(1) failed");
505 %::myconfig = $::auth->read_user(login => 'unittests');
507 apply_upgrades(dbh => $dbh);
512 my $dbupdater = SL::DBUpgrade2->new(form => $::form, return_on_error => 1, auth => $params{auth});
513 my @unapplied_scripts = $dbupdater->unapplied_upgrade_scripts($params{dbh});
515 my $all = @unapplied_scripts;
517 for my $script (@unapplied_scripts) {
519 print "\rUpgrade $i/$all";
520 apply_dbupgrade($dbupdater, $params{dbh}, $script);
525 sub apply_dbupgrade {
526 my ($dbupdater, $dbh, $control_or_file) = @_;
528 my $file = ref($control_or_file) ? ("sql/Pg-upgrade2" . ($dbupdater->{auth} ? "-auth" : "") . "/$control_or_file->{file}") : $control_or_file;
529 my $control = ref($control_or_file) ? $control_or_file : undef;
531 my $error = $dbupdater->process_file($dbh, $file, $control);
533 die("Error applying $file: $error") if $error;
537 my ($dbh, $query, %params) = @_;
540 return if $query->execute(@{ $params{bind} || [] });
544 return if $dbh->do($query, undef, @{ $params{bind} || [] });
546 die($params{message} . ": " . $dbh->errstr) if $params{message};
547 die("Query failed: " . $dbh->errstr . " ; query: $query");
550 parse_args(\%config);
552 check_errors_in_package_names();
554 my %tables_by_domain = make_tables();
556 foreach my $domain (keys %tables_by_domain) {
557 my @tables = @{ $tables_by_domain{$domain} };
558 my @unknown_tables = grep { !$package_names{$domain}->{$_} } @tables;
559 if (@unknown_tables) {
560 error("The following tables do not have entries in \%SL::DB::Helper::Mappings::${domain}_package_names: " . join(' ', sort @unknown_tables));
564 process_table($domain, $_, $package_names{$domain}->{$_}) for @tables;
575 rose_auto_create_model - mana Rose::DB::Object classes for kivitendo
579 scripts/rose_auto_create_model.pl OPTIONS TARGET
581 # use other client than devel.client
582 scripts/rose_auto_create_model.pl --test-client TARGET
583 scripts/rose_auto_create_model.pl --client name-or-id TARGET
587 scripts/rose_auto_create_model.pl --all [--db db]
589 # updates only customer table, login taken from config
590 scripts/rose_auto_create_model.pl customer
592 # updates only parts table, package will be Part
593 scripts/rose_auto_create_model.pl parts=Part
595 # try to update parts, but don't do it. tell what would happen in detail
596 scripts/rose_auto_create_model.pl --no-commit parts
600 Rose::DB::Object comes with a nice function named auto initialization with code
601 generation. The documentation of Rose describes it like this:
603 I<[...] auto-initializing metadata at runtime by querying the database has many
604 caveats. An alternate approach is to query the database for metadata just once,
605 and then generate the equivalent Perl code which can be pasted directly into
606 the class definition in place of the call to auto_initialize.>
608 I<Like the auto-initialization process itself, perl code generation has a
609 convenient wrapper method as well as separate methods for the individual parts.
610 All of the perl code generation methods begin with "perl_", and they support
611 some rudimentary code formatting options to help the code conform to you
612 preferred style. Examples can be found with the documentation for each perl_*
615 I<This hybrid approach to metadata population strikes a good balance between
616 upfront effort and ongoing maintenance. Auto-generating the Perl code for the
617 initial class definition saves a lot of tedious typing. From that point on,
618 manually correcting and maintaining the definition is a small price to pay for
619 the decreased start-up cost, the ability to use the class in the absence of a
620 database connection, and the piece of mind that comes from knowing that your
621 class is stable, and won't change behind your back in response to an "action at
622 a distance" (i.e., a database schema update).>
624 Unfortunately this reads easier than it is, since classes need to go into the
625 right package and directory, certain stuff needs to be adjusted and table names
626 need to be translated into their class names. This script will wrap all that
627 behind a few simple options.
629 In the most basic version, just give it a login and a table name, and it will
630 load the schema information for this table and create the appropriate class
631 files, or update them if already present.
633 Each table has three associated files. A C<SL::DB::MetaSetup::*>
634 class, which is a perl version of the schema definition, a
635 C<SL::DB::*> class file and a C<SL::DB::Manager::*> manager class
636 file. The first one will be updated if the schema changes, the second
637 and third ones will only be created if it they do not exist.
639 =head1 DATABASE NAMES AND TABLES
641 If you want to generate the data for specific tables only then you
642 have to list them on the command line. The format is
643 C<db-name:table-name>. The part C<db-name:> is optional and defaults
644 to C<KIVITENDO:> – which means the tables in the default kivitendo
647 Valid database names are keys in the hash returned by
648 L<SL::DB::Helper::Mappings/get_package_names>.
654 =item C<--test-client, -t>
656 Use the C<testing/database> to create a new testing database, and connect to
657 the first client there. Overrides C<client>.
659 If neither C<test-client> nor C<client> are set, the config key C<devel/client>
662 =item C<--client, -c CLIENT>
664 Provide a client whose database settings are used. C<CLIENT> can be either a
665 database ID or a client's name.
667 If neither C<test-client> nor C<client> are set, the config key C<devel/client>
672 Process all tables from the database. Only those that are blacklistes in
673 L<SL::DB::Helper::Mappings> are excluded.
677 In combination with C<--all> causes all tables in the specific
678 database to be processed, not in all databases.
680 =item C<--no-commit, -n>
684 Do not write back generated files. This will do everything as usual but not
685 actually modify any file.
689 Displays diff for selected file, if file is present and newer file is
690 different. Beware, does not imply C<--no-commit>.
698 Does not print extra information, such as skipped files that were not
699 changed and errors where the auto initialization failed.
709 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>,
710 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>