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