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