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");
435 notice("Creating database");
437 dbh_do($dbh_template, "CREATE DATABASE \"" . $db_cfg->{db} . "\" TEMPLATE \"" . $db_cfg->{template} . "\" ENCODING 'UNICODE'", message => "Database could not be created");
438 $dbh_template->disconnect;
440 notice("Creating initial schema");
443 'dbi:Pg:dbname=' . $db_cfg->{db} . ';host=' . $db_cfg->{host} . ';port=' . $db_cfg->{port},
446 SL::DBConnect->get_options(PrintError => 0, PrintWarn => 0),
449 my $dbh = SL::DBConnect->connect(@dbi_options) || BAIL_OUT("Database connection failed: " . $DBI::errstr);
450 $::auth->{dbh} = $dbh;
451 my $dbupdater = SL::DBUpgrade2->new(form => $::form, return_on_error => 1, silent => 1);
452 my $coa = 'Germany-DATEV-SKR03EU';
454 apply_dbupgrade($dbupdater, $dbh, "sql/lx-office.sql");
455 apply_dbupgrade($dbupdater, $dbh, "sql/${coa}-chart.sql");
457 dbh_do($dbh, qq|UPDATE defaults SET coa = '${coa}', accounting_method = 'cash', profit_determination = 'income', inventory_system = 'periodic', curr = 'EUR'|);
458 dbh_do($dbh, qq|CREATE TABLE schema_info (tag TEXT, login TEXT, itime TIMESTAMP DEFAULT now(), PRIMARY KEY (tag))|);
460 notice("Creating initial auth schema");
462 $dbupdater = SL::DBUpgrade2->new(form => $::form, return_on_error => 1, auth => 1);
463 apply_dbupgrade($dbupdater, $dbh, 'sql/auth_db.sql');
465 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',
496 stylesheet => 'lx-office-erp.css',
497 mandatory_departments => 0,
501 my $sth = $dbh->prepare(qq|INSERT INTO auth.user_config (user_id, cfg_key, cfg_value) VALUES (1, ?, ?)|) || BAIL_OUT($dbh->errstr);
502 dbh_do($dbh, $sth, bind => [ $_, $config{$_} ]) for sort keys %config;
505 $sth = $dbh->prepare(qq|INSERT INTO auth.group_rights (group_id, "right", granted) VALUES (1, ?, TRUE)|) || BAIL_OUT($dbh->errstr);
506 dbh_do($dbh, $sth, bind => [ $_ ]) for sort $::auth->all_rights;
509 dbh_do($dbh, qq|INSERT INTO employee (id, login, name) VALUES (1, 'unittests', 'Unit Tester')|);
511 $::auth->set_client(1) || BAIL_OUT("\$::auth->set_client(1) failed");
512 %::myconfig = $::auth->read_user(login => 'unittests');
514 apply_upgrades(dbh => $dbh);
519 my $dbupdater = SL::DBUpgrade2->new(form => $::form, return_on_error => 1, auth => $params{auth});
520 my @unapplied_scripts = $dbupdater->unapplied_upgrade_scripts($params{dbh});
522 my $all = @unapplied_scripts;
524 for my $script (@unapplied_scripts) {
526 print "\rUpgrade $i/$all";
527 apply_dbupgrade($dbupdater, $params{dbh}, $script);
532 sub apply_dbupgrade {
533 my ($dbupdater, $dbh, $control_or_file) = @_;
535 my $file = ref($control_or_file) ? ("sql/Pg-upgrade2" . ($dbupdater->{auth} ? "-auth" : "") . "/$control_or_file->{file}") : $control_or_file;
536 my $control = ref($control_or_file) ? $control_or_file : undef;
538 my $error = $dbupdater->process_file($dbh, $file, $control);
540 die("Error applying $file: $error") if $error;
544 my ($dbh, $query, %params) = @_;
547 return if $query->execute(@{ $params{bind} || [] });
551 return if $dbh->do($query, undef, @{ $params{bind} || [] });
553 die($params{message} . ": " . $dbh->errstr) if $params{message};
554 die("Query failed: " . $dbh->errstr . " ; query: $query");
557 parse_args(\%config);
559 check_errors_in_package_names();
561 my %tables_by_domain = make_tables();
563 foreach my $domain (keys %tables_by_domain) {
564 my @tables = @{ $tables_by_domain{$domain} };
565 my @unknown_tables = grep { !$package_names{$domain}->{$_} } @tables;
566 if (@unknown_tables) {
567 error("The following tables do not have entries in \%SL::DB::Helper::Mappings::${domain}_package_names: " . join(' ', sort @unknown_tables));
571 process_table($domain, $_, $package_names{$domain}->{$_}) for @tables;
582 rose_auto_create_model - mana Rose::DB::Object classes for kivitendo
586 scripts/rose_auto_create_model.pl OPTIONS TARGET
588 # use other client than devel.client
589 scripts/rose_auto_create_model.pl --test-client TARGET
590 scripts/rose_auto_create_model.pl --client name-or-id TARGET
594 scripts/rose_auto_create_model.pl --all [--db db]
596 # updates only customer table, login taken from config
597 scripts/rose_auto_create_model.pl customer
599 # updates only parts table, package will be Part
600 scripts/rose_auto_create_model.pl parts=Part
602 # try to update parts, but don't do it. tell what would happen in detail
603 scripts/rose_auto_create_model.pl --no-commit parts
607 Rose::DB::Object comes with a nice function named auto initialization with code
608 generation. The documentation of Rose describes it like this:
610 I<[...] auto-initializing metadata at runtime by querying the database has many
611 caveats. An alternate approach is to query the database for metadata just once,
612 and then generate the equivalent Perl code which can be pasted directly into
613 the class definition in place of the call to auto_initialize.>
615 I<Like the auto-initialization process itself, perl code generation has a
616 convenient wrapper method as well as separate methods for the individual parts.
617 All of the perl code generation methods begin with "perl_", and they support
618 some rudimentary code formatting options to help the code conform to you
619 preferred style. Examples can be found with the documentation for each perl_*
622 I<This hybrid approach to metadata population strikes a good balance between
623 upfront effort and ongoing maintenance. Auto-generating the Perl code for the
624 initial class definition saves a lot of tedious typing. From that point on,
625 manually correcting and maintaining the definition is a small price to pay for
626 the decreased start-up cost, the ability to use the class in the absence of a
627 database connection, and the piece of mind that comes from knowing that your
628 class is stable, and won't change behind your back in response to an "action at
629 a distance" (i.e., a database schema update).>
631 Unfortunately this reads easier than it is, since classes need to go into the
632 right package and directory, certain stuff needs to be adjusted and table names
633 need to be translated into their class names. This script will wrap all that
634 behind a few simple options.
636 In the most basic version, just give it a login and a table name, and it will
637 load the schema information for this table and create the appropriate class
638 files, or update them if already present.
640 Each table has three associated files. A C<SL::DB::MetaSetup::*>
641 class, which is a perl version of the schema definition, a
642 C<SL::DB::*> class file and a C<SL::DB::Manager::*> manager class
643 file. The first one will be updated if the schema changes, the second
644 and third ones will only be created if it they do not exist.
646 =head1 DATABASE NAMES AND TABLES
648 If you want to generate the data for specific tables only then you
649 have to list them on the command line. The format is
650 C<db-name:table-name>. The part C<db-name:> is optional and defaults
651 to C<KIVITENDO:> – which means the tables in the default kivitendo
654 Valid database names are keys in the hash returned by
655 L<SL::DB::Helper::Mappings/get_package_names>.
661 =item C<--test-client, -t>
663 Use the C<testing/database> to create a new testing database, and connect to
664 the first client there. Overrides C<client>.
666 If neither C<test-client> nor C<client> are set, the config key C<devel/client>
669 =item C<--client, -c CLIENT>
671 Provide a client whose database settings are used. C<CLIENT> can be either a
672 database ID or a client's name.
674 If neither C<test-client> nor C<client> are set, the config key C<devel/client>
679 Process all tables from the database. Only those that are blacklistes in
680 L<SL::DB::Helper::Mappings> are excluded.
684 In combination with C<--all> causes all tables in the specific
685 database to be processed, not in all databases.
687 =item C<--no-commit, -n>
691 Do not write back generated files. This will do everything as usual but not
692 actually modify any file.
696 Displays diff for selected file, if file is present and newer file is
697 different. Beware, does not imply C<--no-commit>.
705 Does not print extra information, such as skipped files that were not
706 changed and errors where the auto initialization failed.
716 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>,
717 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>