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