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