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