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