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 => 'created_by', },
73 follow_up_access => { who => 'with_access', what => 'to_follow_ups_by', },
75 periodic_invoices_configs => { oe_id => 'order' },
81 SL::LxOfficeConf->read;
83 my $client = $config{client} || $::lx_office_conf{devel}{client};
86 error("No client found in config. Please provide a client:");
90 $::lxdebug = LXDebug->new();
91 $::locale = Locale->new("de");
93 $form->{script} = 'rose_meta_data.pl';
94 $::auth = SL::Auth->new();
96 if (!$::auth->set_client($client)) {
97 error("No client with ID or name '$client' found in config. Please provide a client:");
101 foreach (($meta_path, $manager_path)) {
106 sub fix_relationship_names {
107 my ($domain, $table, $fkey_text) = @_;
109 if ($fkey_text !~ m/key_columns \s+ => \s+ \{ \s+ ['"]? ( [^'"\s]+ ) /x) {
110 die "fix_relationship_names: could not extract the key column for domain/table $domain/$table; foreign key definition text:\n${fkey_text}\n";
113 my $column_name = $1;
114 my %changes = map { %{$_} } grep { $_ } ($foreign_key_name_map{$domain}->{ALL}, $foreign_key_name_map{$domain}->{$table});
116 if (my $desired_name = $changes{$column_name}) {
117 $fkey_text =~ s/^ \s\s [^\s]+ \b/ ${desired_name}/msx;
124 my ($domain, $table, $package) = @_;
126 ($schema, $table) = split(m/\./, $table) if $table =~ m/\./;
127 $package = ucfirst($package || $table);
128 $package =~ s/_+(.)/uc($1)/ge;
129 my $meta_file = "${meta_path}/${package}.pm";
130 my $mngr_file = "${manager_path}/${package}.pm";
131 my $file = "SL/DB/${package}.pm";
133 my $schema_str = $schema ? <<CODE : '';
134 __PACKAGE__->meta->schema('$schema');
138 package SL::DB::AUTO::$package;
140 use base qw(SL::DB::Object);
142 __PACKAGE__->meta->table('$table');
144 __PACKAGE__->meta->auto_initialize;
149 error("Error in execution for table '$table'");
150 error("'$EVAL_ERROR'") unless $config{quiet};
154 my %args = (indent => 2, use_setup => 0);
156 my $definition = "SL::DB::AUTO::$package"->meta->perl_class_definition(%args);
157 $definition =~ s/\n+__PACKAGE__->meta->initialize;\n+/\n\n/;
158 $definition =~ s/::AUTO::/::/g;
161 # Sort column definitions alphabetically
162 if ($definition =~ m/__PACKAGE__->meta->columns\( \n (.+?) \n \);/msx) {
163 my ($start, $end) = ($-[1], $+[1]);
164 my $sorted_columns = join "\n", sort split m/\n/, $1;
165 substr $definition, $start, $end - $start, $sorted_columns;
169 my $foreign_key_definition = "SL::DB::AUTO::$package"->meta->perl_foreign_keys_definition(%args);
170 $foreign_key_definition =~ s/::AUTO::/::/g;
172 if ($foreign_key_definition && ($definition =~ /\Q$foreign_key_definition\E/)) {
173 # These positions refer to the whole setup call, not just the
174 # parameters/actual relationship definitions.
175 my ($start, $end) = ($-[0], $+[0]);
177 # Match the function parameters = the actual relationship
179 next unless $foreign_key_definition =~ m/\(\n(.+)\n\)/s;
181 my ($list_start, $list_end) = ($-[0], $+[0]);
183 # Split the whole chunk on double new lines. The resulting
184 # elements are one relationship each. Then fix the relationship
185 # names and sort them by their new names.
186 my @new_foreign_keys = sort map { fix_relationship_names($domain, $table, $_) } split m/\n\n/m, $1;
188 # Replace the function parameters = the actual relationship
189 # definitions with the new ones.
190 my $sorted_foreign_keys = "(\n" . join("\n\n", @new_foreign_keys) . "\n)";
191 substr $foreign_key_definition, $list_start, $list_end - $list_start, $sorted_foreign_keys;
193 # Replace the whole setup call in the auto-generated output with
195 substr $definition, $start, $end - $start, $foreign_key_definition;
198 $definition =~ s/(meta->table.*)\n/$1\n$schema_str/m if $schema;
200 my $full_definition = <<CODE;
201 # This file has been auto-generated. Do not modify it; it will be overwritten
202 # by $::script automatically.
206 my $meta_definition = <<CODE;
207 # This file has been auto-generated only because it didn't exist.
208 # Feel free to modify it at will; it will not be overwritten automatically.
210 package SL::DB::${package};
214 use SL::DB::MetaSetup::${package};
215 use SL::DB::Manager::${package};
217 __PACKAGE__->meta->initialize;
222 my $file_exists = -f $meta_file;
224 my $old_size = -s $meta_file;
225 my $orig_file = do { local(@ARGV, $/) = ($meta_file); <> };
226 my $old_md5 = md5_hex($orig_file);
227 my $new_size = length $full_definition;
228 my $new_md5 = md5_hex($full_definition);
229 if ($old_size == $new_size && $old_md5 eq $new_md5) {
230 notice("No changes in $meta_file, skipping.") unless $config{quiet};
234 show_diff(\$orig_file, \$full_definition) if $config{show_diff};
237 if (!$config{nocommit}) {
238 open my $out, ">", $meta_file || die;
239 print $out $full_definition;
242 notice("File '$meta_file' " . ($file_exists ? 'updated' : 'created') . " for table '$table'");
246 if (!$config{nocommit}) {
247 open my $out, ">", $file || die;
248 print $out $meta_definition;
251 notice("File '$file' created as well.");
253 return if -f $mngr_file;
255 if (!$config{nocommit}) {
256 open my $out, ">", $mngr_file || die;
258 # This file has been auto-generated only because it didn't exist.
259 # Feel free to modify it at will; it will not be overwritten automatically.
261 package SL::DB::Manager::${package};
265 use SL::DB::Helper::Manager;
266 use base qw(SL::DB::Helper::Manager);
268 sub object_class { 'SL::DB::${package}' }
270 __PACKAGE__->make_manager_methods;
276 notice("File '$mngr_file' created as well.");
282 'client=s' => \ my $client,
285 'no-commit|dry-run' => \ my $nocommit,
286 help => sub { pod2usage(verbose => 99, sections => 'NAME|SYNOPSIS|OPTIONS') },
287 quiet => \ my $quiet,
291 $options->{client} = $client;
292 $options->{all} = $all;
293 $options->{db} = $db;
294 $options->{nocommit} = $nocommit;
295 $options->{quiet} = $quiet;
296 $options->{color} = -t STDOUT ? 1 : 0;
299 if (eval { require Text::Diff; 1 }) {
300 $options->{show_diff} = 1;
302 error('Could not load Text::Diff. Sorry, no diffs for you.');
308 my ($text_a, $text_b) = @_;
315 Text::Diff::diff($text_a, $text_b, { OUTPUT => sub {
316 for (split /\n/, $_[0]) {
317 if ($config{color}) {
318 print colored($_, $colors{substr($_, 0, 1)}), $/;
327 pod2usage(verbose => 99, sections => 'SYNOPSIS');
331 my %tables_by_domain;
333 my @domains = $config{db} ? (uc $config{db}) : sort keys %package_names;
335 foreach my $domain (@domains) {
336 my $db = SL::DB::create(undef, $domain);
337 $tables_by_domain{$domain} = [ grep { my $table = $_; none { $_ eq $table } @{ $blacklist{$domain} } } $db->list_tables ];
342 %tables_by_domain = partition_by {
343 my ($domain, $table) = split m{:};
344 $table ? uc($domain) : 'KIVITENDO';
347 foreach my $tables (values %tables_by_domain) {
348 s{.*:}{} for @{ $tables };
352 error("You specified neither --all nor any specific tables.");
356 return %tables_by_domain;
360 print STDERR colored(shift, 'red'), $/;
367 sub check_errors_in_package_names {
368 foreach my $domain (sort keys %package_names) {
369 my @both = grep { $package_names{$domain}->{$_} } @{ $blacklist{$domain} || [] };
372 print "Error: domain '$domain': The following table names are present in both the black list and the package name hash: ", join(' ', sort @both), "\n";
377 parse_args(\%config);
379 check_errors_in_package_names();
381 my %tables_by_domain = make_tables();
383 foreach my $domain (keys %tables_by_domain) {
384 my @tables = @{ $tables_by_domain{$domain} };
385 my @unknown_tables = grep { !$package_names{$domain}->{$_} } @tables;
386 if (@unknown_tables) {
387 error("The following tables do not have entries in \%SL::DB::Helper::Mappings::${domain}_package_names: " . join(' ', sort @unknown_tables));
391 process_table($domain, $_, $package_names{$domain}->{$_}) for @tables;
402 rose_auto_create_model - mana Rose::DB::Object classes for kivitendo
406 scripts/rose_auto_create_model.pl --client name-or-id [db1:]table1 [[db2:]table2 ...]
407 scripts/rose_auto_create_model.pl --client name-or-id [--all|-a]
410 scripts/rose_auto_create_model.pl --client name-or-id --all [--db db]
412 # updates only customer table, login taken from config
413 scripts/rose_auto_create_model.pl customer
415 # updates only parts table, package will be Part
416 scripts/rose_auto_create_model.pl parts=Part
418 # try to update parts, but don't do it. tell what would happen in detail
419 scripts/rose_auto_create_model.pl --no-commit parts
423 Rose::DB::Object comes with a nice function named auto initialization with code
424 generation. The documentation of Rose describes it like this:
426 I<[...] auto-initializing metadata at runtime by querying the database has many
427 caveats. An alternate approach is to query the database for metadata just once,
428 and then generate the equivalent Perl code which can be pasted directly into
429 the class definition in place of the call to auto_initialize.>
431 I<Like the auto-initialization process itself, perl code generation has a
432 convenient wrapper method as well as separate methods for the individual parts.
433 All of the perl code generation methods begin with "perl_", and they support
434 some rudimentary code formatting options to help the code conform to you
435 preferred style. Examples can be found with the documentation for each perl_*
438 I<This hybrid approach to metadata population strikes a good balance between
439 upfront effort and ongoing maintenance. Auto-generating the Perl code for the
440 initial class definition saves a lot of tedious typing. From that point on,
441 manually correcting and maintaining the definition is a small price to pay for
442 the decreased start-up cost, the ability to use the class in the absence of a
443 database connection, and the piece of mind that comes from knowing that your
444 class is stable, and won't change behind your back in response to an "action at
445 a distance" (i.e., a database schema update).>
447 Unfortunately this reads easier than it is, since classes need to go into the
448 right package and directory, certain stuff needs to be adjusted and table names
449 need to be translated into their class names. This script will wrap all that
450 behind a few simple options.
452 In the most basic version, just give it a login and a table name, and it will
453 load the schema information for this table and create the appropriate class
454 files, or update them if already present.
456 Each table has three associated files. A C<SL::DB::MetaSetup::*>
457 class, which is a perl version of the schema definition, a
458 C<SL::DB::*> class file and a C<SL::DB::Manager::*> manager class
459 file. The first one will be updated if the schema changes, the second
460 and third ones will only be created if it they do not exist.
462 =head1 DATABASE NAMES AND TABLES
464 If you want to generate the data for specific tables only then you
465 have to list them on the command line. The format is
466 C<db-name:table-name>. The part C<db-name:> is optional and defaults
467 to C<KIVITENDO:> – which means the tables in the default kivitendo
470 Valid database names are keys in the hash returned by
471 L<SL::DB::Helper::Mappings/get_package_names>.
477 =item C<--client, -c CLIENT>
479 Provide a client whose database settings are used. If not present the
480 client is loaded from the config key C<devel/client>. If that too is
481 not found, an error is thrown.
483 Note that C<CLIENT> can be either a database ID or a client's name.
487 Process all tables from the database. Only those that are blacklistes in
488 L<SL::DB::Helper::Mappings> are excluded.
492 In combination with C<--all> causes all tables in the specific
493 database to be processed, not in all databases.
495 =item C<--no-commit, -n>
499 Do not write back generated files. This will do everything as usual but not
500 actually modify any file.
504 Displays diff for selected file, if file is present and newer file is
505 different. Beware, does not imply C<--no-commit>.
513 Does not print extra information, such as skipped files that were not
514 changed and errors where the auto initialization failed.
524 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>,
525 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>