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