From: Peter Rabbitson Date: Fri, 18 Jul 2014 16:26:57 +0000 (+0200) Subject: Replace many closure-based proxy methods with static qsubs X-Git-Tag: v0.082800~125 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits%2FDBIx-Class.git;a=commitdiff_plain;h=8d73fcd44e0441f0252744be32bada6816c5ff6b Replace many closure-based proxy methods with static qsubs Not only does this buy a quantum of performance, but it greatly enhances readability of these methods on deparse Deliberately not converting the ManyToMany helper - this code needs a thorough regut :( --- diff --git a/lib/DBIx/Class/CDBICompat/Constructor.pm b/lib/DBIx/Class/CDBICompat/Constructor.pm index f2e78b9..65ce576 100644 --- a/lib/DBIx/Class/CDBICompat/Constructor.pm +++ b/lib/DBIx/Class/CDBICompat/Constructor.pm @@ -1,14 +1,13 @@ package # hide from PAUSE DBIx::Class::CDBICompat::Constructor; -use base qw(DBIx::Class::CDBICompat::ImaDBI); - -use Sub::Name(); - use strict; use warnings; +use base 'DBIx::Class::CDBICompat::ImaDBI'; + use Carp; +use DBIx::Class::_Util qw(quote_sub perlstring); __PACKAGE__->set_sql(Retrieve => <<''); SELECT __ESSENTIAL__ @@ -17,17 +16,16 @@ WHERE %s sub add_constructor { my ($class, $method, $fragment) = @_; - return croak("constructors needs a name") unless $method; - no strict 'refs'; - my $meth = "$class\::$method"; - return carp("$method already exists in $class") - if *$meth{CODE}; + croak("constructors needs a name") unless $method; + + carp("$method already exists in $class") && return + if $class->can($method); - *$meth = Sub::Name::subname $meth => sub { - my $self = shift; - $self->sth_to_objects($self->sql_Retrieve($fragment), \@_); - }; + quote_sub "${class}::${method}" => sprintf( <<'EOC', perlstring $fragment ); + my $self = shift; + $self->sth_to_objects($self->sql_Retrieve(%s), \@_); +EOC } 1; diff --git a/lib/DBIx/Class/CDBICompat/ImaDBI.pm b/lib/DBIx/Class/CDBICompat/ImaDBI.pm index aaa19a0..10270b8 100644 --- a/lib/DBIx/Class/CDBICompat/ImaDBI.pm +++ b/lib/DBIx/Class/CDBICompat/ImaDBI.pm @@ -4,7 +4,7 @@ package # hide from PAUSE use strict; use warnings; use DBIx::ContextualFetch; -use Sub::Name (); +use DBIx::Class::_Util qw(quote_sub perlstring); use base qw(Class::Data::Inheritable); @@ -81,26 +81,20 @@ sub __driver { sub set_sql { my ($class, $name, $sql) = @_; - no strict 'refs'; - my $sql_name = "sql_${name}"; - my $full_sql_name = join '::', $class, $sql_name; - *$full_sql_name = Sub::Name::subname $full_sql_name, - sub { - my $sql = $sql; - my $class = shift; - return $class->storage->dbh_do( - _prepare_sth => $class->transform_sql($sql, @_) - ); - }; - if ($sql =~ /select/i) { - my $search_name = "search_${name}"; - my $full_search_name = join '::', $class, $search_name; - *$full_search_name = Sub::Name::subname $full_search_name, - sub { - my ($class, @args) = @_; - my $sth = $class->$sql_name; - return $class->sth_to_objects($sth, \@args); - }; + + quote_sub "${class}::sql_${name}", sprintf( <<'EOC', perlstring $sql ); + my $class = shift; + return $class->storage->dbh_do( + _prepare_sth => $class->transform_sql(%s, @_) + ); +EOC + + + if ($sql =~ /select/i) { # FIXME - this should be anchore surely...? + quote_sub "${class}::search_${name}", sprintf( <<'EOC', "sql_$name" ); + my ($class, @args) = @_; + $class->sth_to_objects( $class->%s, \@args); +EOC } } diff --git a/lib/DBIx/Class/CDBICompat/Relationship.pm b/lib/DBIx/Class/CDBICompat/Relationship.pm index b0c10fa..0614693 100644 --- a/lib/DBIx/Class/CDBICompat/Relationship.pm +++ b/lib/DBIx/Class/CDBICompat/Relationship.pm @@ -3,7 +3,8 @@ package use strict; use warnings; -use Sub::Name (); + +use DBIx::Class::_Util 'quote_sub'; =head1 NAME @@ -23,20 +24,13 @@ my %method2key = ( args => 'args', ); +quote_sub __PACKAGE__ . "::$_" => "\$_[0]->{$method2key{$_}}" + for keys %method2key; + sub new { my($class, $args) = @_; return bless $args, $class; } -for my $method (keys %method2key) { - my $key = $method2key{$method}; - my $code = sub { - $_[0]->{$key}; - }; - - no strict 'refs'; - *{$method} = Sub::Name::subname $method, $code; -} - 1; diff --git a/lib/DBIx/Class/CDBICompat/Relationships.pm b/lib/DBIx/Class/CDBICompat/Relationships.pm index 3ce3ef5..66fe973 100644 --- a/lib/DBIx/Class/CDBICompat/Relationships.pm +++ b/lib/DBIx/Class/CDBICompat/Relationships.pm @@ -3,11 +3,11 @@ package # hide from PAUSE use strict; use warnings; -use Sub::Name (); -use base qw/Class::Data::Inheritable/; +use base 'Class::Data::Inheritable'; use Clone; use DBIx::Class::CDBICompat::Relationship; +use DBIx::Class::_Util qw(quote_sub perlstring); __PACKAGE__->mk_classdata('__meta_info' => {}); @@ -119,19 +119,14 @@ sub has_many { ); if (@f_method) { - no strict 'refs'; - no warnings 'redefine'; - my $post_proc = sub { my $o = shift; $o = $o->$_ for @f_method; $o; }; - my $name = join '::', $class, $rel; - *$name = Sub::Name::subname $name, - sub { - my $rs = shift->search_related($rel => @_); - $rs->{attrs}{record_filter} = $post_proc; - return (wantarray ? $rs->all : $rs); - }; + quote_sub "${class}::${rel}", sprintf( <<'EOC', perlstring $rel), { '$rf' => \sub { my $o = shift; $o = $o->$_ for @f_method; $o } }; + my $rs = shift->search_related( %s => @_); + $rs->{attrs}{record_filter} = $rf; + return (wantarray ? $rs->all : $rs); +EOC + return 1; } - } diff --git a/lib/DBIx/Class/Relationship/Accessor.pm b/lib/DBIx/Class/Relationship/Accessor.pm index 568e71f..aeefa84 100644 --- a/lib/DBIx/Class/Relationship/Accessor.pm +++ b/lib/DBIx/Class/Relationship/Accessor.pm @@ -3,9 +3,8 @@ package # hide from PAUSE use strict; use warnings; -use Sub::Name; use DBIx::Class::Carp; -use DBIx::Class::_Util 'fail_on_internal_wantarray'; +use DBIx::Class::_Util qw(quote_sub perlstring); use namespace::clean; our %_pod_inherit_config = @@ -24,33 +23,32 @@ sub register_relationship { sub add_relationship_accessor { my ($class, $rel, $acc_type) = @_; - my %meth; if ($acc_type eq 'single') { - $meth{$rel} = sub { + quote_sub "${class}::${rel}" => sprintf(<<'EOC', perlstring $rel); my $self = shift; if (@_) { - $self->set_from_related($rel, @_); - return $self->{_relationship_data}{$rel} = $_[0]; + $self->set_from_related( %1$s => @_ ); + return $self->{_relationship_data}{%1$s} = $_[0]; } - elsif (exists $self->{_relationship_data}{$rel}) { - return $self->{_relationship_data}{$rel}; + elsif (exists $self->{_relationship_data}{%1$s}) { + return $self->{_relationship_data}{%1$s}; } else { - my $rel_info = $class->relationship_info($rel); + my $rel_info = $self->result_source->relationship_info(%1$s); my $cond = $self->result_source->_resolve_condition( - $rel_info->{cond}, $rel, $self, $rel + $rel_info->{cond}, %1$s, $self, %1$s ); if ($rel_info->{attrs}->{undef_on_null_fk}){ return undef unless ref($cond) eq 'HASH'; - return undef if grep { not defined $_ } values %$cond; + return undef if grep { not defined $_ } values %%$cond; } - my $val = $self->find_related($rel, {}, {}); + my $val = $self->find_related( %1$s => {} ); return $val unless $val; # $val instead of undef so that null-objects can go through - return $self->{_relationship_data}{$rel} = $val; + return $self->{_relationship_data}{%1$s} = $val; } - }; +EOC } elsif ($acc_type eq 'filter') { $class->throw_exception("No such column '$rel' to filter") @@ -89,25 +87,17 @@ sub add_relationship_accessor { } elsif ($acc_type eq 'multi') { - $meth{$rel} = sub { - DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = fail_on_internal_wantarray; - shift->search_related($rel, @_) - }; - $meth{"${rel}_rs"} = sub { shift->search_related_rs($rel, @_) }; - $meth{"add_to_${rel}"} = sub { shift->create_related($rel, @_); }; + quote_sub "${class}::${rel}_rs", "shift->search_related_rs( $rel => \@_ )"; + quote_sub "${class}::add_to_${rel}", "shift->create_related( $rel => \@_ )"; + quote_sub "${class}::${rel}", sprintf( <<'EOC', perlstring $rel ); + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = DBIx::Class::_Util::fail_on_internal_wantarray; + shift->search_related( %s => @_ ) +EOC } else { $class->throw_exception("No such relationship accessor type '$acc_type'"); } - { - no strict 'refs'; - no warnings 'redefine'; - foreach my $meth (keys %meth) { - my $name = join '::', $class, $meth; - *$name = subname($name, $meth{$meth}); - } - } } 1; diff --git a/lib/DBIx/Class/Relationship/ProxyMethods.pm b/lib/DBIx/Class/Relationship/ProxyMethods.pm index 6f204f6..0db5780 100644 --- a/lib/DBIx/Class/Relationship/ProxyMethods.pm +++ b/lib/DBIx/Class/Relationship/ProxyMethods.pm @@ -3,8 +3,9 @@ package # hide from PAUSE use strict; use warnings; -use Sub::Name (); -use base qw/DBIx::Class/; +use base 'DBIx::Class'; +use DBIx::Class::_Util 'quote_sub'; +use namespace::clean; our %_pod_inherit_config = ( @@ -22,21 +23,17 @@ sub register_relationship { sub proxy_to_related { my ($class, $rel, $proxy_args) = @_; my %proxy_map = $class->_build_proxy_map_from($proxy_args); - no strict 'refs'; - no warnings 'redefine'; - foreach my $meth_name ( keys %proxy_map ) { - my $proxy_to_col = $proxy_map{$meth_name}; - my $name = join '::', $class, $meth_name; - *$name = Sub::Name::subname $name => sub { - my $self = shift; - my $relobj = $self->$rel; - if (@_ && !defined $relobj) { - $relobj = $self->create_related($rel, { $proxy_to_col => $_[0] }); - @_ = (); - } - return ($relobj ? $relobj->$proxy_to_col(@_) : undef); - } - } + + quote_sub "${class}::$_", sprintf( <<'EOC', $rel, $proxy_map{$_} ) + my $self = shift; + my $relobj = $self->%1$s; + if (@_ && !defined $relobj) { + $relobj = $self->create_related( %1$s => { %2$s => $_[0] } ); + @_ = (); + } + $relobj ? $relobj->%2$s(@_) : undef; +EOC + for keys %proxy_map } sub _build_proxy_map_from { diff --git a/lib/DBIx/Class/ResultSourceProxy.pm b/lib/DBIx/Class/ResultSourceProxy.pm index c3bef15..db4337a 100644 --- a/lib/DBIx/Class/ResultSourceProxy.pm +++ b/lib/DBIx/Class/ResultSourceProxy.pm @@ -4,9 +4,10 @@ package # hide from PAUSE use strict; use warnings; -use base qw/DBIx::Class/; -use Scalar::Util qw/blessed/; -use Sub::Name qw/subname/; +use base 'DBIx::Class'; + +use Scalar::Util 'blessed'; +use DBIx::Class::_Util 'quote_sub'; use namespace::clean; __PACKAGE__->mk_group_accessors('inherited_ro_instance' => 'source_name'); @@ -80,10 +81,10 @@ for my $method_to_proxy (qw/ relationship_info has_relationship /) { - no strict qw/refs/; - *{__PACKAGE__."::$method_to_proxy"} = subname $method_to_proxy => sub { - shift->result_source_instance->$method_to_proxy (@_); - }; + quote_sub + __PACKAGE__."::$method_to_proxy" + => "shift->result_source_instance->$method_to_proxy (\@_);" + ; } 1; diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index 4c3cce5..c83dc87 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -8,8 +8,7 @@ use base 'DBIx::Class'; use DBIx::Class::Carp; use Try::Tiny; use Scalar::Util qw/weaken blessed/; -use DBIx::Class::_Util 'refcount'; -use Sub::Name 'subname'; +use DBIx::Class::_Util qw(refcount quote_sub); use Devel::GlobalDestruction; use namespace::clean; @@ -897,7 +896,6 @@ sub compose_namespace { local *Class::C3::reinitialize = sub { } if DBIx::Class::_ENV_::OLD_MRO; use warnings qw/redefine/; - no strict qw/refs/; foreach my $source_name ($self->sources) { my $orig_source = $self->source($source_name); @@ -919,11 +917,8 @@ sub compose_namespace { } } - foreach my $meth (qw/class source resultset/) { - no warnings 'redefine'; - *{"${target}::${meth}"} = subname "${target}::${meth}" => - sub { shift->schema->$meth(@_) }; - } + quote_sub "${target}::${_}" => "shift->schema->$_(\@_)" + for qw(class source resultset); } Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO; @@ -1497,11 +1492,7 @@ sub compose_connection { } my $schema = $self->compose_namespace($target, $base); - { - no strict 'refs'; - my $name = join '::', $target, 'schema'; - *$name = subname $name, sub { $schema }; - } + quote_sub "${target}::schema", '$s', { '$s' => \$schema }; $schema->connection(@info); foreach my $source_name ($schema->sources) { diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index 230a849..18dbbb9 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -10,11 +10,11 @@ use mro 'c3'; use DBIx::Class::Carp; use Scalar::Util qw/refaddr weaken reftype blessed/; use List::Util qw/first/; -use Sub::Name 'subname'; use Context::Preserve 'preserve_context'; use Try::Tiny; use Data::Compare (); # no imports!!! guard against insane architecture use SQL::Abstract qw(is_plain_value is_literal_value); +use DBIx::Class::_Util qw(quote_sub perlstring); use namespace::clean; # default cursor class, overridable in connect_info attributes @@ -119,9 +119,11 @@ for my $meth (keys %$storage_accessor_idx, qw( my $orig = __PACKAGE__->can ($meth) or die "$meth is not a ::Storage::DBI method!"; - no strict 'refs'; - no warnings 'redefine'; - *{__PACKAGE__ ."::$meth"} = subname $meth => sub { + my $is_getter = $storage_accessor_idx->{$meth} ? 0 : 1; + + quote_sub + __PACKAGE__ ."::$meth", sprintf( <<'EOC', $is_getter, perlstring $meth ), { '$orig' => \$orig }; + if ( # only fire when invoked on an instance, a valid class-based invocation # would e.g. be setting a default for an inherited accessor @@ -133,7 +135,7 @@ for my $meth (keys %$storage_accessor_idx, qw( and # if this is a known *setter* - just set it, no need to connect # and determine the driver - ! ( $storage_accessor_idx->{$meth} and @_ > 1 ) + ( %1$s or @_ <= 1 ) and # Only try to determine stuff if we have *something* that either is or can # provide a DSN. Allows for bare $schema's generated with a plain ->connect() @@ -142,16 +144,15 @@ for my $meth (keys %$storage_accessor_idx, qw( ) { $_[0]->_determine_driver; - # This for some reason crashes and burns on perl 5.8.1 - # IFF the method ends up throwing an exception - #goto $_[0]->can ($meth); + # work around http://rt.perl.org/rt3/Public/Bug/Display.html?id=35878 + goto $_[0]->can(%2$s) unless DBIx::Class::_ENV_::BROKEN_GOTO; - my $cref = $_[0]->can ($meth); + my $cref = $_[0]->can(%2$s); goto $cref; } goto $orig; - }; +EOC } =head1 NAME @@ -1633,17 +1634,13 @@ sub _exec_txn_rollback { shift->_dbh->rollback; } -# generate some identical methods -for my $meth (qw/svp_begin svp_release svp_rollback/) { - no strict qw/refs/; - *{__PACKAGE__ ."::$meth"} = subname $meth => sub { - my $self = shift; - $self->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK; - $self->throw_exception("Unable to $meth() on a disconnected storage") - unless $self->_dbh; - $self->next::method(@_); - }; -} +# generate the DBI-specific stubs, which then fallback to ::Storage proper +quote_sub __PACKAGE__ . "::$_" => sprintf (<<'EOS', $_) for qw(svp_begin svp_release svp_rollback); + $_[0]->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK; + $_[0]->throw_exception('Unable to %s() on a disconnected storage') + unless $_[0]->_dbh; + shift->next::method(@_); +EOS # This used to be the top-half of _execute. It was split out to make it # easier to override in NoBindVars without duping the rest. It takes up diff --git a/lib/DBIx/Class/Storage/DBIHacks.pm b/lib/DBIx/Class/Storage/DBIHacks.pm index ef89092..26f8dca 100644 --- a/lib/DBIx/Class/Storage/DBIHacks.pm +++ b/lib/DBIx/Class/Storage/DBIHacks.pm @@ -15,7 +15,6 @@ use mro 'c3'; use List::Util 'first'; use Scalar::Util 'blessed'; -use Sub::Name 'subname'; use DBIx::Class::_Util 'UNRESOLVABLE_CONDITION'; use SQL::Abstract qw(is_plain_value is_literal_value); use namespace::clean; diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index 384d3e0..83bca47 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -17,6 +17,8 @@ BEGIN { # but of course BROKEN_FORK => ($^O eq 'MSWin32') ? 1 : 0, + BROKEN_GOTO => ($] < '5.008003') ? 1 : 0, + HAS_ITHREADS => $Config{useithreads} ? 1 : 0, # ::Runmode would only be loaded by DBICTest, which in turn implies t/ diff --git a/t/40compose_connection.t b/t/40compose_connection.t index 6cd62ff..a68a2c2 100644 --- a/t/40compose_connection.t +++ b/t/40compose_connection.t @@ -16,15 +16,7 @@ warnings_exist { DBICTest->init_schema( compose_connection => 1, sqlite_use_file cmp_ok(DBICTest->resultset('Artist')->count, '>', 0, 'count is valid'); -# cleanup globals so we do not trigger the leaktest -for ( map { DBICTest->schema->class($_) } DBICTest->schema->sources ) { - $_->class_resolver(undef); - $_->resultset_instance(undef); - $_->result_source_instance(undef); -} -{ - no warnings qw/redefine once/; - *DBICTest::schema = sub {}; -} +# cleanup globaly cached handle so we do not trigger the leaktest +DBICTest->schema->storage->disconnect; done_testing; diff --git a/t/55namespaces_cleaned.t b/t/55namespaces_cleaned.t index 0428069..a8a966d 100644 --- a/t/55namespaces_cleaned.t +++ b/t/55namespaces_cleaned.t @@ -93,6 +93,8 @@ my $skip_idx = { map { $_ => 1 } ( my $has_moose = eval { require Moose::Util }; +Sub::Defer::undefer_all(); + # can't use Class::Inspector for the mundane parts as it does not # distinguish imports from anything else, what a crock of... # Moose is not always available either - hence just do it ourselves diff --git a/t/lib/DBICTest/Util/LeakTracer.pm b/t/lib/DBICTest/Util/LeakTracer.pm index d0c29eb..1a56f41 100644 --- a/t/lib/DBICTest/Util/LeakTracer.pm +++ b/t/lib/DBICTest/Util/LeakTracer.pm @@ -164,7 +164,7 @@ sub visit_namespaces { $visited += visit_namespaces({ %$args, package => $_ }) for map - { $_ =~ /(.+?)::$/ && "${base}::$1" } + { $_ =~ /(.+?)::$/ ? "${base}::$1" : () } grep { $_ =~ /(?{$addr}{weakref} and ! isweak( $weak_registry->{$addr}{weakref} ); } - # the walk is very expensive - if we are $quiet (running in an END block) - # we do not really need to be too thorough - unless ($quiet) { - delete $weak_registry->{$_} for keys %{ symtable_referenced_addresses() }; - } - + # the symtable walk is very expensive + # if we are $quiet (running in an END block) we do not really need to be + # that thorough - can get by with only %Sub::Quote::QUOTED + delete $weak_registry->{$_} for $quiet + ? do { + my $refs = {}; + visit_refs ( + # only look at the closed over stuffs + refs => [ grep { length ref $_ } map { values %{$_->[2]} } grep { ref $_ eq 'ARRAY' } values %Sub::Quote::QUOTED ], + seen_refs => $refs, + action => sub { 1 }, + ); + keys %$refs; + } + : ( + # full sumtable walk, starting from :: + keys %{ symtable_referenced_addresses() } + ) + ; for my $addr (sort { $weak_registry->{$a}{display_name} cmp $weak_registry->{$b}{display_name} } keys %$weak_registry) { diff --git a/t/storage/error.t b/t/storage/error.t index 61d6782..6c9b15c 100644 --- a/t/storage/error.t +++ b/t/storage/error.t @@ -38,7 +38,7 @@ throws_ok ( # exception fallback: SKIP: { - if (DBIx::Class::_ENV_::PEEPEENESS) { + if ( !!DBIx::Class::_ENV_::PEEPEENESS ) { skip "Your perl version $] appears to leak like a sieve - skipping garbage collected \$schema test", 1; }