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 parse_args(\%config);
 324 setup();
 325
 326 my %tables_by_domain = make_tables();
 327
 328 foreach my $domain (keys %tables_by_domain) {
 329   my @tables         = @{ $tables_by_domain{$domain} };
 330   my @unknown_tables = grep { !$package_names{$domain}->{$_} } @tables;
 331   if (@unknown_tables) {
 332     error("The following tables do not have entries in \%SL::DB::Helper::Mappings::${domain}_package_names: " . join(' ', sort @unknown_tables));
 333     exit 1;
 334   }
 335
 336   process_table($domain, $_, $package_names{$domain}->{$_}) for @tables;
 337 }
 338
 339 1;
 340
 341 __END__
 342
 343 =encoding utf-8
 344
 345 =head1 NAME
 346
 347 rose_auto_create_model - mana Rose::DB::Object classes for kivitendo
 348
 349 =head1 SYNOPSIS
 350
 351   scripts/rose_auto_create_model.pl --client name-or-id [db1:]table1 [[db2:]table2 ...]
 352   scripts/rose_auto_create_model.pl --client name-or-id [--all|-a]
 353
 354   # updates all models
 355   scripts/rose_auto_create_model.pl --client name-or-id --all
 356
 357   # updates only customer table, login taken from config
 358   scripts/rose_auto_create_model.pl customer
 359
 360   # updates only parts table, package will be Part
 361   scripts/rose_auto_create_model.pl parts=Part
 362
 363   # try to update parts, but don't do it. tell what would happen in detail
 364   scripts/rose_auto_create_model.pl --no-commit parts
 365
 366 =head1 DESCRIPTION
 367
 368 Rose::DB::Object comes with a nice function named auto initialization with code
 369 generation. The documentation of Rose describes it like this:
 370
 371 I<[...] auto-initializing metadata at runtime by querying the database has many
 372 caveats. An alternate approach is to query the database for metadata just once,
 373 and then generate the equivalent Perl code which can be pasted directly into
 374 the class definition in place of the call to auto_initialize.>
 375
 376 I<Like the auto-initialization process itself, perl code generation has a
 377 convenient wrapper method as well as separate methods for the individual parts.
 378 All of the perl code generation methods begin with "perl_", and they support
 379 some rudimentary code formatting options to help the code conform to you
 380 preferred style. Examples can be found with the documentation for each perl_*
 381 method.>
 382
 383 I<This hybrid approach to metadata population strikes a good balance between
 384 upfront effort and ongoing maintenance. Auto-generating the Perl code for the
 385 initial class definition saves a lot of tedious typing. From that point on,
 386 manually correcting and maintaining the definition is a small price to pay for
 387 the decreased start-up cost, the ability to use the class in the absence of a
 388 database connection, and the piece of mind that comes from knowing that your
 389 class is stable, and won't change behind your back in response to an "action at
 390 a distance" (i.e., a database schema update).>
 391
 392 Unfortunately this reads easier than it is, since classes need to go into the
 393 right package and directory, certain stuff needs to be adjusted and table names
 394 need to be translated into their class names. This script will wrap all that
 395 behind a few simple options.
 396
 397 In the most basic version, just give it a login and a table name, and it will
 398 load the schema information for this table and create the appropriate class
 399 files, or update them if already present.
 400
 401 Each table has three associated files. A C<SL::DB::MetaSetup::*>
 402 class, which is a perl version of the schema definition, a
 403 C<SL::DB::*> class file and a C<SL::DB::Manager::*> manager class
 404 file. The first one will be updated if the schema changes, the second
 405 and third ones will only be created if it they do not exist.
 406
 407 =head1 DATABASE NAMES AND TABLES
 408
 409 If you want to generate the data for specific tables only then you
 410 have to list them on the command line. The format is
 411 C<db-name:table-name>. The part C<db-name:> is optional and defaults
 412 to C<KIVITENDO:> – which means the tables in the default kivitendo
 413 database.
 414
 415 Valid database names are keys in the hash returned by
 416 L<SL::DB::Helper::Mappings/get_package_names>.
 417
 418 =head1 OPTIONS
 419
 420 =over 4
 421
 422 =item C<--client, -c CLIENT>
 423
 424 Provide a client whose database settings are used. If not present the
 425 client is loaded from the config key C<devel/client>. If that too is
 426 not found, an error is thrown.
 427
 428 Note that C<CLIENT> can be either a database ID or a client's name.
 429
 430 =item C<--all, -a>
 431
 432 Process all tables from the database. Only those that are blacklistes in
 433 L<SL::DB::Helper::Mappings> are excluded.
 434
 435 =item C<--no-commit, -n>
 436
 437 =item C<--dry-run>
 438
 439 Do not write back generated files. This will do everything as usual but not
 440 actually modify any file.
 441
 442 =item C<--diff>
 443
 444 Displays diff for selected file, if file is present and newer file is
 445 different. Beware, does not imply C<--no-commit>.
 446
 447 =item C<--help, -h>
 448
 449 Print this help.
 450
 451 =item C<--quiet, -q>
 452
 453 Does not print extra information, such as skipped files that were not
 454 changed and errors where the auto initialization failed.
 455
 456 =back
 457
 458 =head1 BUGS
 459
 460 None yet.
 461
 462 =head1 AUTHOR
 463
 464 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>,
 465 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>
 466
 467 =cut