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