naming_set went into the readonly accessor group by accident, fixed
[dbsrgits/DBIx-Class-Schema-Loader.git] / lib / DBIx / Class / Schema / Loader / Base.pm
index 2d9cc7d..1a6d5a1 100644 (file)
@@ -18,14 +18,13 @@ 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 namespace::clean;
 
-our $VERSION = '0.07009';
+our $VERSION = '0.07010';
 
 __PACKAGE__->mk_group_ro_accessors('simple', qw/
                                 schema
@@ -52,6 +51,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 +88,11 @@ __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
 /);
 
 =head1 NAME
@@ -367,13 +369,13 @@ List of additional components to be loaded into all of your table
 classes.  A good example would be
 L<InflateColumn::DateTime|DBIx::Class::InflateColumn::DateTime>
 
-=head2 result_component_map
+=head2 result_components_map
 
-A hashref of moniker keys and component values.  Unlike C<components>, 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 C<components>, 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',
@@ -383,6 +385,26 @@ components for specified tables.  For example:
   
 You may use this in conjunction with C<components>.
 
+=head2 result_roles
+
+List of L<Moose> roles to be applied to all of your Result classes.
+
+=head2 result_roles_map
+
+A hashref of moniker keys and role values.  Unlike C<result_roles>, 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 C<components>.
+
 =head2 use_namespaces
 
 This is now the default, to go back to L<DBIx::Class::Schema/load_classes> pass
@@ -556,7 +578,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 +628,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')) {
@@ -654,6 +709,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} = {
@@ -711,8 +773,6 @@ Dynamic schema detected, will run in 0.04006 mode.
 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
 to disable this warning.
 
-Also consider setting 'use_namespaces => 1' if/when upgrading.
-
 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
 details.
 EOF
@@ -721,6 +781,10 @@ EOF
             $self->_upgrading_from('v4');
         }
 
+        if ((not defined $self->use_namespaces) && (not $self->naming_set)) {
+            $self->use_namespaces(1);
+        }
+
         $self->naming->{relationships} ||= 'v4';
         $self->naming->{monikers}      ||= 'v4';
 
@@ -825,14 +889,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 +910,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 +947,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 {
@@ -942,7 +1004,7 @@ sub _load_external {
         my $code = $self->_rewrite_old_classnames(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,
@@ -983,7 +1045,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 +1130,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 );
 
     };
@@ -1210,12 +1272,10 @@ 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);
@@ -1545,6 +1605,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,25 +1680,26 @@ 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->_use   ($table_class, @{$self->additional_classes});
     $self->_inject($table_class, @{$self->left_base_classes});
 
     my @components = @{ $self->components || [] };
-    foreach my $moniker (keys %{ $self->result_component_map || {} }) {
-        next unless $moniker eq $table_moniker;
-        push @components, @{ $self->result_component_map->{$moniker} };
-    }
+
+    push @components, @{ $self->result_components_map->{$table_moniker} }
+        if exists $self->result_components_map->{$table_moniker};
+
     $self->_dbic_stmt($table_class, 'load_components', @components) if @components;
 
     $self->_inject($table_class, @{$self->additional_base_classes});
+
+    my @roles = @{ $self->result_roles || [] };
+    push @roles, @{ $self->result_roles_map->{$table_moniker} }
+        if exists $self->result_roles_map->{$table_moniker};
+
+    $self->_with($table_class, @roles) if @roles;
 }
 
 sub _is_result_class_method {
@@ -1634,17 +1707,30 @@ sub _is_result_class_method {
 
     my $table_moniker = $table_name ? $self->_table2moniker($table_name) : '';
 
-    if (not $self->_result_class_methods) {
+    $self->_result_class_methods({})
+        if not defined $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 = map { /^\+/ ? substr($_,1) : "DBIx::Class::$_" } @{ $self->components || [] };
-        foreach my $moniker (keys %{ $self->result_component_map || {} }) {
-            next unless $moniker eq $table_moniker;
-            push @components, @{ $self->result_component_map->{$moniker} };
+
+        my @components = @{ $self->components || [] };
+
+        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) || [] };
         }
@@ -1653,12 +1739,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};
 }