view release on metacpan or  search on metacpan

lib/Class/Std/Fast.pm  view on Meta::CPAN

    # 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);