1 package DBIx::Class::Schema::Loader::Base;
5 use base qw/Class::Accessor::Fast/;
7 use Carp::Clan qw/^DBIx::Class/;
8 use UNIVERSAL::require;
9 use DBIx::Class::Schema::Loader::RelBuilder;
10 use Data::Dump qw/ dump /;
17 our $VERSION = '0.04005';
19 __PACKAGE__->mk_ro_accessors(qw/
26 additional_base_classes
41 default_resultset_class
53 DBIx::Class::Schema::Loader::Base - Base DBIx::Class::Schema::Loader Implementation.
57 See L<DBIx::Class::Schema::Loader>
61 This is the base class for the storage-specific C<DBIx::Class::Schema::*>
62 classes, and implements the common functionality between them.
64 =head1 CONSTRUCTOR OPTIONS
66 These constructor options are the base options for
67 L<DBIx::Class::Schema::Loader/loader_opts>. Available constructor options are:
69 =head2 skip_relationships
71 Skip setting up relationships. The default is to attempt the loading
76 If set to true, each constructive L<DBIx::Class> statement the loader
77 decides to execute will be C<warn>-ed before execution.
81 Set the name of the schema to load (schema in the sense that your database
82 vendor means it). Does not currently support loading more than one schema
87 Only load tables matching regex. Best specified as a qr// regex.
91 Exclude tables matching regex. Best specified as a qr// regex.
95 Overrides the default table name to moniker translation. Can be either
96 a hashref of table keys and moniker values, or a coderef for a translator
97 function taking a single scalar table name argument and returning
98 a scalar moniker. If the hash entry does not exist, or the function
99 returns a false value, the code falls back to default behavior
102 The default behavior is: C<join '', map ucfirst, split /[\W_]+/, lc $table>,
103 which is to say: lowercase everything, split up the table name into chunks
104 anywhere a non-alpha-numeric character occurs, change the case of first letter
105 of each chunk to upper case, and put the chunks back together. Examples:
107 Table Name | Moniker Name
108 ---------------------------
110 luser_group | LuserGroup
111 luser-opts | LuserOpts
113 =head2 inflect_plural
115 Just like L</moniker_map> above (can be hash/code-ref, falls back to default
116 if hash key does not exist or coderef returns false), but acts as a map
117 for pluralizing relationship names. The default behavior is to utilize
118 L<Lingua::EN::Inflect::Number/to_PL>.
120 =head2 inflect_singular
122 As L</inflect_plural> above, but for singularizing relationship names.
123 Default behavior is to utilize L<Lingua::EN::Inflect::Number/to_S>.
125 =head2 schema_base_class
127 Base class for your schema classes. Defaults to 'DBIx::Class::Schema'.
129 =head2 result_base_class
131 Base class for your table classes (aka result classes). Defaults to 'DBIx::Class'.
133 =head2 additional_base_classes
135 List of additional base classes all of your table classes will use.
137 =head2 left_base_classes
139 List of additional base classes all of your table classes will use
140 that need to be leftmost.
142 =head2 additional_classes
144 List of additional classes which all of your table classes will use.
148 List of additional components to be loaded into all of your table
149 classes. A good example would be C<ResultSetManager>.
151 =head2 resultset_components
153 List of additional ResultSet components to be loaded into your table
154 classes. A good example would be C<AlwaysRS>. Component
155 C<ResultSetManager> will be automatically added to the above
156 C<components> list if this option is set.
158 =head2 use_namespaces
160 Generate result class names suitable for
161 L<DBIx::Class::Schema/load_namespaces> and call that instead of
162 L<DBIx::Class::Schema/load_classes>. When using this option you can also
163 specify any of the options for C<load_namespaces> (i.e. C<result_namespace>,
164 C<resultset_namespace>, C<default_resultset_class>), and they will be added
165 to the call (and the generated result class names adjusted appropriately).
167 =head2 dump_directory
169 This option is designed to be a tool to help you transition from this
170 loader to a manually-defined schema when you decide it's time to do so.
172 The value of this option is a perl libdir pathname. Within
173 that directory this module will create a baseline manual
174 L<DBIx::Class::Schema> module set, based on what it creates at runtime
177 The created schema class will have the same classname as the one on
178 which you are setting this option (and the ResultSource classes will be
179 based on this name as well).
181 Normally you wouldn't hard-code this setting in your schema class, as it
182 is meant for one-time manual usage.
184 See L<DBIx::Class::Schema::Loader/dump_to_dir> for examples of the
185 recommended way to access this functionality.
187 =head2 dump_overwrite
189 Deprecated. See L</really_erase_my_files> below, which does *not* mean
190 the same thing as the old C<dump_overwrite> setting from previous releases.
192 =head2 really_erase_my_files
194 Default false. If true, Loader will unconditionally delete any existing
195 files before creating the new ones from scratch when dumping a schema to disk.
197 The default behavior is instead to only replace the top portion of the
198 file, up to and including the final stanza which contains
199 C<# DO NOT MODIFY THIS OR ANYTHING ABOVE!>
200 leaving any customizations you placed after that as they were.
202 When C<really_erase_my_files> is not set, if the output file already exists,
203 but the aforementioned final stanza is not found, or the checksum
204 contained there does not match the generated contents, Loader will
205 croak and not touch the file.
207 You should really be using version control on your schema classes (and all
208 of the rest of your code for that matter). Don't blame me if a bug in this
209 code wipes something out when it shouldn't have, you've been warned.
213 None of these methods are intended for direct invocation by regular
214 users of L<DBIx::Class::Schema::Loader>. Anything you can find here
215 can also be found via standard L<DBIx::Class::Schema> methods somehow.
219 # ensure that a peice of object data is a valid arrayref, creating
220 # an empty one or encapsulating whatever's there.
221 sub _ensure_arrayref {
226 $self->{$_} = [ $self->{$_} ]
227 unless ref $self->{$_} eq 'ARRAY';
233 Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
234 by L<DBIx::Class::Schema::Loader>.
239 my ( $class, %args ) = @_;
241 my $self = { %args };
243 bless $self => $class;
245 $self->_ensure_arrayref(qw/additional_classes
246 additional_base_classes
252 push(@{$self->{components}}, 'ResultSetManager')
253 if @{$self->{resultset_components}};
255 $self->{monikers} = {};
256 $self->{classes} = {};
258 $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
259 $self->{schema} ||= $self->{schema_class};
261 croak "dump_overwrite is deprecated. Please read the"
262 . " DBIx::Class::Schema::Loader::Base documentation"
263 if $self->{dump_overwrite};
265 $self->{relbuilder} = DBIx::Class::Schema::Loader::RelBuilder->new(
266 $self->schema_class, $self->inflect_plural, $self->inflect_singular
267 ) if !$self->{skip_relationships};
272 sub _find_file_in_inc {
273 my ($self, $file) = @_;
275 foreach my $prefix (@INC) {
276 my $fullpath = $prefix . '/' . $file;
277 return $fullpath if -f $fullpath;
284 my ($self, $class) = @_;
286 my $class_path = $class;
287 $class_path =~ s{::}{/}g;
288 $class_path .= '.pm';
290 my $inc_path = $self->_find_file_in_inc($class_path);
292 return if !$inc_path;
294 my $real_dump_path = $self->dump_directory
296 File::Spec->catfile($self->dump_directory, $class_path)
299 my $real_inc_path = Cwd::abs_path($inc_path);
300 return if $real_inc_path eq $real_dump_path;
302 # must use $UNIVERSAL::require::ERROR, $@ is not safe. See RT #44444 --kane
304 croak "Failed to load external class definition"
305 . " for '$class': $UNIVERSAL::require::ERROR";
307 # If we make it to here, we loaded an external definition
308 warn qq/# Loaded external class definition for '$class'\n/
311 # The rest is only relevant when dumping
312 return if !$self->dump_directory;
314 croak 'Failed to locate actual external module file for '
317 open(my $fh, '<', $real_inc_path)
318 or croak "Failed to open '$real_inc_path' for reading: $!";
319 $self->_ext_stmt($class,
320 qq|# These lines were loaded from '$real_inc_path' found in \@INC.|
321 .q|# They are now part of the custom portion of this file|
322 .q|# for you to hand-edit. If you do not either delete|
323 .q|# this section or remove that file from @INC, this section|
324 .q|# will be repeated redundantly when you re-create this|
325 .q|# file again via Loader!|
329 $self->_ext_stmt($class, $_);
331 $self->_ext_stmt($class,
332 qq|# End of lines loaded from '$real_inc_path' |
335 or croak "Failed to close $real_inc_path: $!";
340 Does the actual schema-construction work.
347 $self->_load_tables($self->_tables_list);
354 Rescan the database for newly added tables. Does
355 not process drops or changes. Returns a list of
356 the newly added table monikers.
358 The schema argument should be the schema class
359 or object to be affected. It should probably
360 be derived from the original schema_class used
366 my ($self, $schema) = @_;
368 $self->{schema} = $schema;
371 my @current = $self->_tables_list;
372 foreach my $table ($self->_tables_list) {
373 if(!exists $self->{_tables}->{$table}) {
374 push(@created, $table);
378 my $loaded = $self->_load_tables(@created);
380 return map { $self->monikers->{$_} } @$loaded;
384 my ($self, @tables) = @_;
386 # First, use _tables_list with constraint and exclude
387 # to get a list of tables to operate on
389 my $constraint = $self->constraint;
390 my $exclude = $self->exclude;
392 @tables = grep { /$constraint/ } @tables if $constraint;
393 @tables = grep { ! /$exclude/ } @tables if $exclude;
395 # Save the new tables to the tables list
397 $self->{_tables}->{$_} = 1;
400 # Set up classes/monikers
402 no warnings 'redefine';
403 local *Class::C3::reinitialize = sub { };
406 $self->_make_src_class($_) for @tables;
409 Class::C3::reinitialize;
411 $self->_setup_src_meta($_) for @tables;
413 if(!$self->skip_relationships) {
414 $self->_load_relationships($_) for @tables;
417 $self->_load_external($_)
418 for map { $self->classes->{$_} } @tables;
420 $self->_dump_to_dir if $self->dump_directory;
422 # Drop temporary cache
423 delete $self->{_cache};
428 sub _get_dump_filename {
429 my ($self, $class) = (@_);
432 return $self->dump_directory . q{/} . $class . q{.pm};
435 sub _ensure_dump_subdirs {
436 my ($self, $class) = (@_);
438 my @name_parts = split(/::/, $class);
439 pop @name_parts; # we don't care about the very last element,
440 # which is a filename
442 my $dir = $self->dump_directory;
445 mkdir($dir) or croak "mkdir('$dir') failed: $!";
447 last if !@name_parts;
448 $dir = File::Spec->catdir($dir, shift @name_parts);
455 my $target_dir = $self->dump_directory;
457 my $schema_class = $self->schema_class;
458 my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
460 croak "Must specify target directory for dumping!" if ! $target_dir;
462 warn "Dumping manual schema for $schema_class to directory $target_dir ...\n";
465 qq|package $schema_class;\n\n|
466 . qq|use strict;\nuse warnings;\n\n|
467 . qq|use base '$schema_base_class';\n\n|;
470 if ($self->use_namespaces) {
471 $schema_text .= qq|__PACKAGE__->load_namespaces|;
472 my $namespace_options;
473 for my $attr (qw(result_namespace
475 default_resultset_class)) {
477 $namespace_options .= qq| $attr => '| . $self->$attr . qq|',\n|
480 $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
481 $schema_text .= qq|;\n|;
484 $schema_text .= qq|__PACKAGE__->load_classes;\n|;
488 $self->_write_classfile($schema_class, $schema_text);
490 my $result_base_class = $self->result_base_class || 'DBIx::Class';
492 foreach my $src_class (sort keys %{$self->{_dump_storage}}) {
494 qq|package $src_class;\n\n|
495 . qq|use strict;\nuse warnings;\n\n|
496 . qq|use base '$result_base_class';\n\n|;
498 $self->_write_classfile($src_class, $src_text);
501 warn "Schema dump completed.\n";
504 sub _write_classfile {
505 my ($self, $class, $text) = @_;
507 my $filename = $self->_get_dump_filename($class);
508 $self->_ensure_dump_subdirs($class);
510 if (-f $filename && $self->really_erase_my_files) {
511 warn "Deleting existing file '$filename' due to "
512 . "'really_erase_my_files' setting\n";
516 my $custom_content = $self->_get_custom_content($class, $filename);
518 $custom_content ||= qq|\n\n# You can replace this text with custom|
519 . qq| content, and it will be preserved on regeneration|
523 for @{$self->{_dump_storage}->{$class} || []};
525 $text .= qq|\n\n# Created by DBIx::Class::Schema::Loader|
526 . qq| v| . $DBIx::Class::Schema::Loader::VERSION
527 . q| @ | . POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
528 . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
530 open(my $fh, '>', $filename)
531 or croak "Cannot open '$filename' for writing: $!";
533 # Write the top half and its MD5 sum
534 print $fh $text . Digest::MD5::md5_base64($text) . "\n";
536 # Write out anything loaded via external partial class file in @INC
538 for @{$self->{_ext_storage}->{$class} || []};
540 print $fh $custom_content;
543 or croak "Cannot close '$filename': $!";
546 sub _get_custom_content {
547 my ($self, $class, $filename) = @_;
549 return if ! -f $filename;
550 open(my $fh, '<', $filename)
551 or croak "Cannot open '$filename' for reading: $!";
554 qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
559 if(!$found && /$mark_re/) {
562 croak "Checksum mismatch in '$filename'"
563 if Digest::MD5::md5_base64($buffer) ne $2;
572 croak "Cannot not overwrite '$filename' without 'really_erase_my_files',"
573 . " it does not appear to have been generated by Loader"
585 warn "$target: use $_;" if $self->debug;
586 $self->_raw_stmt($target, "use $_;");
587 $_->require or croak ($_ . "->require: $UNIVERSAL::require::ERROR");
588 $evalstr .= "package $target; use $_;";
590 eval $evalstr if $evalstr;
597 my $schema_class = $self->schema_class;
599 my $blist = join(q{ }, @_);
600 warn "$target: use base qw/ $blist /;" if $self->debug && @_;
601 $self->_raw_stmt($target, "use base qw/ $blist /;") if @_;
603 $_->require or croak ($_ . "->require: $UNIVERSAL::require::ERROR");
604 $schema_class->inject_base($target, $_);
608 # Create class with applicable bases, setup monikers, etc
609 sub _make_src_class {
610 my ($self, $table) = @_;
612 my $schema = $self->schema;
613 my $schema_class = $self->schema_class;
615 my $table_moniker = $self->_table2moniker($table);
616 my @result_namespace = ($schema_class);
617 if ($self->use_namespaces) {
618 my $result_namespace = $self->result_namespace || 'Result';
619 if ($result_namespace =~ /^\+(.*)/) {
620 # Fully qualified namespace
621 @result_namespace = ($1)
625 push @result_namespace, $result_namespace;
628 my $table_class = join(q{::}, @result_namespace, $table_moniker);
630 my $table_normalized = lc $table;
631 $self->classes->{$table} = $table_class;
632 $self->classes->{$table_normalized} = $table_class;
633 $self->monikers->{$table} = $table_moniker;
634 $self->monikers->{$table_normalized} = $table_moniker;
636 { no strict 'refs'; @{"${table_class}::ISA"} = qw/DBIx::Class/ }
638 $self->_use ($table_class, @{$self->additional_classes});
639 $self->_inject($table_class, @{$self->additional_base_classes});
641 $self->_dbic_stmt($table_class, 'load_components', @{$self->components}, 'Core');
643 $self->_dbic_stmt($table_class, 'load_resultset_components', @{$self->resultset_components})
644 if @{$self->resultset_components};
645 $self->_inject($table_class, @{$self->left_base_classes});
648 # Set up metadata (cols, pks, etc) and register the class with the schema
649 sub _setup_src_meta {
650 my ($self, $table) = @_;
652 my $schema = $self->schema;
653 my $schema_class = $self->schema_class;
655 my $table_class = $self->classes->{$table};
656 my $table_moniker = $self->monikers->{$table};
658 $self->_dbic_stmt($table_class,'table',$table);
660 my $cols = $self->_table_columns($table);
662 eval { $col_info = $self->_columns_info_for($table) };
664 $self->_dbic_stmt($table_class,'add_columns',@$cols);
667 my %col_info_lc = map { lc($_), $col_info->{$_} } keys %$col_info;
671 map { $_, ($col_info_lc{$_}||{}) } @$cols
675 my $pks = $self->_table_pk_info($table) || [];
676 @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks)
677 : carp("$table has no primary key");
679 my $uniqs = $self->_table_uniq_info($table) || [];
680 $self->_dbic_stmt($table_class,'add_unique_constraint',@$_) for (@$uniqs);
682 $schema_class->register_class($table_moniker, $table_class);
683 $schema->register_class($table_moniker, $table_class) if $schema ne $schema_class;
688 Returns a sorted list of loaded tables, using the original database table
696 return keys %{$self->_tables};
699 # Make a moniker from a table
701 my ( $self, $table ) = @_;
705 if( ref $self->moniker_map eq 'HASH' ) {
706 $moniker = $self->moniker_map->{$table};
708 elsif( ref $self->moniker_map eq 'CODE' ) {
709 $moniker = $self->moniker_map->($table);
712 $moniker ||= join '', map ucfirst, split /[\W_]+/, lc $table;
717 sub _load_relationships {
718 my ($self, $table) = @_;
720 my $tbl_fk_info = $self->_table_fk_info($table);
721 foreach my $fkdef (@$tbl_fk_info) {
722 $fkdef->{remote_source} =
723 $self->monikers->{delete $fkdef->{remote_table}};
726 my $local_moniker = $self->monikers->{$table};
727 my $rel_stmts = $self->{relbuilder}->generate_code($local_moniker, $tbl_fk_info);
729 foreach my $src_class (sort keys %$rel_stmts) {
730 my $src_stmts = $rel_stmts->{$src_class};
731 foreach my $stmt (@$src_stmts) {
732 $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}});
737 # Overload these in driver class:
739 # Returns an arrayref of column names
740 sub _table_columns { croak "ABSTRACT METHOD" }
742 # Returns arrayref of pk col names
743 sub _table_pk_info { croak "ABSTRACT METHOD" }
745 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
746 sub _table_uniq_info { croak "ABSTRACT METHOD" }
748 # Returns an arrayref of foreign key constraints, each
749 # being a hashref with 3 keys:
750 # local_columns (arrayref), remote_columns (arrayref), remote_table
751 sub _table_fk_info { croak "ABSTRACT METHOD" }
753 # Returns an array of lower case table names
754 sub _tables_list { croak "ABSTRACT METHOD" }
756 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
762 if(!$self->debug && !$self->dump_directory) {
768 $args = '(' . $args . ')' if @_ < 2;
769 my $stmt = $method . $args . q{;};
771 warn qq|$class\->$stmt\n| if $self->debug;
773 $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
776 # Store a raw source line for a class (for dumping purposes)
778 my ($self, $class, $stmt) = @_;
779 push(@{$self->{_dump_storage}->{$class}}, $stmt) if $self->dump_directory;
782 # Like above, but separately for the externally loaded stuff
784 my ($self, $class, $stmt) = @_;
785 push(@{$self->{_ext_storage}->{$class}}, $stmt) if $self->dump_directory;
790 Returns a hashref of loaded table to moniker mappings. There will
791 be two entries for each table, the original name and the "normalized"
792 name, in the case that the two are different (such as databases
793 that like uppercase table names, or preserve your original mixed-case
794 definitions, or what-have-you).
798 Returns a hashref of table to class mappings. In some cases it will
799 contain multiple entries per table for the original and normalized table
800 names, as above in L</monikers>.
804 L<DBIx::Class::Schema::Loader>