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