X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FSchema%2FLoader%2FBase.pm;h=7a791fa19faff4f51ce9a8a5672f9ac5cfbc7522;hb=12b86f073e34672eacdf72ee462a74c6874e84a4;hp=83fa077c82532b4f67262612cd39f319188eec5a;hpb=5ad21d3c00753cc7c6b6e36f8f8af30aa7949261;p=dbsrgits%2FDBIx-Class-Schema-Loader.git diff --git a/lib/DBIx/Class/Schema/Loader/Base.pm b/lib/DBIx/Class/Schema/Loader/Base.pm index 83fa077..7a791fa 100644 --- a/lib/DBIx/Class/Schema/Loader/Base.pm +++ b/lib/DBIx/Class/Schema/Loader/Base.pm @@ -18,14 +18,14 @@ use Class::Unload; use Class::Inspector (); use Scalar::Util 'looks_like_number'; use File::Slurp 'slurp'; -use DBIx::Class::Schema::Loader::Utils qw/split_name dumper_squashed eval_without_redefine_warnings/; +use DBIx::Class::Schema::Loader::Utils qw/split_name dumper_squashed eval_package_without_redefine_warnings class_path/; use DBIx::Class::Schema::Loader::Optional::Dependencies (); use Try::Tiny; use DBIx::Class (); -use Class::Load 'load_class'; +use Encode qw/decode encode/; use namespace::clean; -our $VERSION = '0.07009'; +our $VERSION = '0.07010'; __PACKAGE__->mk_group_ro_accessors('simple', qw/ schema @@ -52,6 +52,7 @@ __PACKAGE__->mk_group_ro_accessors('simple', qw/ default_resultset_class schema_base_class result_base_class + result_roles use_moose overwrite_modifications @@ -88,9 +89,12 @@ __PACKAGE__->mk_group_accessors('simple', qw/ col_collision_map rel_collision_map real_dump_directory - result_component_map + result_components_map + result_roles_map datetime_undef_if_invalid _result_class_methods + naming_set + tables /); =head1 NAME @@ -367,13 +371,13 @@ List of additional components to be loaded into all of your table classes. A good example would be L -=head2 result_component_map +=head2 result_components_map -A hashref of moniker keys and component values. Unlike C, which loads the -given components into every table class, this option allows you to load certain -components for specified tables. For example: +A hashref of moniker keys and component values. Unlike L, which +loads the given components into every Result class, this option allows you to +load certain components for specified Result classes. For example: - result_component_map => { + result_components_map => { StationVisited => '+YourApp::Schema::Component::StationVisited', RouteChange => [ '+YourApp::Schema::Component::RouteChange', @@ -381,7 +385,27 @@ components for specified tables. For example: ], } -You may use this in conjunction with C. +You may use this in conjunction with L. + +=head2 result_roles + +List of L roles to be applied to all of your Result classes. + +=head2 result_roles_map + +A hashref of moniker keys and role values. Unlike L, which +applies the given roles to every Result class, this option allows you to apply +certain roles for specified Result classes. For example: + + result_roles_map => { + StationVisited => [ + 'YourApp::Role::Building', + 'YourApp::Role::Destination', + ], + RouteChange => 'YourApp::Role::TripEvent', + } + +You may use this in conjunction with L. =head2 use_namespaces @@ -556,7 +580,7 @@ my $CURRENT_V = 'v7'; my @CLASS_ARGS = qw( schema_base_class result_base_class additional_base_classes - left_base_classes additional_classes components + left_base_classes additional_classes components result_roles ); # ensure that a peice of object data is a valid arrayref, creating @@ -606,22 +630,55 @@ sub new { } } + $self->result_components_map($self->{result_component_map}) + if defined $self->{result_component_map}; + + $self->result_roles_map($self->{result_role_map}) + if defined $self->{result_role_map}; + + croak "the result_roles and result_roles_map options may only be used in conjunction with use_moose=1" + if ((not defined $self->use_moose) || (not $self->use_moose)) + && ((defined $self->result_roles) || (defined $self->result_roles_map)); + $self->_ensure_arrayref(qw/additional_classes additional_base_classes left_base_classes components + result_roles /); $self->_validate_class_args; - if ($self->result_component_map) { - my %rc_map = %{ $self->result_component_map }; + croak "result_components_map must be a hash" + if defined $self->result_components_map + && ref $self->result_components_map ne 'HASH'; + + if ($self->result_components_map) { + my %rc_map = %{ $self->result_components_map }; foreach my $moniker (keys %rc_map) { $rc_map{$moniker} = [ $rc_map{$moniker} ] unless ref $rc_map{$moniker}; } - $self->result_component_map(\%rc_map); + $self->result_components_map(\%rc_map); + } + else { + $self->result_components_map({}); + } + $self->_validate_result_components_map; + + croak "result_roles_map must be a hash" + if defined $self->result_roles_map + && ref $self->result_roles_map ne 'HASH'; + + if ($self->result_roles_map) { + my %rr_map = %{ $self->result_roles_map }; + foreach my $moniker (keys %rr_map) { + $rr_map{$moniker} = [ $rr_map{$moniker} ] unless ref $rr_map{$moniker}; + } + $self->result_roles_map(\%rr_map); + } else { + $self->result_roles_map({}); } - $self->_validate_result_component_map; + $self->_validate_result_roles_map; if ($self->use_moose) { if (not DBIx::Class::Schema::Loader::Optional::Dependencies->req_ok_for('use_moose')) { @@ -631,7 +688,8 @@ sub new { } $self->{monikers} = {}; - $self->{classes} = {}; + $self->{tables} = {}; + $self->{classes} = {}; $self->{_upgrading_classes} = {}; $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} ); @@ -654,6 +712,13 @@ sub new { $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION); $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION); + if (not defined $self->naming) { + $self->naming_set(0); + } + else { + $self->naming_set(1); + } + if ((not ref $self->naming) && defined $self->naming) { my $naming_ver = $self->naming; $self->{naming} = { @@ -703,7 +768,7 @@ sub _check_back_compat { # just in case, though no one is likely to dump a dynamic schema $self->schema_version_to_dump('0.04006'); - if (not %{ $self->naming }) { + if (not $self->naming_set) { warn < 1' if/when upgrading. - See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more details. EOF @@ -721,6 +784,10 @@ EOF $self->_upgrading_from('v4'); } + if ((not defined $self->use_namespaces) && ($self->naming_set)) { + $self->use_namespaces(1); + } + $self->naming->{relationships} ||= 'v4'; $self->naming->{monikers} ||= 'v4'; @@ -825,14 +892,19 @@ sub _validate_class_args { } } -sub _validate_result_component_map { +sub _validate_result_components_map { my $self = shift; - my $map = $self->result_component_map; - return unless $map && ref $map eq 'HASH'; + foreach my $classes (values %{ $self->result_components_map }) { + $self->_validate_classes('result_components_map', $classes); + } +} + +sub _validate_result_roles_map { + my $self = shift; - foreach my $classes (values %$map) { - $self->_validate_classes('result_component_map', [@$classes]); + foreach my $classes (values %{ $self->result_roles_map }) { + $self->_validate_classes('result_roles_map', $classes); } } @@ -841,7 +913,10 @@ sub _validate_classes { my $key = shift; my $classes = shift; - foreach my $c (@$classes) { + # make a copy to not destroy original + my @classes = @$classes; + + foreach my $c (@classes) { # components default to being under the DBIx::Class namespace unless they # are preceeded with a '+' if ( $key =~ m/component/ && $c !~ s/^\+// ) { @@ -875,20 +950,10 @@ sub _find_file_in_inc { return; } -sub _class_path { - my ($self, $class) = @_; - - my $class_path = $class; - $class_path =~ s{::}{/}g; - $class_path .= '.pm'; - - return $class_path; -} - sub _find_class_in_inc { my ($self, $class) = @_; - return $self->_find_file_in_inc($self->_class_path($class)); + return $self->_find_file_in_inc(class_path($class)); } sub _rewriting { @@ -939,10 +1004,10 @@ sub _load_external { warn qq/# Loaded external class definition for '$class'\n/ if $self->debug; - my $code = $self->_rewrite_old_classnames(scalar slurp $real_inc_path); + my $code = $self->_rewrite_old_classnames(decode 'UTF-8', scalar slurp $real_inc_path); if ($self->dynamic) { # load the class too - eval_without_redefine_warnings($code); + eval_package_without_redefine_warnings($class, $code); } $self->_ext_stmt($class, @@ -962,7 +1027,7 @@ sub _load_external { } if ($old_real_inc_path) { - my $code = slurp $old_real_inc_path; + my $code = decode 'UTF-8', scalar slurp $old_real_inc_path; $self->_ext_stmt($class, <<"EOF"); @@ -983,7 +1048,7 @@ been used by an older version of the Loader. * PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the new name of the Result. EOF - eval_without_redefine_warnings($code); + eval_package_without_redefine_warnings($class, $code); } chomp $code; @@ -1068,7 +1133,7 @@ sub _relbuilder { ->{ $self->naming->{relationships}}; my $relbuilder_class = 'DBIx::Class::Schema::Loader::RelBuilder'.$relbuilder_suff; - load_class $relbuilder_class; + $self->ensure_class_loaded($relbuilder_class); $relbuilder_class->new( $self ); }; @@ -1117,14 +1182,15 @@ sub _load_tables { $self->{quiet} = 1; local $self->{dump_directory} = $self->{temp_directory}; $self->_reload_classes(\@tables); - $self->_load_relationships($_) for @tables; - $self->_relbuilder->cleanup; + $self->_load_relationships(\@tables); $self->{quiet} = 0; # Remove that temp dir from INC so it doesn't get reloaded @INC = grep $_ ne $self->dump_directory, @INC; } + $self->_load_roles($_) for @tables; + $self->_load_external($_) for map { $self->classes->{$_} } @tables; @@ -1210,15 +1276,13 @@ sub _moose_metaclass { sub _reload_class { my ($self, $class) = @_; - my $class_path = $self->_class_path($class); - delete $INC{ $class_path }; + delete $INC{ +class_path($class) }; -# kill redefined warnings try { - eval_without_redefine_warnings ("require $class"); + eval_package_without_redefine_warnings ($class, "require $class"); } catch { - my $source = slurp $self->_get_dump_filename($class); + my $source = decode 'UTF-8', scalar slurp $self->_get_dump_filename($class); die "Failed to reload class $class: $_.\n\nCLASS SOURCE:\n\n$source"; }; } @@ -1333,6 +1397,10 @@ sub _dump_to_dir { else { $src_text .= qq|use base '$result_base_class';\n\n|; } + + $self->_base_class_pod($src_class, $result_base_class) + unless $result_base_class eq 'DBIx::Class::Core'; + $self->_write_classfile($src_class, $src_text); } @@ -1436,7 +1504,7 @@ sub _write_classfile { my $compare_to; if ($old_md5) { $compare_to = $text . $self->_sig_comment($old_ver, $old_ts); - if (Digest::MD5::md5_base64($compare_to) eq $old_md5) { + if (Digest::MD5::md5_base64(encode 'UTF-8', $compare_to) eq $old_md5) { return unless $self->_upgrading_from && $is_schema; } } @@ -1446,11 +1514,11 @@ sub _write_classfile { POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime) ); - open(my $fh, '>', $filename) + open(my $fh, '>:encoding(UTF-8)', $filename) or croak "Cannot open '$filename' for writing: $!"; # Write the top half and its MD5 sum - print $fh $text . Digest::MD5::md5_base64($text) . "\n"; + print $fh $text . Digest::MD5::md5_base64(encode 'UTF-8', $text) . "\n"; # Write out anything loaded via external partial class file in @INC print $fh qq|$_\n| @@ -1489,7 +1557,7 @@ sub _parse_generated_file { return unless -f $fn; - open(my $fh, '<', $fn) + open(my $fh, '<:encoding(UTF-8)', $fn) or croak "Cannot open '$fn' for reading: $!"; my $mark_re = @@ -1506,7 +1574,7 @@ sub _parse_generated_file { $gen .= $pre_md5; croak "Checksum mismatch in '$fn', the auto-generated part of the file has been modified outside of this loader. Aborting.\nIf you want to overwrite these modifications, set the 'overwrite_modifications' loader option.\n" - if !$self->overwrite_modifications && Digest::MD5::md5_base64($gen) ne $md5; + if !$self->overwrite_modifications && Digest::MD5::md5_base64(encode 'UTF-8', $gen) ne $md5; last; } @@ -1545,6 +1613,18 @@ sub _inject { $self->_raw_stmt($target, "use base qw/$blist/;"); } +sub _with { + my $self = shift; + my $target = shift; + + my $rlist = join(q{, }, map { qq{'$_'} } @_); + + return unless $rlist; + + warn "$target: with $rlist;" if $self->debug; + $self->_raw_stmt($target, "\nwith $rlist;"); +} + sub _result_namespace { my ($self, $schema_class, $ns) = @_; my @result_namespace; @@ -1608,47 +1688,68 @@ sub _make_src_class { unless $table_class eq $old_class; } -# this was a bad idea, should be ok now without it -# my $table_normalized = lc $table; -# $self->classes->{$table_normalized} = $table_class; -# $self->monikers->{$table_normalized} = $table_moniker; - - $self->classes->{$table} = $table_class; + $self->classes->{$table} = $table_class; $self->monikers->{$table} = $table_moniker; + $self->tables->{$table_moniker} = $table; + + $self->_pod_class_list($table_class, 'ADDITIONAL CLASSES USED', @{$self->additional_classes}); $self->_use ($table_class, @{$self->additional_classes}); + + $self->_pod_class_list($table_class, 'LEFT BASE CLASSES', @{$self->left_base_classes}); + $self->_inject($table_class, @{$self->left_base_classes}); my @components = @{ $self->components || [] }; - push @components, @{ $self->result_component_map->{$table_moniker} } - if exists $self->result_component_map->{$table_moniker}; + push @components, @{ $self->result_components_map->{$table_moniker} } + if exists $self->result_components_map->{$table_moniker}; + + my @fq_components = @components; + foreach my $component (@fq_components) { + if ($component !~ s/^\+//) { + $component = "DBIx::Class::$component"; + } + } + + $self->_pod_class_list($table_class, 'COMPONENTS LOADED', @fq_components); $self->_dbic_stmt($table_class, 'load_components', @components) if @components; + $self->_pod_class_list($table_class, 'ADDITIONAL BASE CLASSES', @{$self->additional_base_classes}); + $self->_inject($table_class, @{$self->additional_base_classes}); } sub _is_result_class_method { my ($self, $name, $table_name) = @_; - my $table_moniker = $table_name ? $self->_table2moniker($table_name) : ''; + my $table_moniker = $table_name ? $self->monikers->{$table_name} : ''; + + $self->_result_class_methods({}) + if not defined $self->_result_class_methods; - if (not $self->_result_class_methods) { + if (not exists $self->_result_class_methods->{$table_moniker}) { my (@methods, %methods); my $base = $self->result_base_class || 'DBIx::Class::Core'; my @components = @{ $self->components || [] }; - push @components, @{ $self->result_component_map->{$table_moniker} } - if exists $self->result_component_map->{$table_moniker}; + push @components, @{ $self->result_components_map->{$table_moniker} } + if exists $self->result_components_map->{$table_moniker}; for my $c (@components) { $c = $c =~ /^\+/ ? substr($c,1) : "DBIx::Class::$c"; } - for my $class ($base, @components, $self->use_moose ? 'Moose::Object' : ()) { - load_class $class; + my @roles = @{ $self->result_roles || [] }; + + push @roles, @{ $self->result_roles_map->{$table_moniker} } + if exists $self->result_roles_map->{$table_moniker}; + + for my $class ($base, @components, + ($self->use_moose ? 'Moose::Object' : ()), @roles) { + $self->ensure_class_loaded($class); push @methods, @{ Class::Inspector->methods($class) || [] }; } @@ -1657,12 +1758,9 @@ sub _is_result_class_method { @methods{@methods} = (); - # futureproof meta - $methods{meta} = undef; - - $self->_result_class_methods(\%methods); + $self->_result_class_methods->{$table_moniker} = \%methods; } - my $result_methods = $self->_result_class_methods; + my $result_methods = $self->_result_class_methods->{$table_moniker}; return exists $result_methods->{$name}; } @@ -1747,6 +1845,18 @@ sub _make_column_accessor_name { return $accessor; } +sub _quote { + my ($self, $identifier) = @_; + + my $qt = $self->schema->storage->sql_maker->quote_char; + + if (ref $qt) { + return $qt->[0] . $identifier . $qt->[1]; + } + + return "${qt}${identifier}${qt}"; +} + # Set up metadata (cols, pks, etc) sub _setup_src_meta { my ($self, $table) = @_; @@ -1754,20 +1864,24 @@ sub _setup_src_meta { my $schema = $self->schema; my $schema_class = $self->schema_class; - my $table_class = $self->classes->{$table}; + my $table_class = $self->classes->{$table}; my $table_moniker = $self->monikers->{$table}; my $table_name = $table; - my $name_sep = $self->schema->storage->sql_maker->name_sep; + + my $sql_maker = $self->schema->storage->sql_maker; + my $name_sep = $sql_maker->name_sep; if ($name_sep && $table_name =~ /\Q$name_sep\E/) { - $table_name = \ $self->_quote_table_name($table_name); + $table_name = \ $self->_quote($table_name); } - my $full_table_name = ($self->qualify_objects ? ($self->db_schema . '.') : '') . (ref $table_name ? $$table_name : $table_name); + my $full_table_name = ($self->qualify_objects ? + ($self->_quote($self->db_schema) . '.') : '') + . (ref $table_name ? $$table_name : $table_name); # be careful to not create refs Data::Dump can "optimize" - $full_table_name = \do {"".$full_table_name} if ref $table_name; + $full_table_name = \do {"".$full_table_name} if ref $table_name; $self->_dbic_stmt($table_class, 'table', $full_table_name); @@ -1790,7 +1904,7 @@ sub _setup_src_meta { $info->{accessor} = $self->_make_column_accessor_name( $col, $context ); } - $self->_resolve_col_accessor_collisions($full_table_name, $col_info); + $self->_resolve_col_accessor_collisions($table, $col_info); # prune any redundant accessor names while (my ($col, $info) = each %$col_info) { @@ -1899,17 +2013,24 @@ sub _table2moniker { } sub _load_relationships { - my ($self, $table) = @_; + my ($self, $tables) = @_; + + my @tables; + + foreach my $table (@$tables) { + my $tbl_fk_info = $self->_table_fk_info($table); + foreach my $fkdef (@$tbl_fk_info) { + $fkdef->{remote_source} = + $self->monikers->{delete $fkdef->{remote_table}}; + } + my $tbl_uniq_info = $self->_table_uniq_info($table); - my $tbl_fk_info = $self->_table_fk_info($table); - foreach my $fkdef (@$tbl_fk_info) { - $fkdef->{remote_source} = - $self->monikers->{delete $fkdef->{remote_table}}; + my $local_moniker = $self->monikers->{$table}; + + push @tables, [ $local_moniker, $tbl_fk_info, $tbl_uniq_info ]; } - my $tbl_uniq_info = $self->_table_uniq_info($table); - my $local_moniker = $self->monikers->{$table}; - my $rel_stmts = $self->_relbuilder->generate_code($local_moniker, $tbl_fk_info, $tbl_uniq_info); + my $rel_stmts = $self->_relbuilder->generate_code(\@tables); foreach my $src_class (sort keys %$rel_stmts) { my $src_stmts = $rel_stmts->{$src_class}; @@ -1919,6 +2040,23 @@ sub _load_relationships { } } +sub _load_roles { + my ($self, $table) = @_; + + my $table_moniker = $self->monikers->{$table}; + my $table_class = $self->classes->{$table}; + + my @roles = @{ $self->result_roles || [] }; + push @roles, @{ $self->result_roles_map->{$table_moniker} } + if exists $self->result_roles_map->{$table_moniker}; + + if (@roles) { + $self->_pod_class_list($table_class, 'L ROLES APPLIED', @roles); + + $self->_with($table_class, @roles); + } +} + # Overload these in driver class: # Returns an arrayref of column names @@ -2016,6 +2154,31 @@ sub _make_pod { } } +sub _pod_class_list { + my ($self, $class, $title, @classes) = @_; + + return unless @classes && $self->generate_pod; + + $self->_pod($class, "=head1 $title"); + $self->_pod($class, '=over 4'); + + foreach my $link (@classes) { + $self->_pod($class, "=item * L<$link>"); + } + + $self->_pod($class, '=back'); + $self->_pod_cut($class); +} + +sub _base_class_pod { + my ($self, $class, $base_class) = @_; + + return unless $self->generate_pod; + + $self->_pod($class, "=head1 BASE CLASS: L<$base_class>"); + $self->_pod_cut($class); +} + sub _filter_comment { my ($self, $txt) = @_; @@ -2069,20 +2232,6 @@ sub _ext_stmt { push(@{$self->{_ext_storage}->{$class}}, $stmt); } -sub _quote_table_name { - my ($self, $table) = @_; - - my $qt = $self->schema->storage->sql_maker->quote_char; - - return $table unless $qt; - - if (ref $qt) { - return $qt->[0] . $table . $qt->[1]; - } - - return $qt . $table . $qt; -} - sub _custom_column_info { my ( $self, $table_name, $column_name, $column_info ) = @_;