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";
47 our %foreign_key_name_map = (
48 oe => { payment => 'payment_terms', },
49 ar => { payment => 'payment_terms', },
50 ap => { payment => 'payment_terms', },
52 orderitems => { parts => 'part', trans => 'order', },
53 delivery_order_items => { parts => 'part' },
54 invoice => { parts => 'part' },
56 periodic_invoices_configs => { oe => 'order' },
61 SL::LxOfficeConf->read;
63 my $login = $config{login} || $::lx_office_conf{devel}{login};
66 error("No login found in config. Please provide a login:");
70 $::lxdebug = LXDebug->new();
71 $::locale = Locale->new("de");
73 $::auth = SL::Auth->new();
74 $::user = User->new(login => $login);
75 %::myconfig = $auth->read_user(login => $login);
76 $::request = { cgi => CGI->new({}) };
77 $form->{script} = 'rose_meta_data.pl';
78 $form->{login} = $login;
80 map { $form->{$_} = $::myconfig{$_} } qw(stylesheet charset);
82 mkdir $meta_path unless -d $meta_path;
86 my @spec = split(/=/, shift, 2);
89 ($schema, $table) = split(m/\./, $table) if $table =~ m/\./;
90 my $package = ucfirst($spec[1] || $spec[0]);
91 $package =~ s/_+(.)/uc($1)/ge;
92 my $meta_file = "${meta_path}/${package}.pm";
93 my $file = "SL/DB/${package}.pm";
95 $schema = <<CODE if $schema;
96 __PACKAGE__->meta->schema('$schema');
99 my $definition = eval <<CODE;
100 package SL::DB::AUTO::$package;
102 use base qw(SL::DB::Object);
104 __PACKAGE__->meta->table('$table');
106 __PACKAGE__->meta->auto_initialize;
108 __PACKAGE__->meta->perl_class_definition(indent => 2); # , braces => 'bsd'
112 error("Error in execution for table '$table'");
113 error("'$EVAL_ERROR'") if $config{verbose};
117 $definition =~ s/::AUTO::/::/g;
119 while (my ($auto_generated_name, $desired_name) = each %{ $foreign_key_name_map{$table} || {} }) {
120 $definition =~ s/( foreign_keys \s*=> \s*\[ .* ^\s+ ) ${auto_generated_name} \b/${1}${desired_name}/msx;
123 my $full_definition = <<CODE;
124 # This file has been auto-generated. Do not modify it; it will be overwritten
125 # by $::script automatically.
129 my $meta_definition = <<CODE;
130 # This file has been auto-generated only because it didn't exist.
131 # Feel free to modify it at will; it will not be overwritten automatically.
133 package SL::DB::${package};
137 use SL::DB::MetaSetup::${package};
139 # Creates get_all, get_all_count, get_all_iterator, delete_all and update_all.
141 __PACKAGE__->meta->make_manager_class;
146 my $file_exists = -f $meta_file;
148 my $old_size = -s $meta_file;
149 my $orig_file = do { local(@ARGV, $/) = ($meta_file); <> };
150 my $old_md5 = md5_hex($orig_file);
151 my $new_size = length $full_definition;
152 my $new_md5 = md5_hex($full_definition);
153 if ($old_size == $new_size && $old_md5 == $new_md5) {
154 notice("No changes in $meta_file, skipping.") if $config{verbose};
158 show_diff(\$orig_file, \$full_definition) if $config{show_diff};
161 if (!$config{nocommit}) {
162 open my $out, ">", $meta_file || die;
163 print $out $full_definition;
166 notice("File '$meta_file' " . ($file_exists ? 'updated' : 'created') . " for table '$table'");
169 if (!$config{nocommit}) {
170 open my $out, ">", $file || die;
171 print $out $meta_definition;
174 notice("File '$file' created as well.");
181 'login|user=s' => \ my $login,
183 'no-commit|dry-run' => \ my $nocommit,
184 help => sub { pod2usage(verbose => 99, sections => 'NAME|SYNOPSIS|OPTIONS') },
185 verbose => \ my $verbose,
189 $options->{login} = $login if $login;
190 $options->{all} = $all;
191 $options->{nocommit} = $nocommit;
192 $options->{verbose} = $verbose;
195 if (eval { require Text::Diff; 1 }) {
196 $options->{show_diff} = 1;
198 error('Could not load Text::Diff. Sorry, no diffs for you.');
204 my ($text_a, $text_b) = @_;
211 Text::Diff::diff($text_a, $text_b, { OUTPUT => sub {
212 for (split /\n/, $_[0]) {
213 print colored($_, $colors{substr($_, 0, 1)}), $/;
219 pod2usage(verbose => 99, sections => 'SYNOPSIS');
225 my $db = SL::DB::create(undef, 'LXOFFICE');
227 map { $package_names{LXOFFICE}->{$_} ? "$_=" . $package_names{LXOFFICE}->{$_} : $_ }
228 grep { my $table = $_; !any { $_ eq $table } @{ $blacklist{LXOFFICE} } }
233 error("You specified neither --all nor any specific tables.");
241 print STDERR colored(shift, 'red'), $/;
248 parse_args(\%config);
250 my @tables = make_tables();
252 for my $table (@tables) {
253 # add default model name unless model name is given or no defaults exists
254 $table .= '=' . $package_names{LXOFFICE}->{lc $table} if $table !~ /=/ && $package_names{LXOFFICE}->{lc $table};
256 process_table($table);
267 rose_auto_create_model - mana Rose::DB::Object classes for kivitendo
271 scripts/rose_create_model.pl --login login table1[=package1] [table2[=package2] ...]
272 scripts/rose_create_model.pl --login login [--all|-a]
275 scripts/rose_create_model.pl --login login --all
277 # updates only customer table, login taken from config
278 scripts/rose_create_model.pl customer
280 # updates only parts table, package will be Part
281 scripts/rose_create_model.pl parts=Part
283 # try to update parts, but don't do it. tell what would happen in detail
284 scripts/rose_create_model.pl --no-commit --verbose parts
288 Rose::DB::Object comes with a nice function named auto initialization with code
289 generation. The documentation of Rose describes it like this:
291 I<[...] auto-initializing metadata at runtime by querying the database has many
292 caveats. An alternate approach is to query the database for metadata just once,
293 and then generate the equivalent Perl code which can be pasted directly into
294 the class definition in place of the call to auto_initialize.>
296 I<Like the auto-initialization process itself, perl code generation has a
297 convenient wrapper method as well as separate methods for the individual parts.
298 All of the perl code generation methods begin with "perl_", and they support
299 some rudimentary code formatting options to help the code conform to you
300 preferred style. Examples can be found with the documentation for each perl_*
303 I<This hybrid approach to metadata population strikes a good balance between
304 upfront effort and ongoing maintenance. Auto-generating the Perl code for the
305 initial class definition saves a lot of tedious typing. From that point on,
306 manually correcting and maintaining the definition is a small price to pay for
307 the decreased start-up cost, the ability to use the class in the absence of a
308 database connection, and the piece of mind that comes from knowing that your
309 class is stable, and won't change behind your back in response to an "action at
310 a distance" (i.e., a database schema update).>
312 Unfortunately this reads easier than it is, since classes need to go into the
313 right package and directory, certain stuff needs to be adjusted and table names
314 need to be translated into their class names. This script will wrap all that
315 behind a few simple options.
317 In the most basic version, just give it a login and a table name, and it will
318 load the schema information for this table and create the appropriate class
319 files, or update them if already present.
321 Each table has two associated files. A C<SL::DB::MetaSetup::*> class, which is
322 a perl version of the schema definition, and a C<SL::DB::*> class file. The
323 first one will be updated if the schema changes, the second one will only be
324 created if it does not exist.
330 =item C<--login, -l LOGIN>
332 =item C<--user, -u LOGIN>
334 Provide a login. If not present the login is loaded from the config key
335 C<devel/login>. If that too is not found, an error is thrown.
339 Process all tables from the database. Only those that are blacklistes in
340 L<SL::DB::Helper::Mappings> are excluded.
342 =item C<--no-commit, -n>
346 Do not write back generated files. This will do everything as usual but not
347 actually modify any file.
351 Displays diff for selected file, if file is present and newer file is
352 different. Beware, does not imply C<--no-commit>.
358 =item C<--verbose, -v>
360 Prints extra information, such as skipped files that were not changed and
361 errors where the auto initialization failed.
371 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>