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   );
 188
 189   $options->{client}   = $client;
 190   $options->{all}      = $all;
 191   $options->{nocommit} = $nocommit;
 192   $options->{quiet}    = $quiet;
 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, 'KIVITENDO');
 226     @tables =
 227       map { $package_names{KIVITENDO}->{$_} ? "$_=" . $package_names{KIVITENDO}->{$_} : $_ }
 228       grep { my $table = $_; !any { $_ eq $table } @{ $blacklist{KIVITENDO} } }
 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{KIVITENDO}->{lc $table} if $table !~ /=/ && $package_names{KIVITENDO}->{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 --client name-or-id table1[=package1] [table2[=package2] ...]
 272   scripts/rose_create_model.pl --client name-or-id [--all|-a]
 273
 274   # updates all models
 275   scripts/rose_create_model.pl --client name-or-id --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 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<--client, -c CLIENT>
 331
 332 Provide a client whose database settings are used. If not present the
 333 client is loaded from the config key C<devel/client>. If that too is
 334 not found, an error is thrown.
 335
 336 Note that C<CLIENT> can be either a database ID or a client's name.
 337
 338 =item C<--all, -a>
 339
 340 Process all tables from the database. Only those that are blacklistes in
 341 L<SL::DB::Helper::Mappings> are excluded.
 342
 343 =item C<--no-commit, -n>
 344
 345 =item C<--dry-run>
 346
 347 Do not write back generated files. This will do everything as usual but not
 348 actually modify any file.
 349
 350 =item C<--diff>
 351
 352 Displays diff for selected file, if file is present and newer file is
 353 different. Beware, does not imply C<--no-commit>.
 354
 355 =item C<--help, -h>
 356
 357 Print this help.
 358
 359 =item C<--quiet, -q>
 360
 361 Does not print extra information, such as skipped files that were not
 362 changed and errors where the auto initialization failed.
 363
 364 =back
 365
 366 =head1 BUGS
 367
 368 None yet.
 369
 370 =head1 AUTHOR
 371
 372 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>
 373
 374 =cut