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