use Carp ();
use Scalar::Util ();
use MRO::Compat;
-use Sub::Name ();
-our $VERSION = '0.09006';
+our $VERSION = '0.09008';
$VERSION = eval $VERSION;
-# when changing minimum version don't forget to adjust L</PERFROMANCE> as well
-our $__minimum_xsa_version = '1.06';
+# when changing minimum version don't forget to adjust L</PERFORMANCE> and
+# the Makefile.PL as well
+our $__minimum_xsa_version;
+BEGIN {
+ $__minimum_xsa_version = '1.06';
+}
our $USE_XS;
# the unless defined is here so that we can override the value
$USE_XS = $ENV{CAG_USE_XS}
unless defined $USE_XS;
-my ($xsa_loaded, $xsa_autodetected);
-
-my $load_xsa = sub {
- return if $xsa_loaded++;
- require Class::XSAccessor;
- Class::XSAccessor->VERSION($__minimum_xsa_version);
-};
+# Yes this method is undocumented
+# Yes it should be a private coderef like all the rest at the end of this file
+# No we can't do that (yet) because the DBIC-CDBI compat layer overrides it
+# %$*@!?&!&#*$!!!
+sub _mk_group_accessors {
+ my($self, $maker, $group, @fields) = @_;
+ my $class = Scalar::Util::blessed $self || $self;
-my $use_xs = sub {
- if (defined $USE_XS) {
- $load_xsa->() if ($USE_XS && ! $xsa_loaded);
- return $USE_XS;
- }
+ no strict 'refs';
+ no warnings 'redefine';
- $xsa_autodetected = 1;
- $USE_XS = 0;
+ # So we don't have to do lots of lookups inside the loop.
+ $maker = $self->can($maker) unless ref $maker;
- # Class::XSAccessor is segfaulting on win32, in some
- # esoteric heavily-threaded scenarios
- # Win32 users can set $USE_XS/CAG_USE_XS to try to use it anyway
- if ($^O ne 'MSWin32') {
- local $@;
- eval { $load_xsa->(); $USE_XS = 1 };
- }
+ foreach (@fields) {
+ if( $_ eq 'DESTROY' ) {
+ Carp::carp("Having a data accessor named DESTROY in ".
+ "'$class' is unwise.");
+ }
- return $USE_XS;
-};
+ my ($name, $field) = (ref $_)
+ ? (@$_)
+ : ($_, $_)
+ ;
-my $maker_type_map = {
- rw => {
- xsa => 'accessors',
- cag => 'make_group_accessor',
- },
- ro => {
- xsa => 'getters',
- cag => 'make_group_ro_accessor',
- },
- wo => {
- xsa => 'setters',
- cag => 'make_group_wo_accessor',
- },
-};
+ my $alias = "_${name}_accessor";
-# When installing an XSA simple accessor, we need to make sure we are not
-# short-circuiting a (compile or runtime) get_simple/set_simple override.
-# What we do here is install a lazy first-access check, which will decide
-# the ultimate coderef being placed in the accessor slot
-
-my $no_xsa_classes_warned;
-my $add_xs_accessor = sub {
- my ($class, $group, $field, $name, $type) = @_;
-
- Class::XSAccessor->import({
- replace => 1,
- class => $class,
- $maker_type_map->{$type}{xsa} => {
- $name => $field,
- },
- });
-
- my $xs_cref = $class->can($name);
-
- my $pp_cref = do {
- my $cag_method = $maker_type_map->{$type}{cag};
- local $USE_XS = 0;
- $class->$cag_method ($group, $field, $name, $type);
- };
+ for my $meth ($name, $alias) {
- # can't use pkg_gen to track this stuff, as it doesn't
- # detect superclass mucking
- my $original_getter = __PACKAGE__->can ("get_$group");
- my $original_setter = __PACKAGE__->can ("set_$group");
+ # the maker may elect to not return anything, meaning it already
+ # installed the coderef for us (e.g. lack of Sub::Name)
+ my $cref = $self->$maker($group, $field, $meth)
+ or next;
- return sub {
- my $self = $_[0];
- my $current_class = (ref $self) || $self;
+ my $fq_meth = "${class}::${meth}";
- my $final_cref;
- if (
- $current_class->can("get_$group") == $original_getter
- &&
- $current_class->can("set_$group") == $original_setter
- ) {
- # nothing has changed, might as well use the XS crefs
- #
- # note that by the time this code executes, we already have
- # *objects* (since XSA works on 'simple' only by definition).
- # If someone is mucking with the symbol table *after* there
- # are some objects already - look! many, shiny pieces! :)
- $final_cref = $xs_cref;
- }
- else {
- $final_cref = $pp_cref;
- if ($USE_XS and ! $xsa_autodetected and ! $no_xsa_classes_warned->{$current_class}++) {
- warn 'Explicitly requested use of Class::XSAccessor disabled for objects of class'
- . " '$current_class' due to an overriden get_$group and/or set_$group\n";
- }
+ *$fq_meth = Sub::Name::subname($fq_meth, $cref);
+ #unless defined &{$class."\:\:$field"}
}
-
- # installing an XSA cref that was originally created on a class
- # different than $current_class is perfectly safe as per
- # C::XSA's author
- my $fq_meth = "${current_class}::${name}";
-
- no strict qw/refs/;
- no warnings qw/redefine/;
-
- *$fq_meth = Sub::Name::subname($fq_meth, $final_cref);
-
- goto $final_cref;
- };
+ }
};
+# coderef is setup at the end for clarity
+my $gen_accessor;
+
=head1 NAME
Class::Accessor::Grouped - Lets you build groups of accessors
=cut
sub mk_group_accessors {
- my ($self, $group, @fields) = @_;
+ my ($self, $group, @fields) = @_;
- $self->_mk_group_accessors('make_group_accessor', $group, @fields);
- return;
-}
-
-
-{
- no strict 'refs';
- no warnings 'redefine';
-
- sub _mk_group_accessors {
- my($self, $maker, $group, @fields) = @_;
- my $class = Scalar::Util::blessed $self || $self;
-
- # So we don't have to do lots of lookups inside the loop.
- $maker = $self->can($maker) unless ref $maker;
-
- foreach (@fields) {
- if( $_ eq 'DESTROY' ) {
- Carp::carp("Having a data accessor named DESTROY in ".
- "'$class' is unwise.");
- }
-
- my ($name, $field) = (ref $_)
- ? (@$_)
- : ($_, $_)
- ;
-
- my $alias = "_${name}_accessor";
-
- for my $meth ($name, $alias) {
-
- # the maker may elect to not return anything, meaning it already
- # installed the coderef for us
- my $cref = $self->$maker($group, $field, $meth)
- or next;
-
- my $fq_meth = join('::', $class, $meth);
-
- *$fq_meth = Sub::Name::subname($fq_meth, $cref);
- #unless defined &{$class."\:\:$field"}
- }
- }
- }
+ $self->_mk_group_accessors('make_group_accessor', $group, @fields);
+ return;
}
=head2 mk_group_ro_accessors
=cut
-sub make_group_accessor {
- my ($class, $group, $field, $name) = @_;
-
- if ( $group eq 'simple' && $use_xs->() ) {
- return $add_xs_accessor->(@_, 'rw');
- }
-
- my $set = "set_$group";
- my $get = "get_$group";
-
- $field =~ s/'/\\'/g;
-
- # eval for faster fastiness
- my $code = eval "sub {
- if(\@_ > 1) {
- return shift->$set('$field', \@_);
- }
- else {
- return shift->$get('$field');
- }
- };";
- Carp::croak $@ if $@;
-
- return $code;
-}
+sub make_group_accessor { $gen_accessor->('rw', @_) }
=head2 make_group_ro_accessor
=cut
-sub make_group_ro_accessor {
- my($class, $group, $field, $name) = @_;
-
- if ( $group eq 'simple' && $use_xs->() ) {
- return $add_xs_accessor->(@_, 'ro');
- }
-
- my $get = "get_$group";
-
- $field =~ s/'/\\'/g;
-
- my $code = eval "sub {
- if(\@_ > 1) {
- my \$caller = caller;
- Carp::croak(\"'\$caller' cannot alter the value of '$field' on \".
- \"objects of class '$class'\");
- }
- else {
- return shift->$get('$field');
- }
- };";
- Carp::croak $@ if $@;
-
- return $code;
-}
+sub make_group_ro_accessor { $gen_accessor->('ro', @_) }
=head2 make_group_wo_accessor
=cut
-sub make_group_wo_accessor {
- my($class, $group, $field, $name) = @_;
-
- if ( $group eq 'simple' && $use_xs->() ) {
- return $add_xs_accessor->(@_, 'wo')
- }
-
- my $set = "set_$group";
-
- $field =~ s/'/\\'/g;
-
- my $code = eval "sub {
- unless (\@_ > 1) {
- my \$caller = caller;
- Carp::croak(\"'\$caller' cannot access the value of '$field' on \".
- \"objects of class '$class'\");
- }
- else {
- return shift->$set('$field', \@_);
- }
- };";
- Carp::croak $@ if $@;
-
- return $code;
-}
+sub make_group_wo_accessor { $gen_accessor->('wo', @_) }
=head2 get_simple
=cut
sub get_simple {
- return $_[0]->{$_[1]};
+ return $_[0]->{$_[1]};
}
=head2 set_simple
=cut
sub set_simple {
- return $_[0]->{$_[1]} = $_[2];
+ return $_[0]->{$_[1]} = $_[2];
}
sub get_inherited {
my $class;
- if ( ($class = ref $_[0]) && Scalar::Util::blessed $_[0]) {
+ if ( defined( $class = Scalar::Util::blessed $_[0] ) ) {
if (Scalar::Util::reftype $_[0] eq 'HASH') {
return $_[0]->{$_[1]} if exists $_[0]->{$_[1]};
}
}
no strict 'refs';
- no warnings qw/uninitialized/;
+ no warnings 'uninitialized';
my $cag_slot = '::__cag_'. $_[1];
return ${$class.$cag_slot} if defined(${$class.$cag_slot});
=cut
sub set_inherited {
- if (Scalar::Util::blessed $_[0]) {
+ if (defined Scalar::Util::blessed $_[0]) {
if (Scalar::Util::reftype $_[0] eq 'HASH') {
return $_[0]->{$_[1]} = $_[2];
} else {
local $^W = 0;
require Class::Inspector;
if (Class::Inspector->installed($_[2]) && !Class::Inspector->loaded($_[2])) {
- eval "use $_[2]";
+ eval "require $_[2]";
Carp::croak("Could not load $_[1] '$_[2]': ", $@) if $@;
};
return @{mro::get_linear_isa( ref($_[0]) || $_[0] )};
};
-1;
-
=head1 PERFORMANCE
To provide total flexibility L<Class::Accessor::Grouped> calls methods
it under the same terms as perl itself.
=cut
+
+########################################################################
+########################################################################
+########################################################################
+#
+# Here be many angry dragons
+# (all code is in private coderefs since everything inherits CAG)
+#
+########################################################################
+########################################################################
+
+BEGIN {
+
+ die "Huh?! No minimum C::XSA version?!\n"
+ unless $__minimum_xsa_version;
+
+ local $@;
+ my $err;
+
+ $err = eval { require Sub::Name; 1; } ? undef : do {
+ delete $INC{'Sub/Name.pm'}; # because older perls suck
+ $@;
+ };
+ *__CAG_NO_SUBNAME = $err
+ ? sub () { $err }
+ : sub () { 0 }
+ ;
+
+
+ $err = eval {
+ require Class::XSAccessor;
+ Class::XSAccessor->VERSION($__minimum_xsa_version);
+ require Sub::Name;
+ 1;
+ } ? undef : do {
+ delete $INC{'Sub/Name.pm'}; # because older perls suck
+ delete $INC{'Class/XSAccessor.pm'};
+ $@;
+ };
+ *__CAG_NO_CXSA = $err
+ ? sub () { $err }
+ : sub () { 0 }
+ ;
+
+
+ *__CAG_BROKEN_GOTO = ($] < '5.008009')
+ ? sub () { 1 }
+ : sub () { 0 }
+ ;
+
+
+ *__CAG_UNSTABLE_DOLLARAT = ($] < '5.013002')
+ ? sub () { 1 }
+ : sub () { 0 }
+ ;
+
+};
+
+# Autodetect unless flag supplied
+# Class::XSAccessor is segfaulting on win32, in some
+# esoteric heavily-threaded scenarios
+# Win32 users can set $USE_XS/CAG_USE_XS to try to use it anyway
+my $xsa_autodetected;
+if (! defined $USE_XS) {
+ $USE_XS = (!__CAG_NO_CXSA and $^O ne 'MSWin32') ? 1 : 0;
+ $xsa_autodetected++;
+}
+
+my $maker_templates = {
+ rw => {
+ xs_call => 'accessors',
+ pp_code => sub {
+ my $set = "set_$_[0]";
+ my $get = "get_$_[0]";
+ my $field = $_[1];
+ $field =~ s/'/\\'/g;
+
+ "
+ \@_ > 1
+ ? shift->$set('$field', \@_)
+ : shift->$get('$field')
+ "
+ },
+ },
+ ro => {
+ xs_call => 'getters',
+ pp_code => sub {
+ my $get = "get_$_[0]";
+ my $field = $_[1];
+ $field =~ s/'/\\'/g;
+
+ "
+ \@_ == 1
+ ? shift->$get('$field')
+ : do {
+ my \$caller = caller;
+ my \$class = ref \$_[0] || \$_[0];
+ Carp::croak(\"'\$caller' cannot alter the value of '$field' \".
+ \"(read-only attributes of class '\$class')\");
+ }
+ "
+ },
+ },
+ wo => {
+ xs_call => 'setters',
+ pp_code => sub {
+ my $set = "set_$_[0]";
+ my $field = $_[1];
+ $field =~ s/'/\\'/g;
+
+ "
+ \@_ > 1
+ ? shift->$set('$field', \@_)
+ : do {
+ my \$caller = caller;
+ my \$class = ref \$_[0] || \$_[0];
+ Carp::croak(\"'\$caller' cannot access the value of '$field' \".
+ \"(write-only attributes of class '\$class')\");
+ }
+ "
+ },
+ },
+};
+
+
+my ($accessor_maker_cache, $no_xsa_warned_classes);
+
+# can't use pkg_gen to track this stuff, as it doesn't
+# detect superclass mucking
+my $original_simple_getter = __PACKAGE__->can ('get_simple');
+my $original_simple_setter = __PACKAGE__->can ('set_simple');
+
+# Note!!! Unusual signature
+$gen_accessor = sub {
+ my ($type, $class, $group, $field, $methname) = @_;
+ if (my $c = ref $class) {
+ $class = $c;
+ }
+
+ my $fq_name = "${class}::${methname}";
+
+ # When installing an XSA simple accessor, we need to make sure we are not
+ # short-circuiting a (compile or runtime) get_simple/set_simple override.
+ # What we do here is install a lazy first-access check, which will decide
+ # the ultimate coderef being placed in the accessor slot
+ if ($USE_XS and $group eq 'simple') {
+ ($accessor_maker_cache->{xs}{$field}{$type}{$fq_name} ||= do {
+ die sprintf( "Class::XSAccessor requested but not available:\n%s\n", __CAG_NO_CXSA )
+ if __CAG_NO_CXSA;
+
+ sub { sub {
+ my $current_class = Scalar::Util::blessed( $_[0] ) || $_[0];
+
+ if (
+ $current_class->can('get_simple') == $original_simple_getter
+ &&
+ $current_class->can('set_simple') == $original_simple_setter
+ ) {
+ # nothing has changed, might as well use the XS crefs
+ #
+ # note that by the time this code executes, we already have
+ # *objects* (since XSA works on 'simple' only by definition).
+ # If someone is mucking with the symbol table *after* there
+ # are some objects already - look! many, shiny pieces! :)
+ Class::XSAccessor->import(
+ replace => 1,
+ class => $class,
+ $maker_templates->{$type}{xs_call} => {
+ $methname => $field,
+ },
+ );
+ }
+ else {
+ if (! $xsa_autodetected and ! $no_xsa_warned_classes->{$current_class}++) {
+ # not using Carp since the line where this happens doesn't mean much
+ warn 'Explicitly requested use of Class::XSAccessor disabled for objects of class '
+ . "'$current_class' due to an overriden get_simple and/or set_simple\n";
+ }
+
+ no strict qw/refs/;
+
+ *$fq_name = Sub::Name::subname($fq_name, do {
+ # that's faster than local
+ $USE_XS = 0;
+ my $c = $gen_accessor->($type, $class, 'simple', $field, $methname);
+ $USE_XS = 1;
+ $c;
+ });
+ }
+
+ # older perls segfault if the cref behind the goto throws
+ # http://rt.perl.org/rt3/Public/Bug/Display.html?id=35878
+ return $current_class->can($methname)->(@_) if __CAG_BROKEN_GOTO;
+
+ goto $current_class->can($methname);
+ }}
+ })->();
+ }
+
+ # no Sub::Name - just install the coderefs directly (compiling every time)
+ elsif (__CAG_NO_SUBNAME) {
+ my $src = $accessor_maker_cache->{source}{$type}{$group}{$field} ||=
+ $maker_templates->{$type}{pp_code}->($group, $field);
+
+ local $@ if __CAG_UNSTABLE_DOLLARAT;
+ eval "sub ${fq_name}{$src}";
+
+ undef; # so that no attempt will be made to install anything
+ }
+
+ # a coderef generator with a variable pad (returns a fresh cref on every invocation)
+ else {
+ ($accessor_maker_cache->{pp}{$group}{$field}{$type} ||= do {
+ my $src = $accessor_maker_cache->{source}{$type}{$group}{$field} ||=
+ $maker_templates->{$type}{pp_code}->($group, $field);
+
+ local $@ if __CAG_UNSTABLE_DOLLARAT;
+ eval "sub { my \$dummy; sub { \$dummy if 0; $src } }" or die $@;
+ })->()
+ }
+};
+
+1;