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__
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;
use strict;
use warnings;
use DBIx::ContextualFetch;
-use Sub::Name ();
+use DBIx::Class::_Util qw(quote_sub perlstring);
use base qw(Class::Data::Inheritable);
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
}
}
use strict;
use warnings;
-use Sub::Name ();
+
+use DBIx::Class::_Util 'quote_sub';
=head1 NAME
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;
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' => {});
);
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;
}
-
}
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 =
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")
}
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;
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 =
(
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 {
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');
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;
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;
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);
}
}
- 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;
}
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) {
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
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
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()
) {
$_[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
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
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;
# 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/
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;
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
$visited += visit_namespaces({ %$args, package => $_ }) for map
- { $_ =~ /(.+?)::$/ && "${base}::$1" }
+ { $_ =~ /(.+?)::$/ ? "${base}::$1" : () }
grep
{ $_ =~ /(?<!^main)::$/ }
do { no strict 'refs'; keys %{ $base . '::'} }
sub assert_empty_weakregistry {
my ($weak_registry, $quiet) = @_;
+ Sub::Defer::undefer_all();
+
# in case we hooked bless any extra object creation will wreak
# havoc during the assert phase
local *CORE::GLOBAL::bless;
if defined $weak_registry->{$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) {
# 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;
}
projects / dbsrgits/DBIx-Class.git / commitdiff