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