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 Pod::Usage;
  18 use Rose::DB::Object 0.809;
  19 use Term::ANSIColor;
  20
  21 use SL::Auth;
  22 use SL::DBUtils;
  23 use SL::DB;
  24 use SL::Form;
  25 use SL::Locale;
  26 use SL::LXDebug;
  27 use SL::LxOfficeConf;
  28 use SL::DB::Helper::ALL;
  29 use SL::DB::Helper::Mappings;
  30
  31 my %blacklist     = SL::DB::Helper::Mappings->get_blacklist;
  32 my %package_names = SL::DB::Helper::Mappings->get_package_names;
  33
  34 our $form;
  35 our $auth;
  36 our %lx_office_conf;
  37
  38 our $script =  __FILE__;
  39 $script     =~ s:.*/::;
  40
  41 $OUTPUT_AUTOFLUSH       = 1;
  42 $Data::Dumper::Sortkeys = 1;
  43
  44 our $meta_path    = "SL/DB/MetaSetup";
  45 our $manager_path = "SL/DB/Manager";
  46
  47 my %config;
  48
  49 our %foreign_key_name_map = (
  50   oe                   => { payment => 'payment_terms', },
  51   ar                   => { payment => 'payment_terms', },
  52   ap                   => { payment => 'payment_terms', },
  53
  54   orderitems           => { parts => 'part', trans => 'order', },
  55   delivery_order_items => { parts => 'part' },
  56   invoice              => { parts => 'part' },
  57   follow_ups           => { 'employee_obj' => 'created_for' },
  58
  59   periodic_invoices_configs => { oe => 'order' },
  60 );
  61
  62 sub setup {
  63
  64   SL::LxOfficeConf->read;
  65
  66   my $client = $config{client} || $::lx_office_conf{devel}{client};
  67
  68   if (!$client) {
  69     error("No client found in config. Please provide a client:");
  70     usage();
  71   }
  72
  73   $::lxdebug      = LXDebug->new();
  74   $::locale       = Locale->new("de");
  75   $::form         = new Form;
  76   $form->{script} = 'rose_meta_data.pl';
  77   $::auth         = SL::Auth->new();
  78
  79   if (!$::auth->set_client($client)) {
  80     error("No client with ID or name '$client' found in config. Please provide a client:");
  81     usage();
  82   }
  83
  84   foreach (($meta_path, $manager_path)) {
  85     mkdir $_ unless -d;
  86   }
  87 }
  88
  89 sub process_table {
  90   my @spec       =  @_;
  91   my $table      =  $spec[0];
  92   my $schema     = '';
  93   ($schema, $table) = split(m/\./, $table) if $table =~ m/\./;
  94   my $package    =  ucfirst($spec[1] || $spec[0]);
  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;
 290   if ($config{all}) {
 291     my $db  = SL::DB::create(undef, 'KIVITENDO');
 292     @tables = grep { my $table = $_; none { $_ eq $table } @{ $blacklist{KIVITENDO} } } $db->list_tables;
 293
 294   } elsif (@ARGV) {
 295     @tables = @ARGV;
 296   } else {
 297     error("You specified neither --all nor any specific tables.");
 298     usage();
 299   }
 300
 301   @tables;
 302 }
 303
 304 sub error {
 305   print STDERR colored(shift, 'red'), $/;
 306 }
 307
 308 sub notice {
 309   print @_, $/;
 310 }
 311
 312 parse_args(\%config);
 313 setup();
 314 my @tables = make_tables();
 315
 316 my @unknown_tables = grep { !$package_names{KIVITENDO}->{$_} } @tables;
 317 if (@unknown_tables) {
 318   error("The following tables do not have entries in \%SL::DB::Helper::Mappings::kivitendo_package_names: " . join(' ', sort @unknown_tables));
 319   exit 1;
 320 }
 321
 322 process_table($_, $package_names{KIVITENDO}->{$_}) for @tables;
 323
 324 1;
 325
 326 __END__
 327
 328 =encoding utf-8
 329
 330 =head1 NAME
 331
 332 rose_auto_create_model - mana Rose::DB::Object classes for kivitendo
 333
 334 =head1 SYNOPSIS
 335
 336   scripts/rose_auto_create_model.pl --client name-or-id table1 [table2 ...]
 337   scripts/rose_auto_create_model.pl --client name-or-id [--all|-a]
 338
 339   # updates all models
 340   scripts/rose_auto_create_model.pl --client name-or-id --all
 341
 342   # updates only customer table, login taken from config
 343   scripts/rose_auto_create_model.pl customer
 344
 345   # updates only parts table, package will be Part
 346   scripts/rose_auto_create_model.pl parts=Part
 347
 348   # try to update parts, but don't do it. tell what would happen in detail
 349   scripts/rose_auto_create_model.pl --no-commit parts
 350
 351 =head1 DESCRIPTION
 352
 353 Rose::DB::Object comes with a nice function named auto initialization with code
 354 generation. The documentation of Rose describes it like this:
 355
 356 I<[...] auto-initializing metadata at runtime by querying the database has many
 357 caveats. An alternate approach is to query the database for metadata just once,
 358 and then generate the equivalent Perl code which can be pasted directly into
 359 the class definition in place of the call to auto_initialize.>
 360
 361 I<Like the auto-initialization process itself, perl code generation has a
 362 convenient wrapper method as well as separate methods for the individual parts.
 363 All of the perl code generation methods begin with "perl_", and they support
 364 some rudimentary code formatting options to help the code conform to you
 365 preferred style. Examples can be found with the documentation for each perl_*
 366 method.>
 367
 368 I<This hybrid approach to metadata population strikes a good balance between
 369 upfront effort and ongoing maintenance. Auto-generating the Perl code for the
 370 initial class definition saves a lot of tedious typing. From that point on,
 371 manually correcting and maintaining the definition is a small price to pay for
 372 the decreased start-up cost, the ability to use the class in the absence of a
 373 database connection, and the piece of mind that comes from knowing that your
 374 class is stable, and won't change behind your back in response to an "action at
 375 a distance" (i.e., a database schema update).>
 376
 377 Unfortunately this reads easier than it is, since classes need to go into the
 378 right package and directory, certain stuff needs to be adjusted and table names
 379 need to be translated into their class names. This script will wrap all that
 380 behind a few simple options.
 381
 382 In the most basic version, just give it a login and a table name, and it will
 383 load the schema information for this table and create the appropriate class
 384 files, or update them if already present.
 385
 386 Each table has three associated files. A C<SL::DB::MetaSetup::*>
 387 class, which is a perl version of the schema definition, a
 388 C<SL::DB::*> class file and a C<SL::DB::Manager::*> manager class
 389 file. The first one will be updated if the schema changes, the second
 390 and third ones will only be created if it they do not exist.
 391
 392 =head1 OPTIONS
 393
 394 =over 4
 395
 396 =item C<--client, -c CLIENT>
 397
 398 Provide a client whose database settings are used. If not present the
 399 client is loaded from the config key C<devel/client>. If that too is
 400 not found, an error is thrown.
 401
 402 Note that C<CLIENT> can be either a database ID or a client's name.
 403
 404 =item C<--all, -a>
 405
 406 Process all tables from the database. Only those that are blacklistes in
 407 L<SL::DB::Helper::Mappings> are excluded.
 408
 409 =item C<--no-commit, -n>
 410
 411 =item C<--dry-run>
 412
 413 Do not write back generated files. This will do everything as usual but not
 414 actually modify any file.
 415
 416 =item C<--diff>
 417
 418 Displays diff for selected file, if file is present and newer file is
 419 different. Beware, does not imply C<--no-commit>.
 420
 421 =item C<--help, -h>
 422
 423 Print this help.
 424
 425 =item C<--quiet, -q>
 426
 427 Does not print extra information, such as skipped files that were not
 428 changed and errors where the auto initialization failed.
 429
 430 =back
 431
 432 =head1 BUGS
 433
 434 None yet.
 435
 436 =head1 AUTHOR
 437
 438 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>,
 439 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>
 440
 441 =cut