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.
10 use CGI qw( -no_xhtml);
13 use Digest::MD5 qw(md5_hex);
14 use English qw( -no_match_vars );
16 use List::MoreUtils qw(any);
27 use SL::DB::Helper::ALL;
28 use SL::DB::Helper::Mappings;
30 my %blacklist = SL::DB::Helper::Mappings->get_blacklist;
31 my %package_names = SL::DB::Helper::Mappings->get_package_names;
38 our $script = __FILE__;
41 $OUTPUT_AUTOFLUSH = 1;
42 $Data::Dumper::Sortkeys = 1;
44 our $meta_path = "SL/DB/MetaSetup";
50 SL::LxOfficeConf->read;
52 my $login = $config{login} || $::lx_office_conf{devel}{login};
55 error("No login found in config. Please provide a login:");
59 $::lxdebug = LXDebug->new();
60 $::locale = Locale->new("de");
63 $::auth = SL::Auth->new();
64 $::user = User->new($login);
65 %::myconfig = $auth->read_user($login);
67 $form->{script} = 'rose_meta_data.pl';
68 $form->{login} = $login;
70 map { $form->{$_} = $::myconfig{$_} } qw(stylesheet charset);
72 mkdir $meta_path unless -d $meta_path;
76 my @spec = split(/=/, shift, 2);
79 ($schema, $table) = split(m/\./, $table) if $table =~ m/\./;
80 my $package = ucfirst($spec[1] || $spec[0]);
81 $package =~ s/_+(.)/uc($1)/ge;
82 my $meta_file = "${meta_path}/${package}.pm";
83 my $file = "SL/DB/${package}.pm";
85 $schema = <<CODE if $schema;
86 __PACKAGE__->meta->schema('$schema');
89 my $definition = eval <<CODE;
90 package SL::DB::AUTO::$package;
92 use base qw(SL::DB::Object);
94 __PACKAGE__->meta->table('$table');
96 __PACKAGE__->meta->auto_initialize;
98 __PACKAGE__->meta->perl_class_definition(indent => 2); # , braces => 'bsd'
102 error("Error in execution for table '$table'");
103 error("'$EVAL_ERROR'") if $config{verbose};
107 $definition =~ s/::AUTO::/::/g;
108 my $full_definition = <<CODE;
109 # This file has been auto-generated. Do not modify it; it will be overwritten
110 # by $::script automatically.
114 my $meta_definition = <<CODE;
115 # This file has been auto-generated only because it didn't exist.
116 # Feel free to modify it at will; it will not be overwritten automatically.
118 package SL::DB::${package};
122 use SL::DB::MetaSetup::${package};
124 # Creates get_all, get_all_count, get_all_iterator, delete_all and update_all.
125 __PACKAGE__->meta->make_manager_class;
130 my $file_exists = -f $meta_file;
132 my $old_size = -s $meta_file;
133 my $orig_file = do { local(@ARGV, $/) = ($meta_file); <> };
134 my $old_md5 = md5_hex($orig_file);
135 my $new_size = length $full_definition;
136 my $new_md5 = md5_hex($full_definition);
137 if ($old_size == $new_size && $old_md5 == $new_md5) {
138 notice("No changes in $meta_file, skipping.") if $config{verbose};
142 show_diff(\$orig_file, \$full_definition) if $config{show_diff};
145 if (!$config{nocommit}) {
146 open my $out, ">", $meta_file || die;
147 print $out $full_definition;
150 notice("File '$meta_file' " . ($file_exists ? 'updated' : 'created') . " for table '$table'");
153 if (!$config{nocommit}) {
154 open my $out, ">", $file || die;
155 print $out $meta_definition;
158 notice("File '$file' created as well.");
165 'login|user=s' => \ my $login,
167 sugar => \ my $sugar,
168 'no-commit|dry-run' => \ my $nocommit,
169 help => sub { pod2usage(verbose => 99, sections => 'NAME|SYNOPSIS|OPTIONS') },
170 verbose => \ my $verbose,
174 $options->{login} = $login if $login;
175 $options->{sugar} = $sugar;
176 $options->{all} = $all;
177 $options->{nocommit} = $nocommit;
178 $options->{verbose} = $verbose;
181 if (eval { require Text::Diff; 1 }) {
182 $options->{show_diff} = 1;
184 error('Could not load Text::Diff. Sorry, no diffs for you.');
190 my ($text_a, $text_b) = @_;
197 Text::Diff::diff($text_a, $text_b, { OUTPUT => sub {
198 for (split /\n/, $_[0]) {
199 print colored($_, $colors{substr($_, 0, 1)}), $/;
205 pod2usage(verbose => 99, sections => 'SYNOPSIS');
210 if ($config{all} || $config{sugar}) {
211 my ($type, $prefix) = $config{sugar} ? ('SUGAR', 'sugar_') : ('LXOFFICE', '');
212 my $db = SL::DB::create(undef, $type);
214 map { $package_names{$type}->{$_} ? "$_=" . $package_names{$type}->{$_} : $prefix ? "$_=$prefix$_" : $_ }
215 grep { my $table = $_; !any { $_ eq $table } @{ $blacklist{$type} } }
220 error("You specified neither --sugar nor --all nor any specific tables.");
228 print STDERR colored(shift, 'red'), $/;
235 parse_args(\%config);
237 my @tables = make_tables();
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};
243 process_table($table);
254 rose_auto_create_model - mana Rose::DB::Object classes for Lx-Office
258 scripts/rose_create_model.pl --login login table1[=package1] [table2[=package2] ...]
259 scripts/rose_create_model.pl --login login [--all|-a] [--sugar|-s]
262 scripts/rose_create_model.pl --login login --all
264 # updates only customer table, login taken from config
265 scripts/rose_create_model.pl customer
267 # updates only parts table, package will be Part
268 scripts/rose_create_model.pl parts=Part
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
275 Rose::DB::Object comes with a nice function named auto initialization with code
276 generation. The documentation of Rose describes it like this:
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.>
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_*
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).>
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.
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.
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.
317 =item C<--login, -l LOGIN>
319 =item C<--user, -u LOGIN>
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.
326 Process all tables from the database. Only those that are blacklistes in
327 L<SL::DB::Helper::Mappings> are excluded.
331 Process tables in sugar schema instead of standard schema. Rarely useful unless
332 you debug schema awareness of the RDBO layer.
334 =item C<--no-commit, -n>
337 Do not write back generated files. This will do everything as usual but not
338 actually modify any file.
342 Displays diff for selected file, if file is present and newer file is
343 different. Beware, does not imply C<--no-commit>.
349 =item C<--verbose, -v>
351 Prints extra information, such as skipped files that were not changed and
352 errors where the auto initialization failed.
362 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>