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;
+# 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 $load_xsa = sub {
- return if $xsa_loaded++;
- require Class::XSAccessor;
- Class::XSAccessor->VERSION($__minimum_xsa_version);
-};
+ no strict 'refs';
+ no warnings 'redefine';
-my $use_xs = sub {
- if (defined $USE_XS) {
- $load_xsa->() if ($USE_XS && ! $xsa_loaded);
- return $USE_XS;
- }
+ # So we don't have to do lots of lookups inside the loop.
+ $maker = $self->can($maker) unless ref $maker;
- $USE_XS = 0;
+ foreach (@fields) {
+ if( $_ eq 'DESTROY' ) {
+ Carp::carp("Having a data accessor named DESTROY in ".
+ "'$class' is unwise.");
+ }
- # 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 };
- }
+ 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 (e.g. lack of Sub::Name)
+ my $cref = $self->$maker($group, $field, $meth)
+ or next;
- return $USE_XS;
+ my $fq_meth = "${class}::${meth}";
+
+ *$fq_meth = Sub::Name::subname($fq_meth, $cref);
+ #unless defined &{$class."\:\:$field"}
+ }
+ }
};
+# 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->() ) {
- Class::XSAccessor->import({
- replace => 1,
- class => $class,
- accessors => {
- $name => $field,
- },
- });
- return;
- }
-
- 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->() ) {
- Class::XSAccessor->import({
- replace => 1,
- class => $class,
- getters => {
- $name => $field,
- },
- });
- return;
- }
-
- 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->() ) {
- Class::XSAccessor->import({
- replace => 1,
- class => $class,
- setters => {
- $name => $field,
- },
- });
- return;
- }
-
- 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
=head2 Notes on Class::XSAccessor
+You can force (or disable) the use of L<Class::XSAccessor> before creating a
+particular C<simple> accessor by either manipulating the global variable
+C<$Class::Accessor::Grouped::USE_XS> to true or false (preferably with
+L<localization|perlfunc/local>, or you can do so before runtime via the
+C<CAG_USE_XS> environment variable.
+
+Since L<Class::XSAccessor> has no knowledge of L</get_simple> and
+L</set_simple> this module does its best to detect if you are overriding
+one of these methods and will fall back to using the perl version of the
+accessor in order to maintain consistency. However be aware that if you
+enable use of C<Class::XSAccessor> (automatically or explicitly), create
+an object, invoke a simple accessor on that object, and B<then> manipulate
+the symbol table to install a C<get/set_simple> override - you get to keep
+all the pieces.
+
While L<Class::XSAccessor> works surprisingly well for the amount of black
magic it tries to pull off, it's still black magic. At present (Sep 2010)
the module is known to have problems on Windows under heavy thread-stress
(e.g. Win32+Apache+mod_perl). Thus for the time being L<Class::XSAccessor>
will not be used automatically if you are running under C<MSWin32>.
-You can force the use of L<Class::XSAccessor> before creating a particular
-C<simple> accessor by either manipulating the global variable
-C<$Class::Accessor::Grouped::USE_XS>, or you can do so before runtime via the
-C<CAG_USE_XS> environment variable.
-
=head1 AUTHORS
Matt S. Trout <mst@shadowcatsystems.co.uk>
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;
+ }
+
+
+ # 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') {
+ my $fq_name = "${class}::${methname}";
+ ($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);
+
+ no warnings 'redefine';
+ local $@ if __CAG_UNSTABLE_DOLLARAT;
+ eval "sub ${class}::${methname}{$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;
projects / p5sagit/Class-Accessor-Grouped.git / blobdiff