view release on metacpan or  search on metacpan

lib/Class.pm  view on Meta::CPAN

    no strict 'refs';
    my $parent_symtab = \%{"${parent}::"};

    # Single pass with optimized checks
    for my $method (keys %$parent_symtab) {
        # Skip special methods and private methods quickly
        next if $SKIP_METHODS{$method};
        next if $method =~ /^_/;
        next if $method =~ /::$/;  # Skip nested packages

        # Skip if already defined in child or not a CODE ref in parent
        next if defined &{"${child}::${method}"};
        next unless defined &{"${parent}::${method}"};

        # Copy the method
        *{"${child}::${method}"} = \&{"${parent}::${method}"};
    }
}

sub _delete_build_cache {
    my ($class) = @_;
    delete $BUILD_METHODS_CACHE{$class};

    # Clear cache for all classes that inherit from this one
    for my $cached_class (keys %BUILD_METHODS_CACHE) {
        if (_inherits_from($cached_class, $class)) {
            delete $BUILD_METHODS_CACHE{$cached_class};
        }
    }

    # Also clear method copy cache for affected classes
    for my $cache_key (keys %METHOD_COPY_CACHE) {
        my ($child, $parent) = split(/\|/, $cache_key);
        if ($child eq $class || _inherits_from($child, $class)) {
            delete $METHOD_COPY_CACHE{$cache_key};
        }
    }
}

sub _inherits_from {
    my ($class, $parent) = @_;

    no strict 'refs';
    my @isa = @{"${class}::ISA"};

    return 1 if grep { $_ eq $parent } @isa;

    foreach my $direct_parent (@isa) {
        return 1 if _inherits_from($direct_parent, $parent);
    }

    return 0;
}

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

    # Enable strict and warnings
    strict->import;
    warnings->import;

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

    # Install new and extends
    no strict 'refs';
    *{"${caller}::new"}     = \&Class::new;
    *{"${caller}::extends"} = \&Class::extends;

    # optional extends => Parent
    if (@args && $args[0] eq 'extends') {
        $class->extends(@args[1..$#args]);
    }
}

=head1 NAME

Class - Lightweight Perl object system with parent-first BUILD and method copying

=head1 VERSION

Version v0.1.1

=head1 SYNOPSIS

    use Class;

    # Simple class with attributes and BUILD
    package Person;
    use Class;

    sub BUILD {
        my ($self, $attrs) = @_;
        $self->{full_name} = $attrs->{first} . ' ' . $attrs->{last};
    }

    package Employee;
    use Class;
    extends 'Person';

    sub BUILD {
        my ($self, $attrs) = @_;
        $self->{employee_id} = $attrs->{id};
    }

    # Create an object
    my $emp = Employee->new(first => 'John', last => 'Doe', id => 123);

    print $emp->{full_name};   # John Doe
    print $emp->{employee_id}; # 123

    # Using roles if Role.pm is available
    package Manager;
    use Class;