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