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