File Coverage

blib/lib/Class/Std/Fast.pm

Criterion	Covered	Total	%
statement	214	241	88.8
branch	65	90	72.2
condition	31	47	65.9
subroutine	39	48	81.2
pod	5	5	100.0
total	354	431	82.1

package Class::Std::Fast;

use version; $VERSION = qv('0.0.8');
use strict;
use warnings;
use Carp;

BEGIN {
    # warn if we cannot save aray UNIVERSAL::Can (because Class::Std has
    # already overwritten it...)
    exists $INC{'Class/Std.pm'}
        && warn 'Class::Std::Fast loaded too late - put
>use Class::Std::Fast< somewhere at the top of your application
';

    # save away UNIVERSAL::can
    *real_can = \&UNIVERSAL::can;

    require Class::Std;
    no strict qw(refs);
    for my $sub ( qw(MODIFY_CODE_ATTRIBUTES AUTOLOAD _mislabelled initialize) ) {
        *{$sub} = \&{'Class::Std::' . $sub};
    }
}

my %object_cache_of = ();
my %do_cache_class_of = ();
my %destroy_isa_unsorted_of = ();

my %attribute;


my %optimization_level_of = ();
my $instance_counter      = 1;

# use () prototype to indicate to perl that it does not need to prepare an
# argument stack
sub OBJECT_CACHE_REF () { return \%object_cache_of };
sub ID_GENERATOR_REF () { return \$instance_counter };

my @exported_subs = qw(
    ident
    DESTROY
    _DUMP
    AUTOLOAD
);
my @exported_extension_subs = qw(
    MODIFY_CODE_ATTRIBUTES
    MODIFY_HASH_ATTRIBUTES
);

