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(none);
  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::Locale;
  27 use SL::LXDebug;
  28 use SL::LxOfficeConf;
  29 use SL::DB::Helper::ALL;
  30 use SL::DB::Helper::Mappings;
  31
  32 my %blacklist     = SL::DB::Helper::Mappings->get_blacklist;
  33 my %package_names = SL::DB::Helper::Mappings->get_package_names;
  34
  35 our $form;
  36 our $auth;
  37 our %lx_office_conf;
  38
  39 our $script =  __FILE__;
  40 $script     =~ s:.*/::;
  41
  42 $OUTPUT_AUTOFLUSH       = 1;
  43 $Data::Dumper::Sortkeys = 1;
  44
  45 our $meta_path    = "SL/DB/MetaSetup";
  46 our $manager_path = "SL/DB/Manager";
  47
  48 my %config;
  49
  50 our %foreign_key_name_map = (
  51   oe                   => { payment => 'payment_terms', },
  52   ar                   => { payment => 'payment_terms', },
  53   ap                   => { payment => 'payment_terms', },
  54
  55   orderitems           => { parts => 'part', trans => 'order', },
  56   delivery_order_items => { parts => 'part' },
  57   invoice              => { parts => 'part' },
  58   follow_ups           => { 'employee_obj' => 'created_for' },
  59
  60   periodic_invoices_configs => { oe => 'order' },
  61 );
  62
  63 sub setup {
  64
  65   SL::LxOfficeConf->read;
  66
  67   my $client = $config{client} || $::lx_office_conf{devel}{client};
  68
  69   if (!$client) {
  70     error("No client found in config. Please provide a client:");
  71     usage();
  72   }
  73
  74   $::lxdebug      = LXDebug->new();
  75   $::locale       = Locale->new("de");
  76   $::form         = new Form;
  77   $form->{script} = 'rose_meta_data.pl';
  78   $::auth         = SL::Auth->new();
  79
  80   if (!$::auth->set_client($client)) {
  81     error("No client with ID or name '$client' found in config. Please provide a client:");
  82     usage();
  83   }
  84
  85   foreach (($meta_path, $manager_path)) {
  86     mkdir $_ unless -d;
  87   }
  88 }
  89
  90 sub process_table {
  91   my ($domain, $table, $package) = @_;
  92   my $schema     = '';
  93   ($schema, $table) = split(m/\./, $table) if $table =~ m/\./;
  94   $package       =  ucfirst($package || $table);
  95   $package       =~ s/_+(.)/uc($1)/ge;
  96   my $meta_file  =  "${meta_path}/${package}.pm";
  97   my $mngr_file  =  "${manager_path}/${package}.pm";
  98   my $file       =  "SL/DB/${package}.pm";
  99
 100   my $schema_str = $schema ? <<CODE : '';
 101 __PACKAGE__->meta->schema('$schema');
 102 CODE
 103
 104   eval <<CODE;
 105     package SL::DB::AUTO::$package;
 106     use SL::DB::Object;
 107     use base qw(SL::DB::Object);
 108
 109     __PACKAGE__->meta->table('$table');
 110     $schema_str
 111     __PACKAGE__->meta->auto_initialize;
 112
 113 CODE
 114
 115   if ($EVAL_ERROR) {
 116     error("Error in execution for table '$table'");
 117     error("'$EVAL_ERROR'") unless $config{quiet};
 118     return;
 119   }
 120
 121   my %args = (indent => 2, use_setup => 0);
 122
 123   my $definition =  "SL::DB::AUTO::$package"->meta->perl_class_definition(%args);
 124   $definition =~ s/\n+__PACKAGE__->meta->initialize;\n+/\n\n/;
 125   $definition =~ s/::AUTO::/::/g;
 126
 127
 128   # Sort column definitions alphabetically
 129   if ($definition =~ m/__PACKAGE__->meta->columns\( \n (.+?) \n \);/msx) {
 130     my ($start, $end)  = ($-[1], $+[1]);
 131     my $sorted_columns = join "\n", sort split m/\n/, $1;
 132     substr $definition, $start, $end - $start, $sorted_columns;
 133   }
 134
 135   # patch foreign keys
 136   my $foreign_key_definition = "SL::DB::AUTO::$package"->meta->perl_foreign_keys_definition(%args);
 137   $foreign_key_definition =~ s/::AUTO::/::/g;
 138
 139   if ($foreign_key_definition && ($definition =~ /\Q$foreign_key_definition\E/)) {
 140     my ($start, $end) = ($-[0], $+[0]);
 141
 142     while (my ($auto_generated_name, $desired_name) = each %{ $foreign_key_name_map{$table} || {} }) {
 143       $foreign_key_definition =~ s/^ \s \s ${auto_generated_name} \b/  ${desired_name}/msx;
 144     }
 145
 146     # Sort foreign key definitions alphabetically
 147     if ($foreign_key_definition =~ m/\(\n(.+)\n\)/s) {
 148       my ($list_start, $list_end) = ($-[0], $+[0]);
 149       my @foreign_keys            = split m/\n\n/m, $1;
 150       my $sorted_foreign_keys     = "(\n" . join("\n\n", sort @foreign_keys) . "\n)";
 151
 152       substr $foreign_key_definition, $list_start, $list_end - $list_start, $sorted_foreign_keys;;
 153     }
 154
 155     substr($definition, $start, $end - $start) = $foreign_key_definition;
 156   }
 157
 158   $definition =~ s/(meta->table.*)\n/$1\n$schema_str/m if $schema;
 159
 160   my $full_definition = <<CODE;
 161 # This file has been auto-generated. Do not modify it; it will be overwritten
 162 # by $::script automatically.
 163 $definition;
 164 CODE
 165
 166   my $meta_definition = <<CODE;
 167 # This file has been auto-generated only because it didn't exist.
 168 # Feel free to modify it at will; it will not be overwritten automatically.
 169
 170 package SL::DB::${package};
 171
 172 use strict;
 173
 174 use SL::DB::MetaSetup::${package};
 175 use SL::DB::Manager::${package};
 176
 177 __PACKAGE__->meta->initialize;
 178
 179 1;
 180 CODE
 181
 182   my $file_exists = -f $meta_file;
 183   if ($file_exists) {
 184     my $old_size    = -s $meta_file;
 185     my $orig_file   = do { local(@ARGV, $/) = ($meta_file); <> };
 186     my $old_md5     = md5_hex($orig_file);
 187     my $new_size    = length $full_definition;
 188     my $new_md5     = md5_hex($full_definition);
 189     if ($old_size == $new_size && $old_md5 eq $new_md5) {
 190       notice("No changes in $meta_file, skipping.") unless $config{quiet};
 191       return;
 192     }
 193
 194     show_diff(\$orig_file, \$full_definition) if $config{show_diff};
 195   }
 196
 197   if (!$config{nocommit}) {
 198     open my $out, ">", $meta_file || die;
 199     print $out $full_definition;
 200   }
 201
 202   notice("File '$meta_file' " . ($file_exists ? 'updated' : 'created') . " for table '$table'");
 203
 204   return if -f $file;
 205
 206   if (!$config{nocommit}) {
 207     open my $out, ">", $file || die;
 208     print $out $meta_definition;
 209   }
 210
 211   notice("File '$file' created as well.");
 212
 213   return if -f $mngr_file;
 214
 215   if (!$config{nocommit}) {
 216     open my $out, ">", $mngr_file || die;
 217     print $out <<EOT;
 218 # This file has been auto-generated only because it didn't exist.
 219 # Feel free to modify it at will; it will not be overwritten automatically.
 220
 221 package SL::DB::Manager::${package};
 222
 223 use strict;
 224
 225 use SL::DB::Helper::Manager;
 226 use base qw(SL::DB::Helper::Manager);
 227
 228 sub object_class { 'SL::DB::${package}' }
 229
 230 __PACKAGE__->make_manager_methods;
 231
 232 1;
 233 EOT
 234   }
 235
 236   notice("File '$mngr_file' created as well.");
 237 }
 238
 239 sub parse_args {
 240   my ($options) = @_;
 241   GetOptions(
 242     'client=s'          => \ my $client,
 243     all                 => \ my $all,
 244     'no-commit|dry-run' => \ my $nocommit,
 245     help                => sub { pod2usage(verbose => 99, sections => 'NAME|SYNOPSIS|OPTIONS') },
 246     quiet               => \ my $quiet,
 247     diff                => \ my $diff,
 248   );
 249
 250   $options->{client}   = $client;
 251   $options->{all}      = $all;
 252   $options->{nocommit} = $nocommit;
 253   $options->{quiet}    = $quiet;
 254   $options->{color}    = -t STDOUT ? 1 : 0;
 255
 256   if ($diff) {
 257     if (eval { require Text::Diff; 1 }) {
 258       $options->{show_diff} = 1;
 259     } else {
 260       error('Could not load Text::Diff. Sorry, no diffs for you.');
 261     }
 262   }
 263 }
 264
 265 sub show_diff {
 266    my ($text_a, $text_b) = @_;
 267
 268    my %colors = (
 269      '+' => 'green',
 270      '-' => 'red',
 271    );
 272
 273    Text::Diff::diff($text_a, $text_b, { OUTPUT => sub {
 274      for (split /\n/, $_[0]) {
 275        if ($config{color}) {
 276          print colored($_, $colors{substr($_, 0, 1)}), $/;
 277        } else {
 278          print $_, $/;
 279        }
 280      }
 281    }});
 282 }
 283
 284 sub usage {
 285   pod2usage(verbose => 99, sections => 'SYNOPSIS');
 286 }
 287
 288 sub make_tables {
 289   my %tables_by_domain;
 290   if ($config{all}) {
 291     foreach my $domain (sort keys %package_names) {
 292       my $db  = SL::DB::create(undef, $domain);
 293       $tables_by_domain{$domain} = [ grep { my $table = $_; none { $_ eq $table } @{ $blacklist{$domain} } } $db->list_tables ];
 294       $db->disconnect;
 295     }
 296
 297   } elsif (@ARGV) {
 298     %tables_by_domain = partition_by {
 299       my ($domain, $table) = split m{:};
 300       $table ? uc($domain) : 'KIVITENDO';
 301     } @ARGV;
 302
 303     foreach my $tables (values %tables_by_domain) {
 304       s{.*:}{} for @{ $tables };
 305     }
 306
 307   } else {
 308     error("You specified neither --all nor any specific tables.");
 309     usage();
 310   }
 311
 312   return %tables_by_domain;
 313 }
 314
 315 sub error {
 316   print STDERR colored(shift, 'red'), $/;
 317 }
 318
 319 sub notice {
 320   print @_, $/;
 321 }
 322
 323 sub check_errors_in_package_names {
 324   foreach my $domain (sort keys %package_names) {
 325     my @both = grep { $package_names{$domain}->{$_} } @{ $blacklist{$domain} || [] };
 326     next unless @both;
 327
 328     print "Error: domain '$domain': The following table names are present in both the black list and the package name hash: ", join(' ', sort @both), "\n";
 329     exit 1;
 330   }
 331 }
 332
 333 parse_args(\%config);
 334 setup();
 335 check_errors_in_package_names();
 336
 337 my %tables_by_domain = make_tables();
 338
 339 foreach my $domain (keys %tables_by_domain) {
 340   my @tables         = @{ $tables_by_domain{$domain} };
 341   my @unknown_tables = grep { !$package_names{$domain}->{$_} } @tables;
 342   if (@unknown_tables) {
 343     error("The following tables do not have entries in \%SL::DB::Helper::Mappings::${domain}_package_names: " . join(' ', sort @unknown_tables));
 344     exit 1;
 345   }
 346
 347   process_table($domain, $_, $package_names{$domain}->{$_}) for @tables;
 348 }
 349
 350 1;
 351
 352 __END__
 353
 354 =encoding utf-8
 355
 356 =head1 NAME
 357
 358 rose_auto_create_model - mana Rose::DB::Object classes for kivitendo
 359
 360 =head1 SYNOPSIS
 361
 362   scripts/rose_auto_create_model.pl --client name-or-id [db1:]table1 [[db2:]table2 ...]
 363   scripts/rose_auto_create_model.pl --client name-or-id [--all|-a]
 364
 365   # updates all models
 366   scripts/rose_auto_create_model.pl --client name-or-id --all
 367
 368   # updates only customer table, login taken from config
 369   scripts/rose_auto_create_model.pl customer
 370
 371   # updates only parts table, package will be Part
 372   scripts/rose_auto_create_model.pl parts=Part
 373
 374   # try to update parts, but don't do it. tell what would happen in detail
 375   scripts/rose_auto_create_model.pl --no-commit parts
 376
 377 =head1 DESCRIPTION
 378
 379 Rose::DB::Object comes with a nice function named auto initialization with code
 380 generation. The documentation of Rose describes it like this:
 381
 382 I<[...] auto-initializing metadata at runtime by querying the database has many
 383 caveats. An alternate approach is to query the database for metadata just once,
 384 and then generate the equivalent Perl code which can be pasted directly into
 385 the class definition in place of the call to auto_initialize.>
 386
 387 I<Like the auto-initialization process itself, perl code generation has a
 388 convenient wrapper method as well as separate methods for the individual parts.
 389 All of the perl code generation methods begin with "perl_", and they support
 390 some rudimentary code formatting options to help the code conform to you
 391 preferred style. Examples can be found with the documentation for each perl_*
 392 method.>
 393
 394 I<This hybrid approach to metadata population strikes a good balance between
 395 upfront effort and ongoing maintenance. Auto-generating the Perl code for the
 396 initial class definition saves a lot of tedious typing. From that point on,
 397 manually correcting and maintaining the definition is a small price to pay for
 398 the decreased start-up cost, the ability to use the class in the absence of a
 399 database connection, and the piece of mind that comes from knowing that your
 400 class is stable, and won't change behind your back in response to an "action at
 401 a distance" (i.e., a database schema update).>
 402
 403 Unfortunately this reads easier than it is, since classes need to go into the
 404 right package and directory, certain stuff needs to be adjusted and table names
 405 need to be translated into their class names. This script will wrap all that
 406 behind a few simple options.
 407
 408 In the most basic version, just give it a login and a table name, and it will
 409 load the schema information for this table and create the appropriate class
 410 files, or update them if already present.
 411
 412 Each table has three associated files. A C<SL::DB::MetaSetup::*>
 413 class, which is a perl version of the schema definition, a
 414 C<SL::DB::*> class file and a C<SL::DB::Manager::*> manager class
 415 file. The first one will be updated if the schema changes, the second
 416 and third ones will only be created if it they do not exist.
 417
 418 =head1 DATABASE NAMES AND TABLES
 419
 420 If you want to generate the data for specific tables only then you
 421 have to list them on the command line. The format is
 422 C<db-name:table-name>. The part C<db-name:> is optional and defaults
 423 to C<KIVITENDO:> – which means the tables in the default kivitendo
 424 database.
 425
 426 Valid database names are keys in the hash returned by
 427 L<SL::DB::Helper::Mappings/get_package_names>.
 428
 429 =head1 OPTIONS
 430
 431 =over 4
 432
 433 =item C<--client, -c CLIENT>
 434
 435 Provide a client whose database settings are used. If not present the
 436 client is loaded from the config key C<devel/client>. If that too is
 437 not found, an error is thrown.
 438
 439 Note that C<CLIENT> can be either a database ID or a client's name.
 440
 441 =item C<--all, -a>
 442
 443 Process all tables from the database. Only those that are blacklistes in
 444 L<SL::DB::Helper::Mappings> are excluded.
 445
 446 =item C<--no-commit, -n>
 447
 448 =item C<--dry-run>
 449
 450 Do not write back generated files. This will do everything as usual but not
 451 actually modify any file.
 452
 453 =item C<--diff>
 454
 455 Displays diff for selected file, if file is present and newer file is
 456 different. Beware, does not imply C<--no-commit>.
 457
 458 =item C<--help, -h>
 459
 460 Print this help.
 461
 462 =item C<--quiet, -q>
 463
 464 Does not print extra information, such as skipped files that were not
 465 changed and errors where the auto initialization failed.
 466
 467 =back
 468
 469 =head1 BUGS
 470
 471 None yet.
 472
 473 =head1 AUTHOR
 474
 475 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>,
 476 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>
 477
 478 =cut