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;
37 our $script = __FILE__;
40 $OUTPUT_AUTOFLUSH = 1;
41 $Data::Dumper::Sortkeys = 1;
43 our $meta_path = "SL/DB/MetaSetup";
49 SL::LxOfficeConf->read;
51 my $login = $config{login} || $::lx_office_conf{devel}{login};
54 error("No login found in config. Please provide a login:");
58 $::lxdebug = LXDebug->new();
59 $::locale = Locale->new("de");
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;
68 map { $form->{$_} = $::myconfig{$_} } qw(stylesheet charset);
70 mkdir $meta_path unless -d $meta_path;
74 my @spec = split(/=/, shift, 2);
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";
83 $schema = <<CODE if $schema;
84 __PACKAGE__->meta->schema('$schema');
87 my $definition = eval <<CODE;
88 package SL::DB::AUTO::$package;
90 use base qw(SL::DB::Object);
92 __PACKAGE__->meta->table('$table');
94 __PACKAGE__->meta->auto_initialize;
96 __PACKAGE__->meta->perl_class_definition(indent => 2); # , braces => 'bsd'
100 error("Error in execution for table '$table'");
101 error("'$EVAL_ERROR'") if $config{verbose};
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.
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.
116 package SL::DB::${package};
120 use SL::DB::MetaSetup::${package};
122 # Creates get_all, get_all_count, get_all_iterator, delete_all and update_all.
123 __PACKAGE__->meta->make_manager_class;
128 my $file_exists = -f $meta_file;
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};
140 show_diff(\$orig_file, \$full_definition) if $config{show_diff};
143 if (!$config{nocommit}) {
144 open my $out, ">", $meta_file || die;
145 print $out $full_definition;
148 notice("File '$meta_file' " . ($file_exists ? 'updated' : 'created') . " for table '$table'");
151 if (!$config{nocommit}) {
152 open my $out, ">", $file || die;
153 print $out $meta_definition;
156 notice("File '$file' created as well.");
163 'login|user=s' => \ my $login,
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,
172 $options->{login} = $login if $login;
173 $options->{sugar} = $sugar;
174 $options->{all} = $all;
175 $options->{nocommit} = $nocommit;
176 $options->{verbose} = $verbose;
179 if (eval { require Text::Diff; 1 }) {
180 $options->{show_diff} = 1;
182 error('Could not load Text::Diff. Sorry, no diffs for you.');
188 my ($text_a, $text_b) = @_;
195 Text::Diff::diff($text_a, $text_b, { OUTPUT => sub {
196 for (split /\n/, $_[0]) {
197 print colored($_, $colors{substr($_, 0, 1)}), $/;
203 pod2usage(verbose => 99, sections => 'SYNOPSIS');
208 if ($config{all} || $config{sugar}) {
209 my ($type, $prefix) = $config{sugar} ? ('SUGAR', 'sugar_') : ('LXOFFICE', '');
210 my $db = SL::DB::create(undef, $type);
212 map { $package_names{$type}->{$_} ? "$_=" . $package_names{$type}->{$_} : $prefix ? "$_=$prefix$_" : $_ }
213 grep { my $table = $_; !any { $_ eq $table } @{ $blacklist{$type} } }
218 error("You specified neither --sugar nor --all nor any specific tables.");
226 print STDERR colored(shift, 'red'), $/;
233 parse_args(\%config);
235 my @tables = make_tables();
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};
241 process_table($table);
252 rose_auto_create_model - mana Rose::DB::Object classes for Lx-Office
256 scripts/rose_create_model.pl --login login table1[=package1] [table2[=package2] ...]
257 scripts/rose_create_model.pl --login login [--all|-a] [--sugar|-s]
260 scripts/rose_create_model.pl --login login --all
262 # updates only customer table, login taken from config
263 scripts/rose_create_model.pl customer
265 # updates only parts table, package will be Part
266 scripts/rose_create_model.pl parts=Part
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
273 Rose::DB::Object comes with a nice function named auto initialization with code
274 generation. The documentation of Rose describes it like this:
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.>
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_*
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).>
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.
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.
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.
315 =item C<--login, -l LOGIN>
317 =item C<--user, -u LOGIN>
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.
324 Process all tables from the database. Only those that are blacklistes in
325 L<SL::DB::Helper::Mappings> are excluded.
329 Process tables in sugar schema instead of standard schema. Rarely useful unless
330 you debug schema awareness of the RDBO layer.
332 =item C<--no-commit, -n>
335 Do not write back generated files. This will do everything as usual but not
336 actually modify any file.
340 Displays diff for selected file, if file is present and newer file is
341 different. Beware, does not imply C<--no-commit>.
347 =item C<--verbose, -v>
349 Prints extra information, such as skipped files that were not changed and
350 errors where the auto initialization failed.
360 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>