sub _cache_class_ref () {
    croak q{you can't call this method in your namespace}
        if 0 != index caller, 'Class::Std::';
    return \%do_cache_class_of;
}

sub _attribute_ref () {
    croak q{you can't call this method in your namespace}
        if 0 != index caller, 'Class::Std::';
    return \%attribute;
}

sub _get_internal_attributes {
    croak q{you can't call this method in your namespace}
        if 0 != index caller, 'Class::Std::';
    return $attribute{$_[-1]};
}

sub _set_optimization_level {
    $optimization_level_of{$_[0]} = $_[1] || 1;
}

# Prototype allows perl to inline ID
sub ID() {
    return $instance_counter++;
}

sub ident ($) {
    return ${$_[0]};
}

sub _init_class_cache {
    $do_cache_class_of{ $_[0] } = 1;
    $object_cache_of{ $_[0] } ||= [];
}

sub _init_import {
    my ($caller_package, %flags) = @_;
    $destroy_isa_unsorted_of{ $caller_package } = undef
        if ($flags{isa_unsorted});

    _init_class_cache( $caller_package )
        if ($flags{cache});

    no strict qw(refs);

    if ($flags{constructor} eq 'normal') {
        *{ $caller_package . '::new' } = \&new;
    }
    elsif ($flags{constructor} eq 'basic' && $flags{cache}) {
        *{ $caller_package . '::new' } = \&_new_basic_cache;
    }
    elsif ($flags{constructor} eq 'basic' && ! $flags{cache}) {
        *{ $caller_package . '::new' } = \&_new_basic;
    }
    elsif ($flags{constructor} eq 'none' ) {
        # nothing to do
    }
    else {
        croak "Illegal import flags constructor => '$flags{constructor}', cache => '$flags{cache}'";
    }
}

sub import {
    my $caller_package = caller;

    my %flags = (@_>=3)
            ? @_[1..$#_]
            : (@_==2) && $_[1] >=2
                ? ( constructor =>  'basic', cache => 0 )
                : ( constructor => 'normal', cache => 0);
    $flags{cache} = 0 if not defined $flags{cache};
    $flags{constructor} = 'normal' if not defined $flags{constructor};

    _init_import($caller_package, %flags);

    no strict qw(refs);
    for my $sub ( @exported_subs ) {
        *{ $caller_package . '::' . $sub } = \&{$sub};
    }
    for my $sub ( @exported_extension_subs ) {
        my $target = $caller_package . '::' . $sub;
        my $real_sub = *{ $target }{CODE} || sub { return @_[2..$#_] };
        no warnings qw(redefine);
        *{ $target } = sub {
            my ($package, $referent, @unhandled) = @_;
            for my $handler ($sub, $real_sub) {
                next if ! @unhandled;
                @unhandled = $handler->($package, $referent, @unhandled);
            }
            return @unhandled;
        };
    }
}

sub __create_getter {
    my ($package, $referent, $getter) = @_;
    no strict 'refs';
    *{$package.'::get_'.$getter} = sub {
        return $referent->{${$_[0]}};
    }
}

sub __create_setter {
    my ($package, $referent, $setter) = @_;
    no strict 'refs';
    *{$package.'::set_'.$setter} = sub {
        $referent->{${$_[0]}} = $_[1];
        return $_[0];
    }
}

sub MODIFY_HASH_ATTRIBUTES {
    my ($package, $referent, @attrs) = @_;
    for my $attr (@attrs) {
        next if $attr !~ m/\A ATTRS? \s* (?: \( (.*) \) )? \z/xms;
        my ($default, $init_arg, $getter, $setter, $name);
        if (my $config = $1) {
            $default  = Class::Std::_extract_default($config);
            $name     = Class::Std::_extract_name($config);
            $init_arg = Class::Std::_extract_init_arg($config) || $name;
            if ($getter = Class::Std::_extract_get($config) || $name) {
                __create_getter($package, $referent, $getter, $name);
            }
            if ($setter = Class::Std::_extract_set($config) || $name) {
                __create_setter($package, $referent, $setter, $name);
            }
        }
        undef $attr;
        push @{$attribute{$package}}, {
            ref      => $referent,
            default  => $default,
            init_arg => $init_arg,
            name     => $name || $init_arg || $getter || $setter || '????',
        };
    }
    return grep { defined } @attrs;
}

sub _DUMP {
    my ($self) = @_;
    my $id = ${$self};

    my %dump;
    for my $package (keys %attribute) {
        my $attr_list_ref = $attribute{$package};
        for my $attr_ref ( @{$attr_list_ref} ) {
            next if !exists $attr_ref->{ref}{$id};
            $dump{$package}{$attr_ref->{name}} = $attr_ref->{ref}{$id};
        }
    }

    require Data::Dumper;
    my $dump = Data::Dumper::Dumper(\%dump);
    $dump =~ s/^.{8}//gxms;
    return $dump;
}

sub _new_basic {
    return bless \(my $anon_scalar = $instance_counter++), $_[0];
}

sub _new_basic_cache {
    return pop @{ $object_cache_of{ $_[0] }}
        || bless \(my $anon_scalar = $instance_counter++), $_[0];
}

sub new {
    no strict 'refs';

    # Symbol Class:: must exist...
    croak "Can't find class $_[0]" if ! keys %{ $_[0] . '::' };

    Class::Std::initialize(); # Ensure run-time (and mod_perl) setup is done

    # extra safety only required if we actually care of arguments ...
    croak "Argument to $_[0]\->new() must be hash reference"
        if ($#_) && ref $_[1] ne 'HASH';

    # try cache first if caching is enabled for this class
    my $new_obj = exists($do_cache_class_of{ $_[0] })
        && pop @{ $object_cache_of{ $_[0] } }
        || bless \(my $another_anon_scalar = $instance_counter++), $_[0];

    my (@missing_inits, @suss_keys, @start_methods);
    $_[1] ||= {};
    my %arg_set;
    BUILD: for my $base_class (Class::Std::_reverse_hierarchy_of($_[0])) {
        my $arg_set = $arg_set{$base_class}
            = { %{$_[1]}, %{$_[1]->{$base_class}||{}} };

        # Apply BUILD() methods ...
        {
        no warnings 'once';
        if (my $build_ref = *{$base_class.'::BUILD'}{CODE}) {
            $build_ref->($new_obj, ${$new_obj}, $arg_set);
        }
        if (my $init_ref = *{$base_class.'::START'}{CODE}) {
            push @start_methods, sub {
                $init_ref->($new_obj, ${$new_obj}, $arg_set);
            };
        }
    }

    # Apply init_arg and default for attributes still undefined ...
    my $init_arg;
        INIT:
        for my $attr_ref ( @{$attribute{$base_class}} ) {
            defined $attr_ref->{ref}{${$new_obj}} and next INIT;
            # Get arg from initializer list...
            if (defined $attr_ref->{init_arg} && exists $arg_set->{$attr_ref->{init_arg}}) {
                $attr_ref->{ref}{${$new_obj}} = $arg_set->{$attr_ref->{init_arg}};
                next INIT;
            }
            elsif (defined $attr_ref->{default}) {
                # Or use default value specified...
                $attr_ref->{ref}{${$new_obj}} = eval $attr_ref->{default};

                $@ and $attr_ref->{ref}{${$new_obj}} = $attr_ref->{default};
                next INIT;
            }
            if (defined $attr_ref->{init_arg}) {
                # Record missing init_arg ...
                push @missing_inits,
                     "Missing initializer label for $base_class: "
                     . "'$attr_ref->{init_arg}'.\n";
                push @suss_keys, keys %{$arg_set};
            }
        }
    }

    croak @missing_inits, _mislabelled(@suss_keys),
          'Fatal error in constructor call'
                if @missing_inits;

    $_->() for @start_methods;

    return $new_obj;
}


# Copied form Class::Std for performance
my %_hierarchy_of;

sub _hierarchy_of {
    my ($class) = @_;

    return @{$_hierarchy_of{$class}} if exists $_hierarchy_of{$class};

    no strict 'refs';

    my @hierarchy = $class;
    my @parents   = @{$class.'::ISA'};

    while (defined (my $parent = shift @parents)) {
        push @hierarchy, $parent;
        push @parents, @{$parent.'::ISA'};
    }

    # only sort if sorting is of any interest
    # BIG speedup for classes with a long linear inheritance tree -
    # may cause trouble with diamond inheritance.
    # Sorting must be disabled by user
    if (! exists $destroy_isa_unsorted_of{$class}) {
        my %seen;
        # maybe applying the Schwarzian transform could help?
        # ... and sort {} grep {} @list runs through the list twice...
        return @{$_hierarchy_of{$class}} =
            sort { $a->isa($b) ? -1
                   : $b->isa($a) ? +1
                   :                0
                   }
                   grep { ! exists $seen{$_} and $seen{$_} = 1 } @hierarchy;
    }
    else {
        my %seen;
        return @{$_hierarchy_of{$class}} = grep { ! exists $seen{$_} and $seen{$_} = 1 } @hierarchy;
    }
}

# DESTROY looks a bit cryptic, thus needs to be explained...
#
# It performs the following tasks:
# - traverse the @ISA hierarchy
#   - for every base class
#       - call DEMOLISH if there is such a method with $_[0], ${$_[0]} as
#         arguments (read as: $self, $ident).
#       - delete the element with key ${ $_[0] } (read as: $ident)from all :ATTR hashes
#
sub DESTROY {
    my $ident = ${$_[0]};
    my $class = ref $_[0];
    push @_, $ident;
    # Shortcut: check @ISA - saves us a method call if 0...
#    DEMOLISH: for my $base_class (scalar @{ "$class\::ISA" }
#        ? Class::Std::_hierarchy_of($class)
#        : ($class) ) {
    no strict qw(refs);
    for my $base_class (exists $_hierarchy_of{$class} ? @{$_hierarchy_of{$class}} : _hierarchy_of($class)) {
        # call by & to tell perl that it doesn't need to put up a new argument
        # stack
        &{"$base_class\::DEMOLISH"}
            if ( exists(&{"$base_class\::DEMOLISH"}) );

        delete $_->{ref}->{ $ident }
            for (@{$attribute{$base_class}});
   }
    # call with @_ as arguments - dirty but fast...
    &Class::Std::Fast::_cache if exists($do_cache_class_of{ $class });
}

# Maybe we could speed up DESTROY by putting specific DESTROY methods
# into Class::Std::Fast classes via symbol table

sub _cache {
    push @{ $object_cache_of{ ref $_[0] }}, bless $_[0], ref $_[0];
}

# clean out cache method to prevent it being called in global destruction
sub END {
    no warnings qw(redefine);
    *Class::Std::Fast::_cache = sub {};
}

# save away real can. We need can() [the real one] in
# Class::Std::Fast::Storable - implementing STORBALE_freeze_pre / post
# via AUTOMETHOD is a bad idea, anyway...

sub real_can;
# *real_can = \&CORE::UNIVERSAL::can;

# Override can to make it work with AUTOMETHODs
# Slows down can() for all objects
{
    my $real_can = \&UNIVERSAL::can;
    no warnings qw(redefine once);
    *UNIVERSAL::can = sub {
        defined $_[0] or return;
        my ($invocant, $method_name) = @_;

        if (my $sub_ref = $real_can->(@_)) {
            return $sub_ref;
        }

        # call to Class::Std::_hierarchy_of replaced by hash lookup
        for my $parent_class ( exists $_hierarchy_of{ ref $invocant || $invocant }
            ? @{ $_hierarchy_of{ ref $invocant || $invocant }}
            : Class::Std::Fast::_hierarchy_of(ref $invocant || $invocant) ) {
            no strict 'refs';
            if (my $automethod_ref = *{$parent_class.'::AUTOMETHOD'}{CODE}) {
                local $CALLER::_ = $_;
                local $_ = $method_name;
                if (my $method_impl = $automethod_ref->(@_)) {
                    return sub { my $inv = shift; $inv->$method_name(@_) }
                }
            }
        }

        return;
    };
}

1;

__END__