X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2F_Util.pm;h=37d4ad77ddf397300fb0a0902d0a21d431802844;hb=2603b49536d45448ac98cd8aa7c7393867cb0db2;hp=f1a36199a214324d0594b329d2f7d00c9e1f210f;hpb=1c1795560d485d8c454e84b0a50f29957d113d66;p=dbsrgits%2FDBIx-Class.git

diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm
index f1a3619..37d4ad7 100644
--- a/lib/DBIx/Class/_Util.pm
+++ b/lib/DBIx/Class/_Util.pm
@@ -6,8 +6,6 @@ use DBIx::Class::StartupCheck;  # load es early as we can, usually a noop
 use warnings;
 use strict;
 
-use constant SPURIOUS_VERSION_CHECK_WARNINGS => ( "$]" < 5.010 ? 1 : 0);
-
 my $mro_recursor_stack;
 
 BEGIN {
@@ -17,15 +15,23 @@ BEGIN {
   use Config;
 
   use constant {
+    PERL_VERSION => "$]",
+    OS_NAME => "$^O",
+  };
+
+  use constant {
 
     # but of course
-    BROKEN_FORK => ($^O eq 'MSWin32') ? 1 : 0,
+    BROKEN_FORK => (OS_NAME eq 'MSWin32') ? 1 : 0,
+
+    BROKEN_GOTO => ( PERL_VERSION < 5.008003 ) ? 1 : 0,
 
-    BROKEN_GOTO => ( "$]" < 5.008003 ) ? 1 : 0,
+    # perl -MScalar::Util=weaken -e 'weaken( $hash{key} = \"value" )'
+    BROKEN_WEAK_SCALARREF_VALUES => ( PERL_VERSION < 5.008003 ) ? 1 : 0,
 
     HAS_ITHREADS => $Config{useithreads} ? 1 : 0,
 
-    UNSTABLE_DOLLARAT => ( "$]" < 5.013002 ) ? 1 : 0,
+    UNSTABLE_DOLLARAT => ( PERL_VERSION < 5.013002 ) ? 1 : 0,
 
     ( map
       #
@@ -44,11 +50,9 @@ BEGIN {
     ),
 
     IV_SIZE => $Config{ivsize},
-
-    OS_NAME => $^O,
   };
 
-  if ( "$]" < 5.009_005) {
+  if ( PERL_VERSION < 5.009_005) {
     require MRO::Compat;
     constant->import( OLD_MRO => 1 );
 
@@ -146,6 +150,8 @@ BEGIN {
   sub PEEPEENESS () { &$sigh }
 }
 
+use constant SPURIOUS_VERSION_CHECK_WARNINGS => ( DBIx::Class::_ENV_::PERL_VERSION < 5.010 ? 1 : 0);
+
 # FIXME - this is not supposed to be here
 # Carp::Skip to the rescue soon
 use DBIx::Class::Carp '^DBIx::Class|^DBICTest';
@@ -167,6 +173,7 @@ our @EXPORT_OK = qw(
   fail_on_internal_wantarray fail_on_internal_call
   refdesc refcount hrefaddr set_subname describe_class_methods
   scope_guard detected_reinvoked_destructor
+  true false
   is_exception dbic_internal_try visit_namespaces
   quote_sub qsub perlstring serialize deep_clone dump_value uniq
   parent_dir mkdir_p
@@ -175,15 +182,10 @@ our @EXPORT_OK = qw(
 
 use constant UNRESOLVABLE_CONDITION => \ '1 = 0';
 
-BEGIN {
-  # add preliminary attribute support
-  # FIXME FIXME FIXME
-  # To be revisited when Moo with proper attr support ships
-  Sub::Quote->VERSION(2.002);
-}
 # Override forcing no_defer, and adding naming consistency checks
+our %refs_closed_over_by_quote_sub_installed_crefs;
 sub quote_sub {
-  Carp::confess( "Anonymous quoting not supported by the DBIC sub_quote override - supply a sub name" ) if
+  Carp::confess( "Anonymous quoting not supported by the DBIC quote_sub override - supply a sub name" ) if
     @_ < 2
       or
     ! defined $_[1]
@@ -191,16 +193,27 @@ sub quote_sub {
     length ref $_[1]
   ;
 
-  Carp::confess( "The DBIC sub_quote override expects sub name '$_[0]' to be fully qualified" )
-    unless $_[0] =~ /::/;
+  Carp::confess( "The DBIC quote_sub override expects sub name '$_[0]' to be fully qualified" )
+    unless (my $stash) = $_[0] =~ /^(.+)::/;
+
+  Carp::confess(
+    "The DBIC sub_quote override does not support 'no_install'"
+  ) if (
+    $_[3]
+      and
+    $_[3]->{no_install}
+  );
 
-  Carp::confess( "The DBIC sub_quote override expects the sub name '$_[0]' to match the supplied 'package' argument" ) if
+  Carp::confess(
+    'The DBIC quote_sub override expects the namespace-part of sub name '
+  . "'$_[0]' to match the supplied package argument '$_[3]->{package}'"
+  ) if (
     $_[3]
       and
     defined $_[3]->{package}
       and
-    index( $_[0], $_[3]->{package} ) != 0
-  ;
+    $stash ne $_[3]->{package}
+  );
 
   my @caller = caller(0);
   my $sq_opts = {
@@ -214,28 +227,23 @@ sub quote_sub {
     no_defer => 1,
   };
 
-  my $cref = Sub::Quote::quote_sub( $_[0], $_[1], $_[2]||{}, $sq_opts );
-
-  # FIXME FIXME FIXME
-  # To be revisited when Moo with proper attr support ships
-  if(
-    # external application does not work on things like :prototype(...), :lvalue, etc
-    my @attrs = grep {
-      $_ !~ /^[a-z]/
+  weaken (
+    # just use a growing counter, no need to perform neither compaction
+    # nor any special ithread-level handling
+    $refs_closed_over_by_quote_sub_installed_crefs
+     { scalar keys %refs_closed_over_by_quote_sub_installed_crefs }
+      = $_
+  ) for grep {
+    length ref $_
+      and
+    (
+      ! DBIx::Class::_ENV_::BROKEN_WEAK_SCALARREF_VALUES
         or
-      Carp::confess( "The DBIC sub_quote override does not support applying of reserved attribute '$_'" )
-    } @{ $sq_opts->{attributes} || []}
-  ) {
-    Carp::confess( "The DBIC sub_quote override does not allow mixing 'attributes' with 'no_install'" )
-      if $sq_opts->{no_install};
-
-    # might be different from $sq_opts->{package};
-    my ($install_into) = $_[0] =~ /(.+)::[^:]+$/;
-
-    attributes->import( $install_into, $cref, @attrs );
-  }
+      ref $_ ne 'SCALAR'
+    )
+  } values %{ $_[2] || {} };
 
-  $cref;
+  Sub::Quote::quote_sub( $_[0], $_[1], $_[2]||{}, $sq_opts );
 }
 
 sub sigwarn_silencer ($) {
@@ -362,6 +370,20 @@ sub dump_value ($) {
   $dump_str;
 }
 
+###
+### This is *NOT* boolean.pm - deliberately not using a singleton
+###
+{
+  package # hide from pause
+    DBIx::Class::_Util::_Bool;
+  use overload
+    bool => sub { ${$_[0]} },
+    fallback => 1,
+  ;
+}
+sub true () { my $x = 1; bless \$x, "DBIx::Class::_Util::_Bool" }
+sub false () { my $x = 0; bless \$x, "DBIx::Class::_Util::_Bool" }
+
 sub scope_guard (&) {
   croak 'Calling scope_guard() in void context makes no sense'
     if ! defined wantarray;
@@ -653,11 +675,28 @@ sub modver_gt_or_eq_and_lt ($$$) {
   our $describe_class_query_cache;
 
   sub describe_class_methods {
-    my ($class) = @_;
+    my $args = (
+      ref $_[0] eq 'HASH'                 ? $_[0]
+    : ( @_ == 1 and ! length ref $_[0] )  ? { class => $_[0] }
+    :                                       { @_ }
+    );
+
+    my ($class, $requested_mro) = @{$args}{qw( class use_mro )};
 
-    croak "Expecting a class name"
+    croak "Expecting a class name either as the sole argument or a 'class' option"
       if not defined $class or $class !~ $module_name_rx;
 
+    $requested_mro ||= mro::get_mro($class);
+
+    # mro::set_mro() does not bump pkg_gen - WHAT THE FUCK?!
+    my $query_cache_key = "$class|$requested_mro";
+
+    my $stack_cache_key =
+      ( mro::get_mro($class) eq $requested_mro )
+        ? $class
+        : $query_cache_key
+    ;
+
     # use a cache on old MRO, since while we are recursing in this function
     # nothing can possibly change (the speedup is immense)
     # (yes, people could be tie()ing the stash and adding methods on access
@@ -674,9 +713,9 @@ sub modver_gt_or_eq_and_lt ($$$) {
     $my_gen += get_real_pkg_gen($_) for ( my @full_ISA = (
 
       @{
-        $mro_recursor_stack->{cache}{$class}{linear_isa}
+        $mro_recursor_stack->{cache}{$stack_cache_key}{linear_isa}
           ||=
-        mro::get_linear_isa($class)
+        mro::get_linear_isa($class, $requested_mro)
       },
 
       ((
@@ -691,42 +730,38 @@ sub modver_gt_or_eq_and_lt ($$$) {
 
     ));
 
-    my $slot = $describe_class_query_cache->{$class} ||= {};
+    my $slot = $describe_class_query_cache->{$query_cache_key} ||= {};
 
     unless ( ($slot->{cumulative_gen}||0) == $my_gen ) {
 
-      # remove ourselves from ISA
-      shift @full_ISA;
-
       # reset
       %$slot = (
         class => $class,
-        isa => [
-          @{ $mro_recursor_stack->{cache}{$class}{linear_isa} }
-            [ 1 .. $#{$mro_recursor_stack->{cache}{$class}{linear_isa}} ]
+        isa => { map { $_ => 1 } @full_ISA },
+        linear_isa => [
+          @{ $mro_recursor_stack->{cache}{$stack_cache_key}{linear_isa} }
+            [ 1 .. $#{$mro_recursor_stack->{cache}{$stack_cache_key}{linear_isa}} ]
         ],
         mro => {
-          type => mro::get_mro($class),
+          type => $requested_mro,
+          is_c3 => ( ($requested_mro eq 'c3') ? 1 : 0 ),
         },
         cumulative_gen => $my_gen,
       );
-      $slot->{mro}{is_c3} = ($slot->{mro}{type} eq 'c3') ? 1 : 0;
+
+      # remove ourselves from ISA
+      shift @full_ISA;
 
       # ensure the cache is populated for the parents, code below can then
       # efficiently operate over the query_cache directly
       describe_class_methods($_) for reverse @full_ISA;
 
-      my $current_node_refaddr;
       no strict 'refs';
 
       # combine full ISA-order inherited and local method list into a
       # "shadowing stack"
 
       (
-        $current_node_refaddr = refaddr($_)
-
-          and
-
         unshift @{ $slot->{methods}{$_->{name}} }, $_
 
           and
@@ -750,7 +785,7 @@ sub modver_gt_or_eq_and_lt ($$$) {
         # what describe_class_methods for @full_ISA produced above
         ( map { values %{
           $describe_class_query_cache->{$_}{methods_defined_in_class} || {}
-        } } reverse @full_ISA ),
+        } } map { "$_|" . mro::get_mro($_) } reverse @full_ISA ),
 
         # our own non-cleaned subs + their attributes
         ( map {