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