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 our %foreign_key_name_map = (
52 oe => { payment => 'payment_terms', },
53 ar => { payment => 'payment_terms', },
54 ap => { payment => 'payment_terms', },
56 orderitems => { parts => 'part', trans => 'order', },
57 delivery_order_items => { parts => 'part' },
58 invoice => { parts => 'part' },
59 follow_ups => { 'employee_obj' => 'created_for' },
61 periodic_invoices_configs => { oe => 'order' },
67 SL::LxOfficeConf->read;
69 my $client = $config{client} || $::lx_office_conf{devel}{client};
72 error("No client found in config. Please provide a client:");
76 $::lxdebug = LXDebug->new();
77 $::locale = Locale->new("de");
79 $form->{script} = 'rose_meta_data.pl';
80 $::auth = SL::Auth->new();
82 if (!$::auth->set_client($client)) {
83 error("No client with ID or name '$client' found in config. Please provide a client:");
87 foreach (($meta_path, $manager_path)) {
93 my ($domain, $table, $package) = @_;
95 ($schema, $table) = split(m/\./, $table) if $table =~ m/\./;
96 $package = ucfirst($package || $table);
97 $package =~ s/_+(.)/uc($1)/ge;
98 my $meta_file = "${meta_path}/${package}.pm";
99 my $mngr_file = "${manager_path}/${package}.pm";
100 my $file = "SL/DB/${package}.pm";
102 my $schema_str = $schema ? <<CODE : '';
103 __PACKAGE__->meta->schema('$schema');
107 package SL::DB::AUTO::$package;
109 use base qw(SL::DB::Object);
111 __PACKAGE__->meta->table('$table');
113 __PACKAGE__->meta->auto_initialize;
118 error("Error in execution for table '$table'");
119 error("'$EVAL_ERROR'") unless $config{quiet};
123 my %args = (indent => 2, use_setup => 0);
125 my $definition = "SL::DB::AUTO::$package"->meta->perl_class_definition(%args);
126 $definition =~ s/\n+__PACKAGE__->meta->initialize;\n+/\n\n/;
127 $definition =~ s/::AUTO::/::/g;
130 # Sort column definitions alphabetically
131 if ($definition =~ m/__PACKAGE__->meta->columns\( \n (.+?) \n \);/msx) {
132 my ($start, $end) = ($-[1], $+[1]);
133 my $sorted_columns = join "\n", sort split m/\n/, $1;
134 substr $definition, $start, $end - $start, $sorted_columns;
138 my $foreign_key_definition = "SL::DB::AUTO::$package"->meta->perl_foreign_keys_definition(%args);
139 $foreign_key_definition =~ s/::AUTO::/::/g;
141 if ($foreign_key_definition && ($definition =~ /\Q$foreign_key_definition\E/)) {
142 my ($start, $end) = ($-[0], $+[0]);
144 my %changes = map { %{$_} } grep { $_ } ($foreign_key_name_map{$domain}->{ALL}, $foreign_key_name_map{$domain}->{$table});
145 while (my ($auto_generated_name, $desired_name) = each %changes) {
146 $foreign_key_definition =~ s/^ \s \s ${auto_generated_name} \b/ ${desired_name}/msx;
149 # Sort foreign key definitions alphabetically
150 if ($foreign_key_definition =~ m/\(\n(.+)\n\)/s) {
151 my ($list_start, $list_end) = ($-[0], $+[0]);
152 my @foreign_keys = split m/\n\n/m, $1;
153 my $sorted_foreign_keys = "(\n" . join("\n\n", sort @foreign_keys) . "\n)";
155 substr $foreign_key_definition, $list_start, $list_end - $list_start, $sorted_foreign_keys;;
158 substr($definition, $start, $end - $start) = $foreign_key_definition;
161 $definition =~ s/(meta->table.*)\n/$1\n$schema_str/m if $schema;
163 my $full_definition = <<CODE;
164 # This file has been auto-generated. Do not modify it; it will be overwritten
165 # by $::script automatically.
169 my $meta_definition = <<CODE;
170 # This file has been auto-generated only because it didn't exist.
171 # Feel free to modify it at will; it will not be overwritten automatically.
173 package SL::DB::${package};
177 use SL::DB::MetaSetup::${package};
178 use SL::DB::Manager::${package};
180 __PACKAGE__->meta->initialize;
185 my $file_exists = -f $meta_file;
187 my $old_size = -s $meta_file;
188 my $orig_file = do { local(@ARGV, $/) = ($meta_file); <> };
189 my $old_md5 = md5_hex($orig_file);
190 my $new_size = length $full_definition;
191 my $new_md5 = md5_hex($full_definition);
192 if ($old_size == $new_size && $old_md5 eq $new_md5) {
193 notice("No changes in $meta_file, skipping.") unless $config{quiet};
197 show_diff(\$orig_file, \$full_definition) if $config{show_diff};
200 if (!$config{nocommit}) {
201 open my $out, ">", $meta_file || die;
202 print $out $full_definition;
205 notice("File '$meta_file' " . ($file_exists ? 'updated' : 'created') . " for table '$table'");
209 if (!$config{nocommit}) {
210 open my $out, ">", $file || die;
211 print $out $meta_definition;
214 notice("File '$file' created as well.");
216 return if -f $mngr_file;
218 if (!$config{nocommit}) {
219 open my $out, ">", $mngr_file || die;
221 # This file has been auto-generated only because it didn't exist.
222 # Feel free to modify it at will; it will not be overwritten automatically.
224 package SL::DB::Manager::${package};
228 use SL::DB::Helper::Manager;
229 use base qw(SL::DB::Helper::Manager);
231 sub object_class { 'SL::DB::${package}' }
233 __PACKAGE__->make_manager_methods;
239 notice("File '$mngr_file' created as well.");
245 'client=s' => \ my $client,
248 'no-commit|dry-run' => \ my $nocommit,
249 help => sub { pod2usage(verbose => 99, sections => 'NAME|SYNOPSIS|OPTIONS') },
250 quiet => \ my $quiet,
254 $options->{client} = $client;
255 $options->{all} = $all;
256 $options->{db} = $db;
257 $options->{nocommit} = $nocommit;
258 $options->{quiet} = $quiet;
259 $options->{color} = -t STDOUT ? 1 : 0;
262 if (eval { require Text::Diff; 1 }) {
263 $options->{show_diff} = 1;
265 error('Could not load Text::Diff. Sorry, no diffs for you.');
271 my ($text_a, $text_b) = @_;
278 Text::Diff::diff($text_a, $text_b, { OUTPUT => sub {
279 for (split /\n/, $_[0]) {
280 if ($config{color}) {
281 print colored($_, $colors{substr($_, 0, 1)}), $/;
290 pod2usage(verbose => 99, sections => 'SYNOPSIS');
294 my %tables_by_domain;
296 my @domains = $config{db} ? (uc $config{db}) : sort keys %package_names;
298 foreach my $domain (@domains) {
299 my $db = SL::DB::create(undef, $domain);
300 $tables_by_domain{$domain} = [ grep { my $table = $_; none { $_ eq $table } @{ $blacklist{$domain} } } $db->list_tables ];
305 %tables_by_domain = partition_by {
306 my ($domain, $table) = split m{:};
307 $table ? uc($domain) : 'KIVITENDO';
310 foreach my $tables (values %tables_by_domain) {
311 s{.*:}{} for @{ $tables };
315 error("You specified neither --all nor any specific tables.");
319 return %tables_by_domain;
323 print STDERR colored(shift, 'red'), $/;
330 sub check_errors_in_package_names {
331 foreach my $domain (sort keys %package_names) {
332 my @both = grep { $package_names{$domain}->{$_} } @{ $blacklist{$domain} || [] };
335 print "Error: domain '$domain': The following table names are present in both the black list and the package name hash: ", join(' ', sort @both), "\n";
340 parse_args(\%config);
342 check_errors_in_package_names();
344 my %tables_by_domain = make_tables();
346 foreach my $domain (keys %tables_by_domain) {
347 my @tables = @{ $tables_by_domain{$domain} };
348 my @unknown_tables = grep { !$package_names{$domain}->{$_} } @tables;
349 if (@unknown_tables) {
350 error("The following tables do not have entries in \%SL::DB::Helper::Mappings::${domain}_package_names: " . join(' ', sort @unknown_tables));
354 process_table($domain, $_, $package_names{$domain}->{$_}) for @tables;
365 rose_auto_create_model - mana Rose::DB::Object classes for kivitendo
369 scripts/rose_auto_create_model.pl --client name-or-id [db1:]table1 [[db2:]table2 ...]
370 scripts/rose_auto_create_model.pl --client name-or-id [--all|-a]
373 scripts/rose_auto_create_model.pl --client name-or-id --all [--db db]
375 # updates only customer table, login taken from config
376 scripts/rose_auto_create_model.pl customer
378 # updates only parts table, package will be Part
379 scripts/rose_auto_create_model.pl parts=Part
381 # try to update parts, but don't do it. tell what would happen in detail
382 scripts/rose_auto_create_model.pl --no-commit parts
386 Rose::DB::Object comes with a nice function named auto initialization with code
387 generation. The documentation of Rose describes it like this:
389 I<[...] auto-initializing metadata at runtime by querying the database has many
390 caveats. An alternate approach is to query the database for metadata just once,
391 and then generate the equivalent Perl code which can be pasted directly into
392 the class definition in place of the call to auto_initialize.>
394 I<Like the auto-initialization process itself, perl code generation has a
395 convenient wrapper method as well as separate methods for the individual parts.
396 All of the perl code generation methods begin with "perl_", and they support
397 some rudimentary code formatting options to help the code conform to you
398 preferred style. Examples can be found with the documentation for each perl_*
401 I<This hybrid approach to metadata population strikes a good balance between
402 upfront effort and ongoing maintenance. Auto-generating the Perl code for the
403 initial class definition saves a lot of tedious typing. From that point on,
404 manually correcting and maintaining the definition is a small price to pay for
405 the decreased start-up cost, the ability to use the class in the absence of a
406 database connection, and the piece of mind that comes from knowing that your
407 class is stable, and won't change behind your back in response to an "action at
408 a distance" (i.e., a database schema update).>
410 Unfortunately this reads easier than it is, since classes need to go into the
411 right package and directory, certain stuff needs to be adjusted and table names
412 need to be translated into their class names. This script will wrap all that
413 behind a few simple options.
415 In the most basic version, just give it a login and a table name, and it will
416 load the schema information for this table and create the appropriate class
417 files, or update them if already present.
419 Each table has three associated files. A C<SL::DB::MetaSetup::*>
420 class, which is a perl version of the schema definition, a
421 C<SL::DB::*> class file and a C<SL::DB::Manager::*> manager class
422 file. The first one will be updated if the schema changes, the second
423 and third ones will only be created if it they do not exist.
425 =head1 DATABASE NAMES AND TABLES
427 If you want to generate the data for specific tables only then you
428 have to list them on the command line. The format is
429 C<db-name:table-name>. The part C<db-name:> is optional and defaults
430 to C<KIVITENDO:> – which means the tables in the default kivitendo
433 Valid database names are keys in the hash returned by
434 L<SL::DB::Helper::Mappings/get_package_names>.
440 =item C<--client, -c CLIENT>
442 Provide a client whose database settings are used. If not present the
443 client is loaded from the config key C<devel/client>. If that too is
444 not found, an error is thrown.
446 Note that C<CLIENT> can be either a database ID or a client's name.
450 Process all tables from the database. Only those that are blacklistes in
451 L<SL::DB::Helper::Mappings> are excluded.
455 In combination with C<--all> causes all tables in the specific
456 database to be processed, not in all databases.
458 =item C<--no-commit, -n>
462 Do not write back generated files. This will do everything as usual but not
463 actually modify any file.
467 Displays diff for selected file, if file is present and newer file is
468 different. Beware, does not imply C<--no-commit>.
476 Does not print extra information, such as skipped files that were not
477 changed and errors where the auto initialization failed.
487 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>,
488 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>