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