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);
66 $form->{script} = 'rose_meta_data.pl';
67 $form->{login} = $login;
69 map { $form->{$_} = $::myconfig{$_} } qw(stylesheet charset);
71 mkdir $meta_path unless -d $meta_path;
75 my @spec = split(/=/, shift, 2);
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";
84 $schema = <<CODE if $schema;
85 __PACKAGE__->meta->schema('$schema');
88 my $definition = eval <<CODE;
89 package SL::DB::AUTO::$package;
91 use base qw(SL::DB::Object);
93 __PACKAGE__->meta->table('$table');
95 __PACKAGE__->meta->auto_initialize;
97 __PACKAGE__->meta->perl_class_definition(indent => 2); # , braces => 'bsd'
101 error("Error in execution for table '$table'");
102 error("'$EVAL_ERROR'") if $config{verbose};
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.
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.
117 package SL::DB::${package};
121 use SL::DB::MetaSetup::${package};
123 # Creates get_all, get_all_count, get_all_iterator, delete_all and update_all.
124 __PACKAGE__->meta->make_manager_class;
129 my $file_exists = -f $meta_file;
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};
141 show_diff(\$orig_file, \$full_definition) if $config{show_diff};
144 if (!$config{nocommit}) {
145 open my $out, ">", $meta_file || die;
146 print $out $full_definition;
149 notice("File '$meta_file' " . ($file_exists ? 'updated' : 'created') . " for table '$table'");
152 if (!$config{nocommit}) {
153 open my $out, ">", $file || die;
154 print $out $meta_definition;
157 notice("File '$file' created as well.");
164 'login|user=s' => \ my $login,
166 sugar => \ my $sugar,
167 'no-commit|dry-run' => \ my $nocommit,
168 help => sub { pod2usage(verbose => 99, sections => 'NAME|SYNOPSIS|OPTIONS') },
169 verbose => \ my $verbose,
173 $options->{login} = $login if $login;
174 $options->{sugar} = $sugar;
175 $options->{all} = $all;
176 $options->{nocommit} = $nocommit;
177 $options->{verbose} = $verbose;
180 if (eval { require Text::Diff; 1 }) {
181 $options->{show_diff} = 1;
183 error('Could not load Text::Diff. Sorry, no diffs for you.');
189 my ($text_a, $text_b) = @_;
196 Text::Diff::diff($text_a, $text_b, { OUTPUT => sub {
197 for (split /\n/, $_[0]) {
198 print colored($_, $colors{substr($_, 0, 1)}), $/;
204 pod2usage(verbose => 99, sections => 'SYNOPSIS');
209 if ($config{all} || $config{sugar}) {
210 my ($type, $prefix) = $config{sugar} ? ('SUGAR', 'sugar_') : ('LXOFFICE', '');
211 my $db = SL::DB::create(undef, $type);
213 map { $package_names{$type}->{$_} ? "$_=" . $package_names{$type}->{$_} : $prefix ? "$_=$prefix$_" : $_ }
214 grep { my $table = $_; !any { $_ eq $table } @{ $blacklist{$type} } }
219 error("You specified neither --sugar nor --all nor any specific tables.");
227 print STDERR colored(shift, 'red'), $/;
234 parse_args(\%config);
236 my @tables = make_tables();
238 for my $table (@tables) {
239 # add default model name unless model name is given or no defaults exists
240 $table .= '=' . $package_names{LXOFFICE}->{lc $table} if $table !~ /=/ && $package_names{LXOFFICE}->{lc $table};
242 process_table($table);
253 rose_auto_create_model - mana Rose::DB::Object classes for Lx-Office
257 scripts/rose_create_model.pl --login login table1[=package1] [table2[=package2] ...]
258 scripts/rose_create_model.pl --login login [--all|-a] [--sugar|-s]
261 scripts/rose_create_model.pl --login login --all
263 # updates only customer table, login taken from config
264 scripts/rose_create_model.pl customer
266 # updates only parts table, package will be Part
267 scripts/rose_create_model.pl parts=Part
269 # try to update parts, but don't do it. tell what would happen in detail
270 scripts/rose_create_model.pl --no-commit --verbose parts
274 Rose::DB::Object comes with a nice function named auto initialization with code
275 generation. The documentation of Rose describes it like this:
277 I<[...] auto-initializing metadata at runtime by querying the database has many
278 caveats. An alternate approach is to query the database for metadata just once,
279 and then generate the equivalent Perl code which can be pasted directly into
280 the class definition in place of the call to auto_initialize.>
282 I<Like the auto-initialization process itself, perl code generation has a
283 convenient wrapper method as well as separate methods for the individual parts.
284 All of the perl code generation methods begin with "perl_", and they support
285 some rudimentary code formatting options to help the code conform to you
286 preferred style. Examples can be found with the documentation for each perl_*
289 I<This hybrid approach to metadata population strikes a good balance between
290 upfront effort and ongoing maintenance. Auto-generating the Perl code for the
291 initial class definition saves a lot of tedious typing. From that point on,
292 manually correcting and maintaining the definition is a small price to pay for
293 the decreased start-up cost, the ability to use the class in the absence of a
294 database connection, and the piece of mind that comes from knowing that your
295 class is stable, and won't change behind your back in response to an "action at
296 a distance" (i.e., a database schema update).>
298 Unfortunately this reads easier than it is, since classes need to go into the
299 right package and directory, certain stuff needs to be adjusted and table names
300 need to be translated into their class names. This script will wrap all that
301 behind a few simple options.
303 In the most basic version, just give it a login and a table name, and it will
304 load the schema information for this table and create the appropriate class
305 files, or update them if already present.
307 Each table has two associated files. A C<SL::DB::MetaSetup::*> class, which is
308 a perl version of the schema definition, and a C<SL::DB::*> class file. The
309 first one will be updated if the schema changes, the second one will only be
310 created if it does not exist.
316 =item C<--login, -l LOGIN>
318 =item C<--user, -u LOGIN>
320 Provide a login. If not present the login is loaded from the config key
321 C<devel/login>. If that too is not found, an error is thrown.
325 Process all tables from the database. Only those that are blacklistes in
326 L<SL::DB::Helper::Mappings> are excluded.
330 Process tables in sugar schema instead of standard schema. Rarely useful unless
331 you debug schema awareness of the RDBO layer.
333 =item C<--no-commit, -n>
336 Do not write back generated files. This will do everything as usual but not
337 actually modify any file.
341 Displays diff for selected file, if file is present and newer file is
342 different. Beware, does not imply C<--no-commit>.
348 =item C<--verbose, -v>
350 Prints extra information, such as skipped files that were not changed and
351 errors where the auto initialization failed.
361 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>