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.
10 push (@INC, $FindBin::Bin . '/../modules/fallback'); # Only use our own versions of modules if there's no system version.
13 use CGI qw( -no_xhtml);
16 use Digest::MD5 qw(md5_hex);
17 use English qw( -no_match_vars );
19 use List::MoreUtils qw(apply none uniq);
20 use List::UtilsBy qw(partition_by);
22 use Rose::DB::Object 0.809;
29 use SL::InstanceConfiguration;
33 use SL::DB::Helper::ALL;
34 use SL::DB::Helper::Mappings;
36 chdir($FindBin::Bin . '/..');
38 my %blacklist = SL::DB::Helper::Mappings->get_blacklist;
39 my %package_names = SL::DB::Helper::Mappings->get_package_names;
45 our $script = __FILE__;
48 $OUTPUT_AUTOFLUSH = 1;
49 $Data::Dumper::Sortkeys = 1;
51 our $meta_path = "SL/DB/MetaSetup";
52 our $manager_path = "SL/DB/Manager";
56 # Maps column names in tables to foreign key relationship names. For
59 # »follow_up_access« contains a column named »who«. Rose normally
60 # names the resulting relationship after the class the target table
61 # uses. In this case the target table is »employee« and the
62 # corresponding class SL::DB::Employee. The resulting relationship
63 # would be named »employee«.
65 # In order to rename this relationship we have to map »who« to
67 # follow_up_access => { who => 'granted_by' },
69 our %foreign_key_name_map = (
71 oe => { payment_id => 'payment_terms', },
72 ar => { payment_id => 'payment_terms', },
73 ap => { payment_id => 'payment_terms', },
75 orderitems => { parts_id => 'part', trans_id => 'order', },
76 delivery_order_items => { parts_id => 'part' },
77 invoice => { parts_id => 'part' },
78 follow_ups => { created_for_user => 'created_for_employee', created_by => 'created_by_employee', },
79 follow_up_access => { who => 'with_access', what => 'to_follow_ups_by', },
81 periodic_invoices_configs => { oe_id => 'order', email_recipient_contact_id => 'email_recipient_contact' },
82 reconciliation_links => { acc_trans_id => 'acc_trans' },
84 assembly => { parts_id => 'part', id => 'assembly_part' },
85 assortment_items => { parts_id => 'part' },
91 SL::LxOfficeConf->read;
93 my $client = $config{client} || $::lx_office_conf{devel}{client};
94 my $new_client = $config{new_client};
96 if (!$client && !$new_client) {
97 error("No client found in config. Please provide a client:");
101 $::lxdebug = LXDebug->new();
102 $::lxdebug->disable_sub_tracing;
103 $::locale = Locale->new("de");
105 $::instance_conf = SL::InstanceConfiguration->new;
106 $form->{script} = 'rose_meta_data.pl';
109 $::auth = SL::Auth->new(unit_tests_database => 1);
111 drop_and_create_test_database();
113 $::auth = SL::Auth->new();
116 if (!$::auth->set_client($client)) {
117 error("No client with ID or name '$client' found in config. Please provide a client:");
121 foreach (($meta_path, $manager_path)) {
126 sub fix_relationship_names {
127 my ($domain, $table, $fkey_text) = @_;
129 if ($fkey_text !~ m/key_columns \s+ => \s+ \{ \s+ ['"]? ( [^'"\s]+ ) /x) {
130 die "fix_relationship_names: could not extract the key column for domain/table $domain/$table; foreign key definition text:\n${fkey_text}\n";
133 my $column_name = $1;
134 my %changes = map { %{$_} } grep { $_ } ($foreign_key_name_map{$domain}->{ALL}, $foreign_key_name_map{$domain}->{$table});
136 if (my $desired_name = $changes{$column_name}) {
137 $fkey_text =~ s/^ \s\s [^\s]+ \b/ ${desired_name}/msx;
144 my ($domain, $table, $package) = @_;
146 ($schema, $table) = split(m/\./, $table) if $table =~ m/\./;
147 $package = ucfirst($package || $table);
148 $package =~ s/_+(.)/uc($1)/ge;
149 my $meta_file = "${meta_path}/${package}.pm";
150 my $mngr_file = "${manager_path}/${package}.pm";
151 my $file = "SL/DB/${package}.pm";
153 my $schema_str = $schema ? <<CODE : '';
154 __PACKAGE__->meta->schema('$schema');
158 package SL::DB::AUTO::$package;
159 use parent qw(SL::DB::Object);
161 __PACKAGE__->meta->table('$table');
163 __PACKAGE__->meta->auto_initialize;
168 error("Error in execution for table '$table'");
169 error("'$EVAL_ERROR'") unless $config{quiet};
173 my %args = (indent => 2, use_setup => 0);
175 my $definition = "SL::DB::AUTO::$package"->meta->perl_class_definition(%args);
176 $definition =~ s/\n+__PACKAGE__->meta->initialize;\n+/\n\n/;
177 $definition =~ s/::AUTO::/::/g;
180 # Sort column definitions alphabetically
181 if ($definition =~ m/__PACKAGE__->meta->columns\( \n (.+?) \n \);/msx) {
182 my ($start, $end) = ($-[1], $+[1]);
183 my $sorted_columns = join "\n", sort split m/\n/, $1;
184 substr $definition, $start, $end - $start, $sorted_columns;
188 my $foreign_key_definition = "SL::DB::AUTO::$package"->meta->perl_foreign_keys_definition(%args);
189 $foreign_key_definition =~ s/::AUTO::/::/g;
191 if ($foreign_key_definition && ($definition =~ /\Q$foreign_key_definition\E/)) {
192 # These positions refer to the whole setup call, not just the
193 # parameters/actual relationship definitions.
194 my ($start, $end) = ($-[0], $+[0]);
196 # Match the function parameters = the actual relationship
198 next unless $foreign_key_definition =~ m/\(\n(.+)\n\)/s;
200 my ($list_start, $list_end) = ($-[0], $+[0]);
202 # Split the whole chunk on double new lines. The resulting
203 # elements are one relationship each. Then fix the relationship
204 # names and sort them by their new names.
205 my @new_foreign_keys = sort map { fix_relationship_names($domain, $table, $_) } split m/\n\n/m, $1;
207 # Replace the function parameters = the actual relationship
208 # definitions with the new ones.
209 my $sorted_foreign_keys = "(\n" . join("\n\n", @new_foreign_keys) . "\n)";
210 substr $foreign_key_definition, $list_start, $list_end - $list_start, $sorted_foreign_keys;
212 # Replace the whole setup call in the auto-generated output with
214 substr $definition, $start, $end - $start, $foreign_key_definition;
217 $definition =~ s/(meta->table.*)\n/$1\n$schema_str/m if $schema;
218 $definition =~ s{^use base}{use parent}m;
220 my $full_definition = <<CODE;
221 # This file has been auto-generated. Do not modify it; it will be overwritten
222 # by $::script automatically.
226 my $meta_definition = <<CODE;
227 # This file has been auto-generated only because it didn't exist.
228 # Feel free to modify it at will; it will not be overwritten automatically.
230 package SL::DB::${package};
234 use SL::DB::MetaSetup::${package};
235 use SL::DB::Manager::${package};
237 __PACKAGE__->meta->initialize;
242 my $file_exists = -f $meta_file;
244 my $old_size = -s $meta_file;
245 my $orig_file = do { local(@ARGV, $/) = ($meta_file); <> };
246 my $old_md5 = md5_hex($orig_file);
247 my $new_size = length $full_definition;
248 my $new_md5 = md5_hex($full_definition);
249 if ($old_size == $new_size && $old_md5 eq $new_md5) {
250 notice("No changes in $meta_file, skipping.") unless $config{quiet};
254 show_diff(\$orig_file, \$full_definition) if $config{show_diff};
257 if (!$config{nocommit}) {
258 open my $out, ">", $meta_file || die;
259 print $out $full_definition;
262 notice("File '$meta_file' " . ($file_exists ? 'updated' : 'created') . " for table '$table'");
266 if (!$config{nocommit}) {
267 open my $out, ">", $file || die;
268 print $out $meta_definition;
271 notice("File '$file' created as well.");
273 return if -f $mngr_file;
275 if (!$config{nocommit}) {
276 open my $out, ">", $mngr_file || die;
278 # This file has been auto-generated only because it didn't exist.
279 # Feel free to modify it at will; it will not be overwritten automatically.
281 package SL::DB::Manager::${package};
285 use parent qw(SL::DB::Helper::Manager);
287 sub object_class { 'SL::DB::${package}' }
289 __PACKAGE__->make_manager_methods;
295 notice("File '$mngr_file' created as well.");
301 'client=s' => \ my $client,
302 'test-client' => \ my $use_test_client,
305 'no-commit|dry-run' => \ my $nocommit,
306 help => sub { pod2usage(verbose => 99, sections => 'NAME|SYNOPSIS|OPTIONS') },
307 quiet => \ my $quiet,
311 $options->{client} = $client;
312 $options->{new_client} = $use_test_client;
313 $options->{all} = $all;
314 $options->{db} = $db;
315 $options->{nocommit} = $nocommit;
316 $options->{quiet} = $quiet;
317 $options->{color} = -t STDOUT ? 1 : 0;
320 if (eval { require Text::Diff; 1 }) {
321 $options->{show_diff} = 1;
323 error('Could not load Text::Diff. Sorry, no diffs for you.');
329 my ($text_a, $text_b) = @_;
336 Text::Diff::diff($text_a, $text_b, { OUTPUT => sub {
337 for (split /\n/, $_[0]) {
338 if ($config{color}) {
339 print colored($_, $colors{substr($_, 0, 1)}), $/;
348 pod2usage(verbose => 99, sections => 'SYNOPSIS');
351 sub list_all_tables {
354 my @schemas = (undef, uniq apply { s{\..*}{} } grep { m{\.} } keys %{ $package_names{KIVITENDO} });
357 foreach my $schema (@schemas) {
358 $db->schema($schema);
359 push @tables, map { $schema ? "${schema}.${_}" : $_ } $db->list_tables;
368 my %tables_by_domain;
370 my @domains = $config{db} ? (uc $config{db}) : sort keys %package_names;
372 foreach my $domain (@domains) {
373 my $db = SL::DB::create(undef, $domain);
374 $tables_by_domain{$domain} = [ grep { my $table = $_; none { $_ eq $table } @{ $blacklist{$domain} } } list_all_tables($db) ];
379 %tables_by_domain = partition_by {
380 my ($domain, $table) = split m{:};
381 $table ? uc($domain) : 'KIVITENDO';
384 foreach my $tables (values %tables_by_domain) {
385 s{.*:}{} for @{ $tables };
389 error("You specified neither --all nor any specific tables.");
393 return %tables_by_domain;
397 print STDERR colored(shift, 'red'), $/;
404 sub check_errors_in_package_names {
405 foreach my $domain (sort keys %package_names) {
406 my @both = grep { $package_names{$domain}->{$_} } @{ $blacklist{$domain} || [] };
409 print "Error: domain '$domain': The following table names are present in both the black list and the package name hash: ", join(' ', sort @both), "\n";
414 sub drop_and_create_test_database {
415 my $db_cfg = $::lx_office_conf{'testing/database'} || die 'testing/database missing';
418 'dbi:Pg:dbname=' . $db_cfg->{template} . ';host=' . $db_cfg->{host} . ';port=' . $db_cfg->{port},
421 SL::DBConnect->get_options,
425 my $dbh_template = SL::DBConnect->connect(@dbi_options) || BAIL_OUT("No database connection to the template database: " . $DBI::errstr);
426 my $auth_dbh = $::auth->dbconnect(1);
429 notice("Database exists; dropping");
430 $auth_dbh->disconnect;
432 dbh_do($dbh_template, "DROP DATABASE \"" . $db_cfg->{db} . "\"", message => "Database could not be dropped");
437 notice("Creating database");
439 dbh_do($dbh_template, "CREATE DATABASE \"" . $db_cfg->{db} . "\" TEMPLATE \"" . $db_cfg->{template} . "\" ENCODING 'UNICODE'", message => "Database could not be created");
440 $dbh_template->disconnect;
442 notice("Creating initial schema");
445 'dbi:Pg:dbname=' . $db_cfg->{db} . ';host=' . $db_cfg->{host} . ';port=' . $db_cfg->{port},
448 SL::DBConnect->get_options(PrintError => 0, PrintWarn => 0),
451 my $dbh = SL::DBConnect->connect(@dbi_options) || BAIL_OUT("Database connection failed: " . $DBI::errstr);
452 $::auth->{dbh} = $dbh;
453 my $dbupdater = SL::DBUpgrade2->new(form => $::form, return_on_error => 1, silent => 1);
454 my $coa = 'Germany-DATEV-SKR03EU';
456 apply_dbupgrade($dbupdater, $dbh, "sql/lx-office.sql");
457 apply_dbupgrade($dbupdater, $dbh, "sql/${coa}-chart.sql");
459 dbh_do($dbh, qq|UPDATE defaults SET coa = '${coa}', accounting_method = 'cash', profit_determination = 'income', inventory_system = 'periodic', curr = 'EUR'|);
460 dbh_do($dbh, qq|CREATE TABLE schema_info (tag TEXT, login TEXT, itime TIMESTAMP DEFAULT now(), PRIMARY KEY (tag))|);
462 notice("Creating initial auth schema");
464 $dbupdater = SL::DBUpgrade2->new(form => $::form, return_on_error => 1, auth => 1);
465 apply_dbupgrade($dbupdater, $dbh, 'sql/auth_db.sql');
467 apply_upgrades(auth => 1, dbh => $dbh);
469 notice("Creating client, user, group and employee");
471 dbh_do($dbh, qq|DELETE FROM auth.clients|);
472 dbh_do($dbh, qq|INSERT INTO auth.clients (id, name, dbhost, dbport, dbname, dbuser, dbpasswd, is_default) VALUES (1, 'Unit-Tests', ?, ?, ?, ?, ?, TRUE)|,
473 bind => [ @{ $db_cfg }{ qw(host port db user password) } ]);
474 dbh_do($dbh, qq|INSERT INTO auth."user" (id, login) VALUES (1, 'unittests')|);
475 dbh_do($dbh, qq|INSERT INTO auth."group" (id, name) VALUES (1, 'Vollzugriff')|);
476 dbh_do($dbh, qq|INSERT INTO auth.clients_users (client_id, user_id) VALUES (1, 1)|);
477 dbh_do($dbh, qq|INSERT INTO auth.clients_groups (client_id, group_id) VALUES (1, 1)|);
478 dbh_do($dbh, qq|INSERT INTO auth.user_group (user_id, group_id) VALUES (1, 1)|);
481 default_printer_id => '',
482 template_format => '',
484 email => 'unit@tester',
486 dateformat => 'dd.mm.yy',
487 show_form_details => '',
488 name => 'Unit Tester',
490 hide_cvar_search_options => '',
491 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>