this stuff does not work yet
[dbsrgits/DBIx-Class-Schema-Loader.git] / lib / DBIx / Class / Schema / Loader / Base.pm
CommitLineData
996be9ee 1package DBIx::Class::Schema::Loader::Base;
2
3use strict;
4use warnings;
6ae3f335 5use base qw/Class::Accessor::Fast Class::C3::Componentised/;
996be9ee 6use Class::C3;
fa994d3c 7use Carp::Clan qw/^DBIx::Class/;
996be9ee 8use DBIx::Class::Schema::Loader::RelBuilder;
9use Data::Dump qw/ dump /;
10use POSIX qw//;
dd03ee1a 11use File::Spec qw//;
419a2eeb 12use Cwd qw//;
7cab3ab7 13use Digest::MD5 qw//;
22270947 14use Lingua::EN::Inflect::Number qw//;
af31090c 15use File::Temp qw//;
16use Class::Unload;
996be9ee 17require DBIx::Class;
18
b1ad1a84 19our $VERSION = '0.04999_10';
32f784fc 20
996be9ee 21__PACKAGE__->mk_ro_accessors(qw/
22 schema
23 schema_class
24
25 exclude
26 constraint
27 additional_classes
28 additional_base_classes
29 left_base_classes
30 components
31 resultset_components
59cfa251 32 skip_relationships
996be9ee 33 moniker_map
34 inflect_singular
35 inflect_plural
9a95164d 36 naming
996be9ee 37 debug
38 dump_directory
d65cda9e 39 dump_overwrite
28b4691d 40 really_erase_my_files
f44ecc2f 41 use_namespaces
42 result_namespace
43 resultset_namespace
44 default_resultset_class
9c9c2f2b 45 schema_base_class
46 result_base_class
996be9ee 47
996be9ee 48 db_schema
49 _tables
50 classes
51 monikers
52 /);
53
54=head1 NAME
55
56DBIx::Class::Schema::Loader::Base - Base DBIx::Class::Schema::Loader Implementation.
57
58=head1 SYNOPSIS
59
60See L<DBIx::Class::Schema::Loader>
61
62=head1 DESCRIPTION
63
64This is the base class for the storage-specific C<DBIx::Class::Schema::*>
65classes, and implements the common functionality between them.
66
67=head1 CONSTRUCTOR OPTIONS
68
69These constructor options are the base options for
29ddb54c 70L<DBIx::Class::Schema::Loader/loader_options>. Available constructor options are:
3953cbee 71
59cfa251 72=head2 skip_relationships
996be9ee 73
59cfa251 74Skip setting up relationships. The default is to attempt the loading
75of relationships.
996be9ee 76
9a95164d 77=head2 naming
78
79Static schemas (ones dumped to disk) will, by default, use the new-style 0.05XXX
80relationship names and singularized Results, unless you're overwriting an
81existing dump made by a 0.04XXX version of L<DBIx::Class::Schema::Loader>, in
82which case the backward compatible RelBuilder will be activated, and
83singularization will be turned off.
84
85Specifying
86
87 naming => 'v5'
88
89will disable the backward-compatible RelBuilder and use
90the new-style relationship names along with singularized Results, even when
91overwriting a dump made with an earlier version.
92
93The option also takes a hashref:
94
95 naming => { relationships => 'v5', results => 'v4' }
96
97The values can be:
98
99=over 4
100
101=item current
102
103Latest default style, whatever that happens to be.
104
105=item v5
106
107Version 0.05XXX style.
108
109=item v4
110
111Version 0.04XXX style.
112
113=back
114
115Dynamic schemas will always default to the 0.04XXX relationship names and won't
116singularize Results for backward compatibility, to activate the new RelBuilder
117and singularization put this in your C<Schema.pm> file:
118
119 __PACKAGE__->naming('current');
120
121Or if you prefer to use 0.05XXX features but insure that nothing breaks in the
122next major version upgrade:
123
124 __PACKAGE__->naming('v5');
125
996be9ee 126=head2 debug
127
128If set to true, each constructive L<DBIx::Class> statement the loader
129decides to execute will be C<warn>-ed before execution.
130
d65cda9e 131=head2 db_schema
132
133Set the name of the schema to load (schema in the sense that your database
134vendor means it). Does not currently support loading more than one schema
135name.
136
996be9ee 137=head2 constraint
138
139Only load tables matching regex. Best specified as a qr// regex.
140
141=head2 exclude
142
143Exclude tables matching regex. Best specified as a qr// regex.
144
145=head2 moniker_map
146
8f9d7ce5 147Overrides the default table name to moniker translation. Can be either
148a hashref of table keys and moniker values, or a coderef for a translator
996be9ee 149function taking a single scalar table name argument and returning
150a scalar moniker. If the hash entry does not exist, or the function
151returns a false value, the code falls back to default behavior
152for that table name.
153
154The default behavior is: C<join '', map ucfirst, split /[\W_]+/, lc $table>,
155which is to say: lowercase everything, split up the table name into chunks
156anywhere a non-alpha-numeric character occurs, change the case of first letter
157of each chunk to upper case, and put the chunks back together. Examples:
158
159 Table Name | Moniker Name
160 ---------------------------
161 luser | Luser
162 luser_group | LuserGroup
163 luser-opts | LuserOpts
164
165=head2 inflect_plural
166
167Just like L</moniker_map> above (can be hash/code-ref, falls back to default
168if hash key does not exist or coderef returns false), but acts as a map
169for pluralizing relationship names. The default behavior is to utilize
170L<Lingua::EN::Inflect::Number/to_PL>.
171
172=head2 inflect_singular
173
174As L</inflect_plural> above, but for singularizing relationship names.
175Default behavior is to utilize L<Lingua::EN::Inflect::Number/to_S>.
176
9c9c2f2b 177=head2 schema_base_class
178
179Base class for your schema classes. Defaults to 'DBIx::Class::Schema'.
180
181=head2 result_base_class
182
183Base class for your table classes (aka result classes). Defaults to 'DBIx::Class'.
184
996be9ee 185=head2 additional_base_classes
186
187List of additional base classes all of your table classes will use.
188
189=head2 left_base_classes
190
191List of additional base classes all of your table classes will use
192that need to be leftmost.
193
194=head2 additional_classes
195
196List of additional classes which all of your table classes will use.
197
198=head2 components
199
200List of additional components to be loaded into all of your table
201classes. A good example would be C<ResultSetManager>.
202
203=head2 resultset_components
204
8f9d7ce5 205List of additional ResultSet components to be loaded into your table
996be9ee 206classes. A good example would be C<AlwaysRS>. Component
207C<ResultSetManager> will be automatically added to the above
208C<components> list if this option is set.
209
f44ecc2f 210=head2 use_namespaces
211
212Generate result class names suitable for
213L<DBIx::Class::Schema/load_namespaces> and call that instead of
214L<DBIx::Class::Schema/load_classes>. When using this option you can also
215specify any of the options for C<load_namespaces> (i.e. C<result_namespace>,
216C<resultset_namespace>, C<default_resultset_class>), and they will be added
217to the call (and the generated result class names adjusted appropriately).
218
996be9ee 219=head2 dump_directory
220
221This option is designed to be a tool to help you transition from this
222loader to a manually-defined schema when you decide it's time to do so.
223
224The value of this option is a perl libdir pathname. Within
225that directory this module will create a baseline manual
226L<DBIx::Class::Schema> module set, based on what it creates at runtime
227in memory.
228
229The created schema class will have the same classname as the one on
230which you are setting this option (and the ResultSource classes will be
7cab3ab7 231based on this name as well).
996be9ee 232
8f9d7ce5 233Normally you wouldn't hard-code this setting in your schema class, as it
996be9ee 234is meant for one-time manual usage.
235
236See L<DBIx::Class::Schema::Loader/dump_to_dir> for examples of the
237recommended way to access this functionality.
238
d65cda9e 239=head2 dump_overwrite
240
28b4691d 241Deprecated. See L</really_erase_my_files> below, which does *not* mean
242the same thing as the old C<dump_overwrite> setting from previous releases.
243
244=head2 really_erase_my_files
245
7cab3ab7 246Default false. If true, Loader will unconditionally delete any existing
247files before creating the new ones from scratch when dumping a schema to disk.
248
249The default behavior is instead to only replace the top portion of the
250file, up to and including the final stanza which contains
251C<# DO NOT MODIFY THIS OR ANYTHING ABOVE!>
252leaving any customizations you placed after that as they were.
253
28b4691d 254When C<really_erase_my_files> is not set, if the output file already exists,
7cab3ab7 255but the aforementioned final stanza is not found, or the checksum
256contained there does not match the generated contents, Loader will
257croak and not touch the file.
d65cda9e 258
28b4691d 259You should really be using version control on your schema classes (and all
260of the rest of your code for that matter). Don't blame me if a bug in this
261code wipes something out when it shouldn't have, you've been warned.
262
996be9ee 263=head1 METHODS
264
265None of these methods are intended for direct invocation by regular
266users of L<DBIx::Class::Schema::Loader>. Anything you can find here
267can also be found via standard L<DBIx::Class::Schema> methods somehow.
268
269=cut
270
271# ensure that a peice of object data is a valid arrayref, creating
272# an empty one or encapsulating whatever's there.
273sub _ensure_arrayref {
274 my $self = shift;
275
276 foreach (@_) {
277 $self->{$_} ||= [];
278 $self->{$_} = [ $self->{$_} ]
279 unless ref $self->{$_} eq 'ARRAY';
280 }
281}
282
283=head2 new
284
285Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
286by L<DBIx::Class::Schema::Loader>.
287
288=cut
289
290sub new {
291 my ( $class, %args ) = @_;
292
293 my $self = { %args };
294
295 bless $self => $class;
296
996be9ee 297 $self->_ensure_arrayref(qw/additional_classes
298 additional_base_classes
299 left_base_classes
300 components
301 resultset_components
302 /);
303
304 push(@{$self->{components}}, 'ResultSetManager')
305 if @{$self->{resultset_components}};
306
307 $self->{monikers} = {};
308 $self->{classes} = {};
309
996be9ee 310 $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
311 $self->{schema} ||= $self->{schema_class};
312
28b4691d 313 croak "dump_overwrite is deprecated. Please read the"
314 . " DBIx::Class::Schema::Loader::Base documentation"
315 if $self->{dump_overwrite};
316
af31090c 317 $self->{dynamic} = ! $self->{dump_directory};
79193756 318 $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
af31090c 319 TMPDIR => 1,
320 CLEANUP => 1,
321 );
322
79193756 323 $self->{dump_directory} ||= $self->{temp_directory};
324
7824616e 325 $self->_check_back_compat;
9c465d2c 326
7824616e 327 $self;
328}
af31090c 329
7824616e 330sub _check_back_compat {
331 my ($self) = @_;
e8ad6491 332
7824616e 333 my $filename = $self->_get_dump_filename($self->schema_class);
334 return unless -e $filename;
335
336 open(my $fh, '<', $filename)
337 or croak "Cannot open '$filename' for reading: $!";
338
339 while (<$fh>) {
340 if (/^# Created by DBIx::Class::Schema::Loader (v\d+)\.(\d+)/) {
341 my $ver = "${1}_${2}";
342 while (1) {
343 my $compat_class = "DBIx::Class::Schema::Loader::Compat::${ver}";
344 if ($self->load_optional_class($compat_class)) {
345 no strict 'refs';
346 my $class = ref $self || $self;
347 unshift @{"${class}::ISA"}, $compat_class;
348 last;
349 }
350 $ver =~ s/\d\z// or last;
351 }
352 last;
353 }
354 }
355 close $fh;
996be9ee 356}
357
419a2eeb 358sub _find_file_in_inc {
359 my ($self, $file) = @_;
360
361 foreach my $prefix (@INC) {
af31090c 362 my $fullpath = File::Spec->catfile($prefix, $file);
363 return $fullpath if -f $fullpath
364 and Cwd::abs_path($fullpath) ne
365 Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) || '';
419a2eeb 366 }
367
368 return;
369}
370
996be9ee 371sub _load_external {
f96ef30f 372 my ($self, $class) = @_;
373
374 my $class_path = $class;
375 $class_path =~ s{::}{/}g;
376 $class_path .= '.pm';
377
af31090c 378 my $real_inc_path = $self->_find_file_in_inc($class_path);
f96ef30f 379
af31090c 380 return if !$real_inc_path;
f96ef30f 381
382 # If we make it to here, we loaded an external definition
383 warn qq/# Loaded external class definition for '$class'\n/
384 if $self->debug;
385
f96ef30f 386 croak 'Failed to locate actual external module file for '
387 . "'$class'"
388 if !$real_inc_path;
389 open(my $fh, '<', $real_inc_path)
390 or croak "Failed to open '$real_inc_path' for reading: $!";
391 $self->_ext_stmt($class,
565ca24d 392 qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
393 .qq|# They are now part of the custom portion of this file\n|
394 .qq|# for you to hand-edit. If you do not either delete\n|
395 .qq|# this section or remove that file from \@INC, this section\n|
396 .qq|# will be repeated redundantly when you re-create this\n|
397 .qq|# file again via Loader!\n|
f96ef30f 398 );
399 while(<$fh>) {
400 chomp;
401 $self->_ext_stmt($class, $_);
996be9ee 402 }
f96ef30f 403 $self->_ext_stmt($class,
70b72fab 404 qq|# End of lines loaded from '$real_inc_path' |
f96ef30f 405 );
406 close($fh)
407 or croak "Failed to close $real_inc_path: $!";
996be9ee 408}
409
410=head2 load
411
412Does the actual schema-construction work.
413
414=cut
415
416sub load {
417 my $self = shift;
418
b97c2c1e 419 $self->_load_tables($self->_tables_list);
420}
421
422=head2 rescan
423
a60b5b8d 424Arguments: schema
425
b97c2c1e 426Rescan the database for newly added tables. Does
a60b5b8d 427not process drops or changes. Returns a list of
428the newly added table monikers.
429
430The schema argument should be the schema class
431or object to be affected. It should probably
432be derived from the original schema_class used
433during L</load>.
b97c2c1e 434
435=cut
436
437sub rescan {
a60b5b8d 438 my ($self, $schema) = @_;
439
440 $self->{schema} = $schema;
7824616e 441 $self->_relbuilder->{schema} = $schema;
b97c2c1e 442
443 my @created;
444 my @current = $self->_tables_list;
445 foreach my $table ($self->_tables_list) {
446 if(!exists $self->{_tables}->{$table}) {
447 push(@created, $table);
448 }
449 }
450
c39e3507 451 my $loaded = $self->_load_tables(@created);
a60b5b8d 452
c39e3507 453 return map { $self->monikers->{$_} } @$loaded;
b97c2c1e 454}
455
7824616e 456sub _relbuilder {
457 my ($self) = @_;
3fed44ca 458
459 return if $self->{skip_relationships};
460
7824616e 461 $self->{relbuilder} ||= DBIx::Class::Schema::Loader::RelBuilder->new(
462 $self->schema, $self->inflect_plural, $self->inflect_singular
463 );
464}
465
b97c2c1e 466sub _load_tables {
467 my ($self, @tables) = @_;
468
f96ef30f 469 # First, use _tables_list with constraint and exclude
470 # to get a list of tables to operate on
471
472 my $constraint = $self->constraint;
473 my $exclude = $self->exclude;
f96ef30f 474
b97c2c1e 475 @tables = grep { /$constraint/ } @tables if $constraint;
476 @tables = grep { ! /$exclude/ } @tables if $exclude;
f96ef30f 477
b97c2c1e 478 # Save the new tables to the tables list
a60b5b8d 479 foreach (@tables) {
480 $self->{_tables}->{$_} = 1;
481 }
f96ef30f 482
af31090c 483 $self->_make_src_class($_) for @tables;
f96ef30f 484 $self->_setup_src_meta($_) for @tables;
485
e8ad6491 486 if(!$self->skip_relationships) {
181cc907 487 # The relationship loader needs a working schema
af31090c 488 $self->{quiet} = 1;
79193756 489 local $self->{dump_directory} = $self->{temp_directory};
181cc907 490 $self->_reload_classes(@tables);
e8ad6491 491 $self->_load_relationships($_) for @tables;
af31090c 492 $self->{quiet} = 0;
79193756 493
494 # Remove that temp dir from INC so it doesn't get reloaded
495 @INC = grep { $_ ne $self->{dump_directory} } @INC;
e8ad6491 496 }
497
f96ef30f 498 $self->_load_external($_)
75451704 499 for map { $self->classes->{$_} } @tables;
f96ef30f 500
181cc907 501 $self->_reload_classes(@tables);
996be9ee 502
5223f24a 503 # Drop temporary cache
504 delete $self->{_cache};
505
c39e3507 506 return \@tables;
996be9ee 507}
508
af31090c 509sub _reload_classes {
181cc907 510 my ($self, @tables) = @_;
511
512 $self->_dump_to_dir(map { $self->classes->{$_} } @tables);
e9b8719e 513
514 unshift @INC, $self->dump_directory;
af31090c 515
706ef173 516 my @to_register;
517 my %have_source = map { $_ => $self->schema->source($_) }
518 $self->schema->sources;
519
181cc907 520 for my $table (@tables) {
521 my $moniker = $self->monikers->{$table};
522 my $class = $self->classes->{$table};
0ae6b65d 523
524 {
525 no warnings 'redefine';
526 local *Class::C3::reinitialize = sub {};
527 use warnings;
528
706ef173 529 Class::Unload->unload($class);
530 my ($source, $resultset_class);
531 if (
532 ($source = $have_source{$moniker})
533 && ($resultset_class = $source->resultset_class)
534 && ($resultset_class ne 'DBIx::Class::ResultSet')
535 ) {
536 my $has_file = Class::Inspector->loaded_filename($resultset_class);
537 Class::Unload->unload($resultset_class);
6ae3f335 538 $self->ensure_class_loaded($resultset_class) if $has_file;
0ae6b65d 539 }
6ae3f335 540 $self->ensure_class_loaded($class);
af31090c 541 }
706ef173 542 push @to_register, [$moniker, $class];
543 }
af31090c 544
706ef173 545 Class::C3->reinitialize;
546 for (@to_register) {
547 $self->schema->register_class(@$_);
af31090c 548 }
549}
550
996be9ee 551sub _get_dump_filename {
552 my ($self, $class) = (@_);
553
554 $class =~ s{::}{/}g;
555 return $self->dump_directory . q{/} . $class . q{.pm};
556}
557
558sub _ensure_dump_subdirs {
559 my ($self, $class) = (@_);
560
561 my @name_parts = split(/::/, $class);
dd03ee1a 562 pop @name_parts; # we don't care about the very last element,
563 # which is a filename
564
996be9ee 565 my $dir = $self->dump_directory;
7cab3ab7 566 while (1) {
567 if(!-d $dir) {
25328cc4 568 mkdir($dir) or croak "mkdir('$dir') failed: $!";
996be9ee 569 }
7cab3ab7 570 last if !@name_parts;
571 $dir = File::Spec->catdir($dir, shift @name_parts);
996be9ee 572 }
573}
574
575sub _dump_to_dir {
af31090c 576 my ($self, @classes) = @_;
996be9ee 577
fc2b71fd 578 my $schema_class = $self->schema_class;
9c9c2f2b 579 my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
996be9ee 580
e9b8719e 581 my $target_dir = $self->dump_directory;
af31090c 582 warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
583 unless $self->{dynamic} or $self->{quiet};
996be9ee 584
7cab3ab7 585 my $schema_text =
586 qq|package $schema_class;\n\n|
b4dcbcc5 587 . qq|# Created by DBIx::Class::Schema::Loader\n|
588 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
7cab3ab7 589 . qq|use strict;\nuse warnings;\n\n|
9c9c2f2b 590 . qq|use base '$schema_base_class';\n\n|;
f44ecc2f 591
f44ecc2f 592 if ($self->use_namespaces) {
593 $schema_text .= qq|__PACKAGE__->load_namespaces|;
594 my $namespace_options;
595 for my $attr (qw(result_namespace
596 resultset_namespace
597 default_resultset_class)) {
598 if ($self->$attr) {
599 $namespace_options .= qq| $attr => '| . $self->$attr . qq|',\n|
600 }
601 }
602 $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
603 $schema_text .= qq|;\n|;
604 }
605 else {
606 $schema_text .= qq|__PACKAGE__->load_classes;\n|;
f44ecc2f 607 }
996be9ee 608
7cab3ab7 609 $self->_write_classfile($schema_class, $schema_text);
996be9ee 610
9c9c2f2b 611 my $result_base_class = $self->result_base_class || 'DBIx::Class';
612
af31090c 613 foreach my $src_class (@classes) {
7cab3ab7 614 my $src_text =
615 qq|package $src_class;\n\n|
b4dcbcc5 616 . qq|# Created by DBIx::Class::Schema::Loader\n|
617 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
7cab3ab7 618 . qq|use strict;\nuse warnings;\n\n|
9c9c2f2b 619 . qq|use base '$result_base_class';\n\n|;
996be9ee 620
7cab3ab7 621 $self->_write_classfile($src_class, $src_text);
02356864 622 }
996be9ee 623
af31090c 624 warn "Schema dump completed.\n" unless $self->{dynamic} or $self->{quiet};
625
7cab3ab7 626}
627
79193756 628sub _sig_comment {
629 my ($self, $version, $ts) = @_;
630 return qq|\n\n# Created by DBIx::Class::Schema::Loader|
631 . qq| v| . $version
632 . q| @ | . $ts
633 . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
634}
635
7cab3ab7 636sub _write_classfile {
637 my ($self, $class, $text) = @_;
638
639 my $filename = $self->_get_dump_filename($class);
640 $self->_ensure_dump_subdirs($class);
641
28b4691d 642 if (-f $filename && $self->really_erase_my_files) {
7cab3ab7 643 warn "Deleting existing file '$filename' due to "
af31090c 644 . "'really_erase_my_files' setting\n" unless $self->{quiet};
7cab3ab7 645 unlink($filename);
646 }
647
79193756 648 my ($custom_content, $old_md5, $old_ver, $old_ts) = $self->_get_custom_content($class, $filename);
17ca645f 649
7cab3ab7 650 $text .= qq|$_\n|
651 for @{$self->{_dump_storage}->{$class} || []};
652
79193756 653 # Check and see if the dump is infact differnt
654
655 my $compare_to;
656 if ($old_md5) {
657 $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
658
659
660 if (Digest::MD5::md5_base64($compare_to) eq $old_md5) {
661 return;
662 }
663 }
664
665 $text .= $self->_sig_comment(
666 $DBIx::Class::Schema::Loader::VERSION,
667 POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
668 );
7cab3ab7 669
670 open(my $fh, '>', $filename)
671 or croak "Cannot open '$filename' for writing: $!";
672
673 # Write the top half and its MD5 sum
a4476f41 674 print $fh $text . Digest::MD5::md5_base64($text) . "\n";
7cab3ab7 675
676 # Write out anything loaded via external partial class file in @INC
677 print $fh qq|$_\n|
678 for @{$self->{_ext_storage}->{$class} || []};
679
1eea4fb1 680 # Write out any custom content the user has added
7cab3ab7 681 print $fh $custom_content;
682
683 close($fh)
e9b8719e 684 or croak "Error closing '$filename': $!";
7cab3ab7 685}
686
79193756 687sub _default_custom_content {
688 return qq|\n\n# You can replace this text with custom|
689 . qq| content, and it will be preserved on regeneration|
690 . qq|\n1;\n|;
691}
692
7cab3ab7 693sub _get_custom_content {
694 my ($self, $class, $filename) = @_;
695
79193756 696 return ($self->_default_custom_content) if ! -f $filename;
697
7cab3ab7 698 open(my $fh, '<', $filename)
699 or croak "Cannot open '$filename' for reading: $!";
700
701 my $mark_re =
419a2eeb 702 qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
7cab3ab7 703
7cab3ab7 704 my $buffer = '';
79193756 705 my ($md5, $ts, $ver);
7cab3ab7 706 while(<$fh>) {
79193756 707 if(!$md5 && /$mark_re/) {
708 $md5 = $2;
709 my $line = $1;
710
711 # Pull out the previous version and timestamp
712 ($ver, $ts) = $buffer =~ m/# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)$/s;
713
714 $buffer .= $line;
7cab3ab7 715 croak "Checksum mismatch in '$filename'"
79193756 716 if Digest::MD5::md5_base64($buffer) ne $md5;
7cab3ab7 717
718 $buffer = '';
719 }
720 else {
721 $buffer .= $_;
722 }
996be9ee 723 }
724
28b4691d 725 croak "Cannot not overwrite '$filename' without 'really_erase_my_files',"
419a2eeb 726 . " it does not appear to have been generated by Loader"
79193756 727 if !$md5;
5ef3c771 728
79193756 729 # Default custom content:
730 $buffer ||= $self->_default_custom_content;
5ef3c771 731
79193756 732 return ($buffer, $md5, $ver, $ts);
996be9ee 733}
734
735sub _use {
736 my $self = shift;
737 my $target = shift;
738
739 foreach (@_) {
cb54990b 740 warn "$target: use $_;" if $self->debug;
996be9ee 741 $self->_raw_stmt($target, "use $_;");
996be9ee 742 }
743}
744
745sub _inject {
746 my $self = shift;
747 my $target = shift;
748 my $schema_class = $self->schema_class;
749
af31090c 750 my $blist = join(q{ }, @_);
751 warn "$target: use base qw/ $blist /;" if $self->debug && @_;
752 $self->_raw_stmt($target, "use base qw/ $blist /;") if @_;
996be9ee 753}
754
f96ef30f 755# Create class with applicable bases, setup monikers, etc
756sub _make_src_class {
757 my ($self, $table) = @_;
996be9ee 758
a13b2803 759 my $schema = $self->schema;
760 my $schema_class = $self->schema_class;
996be9ee 761
f96ef30f 762 my $table_moniker = $self->_table2moniker($table);
f44ecc2f 763 my @result_namespace = ($schema_class);
764 if ($self->use_namespaces) {
765 my $result_namespace = $self->result_namespace || 'Result';
766 if ($result_namespace =~ /^\+(.*)/) {
767 # Fully qualified namespace
768 @result_namespace = ($1)
769 }
770 else {
771 # Relative namespace
772 push @result_namespace, $result_namespace;
773 }
774 }
775 my $table_class = join(q{::}, @result_namespace, $table_moniker);
996be9ee 776
f96ef30f 777 my $table_normalized = lc $table;
778 $self->classes->{$table} = $table_class;
779 $self->classes->{$table_normalized} = $table_class;
780 $self->monikers->{$table} = $table_moniker;
781 $self->monikers->{$table_normalized} = $table_moniker;
996be9ee 782
f96ef30f 783 $self->_use ($table_class, @{$self->additional_classes});
af31090c 784 $self->_inject($table_class, @{$self->left_base_classes});
996be9ee 785
605fcea8 786 $self->_dbic_stmt($table_class, 'load_components', @{$self->components}, 'Core');
996be9ee 787
f96ef30f 788 $self->_dbic_stmt($table_class, 'load_resultset_components', @{$self->resultset_components})
789 if @{$self->resultset_components};
af31090c 790 $self->_inject($table_class, @{$self->additional_base_classes});
f96ef30f 791}
996be9ee 792
af31090c 793# Set up metadata (cols, pks, etc)
f96ef30f 794sub _setup_src_meta {
795 my ($self, $table) = @_;
996be9ee 796
f96ef30f 797 my $schema = $self->schema;
798 my $schema_class = $self->schema_class;
a13b2803 799
f96ef30f 800 my $table_class = $self->classes->{$table};
801 my $table_moniker = $self->monikers->{$table};
996be9ee 802
ff30991a 803 my $table_name = $table;
804 my $name_sep = $self->schema->storage->sql_maker->name_sep;
805
c177d483 806 if ($name_sep && $table_name =~ /\Q$name_sep\E/) {
ff30991a 807 $table_name = \ $self->_quote_table_name($table_name);
808 }
809
810 $self->_dbic_stmt($table_class,'table',$table_name);
996be9ee 811
f96ef30f 812 my $cols = $self->_table_columns($table);
813 my $col_info;
814 eval { $col_info = $self->_columns_info_for($table) };
815 if($@) {
816 $self->_dbic_stmt($table_class,'add_columns',@$cols);
817 }
818 else {
0906d55b 819 if ($self->_is_case_sensitive) {
820 for my $col (keys %$col_info) {
821 $col_info->{$col}{accessor} = lc $col
822 if $col ne lc($col);
823 }
824 } else {
825 $col_info = { map { lc($_), $col_info->{$_} } keys %$col_info };
c9373b79 826 }
827
e7213f4f 828 my $fks = $self->_table_fk_info($table);
565335e6 829
e7213f4f 830 for my $fkdef (@$fks) {
831 for my $col (@{ $fkdef->{local_columns} }) {
565335e6 832 $col_info->{$col}{is_foreign_key} = 1;
e7213f4f 833 }
834 }
f96ef30f 835 $self->_dbic_stmt(
836 $table_class,
837 'add_columns',
565335e6 838 map { $_, ($col_info->{$_}||{}) } @$cols
f96ef30f 839 );
996be9ee 840 }
841
d70c335f 842 my %uniq_tag; # used to eliminate duplicate uniqs
843
f96ef30f 844 my $pks = $self->_table_pk_info($table) || [];
845 @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks)
846 : carp("$table has no primary key");
d70c335f 847 $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
996be9ee 848
f96ef30f 849 my $uniqs = $self->_table_uniq_info($table) || [];
d70c335f 850 for (@$uniqs) {
851 my ($name, $cols) = @$_;
852 next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
853 $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
854 }
855
996be9ee 856}
857
858=head2 tables
859
860Returns a sorted list of loaded tables, using the original database table
861names.
862
863=cut
864
865sub tables {
866 my $self = shift;
867
b97c2c1e 868 return keys %{$self->_tables};
996be9ee 869}
870
871# Make a moniker from a table
c39e403e 872sub _default_table2moniker {
873 my ($self, $table) = @_;
874
875 return join '', map ucfirst, split /[\W_]+/,
876 Lingua::EN::Inflect::Number::to_S(lc $table);
877}
878
996be9ee 879sub _table2moniker {
880 my ( $self, $table ) = @_;
881
882 my $moniker;
883
884 if( ref $self->moniker_map eq 'HASH' ) {
885 $moniker = $self->moniker_map->{$table};
886 }
887 elsif( ref $self->moniker_map eq 'CODE' ) {
888 $moniker = $self->moniker_map->($table);
889 }
890
c39e403e 891 $moniker ||= $self->_default_table2moniker($table);
996be9ee 892
893 return $moniker;
894}
895
896sub _load_relationships {
e8ad6491 897 my ($self, $table) = @_;
996be9ee 898
e8ad6491 899 my $tbl_fk_info = $self->_table_fk_info($table);
900 foreach my $fkdef (@$tbl_fk_info) {
901 $fkdef->{remote_source} =
902 $self->monikers->{delete $fkdef->{remote_table}};
996be9ee 903 }
26f1c8c9 904 my $tbl_uniq_info = $self->_table_uniq_info($table);
996be9ee 905
e8ad6491 906 my $local_moniker = $self->monikers->{$table};
7824616e 907 my $rel_stmts = $self->_relbuilder->generate_code($local_moniker, $tbl_fk_info, $tbl_uniq_info);
996be9ee 908
996be9ee 909 foreach my $src_class (sort keys %$rel_stmts) {
910 my $src_stmts = $rel_stmts->{$src_class};
911 foreach my $stmt (@$src_stmts) {
912 $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}});
913 }
914 }
915}
916
917# Overload these in driver class:
918
919# Returns an arrayref of column names
920sub _table_columns { croak "ABSTRACT METHOD" }
921
922# Returns arrayref of pk col names
923sub _table_pk_info { croak "ABSTRACT METHOD" }
924
925# Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
926sub _table_uniq_info { croak "ABSTRACT METHOD" }
927
928# Returns an arrayref of foreign key constraints, each
929# being a hashref with 3 keys:
930# local_columns (arrayref), remote_columns (arrayref), remote_table
931sub _table_fk_info { croak "ABSTRACT METHOD" }
932
933# Returns an array of lower case table names
934sub _tables_list { croak "ABSTRACT METHOD" }
935
936# Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
937sub _dbic_stmt {
938 my $self = shift;
939 my $class = shift;
940 my $method = shift;
941
996be9ee 942 my $args = dump(@_);
943 $args = '(' . $args . ')' if @_ < 2;
944 my $stmt = $method . $args . q{;};
945
946 warn qq|$class\->$stmt\n| if $self->debug;
996be9ee 947 $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
948}
949
950# Store a raw source line for a class (for dumping purposes)
951sub _raw_stmt {
952 my ($self, $class, $stmt) = @_;
af31090c 953 push(@{$self->{_dump_storage}->{$class}}, $stmt);
996be9ee 954}
955
7cab3ab7 956# Like above, but separately for the externally loaded stuff
957sub _ext_stmt {
958 my ($self, $class, $stmt) = @_;
af31090c 959 push(@{$self->{_ext_storage}->{$class}}, $stmt);
7cab3ab7 960}
961
565335e6 962sub _quote_table_name {
963 my ($self, $table) = @_;
964
965 my $qt = $self->schema->storage->sql_maker->quote_char;
966
c177d483 967 return $table unless $qt;
968
565335e6 969 if (ref $qt) {
970 return $qt->[0] . $table . $qt->[1];
971 }
972
973 return $qt . $table . $qt;
974}
975
976sub _is_case_sensitive { 0 }
977
996be9ee 978=head2 monikers
979
8f9d7ce5 980Returns a hashref of loaded table to moniker mappings. There will
996be9ee 981be two entries for each table, the original name and the "normalized"
982name, in the case that the two are different (such as databases
983that like uppercase table names, or preserve your original mixed-case
984definitions, or what-have-you).
985
986=head2 classes
987
8f9d7ce5 988Returns a hashref of table to class mappings. In some cases it will
996be9ee 989contain multiple entries per table for the original and normalized table
990names, as above in L</monikers>.
991
992=head1 SEE ALSO
993
994L<DBIx::Class::Schema::Loader>
995
996=cut
997
9981;