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