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 Data::Dumper;
  12 use English qw( -no_match_vars );
  13 use List::MoreUtils qw(any);
  14
  15 use SL::Auth;
  16 use SL::DBUtils;
  17 use SL::DB;
  18 use SL::Form;
  19 use SL::Locale;
  20 use SL::LXDebug;
  21 use SL::DB::Helper::ALL;
  22 use SL::DB::Helper::Mappings;
  23
  24 our $form;
  25 our $cgi;
  26 our $auth;
  27
  28 our $script =  __FILE__;
  29 $script     =~ s:.*/::;
  30
  31 $OUTPUT_AUTOFLUSH       = 1;
  32 $Data::Dumper::Sortkeys = 1;
  33
  34 our $meta_path = "SL/DB/MetaSetup";
  35
  36 sub setup {
  37   if (@ARGV < 2) {
  38     print "Usage: $PROGRAM_NAME login table1[=package1] [table2[=package2] ...]\n";
  39     print "   or  $PROGRAM_NAME login [--all|-a] [--sugar|-s]\n";
  40     exit 1;
  41   }
  42
  43   my $login     = shift @ARGV;
  44
  45   $::userspath  = "users";
  46   $::templates  = "templates";
  47   $::sendmail   = "| /usr/sbin/sendmail -t";
  48
  49   $::lxdebug    = LXDebug->new();
  50
  51   require "config/lx-erp.conf";
  52   require "config/lx-erp-local.conf" if -f "config/lx-erp-local.conf";
  53
  54   # locale messages
  55   $::locale       = Locale->new("de");
  56   $::form         = new Form;
  57   $::cgi          = new CGI('');
  58   $::auth         = SL::Auth->new();
  59
  60   $::user         = User->new($login);
  61
  62   %::myconfig     = $auth->read_user($login);
  63   $form->{script} = 'rose_meta_data.pl';
  64   $form->{login}  = $login;
  65
  66   map { $form->{$_} = $::myconfig{$_} } qw(stylesheet charset);
  67
  68   mkdir $meta_path unless -d $meta_path;
  69 }
  70
  71 sub process_table {
  72   my @spec       =  split(/=/, shift, 2);
  73   my $table      =  $spec[0];
  74   my $schema     = '';
  75   ($schema, $table) = split(m/\./, $table) if $table =~ m/\./;
  76   my $package    =  ucfirst($spec[1] || $spec[0]);
  77   $package       =~ s/_+(.)/uc($1)/ge;
  78   my $meta_file  =  "${meta_path}/${package}.pm";
  79   my $file       =  "SL/DB/${package}.pm";
  80
  81   $schema        = <<CODE if $schema;
  82     __PACKAGE__->meta->schema('$schema');
  83 CODE
  84
  85   my $definition =  eval <<CODE;
  86     package SL::DB::AUTO::$package;
  87     use SL::DB::Object;
  88     use base qw(SL::DB::Object);
  89
  90     __PACKAGE__->meta->table('$table');
  91 $schema
  92     __PACKAGE__->meta->auto_initialize;
  93
  94     __PACKAGE__->meta->perl_class_definition(indent => 2); # , braces => 'bsd'
  95 CODE
  96
  97   if ($EVAL_ERROR) {
  98     print STDERR "Error in execution for table '$table': $EVAL_ERROR";
  99     return;
 100   }
 101
 102   $definition =~ s/::AUTO::/::/g;
 103
 104   my $file_exists = -f $meta_file;
 105
 106   open(OUT, ">$meta_file") || die;
 107   print OUT <<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   close OUT;
 113
 114   print "File '$meta_file' " . ($file_exists ? 'updated' : 'created') . " for table '$table'\n";
 115
 116   if (! -f $file) {
 117     open(OUT, ">$file") || die;
 118     print OUT <<CODE;
 119 # This file has been auto-generated only because it didn't exist.
 120 # Feel free to modify it at will; it will not be overwritten automatically.
 121
 122 package SL::DB::${package};
 123
 124 use strict;
 125
 126 use SL::DB::MetaSetup::${package};
 127
 128 # Creates get_all, get_all_count, get_all_iterator, delete_all and update_all.
 129 __PACKAGE__->meta->make_manager_class;
 130
 131 1;
 132 CODE
 133     close OUT;
 134
 135     print "File '$file' created as well.\n";
 136   }
 137 }
 138
 139 setup();
 140
 141 my %blacklist     = SL::DB::Helper::Mappings->get_blacklist;
 142 my %package_names = SL::DB::Helper::Mappings->get_package_names;
 143
 144 my @tables = ();
 145 if (($ARGV[0] eq '--all') || ($ARGV[0] eq '-a') || ($ARGV[0] eq '--sugar') || ($ARGV[0] eq '-s')) {
 146   my ($type, $prefix) = ($ARGV[0] eq '--sugar') || ($ARGV[0] eq '-s') ? ('SUGAR', 'sugar_') : ('LXOFFICE', '');
 147   my $db              = SL::DB::create(undef, $type);
 148   @tables             = map  { $package_names{$type}->{$_} ? "${_}=" . $package_names{$type}->{$_} : $prefix ? "${_}=${prefix}${_}" : $_ }
 149                         grep { my $table = $_; !any { $_ eq $table } @{ $blacklist{$type} } }
 150                         $db->list_tables;
 151
 152 } else {
 153   @tables = @ARGV;
 154 }
 155
 156 foreach my $table (@tables) {
 157   # add default model name unless model name is given or no defaults exists
 158   $table .= '=' . $package_names{LXOFFICE}->{lc $table} if $table !~ /=/ && $package_names{LXOFFICE}->{lc $table};
 159
 160   process_table($table);
 161 }