scripts/rose_auto_create_model.pl

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