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