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     'db=s'              => \ my $db,
 245     'no-commit|dry-run' => \ my $nocommit,
 246     help                => sub { pod2usage(verbose => 99, sections => 'NAME|SYNOPSIS|OPTIONS') },
 247     quiet               => \ my $quiet,
 248     diff                => \ my $diff,
 249   );
 250
 251   $options->{client}   = $client;
 252   $options->{all}      = $all;
 253   $options->{db}       = $db;
 254   $options->{nocommit} = $nocommit;
 255   $options->{quiet}    = $quiet;
 256   $options->{color}    = -t STDOUT ? 1 : 0;
 257
 258   if ($diff) {
 259     if (eval { require Text::Diff; 1 }) {
 260       $options->{show_diff} = 1;
 261     } else {
 262       error('Could not load Text::Diff. Sorry, no diffs for you.');
 263     }
 264   }
 265 }
 266
 267 sub show_diff {
 268    my ($text_a, $text_b) = @_;
 269
 270    my %colors = (
 271      '+' => 'green',
 272      '-' => 'red',
 273    );
 274
 275    Text::Diff::diff($text_a, $text_b, { OUTPUT => sub {
 276      for (split /\n/, $_[0]) {
 277        if ($config{color}) {
 278          print colored($_, $colors{substr($_, 0, 1)}), $/;
 279        } else {
 280          print $_, $/;
 281        }
 282      }
 283    }});
 284 }
 285
 286 sub usage {
 287   pod2usage(verbose => 99, sections => 'SYNOPSIS');
 288 }
 289
 290 sub make_tables {
 291   my %tables_by_domain;
 292   if ($config{all}) {
 293     my @domains = $config{db} ? (uc $config{db}) : sort keys %package_names;
 294
 295     foreach my $domain (@domains) {
 296       my $db  = SL::DB::create(undef, $domain);
 297       $tables_by_domain{$domain} = [ grep { my $table = $_; none { $_ eq $table } @{ $blacklist{$domain} } } $db->list_tables ];
 298       $db->disconnect;
 299     }
 300
 301   } elsif (@ARGV) {
 302     %tables_by_domain = partition_by {
 303       my ($domain, $table) = split m{:};
 304       $table ? uc($domain) : 'KIVITENDO';
 305     } @ARGV;
 306
 307     foreach my $tables (values %tables_by_domain) {
 308       s{.*:}{} for @{ $tables };
 309     }
 310
 311   } else {
 312     error("You specified neither --all nor any specific tables.");
 313     usage();
 314   }
 315
 316   return %tables_by_domain;
 317 }
 318
 319 sub error {
 320   print STDERR colored(shift, 'red'), $/;
 321 }
 322
 323 sub notice {
 324   print @_, $/;
 325 }
 326
 327 sub check_errors_in_package_names {
 328   foreach my $domain (sort keys %package_names) {
 329     my @both = grep { $package_names{$domain}->{$_} } @{ $blacklist{$domain} || [] };
 330     next unless @both;
 331
 332     print "Error: domain '$domain': The following table names are present in both the black list and the package name hash: ", join(' ', sort @both), "\n";
 333     exit 1;
 334   }
 335 }
 336
 337 parse_args(\%config);
 338 setup();
 339 check_errors_in_package_names();
 340
 341 my %tables_by_domain = make_tables();
 342
 343 foreach my $domain (keys %tables_by_domain) {
 344   my @tables         = @{ $tables_by_domain{$domain} };
 345   my @unknown_tables = grep { !$package_names{$domain}->{$_} } @tables;
 346   if (@unknown_tables) {
 347     error("The following tables do not have entries in \%SL::DB::Helper::Mappings::${domain}_package_names: " . join(' ', sort @unknown_tables));
 348     exit 1;
 349   }
 350
 351   process_table($domain, $_, $package_names{$domain}->{$_}) for @tables;
 352 }
 353
 354 1;
 355
 356 __END__
 357
 358 =encoding utf-8
 359
 360 =head1 NAME
 361
 362 rose_auto_create_model - mana Rose::DB::Object classes for kivitendo
 363
 364 =head1 SYNOPSIS
 365
 366   scripts/rose_auto_create_model.pl --client name-or-id [db1:]table1 [[db2:]table2 ...]
 367   scripts/rose_auto_create_model.pl --client name-or-id [--all|-a]
 368
 369   # updates all models
 370   scripts/rose_auto_create_model.pl --client name-or-id --all [--db db]
 371
 372   # updates only customer table, login taken from config
 373   scripts/rose_auto_create_model.pl customer
 374
 375   # updates only parts table, package will be Part
 376   scripts/rose_auto_create_model.pl parts=Part
 377
 378   # try to update parts, but don't do it. tell what would happen in detail
 379   scripts/rose_auto_create_model.pl --no-commit parts
 380
 381 =head1 DESCRIPTION
 382
 383 Rose::DB::Object comes with a nice function named auto initialization with code
 384 generation. The documentation of Rose describes it like this:
 385
 386 I<[...] auto-initializing metadata at runtime by querying the database has many
 387 caveats. An alternate approach is to query the database for metadata just once,
 388 and then generate the equivalent Perl code which can be pasted directly into
 389 the class definition in place of the call to auto_initialize.>
 390
 391 I<Like the auto-initialization process itself, perl code generation has a
 392 convenient wrapper method as well as separate methods for the individual parts.
 393 All of the perl code generation methods begin with "perl_", and they support
 394 some rudimentary code formatting options to help the code conform to you
 395 preferred style. Examples can be found with the documentation for each perl_*
 396 method.>
 397
 398 I<This hybrid approach to metadata population strikes a good balance between
 399 upfront effort and ongoing maintenance. Auto-generating the Perl code for the
 400 initial class definition saves a lot of tedious typing. From that point on,
 401 manually correcting and maintaining the definition is a small price to pay for
 402 the decreased start-up cost, the ability to use the class in the absence of a
 403 database connection, and the piece of mind that comes from knowing that your
 404 class is stable, and won't change behind your back in response to an "action at
 405 a distance" (i.e., a database schema update).>
 406
 407 Unfortunately this reads easier than it is, since classes need to go into the
 408 right package and directory, certain stuff needs to be adjusted and table names
 409 need to be translated into their class names. This script will wrap all that
 410 behind a few simple options.
 411
 412 In the most basic version, just give it a login and a table name, and it will
 413 load the schema information for this table and create the appropriate class
 414 files, or update them if already present.
 415
 416 Each table has three associated files. A C<SL::DB::MetaSetup::*>
 417 class, which is a perl version of the schema definition, a
 418 C<SL::DB::*> class file and a C<SL::DB::Manager::*> manager class
 419 file. The first one will be updated if the schema changes, the second
 420 and third ones will only be created if it they do not exist.
 421
 422 =head1 DATABASE NAMES AND TABLES
 423
 424 If you want to generate the data for specific tables only then you
 425 have to list them on the command line. The format is
 426 C<db-name:table-name>. The part C<db-name:> is optional and defaults
 427 to C<KIVITENDO:> – which means the tables in the default kivitendo
 428 database.
 429
 430 Valid database names are keys in the hash returned by
 431 L<SL::DB::Helper::Mappings/get_package_names>.
 432
 433 =head1 OPTIONS
 434
 435 =over 4
 436
 437 =item C<--client, -c CLIENT>
 438
 439 Provide a client whose database settings are used. If not present the
 440 client is loaded from the config key C<devel/client>. If that too is
 441 not found, an error is thrown.
 442
 443 Note that C<CLIENT> can be either a database ID or a client's name.
 444
 445 =item C<--all, -a>
 446
 447 Process all tables from the database. Only those that are blacklistes in
 448 L<SL::DB::Helper::Mappings> are excluded.
 449
 450 =item C<--db db>
 451
 452 In combination with C<--all> causes all tables in the specific
 453 database to be processed, not in all databases.
 454
 455 =item C<--no-commit, -n>
 456
 457 =item C<--dry-run>
 458
 459 Do not write back generated files. This will do everything as usual but not
 460 actually modify any file.
 461
 462 =item C<--diff>
 463
 464 Displays diff for selected file, if file is present and newer file is
 465 different. Beware, does not imply C<--no-commit>.
 466
 467 =item C<--help, -h>
 468
 469 Print this help.
 470
 471 =item C<--quiet, -q>
 472
 473 Does not print extra information, such as skipped files that were not
 474 changed and errors where the auto initialization failed.
 475
 476 =back
 477
 478 =head1 BUGS
 479
 480 None yet.
 481
 482 =head1 AUTHOR
 483
 484 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>,
 485 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>
 486
 487 =cut