scripts/rose_auto_create_model.pl

   1 #!/usr/bin/perl
   2
   3 use strict;
   4
   5 BEGIN {
   6   use FindBin;
   7
   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.
  11 }
  12
  13 use CGI qw( -no_xhtml);
  14 use Config::Std;
  15 use Data::Dumper;
  16 use Digest::MD5 qw(md5_hex);
  17 use English qw( -no_match_vars );
  18 use Getopt::Long;
  19 use List::MoreUtils qw(apply none uniq);
  20 use List::UtilsBy qw(partition_by);
  21 use Pod::Usage;
  22 use Rose::DB::Object 0.809;
  23 use Term::ANSIColor;
  24
  25 use SL::Auth;
  26 use SL::DBUtils;
  27 use SL::DB;
  28 use SL::Form;
  29 use SL::InstanceConfiguration;
  30 use SL::Locale;
  31 use SL::LXDebug;
  32 use SL::LxOfficeConf;
  33 use SL::DB::Helper::ALL;
  34 use SL::DB::Helper::Mappings;
  35
  36 chdir($FindBin::Bin . '/..');
  37
  38 my %blacklist     = SL::DB::Helper::Mappings->get_blacklist;
  39 my %package_names = SL::DB::Helper::Mappings->get_package_names;
  40
  41 our $form;
  42 our $auth;
  43 our %lx_office_conf;
  44
  45 our $script =  __FILE__;
  46 $script     =~ s{.*/}{};
  47
  48 $OUTPUT_AUTOFLUSH       = 1;
  49 $Data::Dumper::Sortkeys = 1;
  50
  51 our $meta_path    = "SL/DB/MetaSetup";
  52 our $manager_path = "SL/DB/Manager";
  53
  54 my %config;
  55
  56 # Maps column names in tables to foreign key relationship names.  For
  57 # example:
  58 #
  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«.
  64 #
  65 # In order to rename this relationship we have to map »who« to
  66 # e.g. »granted_by«:
  67 #   follow_up_access => { who => 'granted_by' },
  68
  69 our %foreign_key_name_map     = (
  70   KIVITENDO                   => {
  71     oe                        => { payment_id => 'payment_terms', },
  72     ar                        => { payment_id => 'payment_terms', },
  73     ap                        => { payment_id => 'payment_terms', },
  74
  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', },
  80
  81     periodic_invoices_configs => { oe_id => 'order', email_recipient_contact_id => 'email_recipient_contact' },
  82     reconciliation_links      => { acc_trans_id => 'acc_trans' },
  83
  84     assembly                  => { parts_id => 'part', id => 'assembly_part' },
  85   },
  86 );
  87
  88 sub setup {
  89
  90   SL::LxOfficeConf->read;
  91
  92   my $client     = $config{client} || $::lx_office_conf{devel}{client};
  93   my $new_client = $config{new_client};
  94
  95   if (!$client && !$new_client) {
  96     error("No client found in config. Please provide a client:");
  97     usage();
  98   }
  99
 100   $::lxdebug       = LXDebug->new();
 101   $::lxdebug->disable_sub_tracing;
 102   $::locale        = Locale->new("de");
 103   $::form          = new Form;
 104   $::instance_conf = SL::InstanceConfiguration->new;
 105   $form->{script}  = 'rose_meta_data.pl';
 106
 107   if ($new_client) {
 108     $::auth       = SL::Auth->new(unit_tests_database => 1);
 109     $client       = 1;
 110     drop_and_create_test_database();
 111   } else {
 112     $::auth       = SL::Auth->new();
 113   }
 114
 115   if (!$::auth->set_client($client)) {
 116     error("No client with ID or name '$client' found in config. Please provide a client:");
 117     usage();
 118   }
 119
 120   foreach (($meta_path, $manager_path)) {
 121     mkdir $_ unless -d;
 122   }
 123 }
 124
 125 sub fix_relationship_names {
 126   my ($domain, $table, $fkey_text) = @_;
 127
 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";
 130   }
 131
 132   my $column_name = $1;
 133   my %changes     = map { %{$_} } grep { $_ } ($foreign_key_name_map{$domain}->{ALL}, $foreign_key_name_map{$domain}->{$table});
 134
 135   if (my $desired_name = $changes{$column_name}) {
 136     $fkey_text =~ s/^ \s\s [^\s]+ \b/  ${desired_name}/msx;
 137   }
 138
 139   return $fkey_text;
 140 }
 141
 142 sub process_table {
 143   my ($domain, $table, $package) = @_;
 144   my $schema     = '';
 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";
 151
 152   my $schema_str = $schema ? <<CODE : '';
 153 __PACKAGE__->meta->schema('$schema');
 154 CODE
 155
 156   eval <<CODE;
 157     package SL::DB::AUTO::$package;
 158     use parent qw(SL::DB::Object);
 159
 160     __PACKAGE__->meta->table('$table');
 161     $schema_str
 162     __PACKAGE__->meta->auto_initialize;
 163
 164 CODE
 165
 166   if ($EVAL_ERROR) {
 167     error("Error in execution for table '$table'");
 168     error("'$EVAL_ERROR'") unless $config{quiet};
 169     return;
 170   }
 171
 172   my %args = (indent => 2, use_setup => 0);
 173
 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;
 177
 178
 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;
 184   }
 185
 186   # patch foreign keys
 187   my $foreign_key_definition = "SL::DB::AUTO::$package"->meta->perl_foreign_keys_definition(%args);
 188   $foreign_key_definition =~ s/::AUTO::/::/g;
 189
 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]);
 194
 195     # Match the function parameters = the actual relationship
 196     # definitions
 197     next unless $foreign_key_definition =~ m/\(\n(.+)\n\)/s;
 198
 199     my ($list_start, $list_end) = ($-[0], $+[0]);
 200
 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;
 205
 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;
 210
 211     # Replace the whole setup call in the auto-generated output with
 212     # our new version.
 213     substr $definition, $start, $end - $start, $foreign_key_definition;
 214   }
 215
 216   $definition =~ s/(meta->table.*)\n/$1\n$schema_str/m if $schema;
 217   $definition =~ s{^use base}{use parent}m;
 218
 219   my $full_definition = <<CODE;
 220 # This file has been auto-generated. Do not modify it; it will be overwritten
 221 # by $::script automatically.
 222 $definition;
 223 CODE
 224
 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.
 228
 229 package SL::DB::${package};
 230
 231 use strict;
 232
 233 use SL::DB::MetaSetup::${package};
 234 use SL::DB::Manager::${package};
 235
 236 __PACKAGE__->meta->initialize;
 237
 238 1;
 239 CODE
 240
 241   my $file_exists = -f $meta_file;
 242   if ($file_exists) {
 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};
 250       return;
 251     }
 252
 253     show_diff(\$orig_file, \$full_definition) if $config{show_diff};
 254   }
 255
 256   if (!$config{nocommit}) {
 257     open my $out, ">", $meta_file || die;
 258     print $out $full_definition;
 259   }
 260
 261   notice("File '$meta_file' " . ($file_exists ? 'updated' : 'created') . " for table '$table'");
 262
 263   return if -f $file;
 264
 265   if (!$config{nocommit}) {
 266     open my $out, ">", $file || die;
 267     print $out $meta_definition;
 268   }
 269
 270   notice("File '$file' created as well.");
 271
 272   return if -f $mngr_file;
 273
 274   if (!$config{nocommit}) {
 275     open my $out, ">", $mngr_file || die;
 276     print $out <<EOT;
 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.
 279
 280 package SL::DB::Manager::${package};
 281
 282 use strict;
 283
 284 use parent qw(SL::DB::Helper::Manager);
 285
 286 sub object_class { 'SL::DB::${package}' }
 287
 288 __PACKAGE__->make_manager_methods;
 289
 290 1;
 291 EOT
 292   }
 293
 294   notice("File '$mngr_file' created as well.");
 295 }
 296
 297 sub parse_args {
 298   my ($options) = @_;
 299   GetOptions(
 300     'client=s'          => \ my $client,
 301     'test-client'       => \ my $use_test_client,
 302     all                 => \ my $all,
 303     'db=s'              => \ my $db,
 304     'no-commit|dry-run' => \ my $nocommit,
 305     help                => sub { pod2usage(verbose => 99, sections => 'NAME|SYNOPSIS|OPTIONS') },
 306     quiet               => \ my $quiet,
 307     diff                => \ my $diff,
 308   );
 309
 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;
 317
 318   if ($diff) {
 319     if (eval { require Text::Diff; 1 }) {
 320       $options->{show_diff} = 1;
 321     } else {
 322       error('Could not load Text::Diff. Sorry, no diffs for you.');
 323     }
 324   }
 325 }
 326
 327 sub show_diff {
 328    my ($text_a, $text_b) = @_;
 329
 330    my %colors = (
 331      '+' => 'green',
 332      '-' => 'red',
 333    );
 334
 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)}), $/;
 339        } else {
 340          print $_, $/;
 341        }
 342      }
 343    }});
 344 }
 345
 346 sub usage {
 347   pod2usage(verbose => 99, sections => 'SYNOPSIS');
 348 }
 349
 350 sub list_all_tables {
 351   my ($db) = @_;
 352
 353   my @schemas = (undef, uniq apply { s{\..*}{} } grep { m{\.} } keys %{ $package_names{KIVITENDO} });
 354   my @tables;
 355
 356   foreach my $schema (@schemas) {
 357     $db->schema($schema);
 358     push @tables, map { $schema ? "${schema}.${_}" : $_ } $db->list_tables;
 359   }
 360
 361   $db->schema(undef);
 362
 363   return @tables;
 364 }
 365
 366 sub make_tables {
 367   my %tables_by_domain;
 368   if ($config{all}) {
 369     my @domains = $config{db} ? (uc $config{db}) : sort keys %package_names;
 370
 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) ];
 374       $db->disconnect;
 375     }
 376
 377   } elsif (@ARGV) {
 378     %tables_by_domain = partition_by {
 379       my ($domain, $table) = split m{:};
 380       $table ? uc($domain) : 'KIVITENDO';
 381     } @ARGV;
 382
 383     foreach my $tables (values %tables_by_domain) {
 384       s{.*:}{} for @{ $tables };
 385     }
 386
 387   } else {
 388     error("You specified neither --all nor any specific tables.");
 389     usage();
 390   }
 391
 392   return %tables_by_domain;
 393 }
 394
 395 sub error {
 396   print STDERR colored(shift, 'red'), $/;
 397 }
 398
 399 sub notice {
 400   print @_, $/;
 401 }
 402
 403 sub check_errors_in_package_names {
 404   foreach my $domain (sort keys %package_names) {
 405     my @both = grep { $package_names{$domain}->{$_} } @{ $blacklist{$domain} || [] };
 406     next unless @both;
 407
 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";
 409     exit 1;
 410   }
 411 }
 412
 413 sub drop_and_create_test_database {
 414   my $db_cfg          = $::lx_office_conf{'testing/database'} || die 'testing/database missing';
 415
 416   my @dbi_options = (
 417     'dbi:Pg:dbname=' . $db_cfg->{template} . ';host=' . $db_cfg->{host} . ';port=' . $db_cfg->{port},
 418     $db_cfg->{user},
 419     $db_cfg->{password},
 420     SL::DBConnect->get_options,
 421   );
 422
 423   $::auth->reset;
 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);
 426
 427   if ($auth_dbh) {
 428     notice("Database exists; dropping");
 429     $auth_dbh->disconnect;
 430
 431     dbh_do($dbh_template, "DROP DATABASE \"" . $db_cfg->{db} . "\"", message => "Database could not be dropped");
 432
 433     $::auth->reset;
 434   }
 435
 436   notice("Creating database");
 437
 438   dbh_do($dbh_template, "CREATE DATABASE \"" . $db_cfg->{db} . "\" TEMPLATE \"" . $db_cfg->{template} . "\" ENCODING 'UNICODE'", message => "Database could not be created");
 439   $dbh_template->disconnect;
 440
 441   notice("Creating initial schema");
 442
 443   @dbi_options = (
 444     'dbi:Pg:dbname=' . $db_cfg->{db} . ';host=' . $db_cfg->{host} . ';port=' . $db_cfg->{port},
 445     $db_cfg->{user},
 446     $db_cfg->{password},
 447     SL::DBConnect->get_options(PrintError => 0, PrintWarn => 0),
 448   );
 449
 450   my $dbh           = SL::DBConnect->connect(@dbi_options) || BAIL_OUT("Database connection failed: " . $DBI::errstr);
 451   $::auth->{dbh} = $dbh;
 452   my $dbupdater  = SL::DBUpgrade2->new(form => $::form, return_on_error => 1, silent => 1);
 453   my $coa        = 'Germany-DATEV-SKR03EU';
 454
 455   apply_dbupgrade($dbupdater, $dbh, "sql/lx-office.sql");
 456   apply_dbupgrade($dbupdater, $dbh, "sql/${coa}-chart.sql");
 457
 458   dbh_do($dbh, qq|UPDATE defaults SET coa = '${coa}', accounting_method = 'cash', profit_determination = 'income', inventory_system = 'periodic', curr = 'EUR'|);
 459   dbh_do($dbh, qq|CREATE TABLE schema_info (tag TEXT, login TEXT, itime TIMESTAMP DEFAULT now(), PRIMARY KEY (tag))|);
 460
 461   notice("Creating initial auth schema");
 462
 463   $dbupdater = SL::DBUpgrade2->new(form => $::form, return_on_error => 1, auth => 1);
 464   apply_dbupgrade($dbupdater, $dbh, 'sql/auth_db.sql');
 465
 466   apply_upgrades(auth => 1, dbh => $dbh);
 467
 468   notice("Creating client, user, group and employee");
 469
 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)|);
 478
 479   my %config                 = (
 480     default_printer_id       => '',
 481     template_format          => '',
 482     default_media            => '',
 483     email                    => 'unit@tester',
 484     tel                      => '',
 485     dateformat               => 'dd.mm.yy',
 486     show_form_details        => '',
 487     name                     => 'Unit Tester',
 488     signature                => '',
 489     hide_cvar_search_options => '',
 490     numberformat             => '1.000,00',
 491     vclimit                  => 0,
 492     favorites                => '',
 493     copies                   => '',
 494     menustyle                => 'v3',
 495     fax                      => '',
 496     stylesheet               => 'lx-office-erp.css',
 497     mandatory_departments    => 0,
 498     countrycode              => 'de',
 499   );
 500
 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;
 503   $sth->finish;
 504
 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;
 507   $sth->finish;
 508
 509   dbh_do($dbh, qq|INSERT INTO employee (id, login, name) VALUES (1, 'unittests', 'Unit Tester')|);
 510
 511   $::auth->set_client(1) || BAIL_OUT("\$::auth->set_client(1) failed");
 512   %::myconfig = $::auth->read_user(login => 'unittests');
 513
 514   apply_upgrades(dbh => $dbh);
 515 }
 516
 517 sub apply_upgrades {
 518   my %params            = @_;
 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});
 521
 522   my $all = @unapplied_scripts;
 523   my $i;
 524   for my $script (@unapplied_scripts) {
 525     ++$i;
 526     print "\rUpgrade $i/$all";
 527     apply_dbupgrade($dbupdater, $params{dbh}, $script);
 528   }
 529   print " - done.\n";
 530 }
 531
 532 sub apply_dbupgrade {
 533   my ($dbupdater, $dbh, $control_or_file) = @_;
 534
 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;
 537
 538   my $error = $dbupdater->process_file($dbh, $file, $control);
 539
 540   die("Error applying $file: $error") if $error;
 541 }
 542
 543 sub dbh_do {
 544   my ($dbh, $query, %params) = @_;
 545
 546   if (ref($query)) {
 547     return if $query->execute(@{ $params{bind} || [] });
 548     die($dbh->errstr);
 549   }
 550
 551   return if $dbh->do($query, undef, @{ $params{bind} || [] });
 552
 553   die($params{message} . ": " . $dbh->errstr) if $params{message};
 554   die("Query failed: " . $dbh->errstr . " ; query: $query");
 555 }
 556
 557 parse_args(\%config);
 558 setup();
 559 check_errors_in_package_names();
 560
 561 my %tables_by_domain = make_tables();
 562
 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));
 568     exit 1;
 569   }
 570
 571   process_table($domain, $_, $package_names{$domain}->{$_}) for @tables;
 572 }
 573
 574 1;
 575
 576 __END__
 577
 578 =encoding utf-8
 579
 580 =head1 NAME
 581
 582 rose_auto_create_model - mana Rose::DB::Object classes for kivitendo
 583
 584 =head1 SYNOPSIS
 585
 586   scripts/rose_auto_create_model.pl OPTIONS TARGET
 587
 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
 591
 592   # TARGETS:
 593   # updates all models
 594   scripts/rose_auto_create_model.pl --all [--db db]
 595
 596   # updates only customer table, login taken from config
 597   scripts/rose_auto_create_model.pl customer
 598
 599   # updates only parts table, package will be Part
 600   scripts/rose_auto_create_model.pl parts=Part
 601
 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
 604
 605 =head1 DESCRIPTION
 606
 607 Rose::DB::Object comes with a nice function named auto initialization with code
 608 generation. The documentation of Rose describes it like this:
 609
 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.>
 614
 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_*
 620 method.>
 621
 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).>
 630
 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.
 635
 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.
 639
 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.
 645
 646 =head1 DATABASE NAMES AND TABLES
 647
 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
 652 database.
 653
 654 Valid database names are keys in the hash returned by
 655 L<SL::DB::Helper::Mappings/get_package_names>.
 656
 657 =head1 OPTIONS
 658
 659 =over 4
 660
 661 =item C<--test-client, -t>
 662
 663 Use the C<testing/database> to create a new testing database, and connect to
 664 the first client there. Overrides C<client>.
 665
 666 If neither C<test-client> nor C<client> are set, the config key C<devel/client>
 667 will be used.
 668
 669 =item C<--client, -c CLIENT>
 670
 671 Provide a client whose database settings are used. C<CLIENT> can be either a
 672 database ID or a client's name.
 673
 674 If neither C<test-client> nor C<client> are set, the config key C<devel/client>
 675 will be used.
 676
 677 =item C<--all, -a>
 678
 679 Process all tables from the database. Only those that are blacklistes in
 680 L<SL::DB::Helper::Mappings> are excluded.
 681
 682 =item C<--db db>
 683
 684 In combination with C<--all> causes all tables in the specific
 685 database to be processed, not in all databases.
 686
 687 =item C<--no-commit, -n>
 688
 689 =item C<--dry-run>
 690
 691 Do not write back generated files. This will do everything as usual but not
 692 actually modify any file.
 693
 694 =item C<--diff>
 695
 696 Displays diff for selected file, if file is present and newer file is
 697 different. Beware, does not imply C<--no-commit>.
 698
 699 =item C<--help, -h>
 700
 701 Print this help.
 702
 703 =item C<--quiet, -q>
 704
 705 Does not print extra information, such as skipped files that were not
 706 changed and errors where the auto initialization failed.
 707
 708 =back
 709
 710 =head1 BUGS
 711
 712 None yet.
 713
 714 =head1 AUTHOR
 715
 716 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>,
 717 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>
 718
 719 =cut