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', email_recipient_contact_id => 'email_recipient_contact' },
77 reconciliation_links => { acc_trans_id => 'acc_trans' },
79 assembly => { parts_id => 'part', id => 'assembly_part' },
85 SL::LxOfficeConf->read;
87 my $client = $config{client} || $::lx_office_conf{devel}{client};
88 my $new_client = $config{new_client};
90 if (!$client && !$new_client) {
91 error("No client found in config. Please provide a client:");
95 $::lxdebug = LXDebug->new();
96 $::lxdebug->disable_sub_tracing;
97 $::locale = Locale->new("de");
99 $::instance_conf = SL::InstanceConfiguration->new;
100 $form->{script} = 'rose_meta_data.pl';
103 $::auth = SL::Auth->new(unit_tests_database => 1);
105 drop_and_create_test_database();
107 $::auth = SL::Auth->new();
110 if (!$::auth->set_client($client)) {
111 error("No client with ID or name '$client' found in config. Please provide a client:");
115 foreach (($meta_path, $manager_path)) {
120 sub fix_relationship_names {
121 my ($domain, $table, $fkey_text) = @_;
123 if ($fkey_text !~ m/key_columns \s+ => \s+ \{ \s+ ['"]? ( [^'"\s]+ ) /x) {
124 die "fix_relationship_names: could not extract the key column for domain/table $domain/$table; foreign key definition text:\n${fkey_text}\n";
127 my $column_name = $1;
128 my %changes = map { %{$_} } grep { $_ } ($foreign_key_name_map{$domain}->{ALL}, $foreign_key_name_map{$domain}->{$table});
130 if (my $desired_name = $changes{$column_name}) {
131 $fkey_text =~ s/^ \s\s [^\s]+ \b/ ${desired_name}/msx;
138 my ($domain, $table, $package) = @_;
140 ($schema, $table) = split(m/\./, $table) if $table =~ m/\./;
141 $package = ucfirst($package || $table);
142 $package =~ s/_+(.)/uc($1)/ge;
143 my $meta_file = "${meta_path}/${package}.pm";
144 my $mngr_file = "${manager_path}/${package}.pm";
145 my $file = "SL/DB/${package}.pm";
147 my $schema_str = $schema ? <<CODE : '';
148 __PACKAGE__->meta->schema('$schema');
152 package SL::DB::AUTO::$package;
153 use parent qw(SL::DB::Object);
155 __PACKAGE__->meta->table('$table');
157 __PACKAGE__->meta->auto_initialize;
162 error("Error in execution for table '$table'");
163 error("'$EVAL_ERROR'") unless $config{quiet};
167 my %args = (indent => 2, use_setup => 0);
169 my $definition = "SL::DB::AUTO::$package"->meta->perl_class_definition(%args);
170 $definition =~ s/\n+__PACKAGE__->meta->initialize;\n+/\n\n/;
171 $definition =~ s/::AUTO::/::/g;
174 # Sort column definitions alphabetically
175 if ($definition =~ m/__PACKAGE__->meta->columns\( \n (.+?) \n \);/msx) {
176 my ($start, $end) = ($-[1], $+[1]);
177 my $sorted_columns = join "\n", sort split m/\n/, $1;
178 substr $definition, $start, $end - $start, $sorted_columns;
182 my $foreign_key_definition = "SL::DB::AUTO::$package"->meta->perl_foreign_keys_definition(%args);
183 $foreign_key_definition =~ s/::AUTO::/::/g;
185 if ($foreign_key_definition && ($definition =~ /\Q$foreign_key_definition\E/)) {
186 # These positions refer to the whole setup call, not just the
187 # parameters/actual relationship definitions.
188 my ($start, $end) = ($-[0], $+[0]);
190 # Match the function parameters = the actual relationship
192 next unless $foreign_key_definition =~ m/\(\n(.+)\n\)/s;
194 my ($list_start, $list_end) = ($-[0], $+[0]);
196 # Split the whole chunk on double new lines. The resulting
197 # elements are one relationship each. Then fix the relationship
198 # names and sort them by their new names.
199 my @new_foreign_keys = sort map { fix_relationship_names($domain, $table, $_) } split m/\n\n/m, $1;
201 # Replace the function parameters = the actual relationship
202 # definitions with the new ones.
203 my $sorted_foreign_keys = "(\n" . join("\n\n", @new_foreign_keys) . "\n)";
204 substr $foreign_key_definition, $list_start, $list_end - $list_start, $sorted_foreign_keys;
206 # Replace the whole setup call in the auto-generated output with
208 substr $definition, $start, $end - $start, $foreign_key_definition;
211 $definition =~ s/(meta->table.*)\n/$1\n$schema_str/m if $schema;
212 $definition =~ s{^use base}{use parent}m;
214 my $full_definition = <<CODE;
215 # This file has been auto-generated. Do not modify it; it will be overwritten
216 # by $::script automatically.
220 my $meta_definition = <<CODE;
221 # This file has been auto-generated only because it didn't exist.
222 # Feel free to modify it at will; it will not be overwritten automatically.
224 package SL::DB::${package};
228 use SL::DB::MetaSetup::${package};
229 use SL::DB::Manager::${package};
231 __PACKAGE__->meta->initialize;
236 my $file_exists = -f $meta_file;
238 my $old_size = -s $meta_file;
239 my $orig_file = do { local(@ARGV, $/) = ($meta_file); <> };
240 my $old_md5 = md5_hex($orig_file);
241 my $new_size = length $full_definition;
242 my $new_md5 = md5_hex($full_definition);
243 if ($old_size == $new_size && $old_md5 eq $new_md5) {
244 notice("No changes in $meta_file, skipping.") unless $config{quiet};
248 show_diff(\$orig_file, \$full_definition) if $config{show_diff};
251 if (!$config{nocommit}) {
252 open my $out, ">", $meta_file || die;
253 print $out $full_definition;
256 notice("File '$meta_file' " . ($file_exists ? 'updated' : 'created') . " for table '$table'");
260 if (!$config{nocommit}) {
261 open my $out, ">", $file || die;
262 print $out $meta_definition;
265 notice("File '$file' created as well.");
267 return if -f $mngr_file;
269 if (!$config{nocommit}) {
270 open my $out, ">", $mngr_file || die;
272 # This file has been auto-generated only because it didn't exist.
273 # Feel free to modify it at will; it will not be overwritten automatically.
275 package SL::DB::Manager::${package};
279 use parent qw(SL::DB::Helper::Manager);
281 sub object_class { 'SL::DB::${package}' }
283 __PACKAGE__->make_manager_methods;
289 notice("File '$mngr_file' created as well.");
295 'client=s' => \ my $client,
296 'test-client' => \ my $use_test_client,
299 'no-commit|dry-run' => \ my $nocommit,
300 help => sub { pod2usage(verbose => 99, sections => 'NAME|SYNOPSIS|OPTIONS') },
301 quiet => \ my $quiet,
305 $options->{client} = $client;
306 $options->{new_client} = $use_test_client;
307 $options->{all} = $all;
308 $options->{db} = $db;
309 $options->{nocommit} = $nocommit;
310 $options->{quiet} = $quiet;
311 $options->{color} = -t STDOUT ? 1 : 0;
314 if (eval { require Text::Diff; 1 }) {
315 $options->{show_diff} = 1;
317 error('Could not load Text::Diff. Sorry, no diffs for you.');
323 my ($text_a, $text_b) = @_;
330 Text::Diff::diff($text_a, $text_b, { OUTPUT => sub {
331 for (split /\n/, $_[0]) {
332 if ($config{color}) {
333 print colored($_, $colors{substr($_, 0, 1)}), $/;
342 pod2usage(verbose => 99, sections => 'SYNOPSIS');
345 sub list_all_tables {
348 my @schemas = (undef, uniq apply { s{\..*}{} } grep { m{\.} } keys %{ $package_names{KIVITENDO} });
351 foreach my $schema (@schemas) {
352 $db->schema($schema);
353 push @tables, map { $schema ? "${schema}.${_}" : $_ } $db->list_tables;
362 my %tables_by_domain;
364 my @domains = $config{db} ? (uc $config{db}) : sort keys %package_names;
366 foreach my $domain (@domains) {
367 my $db = SL::DB::create(undef, $domain);
368 $tables_by_domain{$domain} = [ grep { my $table = $_; none { $_ eq $table } @{ $blacklist{$domain} } } list_all_tables($db) ];
373 %tables_by_domain = partition_by {
374 my ($domain, $table) = split m{:};
375 $table ? uc($domain) : 'KIVITENDO';
378 foreach my $tables (values %tables_by_domain) {
379 s{.*:}{} for @{ $tables };
383 error("You specified neither --all nor any specific tables.");
387 return %tables_by_domain;
391 print STDERR colored(shift, 'red'), $/;
398 sub check_errors_in_package_names {
399 foreach my $domain (sort keys %package_names) {
400 my @both = grep { $package_names{$domain}->{$_} } @{ $blacklist{$domain} || [] };
403 print "Error: domain '$domain': The following table names are present in both the black list and the package name hash: ", join(' ', sort @both), "\n";
408 sub drop_and_create_test_database {
409 my $db_cfg = $::lx_office_conf{'testing/database'} || die 'testing/database missing';
412 'dbi:Pg:dbname=' . $db_cfg->{template} . ';host=' . $db_cfg->{host} . ';port=' . $db_cfg->{port},
415 SL::DBConnect->get_options,
419 my $dbh_template = SL::DBConnect->connect(@dbi_options) || BAIL_OUT("No database connection to the template database: " . $DBI::errstr);
420 my $auth_dbh = $::auth->dbconnect(1);
423 notice("Database exists; dropping");
424 $auth_dbh->disconnect;
426 dbh_do($dbh_template, "DROP DATABASE \"" . $db_cfg->{db} . "\"", message => "Database could not be dropped");
431 notice("Creating database");
433 dbh_do($dbh_template, "CREATE DATABASE \"" . $db_cfg->{db} . "\" TEMPLATE \"" . $db_cfg->{template} . "\" ENCODING 'UNICODE'", message => "Database could not be created");
434 $dbh_template->disconnect;
436 notice("Creating initial schema");
439 'dbi:Pg:dbname=' . $db_cfg->{db} . ';host=' . $db_cfg->{host} . ';port=' . $db_cfg->{port},
442 SL::DBConnect->get_options(PrintError => 0, PrintWarn => 0),
445 my $dbh = SL::DBConnect->connect(@dbi_options) || BAIL_OUT("Database connection failed: " . $DBI::errstr);
446 $::auth->{dbh} = $dbh;
447 my $dbupdater = SL::DBUpgrade2->new(form => $::form, return_on_error => 1, silent => 1);
448 my $coa = 'Germany-DATEV-SKR03EU';
450 apply_dbupgrade($dbupdater, $dbh, "sql/lx-office.sql");
451 apply_dbupgrade($dbupdater, $dbh, "sql/${coa}-chart.sql");
453 dbh_do($dbh, qq|UPDATE defaults SET coa = '${coa}', accounting_method = 'cash', profit_determination = 'income', inventory_system = 'periodic', curr = 'EUR'|);
454 dbh_do($dbh, qq|CREATE TABLE schema_info (tag TEXT, login TEXT, itime TIMESTAMP DEFAULT now(), PRIMARY KEY (tag))|);
456 notice("Creating initial auth schema");
458 $dbupdater = SL::DBUpgrade2->new(form => $::form, return_on_error => 1, auth => 1);
459 apply_dbupgrade($dbupdater, $dbh, 'sql/auth_db.sql');
461 apply_upgrades(auth => 1, dbh => $dbh);
463 notice("Creating client, user, group and employee");
465 dbh_do($dbh, qq|DELETE FROM auth.clients|);
466 dbh_do($dbh, qq|INSERT INTO auth.clients (id, name, dbhost, dbport, dbname, dbuser, dbpasswd, is_default) VALUES (1, 'Unit-Tests', ?, ?, ?, ?, ?, TRUE)|,
467 bind => [ @{ $db_cfg }{ qw(host port db user password) } ]);
468 dbh_do($dbh, qq|INSERT INTO auth."user" (id, login) VALUES (1, 'unittests')|);
469 dbh_do($dbh, qq|INSERT INTO auth."group" (id, name) VALUES (1, 'Vollzugriff')|);
470 dbh_do($dbh, qq|INSERT INTO auth.clients_users (client_id, user_id) VALUES (1, 1)|);
471 dbh_do($dbh, qq|INSERT INTO auth.clients_groups (client_id, group_id) VALUES (1, 1)|);
472 dbh_do($dbh, qq|INSERT INTO auth.user_group (user_id, group_id) VALUES (1, 1)|);
475 default_printer_id => '',
476 template_format => '',
478 email => 'unit@tester',
480 dateformat => 'dd.mm.yy',
481 show_form_details => '',
482 name => 'Unit Tester',
484 hide_cvar_search_options => '',
485 numberformat => '1.000,00',
491 stylesheet => 'lx-office-erp.css',
492 mandatory_departments => 0,
496 my $sth = $dbh->prepare(qq|INSERT INTO auth.user_config (user_id, cfg_key, cfg_value) VALUES (1, ?, ?)|) || BAIL_OUT($dbh->errstr);
497 dbh_do($dbh, $sth, bind => [ $_, $config{$_} ]) for sort keys %config;
500 $sth = $dbh->prepare(qq|INSERT INTO auth.group_rights (group_id, "right", granted) VALUES (1, ?, TRUE)|) || BAIL_OUT($dbh->errstr);
501 dbh_do($dbh, $sth, bind => [ $_ ]) for sort $::auth->all_rights;
504 dbh_do($dbh, qq|INSERT INTO employee (id, login, name) VALUES (1, 'unittests', 'Unit Tester')|);
506 $::auth->set_client(1) || BAIL_OUT("\$::auth->set_client(1) failed");
507 %::myconfig = $::auth->read_user(login => 'unittests');
509 apply_upgrades(dbh => $dbh);
514 my $dbupdater = SL::DBUpgrade2->new(form => $::form, return_on_error => 1, auth => $params{auth});
515 my @unapplied_scripts = $dbupdater->unapplied_upgrade_scripts($params{dbh});
517 my $all = @unapplied_scripts;
519 for my $script (@unapplied_scripts) {
521 print "\rUpgrade $i/$all";
522 apply_dbupgrade($dbupdater, $params{dbh}, $script);
527 sub apply_dbupgrade {
528 my ($dbupdater, $dbh, $control_or_file) = @_;
530 my $file = ref($control_or_file) ? ("sql/Pg-upgrade2" . ($dbupdater->{auth} ? "-auth" : "") . "/$control_or_file->{file}") : $control_or_file;
531 my $control = ref($control_or_file) ? $control_or_file : undef;
533 my $error = $dbupdater->process_file($dbh, $file, $control);
535 die("Error applying $file: $error") if $error;
539 my ($dbh, $query, %params) = @_;
542 return if $query->execute(@{ $params{bind} || [] });
546 return if $dbh->do($query, undef, @{ $params{bind} || [] });
548 die($params{message} . ": " . $dbh->errstr) if $params{message};
549 die("Query failed: " . $dbh->errstr . " ; query: $query");
552 parse_args(\%config);
554 check_errors_in_package_names();
556 my %tables_by_domain = make_tables();
558 foreach my $domain (keys %tables_by_domain) {
559 my @tables = @{ $tables_by_domain{$domain} };
560 my @unknown_tables = grep { !$package_names{$domain}->{$_} } @tables;
561 if (@unknown_tables) {
562 error("The following tables do not have entries in \%SL::DB::Helper::Mappings::${domain}_package_names: " . join(' ', sort @unknown_tables));
566 process_table($domain, $_, $package_names{$domain}->{$_}) for @tables;
577 rose_auto_create_model - mana Rose::DB::Object classes for kivitendo
581 scripts/rose_auto_create_model.pl OPTIONS TARGET
583 # use other client than devel.client
584 scripts/rose_auto_create_model.pl --test-client TARGET
585 scripts/rose_auto_create_model.pl --client name-or-id TARGET
589 scripts/rose_auto_create_model.pl --all [--db db]
591 # updates only customer table, login taken from config
592 scripts/rose_auto_create_model.pl customer
594 # updates only parts table, package will be Part
595 scripts/rose_auto_create_model.pl parts=Part
597 # try to update parts, but don't do it. tell what would happen in detail
598 scripts/rose_auto_create_model.pl --no-commit parts
602 Rose::DB::Object comes with a nice function named auto initialization with code
603 generation. The documentation of Rose describes it like this:
605 I<[...] auto-initializing metadata at runtime by querying the database has many
606 caveats. An alternate approach is to query the database for metadata just once,
607 and then generate the equivalent Perl code which can be pasted directly into
608 the class definition in place of the call to auto_initialize.>
610 I<Like the auto-initialization process itself, perl code generation has a
611 convenient wrapper method as well as separate methods for the individual parts.
612 All of the perl code generation methods begin with "perl_", and they support
613 some rudimentary code formatting options to help the code conform to you
614 preferred style. Examples can be found with the documentation for each perl_*
617 I<This hybrid approach to metadata population strikes a good balance between
618 upfront effort and ongoing maintenance. Auto-generating the Perl code for the
619 initial class definition saves a lot of tedious typing. From that point on,
620 manually correcting and maintaining the definition is a small price to pay for
621 the decreased start-up cost, the ability to use the class in the absence of a
622 database connection, and the piece of mind that comes from knowing that your
623 class is stable, and won't change behind your back in response to an "action at
624 a distance" (i.e., a database schema update).>
626 Unfortunately this reads easier than it is, since classes need to go into the
627 right package and directory, certain stuff needs to be adjusted and table names
628 need to be translated into their class names. This script will wrap all that
629 behind a few simple options.
631 In the most basic version, just give it a login and a table name, and it will
632 load the schema information for this table and create the appropriate class
633 files, or update them if already present.
635 Each table has three associated files. A C<SL::DB::MetaSetup::*>
636 class, which is a perl version of the schema definition, a
637 C<SL::DB::*> class file and a C<SL::DB::Manager::*> manager class
638 file. The first one will be updated if the schema changes, the second
639 and third ones will only be created if it they do not exist.
641 =head1 DATABASE NAMES AND TABLES
643 If you want to generate the data for specific tables only then you
644 have to list them on the command line. The format is
645 C<db-name:table-name>. The part C<db-name:> is optional and defaults
646 to C<KIVITENDO:> – which means the tables in the default kivitendo
649 Valid database names are keys in the hash returned by
650 L<SL::DB::Helper::Mappings/get_package_names>.
656 =item C<--test-client, -t>
658 Use the C<testing/database> to create a new testing database, and connect to
659 the first client there. Overrides C<client>.
661 If neither C<test-client> nor C<client> are set, the config key C<devel/client>
664 =item C<--client, -c CLIENT>
666 Provide a client whose database settings are used. C<CLIENT> can be either a
667 database ID or a client's name.
669 If neither C<test-client> nor C<client> are set, the config key C<devel/client>
674 Process all tables from the database. Only those that are blacklistes in
675 L<SL::DB::Helper::Mappings> are excluded.
679 In combination with C<--all> causes all tables in the specific
680 database to be processed, not in all databases.
682 =item C<--no-commit, -n>
686 Do not write back generated files. This will do everything as usual but not
687 actually modify any file.
691 Displays diff for selected file, if file is present and newer file is
692 different. Beware, does not imply C<--no-commit>.
700 Does not print extra information, such as skipped files that were not
701 changed and errors where the auto initialization failed.
711 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>,
712 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>