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 $client = $config{client} || $::lx_office_conf{devel}{client};
66 error("No client found in config. Please provide a client:");
70 $::lxdebug = LXDebug->new();
71 $::locale = Locale->new("de");
73 $form->{script} = 'rose_meta_data.pl';
74 $::auth = SL::Auth->new();
76 if (!$::auth->set_client($client)) {
77 error("No client with ID or name '$client' found in config. Please provide a client:");
81 mkdir $meta_path unless -d $meta_path;
85 my @spec = split(/=/, shift, 2);
88 ($schema, $table) = split(m/\./, $table) if $table =~ m/\./;
89 my $package = ucfirst($spec[1] || $spec[0]);
90 $package =~ s/_+(.)/uc($1)/ge;
91 my $meta_file = "${meta_path}/${package}.pm";
92 my $file = "SL/DB/${package}.pm";
94 my $schema_str = $schema ? <<CODE : '';
95 __PACKAGE__->meta->schema('$schema');
99 package SL::DB::AUTO::$package;
101 use base qw(SL::DB::Object);
103 __PACKAGE__->meta->table('$table');
105 __PACKAGE__->meta->auto_initialize;
110 error("Error in execution for table '$table'");
111 error("'$EVAL_ERROR'") unless $config{quiet};
115 my %args = (indent => 2, use_setup => 0);
117 my $definition = "SL::DB::AUTO::$package"->meta->perl_class_definition(%args);
118 $definition =~ s/\n+__PACKAGE__->meta->initialize;\n+/\n\n/;
119 $definition =~ s/::AUTO::/::/g;
122 # Sort column definitions alphabetically
123 if ($definition =~ m/__PACKAGE__->meta->columns\( \n (.+?) \n \);/msx) {
124 my ($start, $end) = ($-[1], $+[1]);
125 my $sorted_columns = join "\n", sort split m/\n/, $1;
126 substr $definition, $start, $end - $start, $sorted_columns;
130 my $foreign_key_definition = "SL::DB::AUTO::$package"->meta->perl_foreign_keys_definition(%args);
131 $foreign_key_definition =~ s/::AUTO::/::/g;
133 if ($foreign_key_definition && ($definition =~ /\Q$foreign_key_definition\E/)) {
134 my ($start, $end) = ($-[0], $+[0]);
136 while (my ($auto_generated_name, $desired_name) = each %{ $foreign_key_name_map{$table} || {} }) {
137 $foreign_key_definition =~ s/^ \s \s ${auto_generated_name} \b/ ${desired_name}/msx;
140 # Sort foreign key definitions alphabetically
141 if ($foreign_key_definition =~ m/\(\n(.+)\n\)/s) {
142 my ($list_start, $list_end) = ($-[0], $+[0]);
143 my @foreign_keys = split m/\n\n/m, $1;
144 my $sorted_foreign_keys = "(\n" . join("\n\n", sort @foreign_keys) . "\n)";
146 substr $foreign_key_definition, $list_start, $list_end - $list_start, $sorted_foreign_keys;;
149 substr($definition, $start, $end - $start) = $foreign_key_definition;
152 $definition =~ s/(meta->table.*)\n/$1\n$schema_str/m if $schema;
154 my $full_definition = <<CODE;
155 # This file has been auto-generated. Do not modify it; it will be overwritten
156 # by $::script automatically.
160 my $meta_definition = <<CODE;
161 # This file has been auto-generated only because it didn't exist.
162 # Feel free to modify it at will; it will not be overwritten automatically.
164 package SL::DB::${package};
168 use SL::DB::MetaSetup::${package};
170 __PACKAGE__->meta->initialize;
172 # Creates get_all, get_all_count, get_all_iterator, delete_all and update_all.
173 __PACKAGE__->meta->make_manager_class;
178 my $file_exists = -f $meta_file;
180 my $old_size = -s $meta_file;
181 my $orig_file = do { local(@ARGV, $/) = ($meta_file); <> };
182 my $old_md5 = md5_hex($orig_file);
183 my $new_size = length $full_definition;
184 my $new_md5 = md5_hex($full_definition);
185 if ($old_size == $new_size && $old_md5 == $new_md5) {
186 notice("No changes in $meta_file, skipping.") unless $config{quiet};
190 show_diff(\$orig_file, \$full_definition) if $config{show_diff};
193 if (!$config{nocommit}) {
194 open my $out, ">", $meta_file || die;
195 print $out $full_definition;
198 notice("File '$meta_file' " . ($file_exists ? 'updated' : 'created') . " for table '$table'");
201 if (!$config{nocommit}) {
202 open my $out, ">", $file || die;
203 print $out $meta_definition;
206 notice("File '$file' created as well.");
213 'client=s' => \ my $client,
215 'no-commit|dry-run' => \ my $nocommit,
216 help => sub { pod2usage(verbose => 99, sections => 'NAME|SYNOPSIS|OPTIONS') },
217 quiet => \ my $quiet,
221 $options->{client} = $client;
222 $options->{all} = $all;
223 $options->{nocommit} = $nocommit;
224 $options->{quiet} = $quiet;
225 $options->{color} = -t STDOUT ? 1 : 0;
228 if (eval { require Text::Diff; 1 }) {
229 $options->{show_diff} = 1;
231 error('Could not load Text::Diff. Sorry, no diffs for you.');
237 my ($text_a, $text_b) = @_;
244 Text::Diff::diff($text_a, $text_b, { OUTPUT => sub {
245 for (split /\n/, $_[0]) {
246 if ($config{color}) {
247 print colored($_, $colors{substr($_, 0, 1)}), $/;
256 pod2usage(verbose => 99, sections => 'SYNOPSIS');
262 my $db = SL::DB::create(undef, 'KIVITENDO');
264 map { $package_names{KIVITENDO}->{$_} ? "$_=" . $package_names{KIVITENDO}->{$_} : $_ }
265 grep { my $table = $_; !any { $_ eq $table } @{ $blacklist{KIVITENDO} } }
270 error("You specified neither --all nor any specific tables.");
278 print STDERR colored(shift, 'red'), $/;
285 parse_args(\%config);
287 my @tables = make_tables();
289 for my $table (@tables) {
290 # add default model name unless model name is given or no defaults exists
291 $table .= '=' . $package_names{KIVITENDO}->{lc $table} if $table !~ /=/ && $package_names{KIVITENDO}->{lc $table};
293 process_table($table);
304 rose_auto_create_model - mana Rose::DB::Object classes for kivitendo
308 scripts/rose_create_model.pl --client name-or-id table1[=package1] [table2[=package2] ...]
309 scripts/rose_create_model.pl --client name-or-id [--all|-a]
312 scripts/rose_create_model.pl --client name-or-id --all
314 # updates only customer table, login taken from config
315 scripts/rose_create_model.pl customer
317 # updates only parts table, package will be Part
318 scripts/rose_create_model.pl parts=Part
320 # try to update parts, but don't do it. tell what would happen in detail
321 scripts/rose_create_model.pl --no-commit parts
325 Rose::DB::Object comes with a nice function named auto initialization with code
326 generation. The documentation of Rose describes it like this:
328 I<[...] auto-initializing metadata at runtime by querying the database has many
329 caveats. An alternate approach is to query the database for metadata just once,
330 and then generate the equivalent Perl code which can be pasted directly into
331 the class definition in place of the call to auto_initialize.>
333 I<Like the auto-initialization process itself, perl code generation has a
334 convenient wrapper method as well as separate methods for the individual parts.
335 All of the perl code generation methods begin with "perl_", and they support
336 some rudimentary code formatting options to help the code conform to you
337 preferred style. Examples can be found with the documentation for each perl_*
340 I<This hybrid approach to metadata population strikes a good balance between
341 upfront effort and ongoing maintenance. Auto-generating the Perl code for the
342 initial class definition saves a lot of tedious typing. From that point on,
343 manually correcting and maintaining the definition is a small price to pay for
344 the decreased start-up cost, the ability to use the class in the absence of a
345 database connection, and the piece of mind that comes from knowing that your
346 class is stable, and won't change behind your back in response to an "action at
347 a distance" (i.e., a database schema update).>
349 Unfortunately this reads easier than it is, since classes need to go into the
350 right package and directory, certain stuff needs to be adjusted and table names
351 need to be translated into their class names. This script will wrap all that
352 behind a few simple options.
354 In the most basic version, just give it a login and a table name, and it will
355 load the schema information for this table and create the appropriate class
356 files, or update them if already present.
358 Each table has two associated files. A C<SL::DB::MetaSetup::*> class, which is
359 a perl version of the schema definition, and a C<SL::DB::*> class file. The
360 first one will be updated if the schema changes, the second one will only be
361 created if it does not exist.
367 =item C<--client, -c CLIENT>
369 Provide a client whose database settings are used. If not present the
370 client is loaded from the config key C<devel/client>. If that too is
371 not found, an error is thrown.
373 Note that C<CLIENT> can be either a database ID or a client's name.
377 Process all tables from the database. Only those that are blacklistes in
378 L<SL::DB::Helper::Mappings> are excluded.
380 =item C<--no-commit, -n>
384 Do not write back generated files. This will do everything as usual but not
385 actually modify any file.
389 Displays diff for selected file, if file is present and newer file is
390 different. Beware, does not imply C<--no-commit>.
398 Does not print extra information, such as skipped files that were not
399 changed and errors where the auto initialization failed.
409 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>