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(none);
17 use List::UtilsBy qw(partition_by);
19 use Rose::DB::Object 0.809;
29 use SL::DB::Helper::ALL;
30 use SL::DB::Helper::Mappings;
32 my %blacklist = SL::DB::Helper::Mappings->get_blacklist;
33 my %package_names = SL::DB::Helper::Mappings->get_package_names;
39 our $script = __FILE__;
42 $OUTPUT_AUTOFLUSH = 1;
43 $Data::Dumper::Sortkeys = 1;
45 our $meta_path = "SL/DB/MetaSetup";
46 our $manager_path = "SL/DB/Manager";
50 # Maps column names in tables to foreign key relationship names. For
53 # »follow_up_access« contains a column named »who«. Rose normally
54 # names the resulting relationship after the class the target table
55 # uses. In this case the target table is »employee« and the
56 # corresponding class SL::DB::Employee. The resulting relationship
57 # would be named »employee«.
59 # In order to rename this relationship we have to map »who« to
61 # follow_up_access => { who => 'granted_by' },
63 our %foreign_key_name_map = (
65 oe => { payment_id => 'payment_terms', },
66 ar => { payment_id => 'payment_terms', },
67 ap => { payment_id => 'payment_terms', },
69 orderitems => { parts_id => 'part', trans_id => 'order', },
70 delivery_order_items => { parts_id => 'part' },
71 invoice => { parts_id => 'part' },
72 follow_ups => { created_for_user => 'created_for', created_by => 'employee', },
74 periodic_invoices_configs => { oe_id => 'order' },
80 SL::LxOfficeConf->read;
82 my $client = $config{client} || $::lx_office_conf{devel}{client};
85 error("No client found in config. Please provide a client:");
89 $::lxdebug = LXDebug->new();
90 $::locale = Locale->new("de");
92 $form->{script} = 'rose_meta_data.pl';
93 $::auth = SL::Auth->new();
95 if (!$::auth->set_client($client)) {
96 error("No client with ID or name '$client' found in config. Please provide a client:");
100 foreach (($meta_path, $manager_path)) {
105 sub fix_relationship_names {
106 my ($domain, $table, $fkey_text) = @_;
108 if ($fkey_text !~ m/key_columns \s+ => \s+ \{ \s+ ['"]? ( [^'"\s]+ ) /x) {
109 die "fix_relationship_names: could not extract the key column for domain/table $domain/$table; foreign key definition text:\n${fkey_text}\n";
112 my $column_name = $1;
113 my %changes = map { %{$_} } grep { $_ } ($foreign_key_name_map{$domain}->{ALL}, $foreign_key_name_map{$domain}->{$table});
115 if (my $desired_name = $changes{$column_name}) {
116 $fkey_text =~ s/^ \s\s [^\s]+ \b/ ${desired_name}/msx;
123 my ($domain, $table, $package) = @_;
125 ($schema, $table) = split(m/\./, $table) if $table =~ m/\./;
126 $package = ucfirst($package || $table);
127 $package =~ s/_+(.)/uc($1)/ge;
128 my $meta_file = "${meta_path}/${package}.pm";
129 my $mngr_file = "${manager_path}/${package}.pm";
130 my $file = "SL/DB/${package}.pm";
132 my $schema_str = $schema ? <<CODE : '';
133 __PACKAGE__->meta->schema('$schema');
137 package SL::DB::AUTO::$package;
139 use base qw(SL::DB::Object);
141 __PACKAGE__->meta->table('$table');
143 __PACKAGE__->meta->auto_initialize;
148 error("Error in execution for table '$table'");
149 error("'$EVAL_ERROR'") unless $config{quiet};
153 my %args = (indent => 2, use_setup => 0);
155 my $definition = "SL::DB::AUTO::$package"->meta->perl_class_definition(%args);
156 $definition =~ s/\n+__PACKAGE__->meta->initialize;\n+/\n\n/;
157 $definition =~ s/::AUTO::/::/g;
160 # Sort column definitions alphabetically
161 if ($definition =~ m/__PACKAGE__->meta->columns\( \n (.+?) \n \);/msx) {
162 my ($start, $end) = ($-[1], $+[1]);
163 my $sorted_columns = join "\n", sort split m/\n/, $1;
164 substr $definition, $start, $end - $start, $sorted_columns;
168 my $foreign_key_definition = "SL::DB::AUTO::$package"->meta->perl_foreign_keys_definition(%args);
169 $foreign_key_definition =~ s/::AUTO::/::/g;
171 if ($foreign_key_definition && ($definition =~ /\Q$foreign_key_definition\E/)) {
172 # These positions refer to the whole setup call, not just the
173 # parameters/actual relationship definitions.
174 my ($start, $end) = ($-[0], $+[0]);
176 # Match the function parameters = the actual relationship
178 next unless $foreign_key_definition =~ m/\(\n(.+)\n\)/s;
180 my ($list_start, $list_end) = ($-[0], $+[0]);
182 # Split the whole chunk on double new lines. The resulting
183 # elements are one relationship each. Then fix the relationship
184 # names and sort them by their new names.
185 my @new_foreign_keys = sort map { fix_relationship_names($domain, $table, $_) } split m/\n\n/m, $1;
187 # Replace the function parameters = the actual relationship
188 # definitions with the new ones.
189 my $sorted_foreign_keys = "(\n" . join("\n\n", @new_foreign_keys) . "\n)";
190 substr $foreign_key_definition, $list_start, $list_end - $list_start, $sorted_foreign_keys;
192 # Replace the whole setup call in the auto-generated output with
194 substr $definition, $start, $end - $start, $foreign_key_definition;
197 $definition =~ s/(meta->table.*)\n/$1\n$schema_str/m if $schema;
199 my $full_definition = <<CODE;
200 # This file has been auto-generated. Do not modify it; it will be overwritten
201 # by $::script automatically.
205 my $meta_definition = <<CODE;
206 # This file has been auto-generated only because it didn't exist.
207 # Feel free to modify it at will; it will not be overwritten automatically.
209 package SL::DB::${package};
213 use SL::DB::MetaSetup::${package};
214 use SL::DB::Manager::${package};
216 __PACKAGE__->meta->initialize;
221 my $file_exists = -f $meta_file;
223 my $old_size = -s $meta_file;
224 my $orig_file = do { local(@ARGV, $/) = ($meta_file); <> };
225 my $old_md5 = md5_hex($orig_file);
226 my $new_size = length $full_definition;
227 my $new_md5 = md5_hex($full_definition);
228 if ($old_size == $new_size && $old_md5 eq $new_md5) {
229 notice("No changes in $meta_file, skipping.") unless $config{quiet};
233 show_diff(\$orig_file, \$full_definition) if $config{show_diff};
236 if (!$config{nocommit}) {
237 open my $out, ">", $meta_file || die;
238 print $out $full_definition;
241 notice("File '$meta_file' " . ($file_exists ? 'updated' : 'created') . " for table '$table'");
245 if (!$config{nocommit}) {
246 open my $out, ">", $file || die;
247 print $out $meta_definition;
250 notice("File '$file' created as well.");
252 return if -f $mngr_file;
254 if (!$config{nocommit}) {
255 open my $out, ">", $mngr_file || die;
257 # This file has been auto-generated only because it didn't exist.
258 # Feel free to modify it at will; it will not be overwritten automatically.
260 package SL::DB::Manager::${package};
264 use SL::DB::Helper::Manager;
265 use base qw(SL::DB::Helper::Manager);
267 sub object_class { 'SL::DB::${package}' }
269 __PACKAGE__->make_manager_methods;
275 notice("File '$mngr_file' created as well.");
281 'client=s' => \ my $client,
284 'no-commit|dry-run' => \ my $nocommit,
285 help => sub { pod2usage(verbose => 99, sections => 'NAME|SYNOPSIS|OPTIONS') },
286 quiet => \ my $quiet,
290 $options->{client} = $client;
291 $options->{all} = $all;
292 $options->{db} = $db;
293 $options->{nocommit} = $nocommit;
294 $options->{quiet} = $quiet;
295 $options->{color} = -t STDOUT ? 1 : 0;
298 if (eval { require Text::Diff; 1 }) {
299 $options->{show_diff} = 1;
301 error('Could not load Text::Diff. Sorry, no diffs for you.');
307 my ($text_a, $text_b) = @_;
314 Text::Diff::diff($text_a, $text_b, { OUTPUT => sub {
315 for (split /\n/, $_[0]) {
316 if ($config{color}) {
317 print colored($_, $colors{substr($_, 0, 1)}), $/;
326 pod2usage(verbose => 99, sections => 'SYNOPSIS');
330 my %tables_by_domain;
332 my @domains = $config{db} ? (uc $config{db}) : sort keys %package_names;
334 foreach my $domain (@domains) {
335 my $db = SL::DB::create(undef, $domain);
336 $tables_by_domain{$domain} = [ grep { my $table = $_; none { $_ eq $table } @{ $blacklist{$domain} } } $db->list_tables ];
341 %tables_by_domain = partition_by {
342 my ($domain, $table) = split m{:};
343 $table ? uc($domain) : 'KIVITENDO';
346 foreach my $tables (values %tables_by_domain) {
347 s{.*:}{} for @{ $tables };
351 error("You specified neither --all nor any specific tables.");
355 return %tables_by_domain;
359 print STDERR colored(shift, 'red'), $/;
366 sub check_errors_in_package_names {
367 foreach my $domain (sort keys %package_names) {
368 my @both = grep { $package_names{$domain}->{$_} } @{ $blacklist{$domain} || [] };
371 print "Error: domain '$domain': The following table names are present in both the black list and the package name hash: ", join(' ', sort @both), "\n";
376 parse_args(\%config);
378 check_errors_in_package_names();
380 my %tables_by_domain = make_tables();
382 foreach my $domain (keys %tables_by_domain) {
383 my @tables = @{ $tables_by_domain{$domain} };
384 my @unknown_tables = grep { !$package_names{$domain}->{$_} } @tables;
385 if (@unknown_tables) {
386 error("The following tables do not have entries in \%SL::DB::Helper::Mappings::${domain}_package_names: " . join(' ', sort @unknown_tables));
390 process_table($domain, $_, $package_names{$domain}->{$_}) for @tables;
401 rose_auto_create_model - mana Rose::DB::Object classes for kivitendo
405 scripts/rose_auto_create_model.pl --client name-or-id [db1:]table1 [[db2:]table2 ...]
406 scripts/rose_auto_create_model.pl --client name-or-id [--all|-a]
409 scripts/rose_auto_create_model.pl --client name-or-id --all [--db db]
411 # updates only customer table, login taken from config
412 scripts/rose_auto_create_model.pl customer
414 # updates only parts table, package will be Part
415 scripts/rose_auto_create_model.pl parts=Part
417 # try to update parts, but don't do it. tell what would happen in detail
418 scripts/rose_auto_create_model.pl --no-commit parts
422 Rose::DB::Object comes with a nice function named auto initialization with code
423 generation. The documentation of Rose describes it like this:
425 I<[...] auto-initializing metadata at runtime by querying the database has many
426 caveats. An alternate approach is to query the database for metadata just once,
427 and then generate the equivalent Perl code which can be pasted directly into
428 the class definition in place of the call to auto_initialize.>
430 I<Like the auto-initialization process itself, perl code generation has a
431 convenient wrapper method as well as separate methods for the individual parts.
432 All of the perl code generation methods begin with "perl_", and they support
433 some rudimentary code formatting options to help the code conform to you
434 preferred style. Examples can be found with the documentation for each perl_*
437 I<This hybrid approach to metadata population strikes a good balance between
438 upfront effort and ongoing maintenance. Auto-generating the Perl code for the
439 initial class definition saves a lot of tedious typing. From that point on,
440 manually correcting and maintaining the definition is a small price to pay for
441 the decreased start-up cost, the ability to use the class in the absence of a
442 database connection, and the piece of mind that comes from knowing that your
443 class is stable, and won't change behind your back in response to an "action at
444 a distance" (i.e., a database schema update).>
446 Unfortunately this reads easier than it is, since classes need to go into the
447 right package and directory, certain stuff needs to be adjusted and table names
448 need to be translated into their class names. This script will wrap all that
449 behind a few simple options.
451 In the most basic version, just give it a login and a table name, and it will
452 load the schema information for this table and create the appropriate class
453 files, or update them if already present.
455 Each table has three associated files. A C<SL::DB::MetaSetup::*>
456 class, which is a perl version of the schema definition, a
457 C<SL::DB::*> class file and a C<SL::DB::Manager::*> manager class
458 file. The first one will be updated if the schema changes, the second
459 and third ones will only be created if it they do not exist.
461 =head1 DATABASE NAMES AND TABLES
463 If you want to generate the data for specific tables only then you
464 have to list them on the command line. The format is
465 C<db-name:table-name>. The part C<db-name:> is optional and defaults
466 to C<KIVITENDO:> – which means the tables in the default kivitendo
469 Valid database names are keys in the hash returned by
470 L<SL::DB::Helper::Mappings/get_package_names>.
476 =item C<--client, -c CLIENT>
478 Provide a client whose database settings are used. If not present the
479 client is loaded from the config key C<devel/client>. If that too is
480 not found, an error is thrown.
482 Note that C<CLIENT> can be either a database ID or a client's name.
486 Process all tables from the database. Only those that are blacklistes in
487 L<SL::DB::Helper::Mappings> are excluded.
491 In combination with C<--all> causes all tables in the specific
492 database to be processed, not in all databases.
494 =item C<--no-commit, -n>
498 Do not write back generated files. This will do everything as usual but not
499 actually modify any file.
503 Displays diff for selected file, if file is present and newer file is
504 different. Beware, does not imply C<--no-commit>.
512 Does not print extra information, such as skipped files that were not
513 changed and errors where the auto initialization failed.
523 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>,
524 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>