view release on metacpan or  search on metacpan

lib/Class/More.pm  view on Meta::CPAN

package Class::More;

use strict;
use warnings;
use version;

our $VERSION   = qv('v0.1.1');
our $AUTHORITY = 'cpan:MANWAR';

my %ACCESSOR_CACHE;
my %BUILD_ORDER_CACHE;
my %PARENT_LOADED_CACHE;
my %ALL_ATTRIBUTES_CACHE;
our %ATTRIBUTES;

sub _generate_fast_accessor {
    my ($attr_name) = @_;

    return $ACCESSOR_CACHE{$attr_name} ||= sub {
        $_[0]{$attr_name} = $_[1] if @_ > 1;
        return $_[0]{$attr_name};
    };
}

sub import {
    my ($class, @args) = @_;
    my $caller = caller;

    strict->import;
    warnings->import;

    no strict 'refs';

    # Install optimised new method
    *{"${caller}::new"} = _generate_optimised_constructor($caller);

    # Install has method
    *{"${caller}::has"} = \&_has;

    # Install extends method
    *{"${caller}::extends"} = \&_extends;

    # Load Role.pm if available
    eval { require Role };
    if (!$@) {
        *{"${caller}::with"} = \&Role::with;
        *{"${caller}::does"} = \&Role::does;
    }

    if (@args && $args[0] eq 'extends') {
        _extends($caller, @args[1..$#args]);
    }
}

sub _generate_optimised_constructor {
    my $class = shift;

    return sub {
        my $class = shift;
        my %args = @_;

        # Fast path: bless hashref directly for maximum speed
        my $self = bless {}, $class;

        # Get cached attributes
        my $class_attrs = _get_all_attributes_fast($class);

        # Ultra-fast path: no attributes, no BUILD methods
        unless (%$class_attrs) {
            my $build_methods = $BUILD_ORDER_CACHE{$class} ||= _compute_build_methods_fast($class);
            unless (@$build_methods) {
                # Absolute fastest path: just copy args and return
                %$self = %args;
                return $self;
            }
        }

        # Make args copy for defaults
        my %args_copy = %args;

        # Process attributes efficiently
        _process_attributes_ultra_fast($class, $self, \%args, \%args_copy, $class_attrs);

        # Copy remaining args
        while (my ($key, $value) = each %args) {
            $self->{$key} = $value unless exists $self->{$key};
        }

        # Call BUILD methods if any