File Coverage

blib/lib/Extender.pm

Criterion	Covered	Total	%
statement	155	181	85.6
branch	36	70	51.4
condition	15	47	31.9
subroutine	30	34	88.2
pod	8	8	100.0
total	244	340	71.7

#!/usr/bin/perl
################################################################################
#
#   Extender - Reference-Scalar-Object method Extender.
#
#   (C) 2024 OnEhIppY - Domero Software
#
################################################################################
package Extender;

use strict;
use warnings;
use Exporter 'import';

our $VERSION = '1.01';
our @EXPORT = qw(Extend Extends GlobExtends Alias AddMethod Decorate ApplyRole InitHook Unload);

################################################################################

sub Extend {
    my ($object, $module, @methods) = @_;

    # Check if the module is already loaded
    unless (exists $INC{$module} || defined *{"${module}::"}) {
        eval "require $module";
        return undef if $@;
    }

    # Get list of functions exported by the module
    no strict 'refs';

    # Add each specified function (or all if none specified) as a method to the object
    foreach my $func ($#methods > -1 ? @methods : @{"${module}::EXPORT"}) {
        *{ref($object) . "::$func"} = sub { unshift @_, $object; goto &{"${module}::$func"} };
    }

    return $object;
}

################################################################################

sub Extends {
    my ($object, %extend) = @_;

    for my $name (keys %extend) {
        # Create the method
        no strict 'refs';
        my $package = ref($object) || $object;  # Get the package or class name

        if (ref $extend{$name} eq 'CODE') {
            # If $extend{$name} is a coderef, directly assign it
            *{$package . "::$name"} = sub {
                my $self = shift;
                return $extend{$name}->($self, @_);
            };
        }
        elsif (ref $extend{$name} eq 'SCALAR' && defined ${$extend{$name}} && ref ${$extend{$name}} eq 'CODE') {
            # If $method_ref is a reference to a scalar containing a coderef
            *{$package . "::$name"} = sub {
                my $self = shift;
                return ${$extend{$name}}->($self, @_);
            };
        }
        else {
            die "Invalid method reference provided for $name. Expected CODE or reference to CODEREF but got ".(ref($extend{$name})).".";
        }
    }

    return $object;
}

################################################################################

sub Alias {
    my ($object, $existing_method, $new_name) = @_;

    # Check if $object is a blessed reference
    die "Not a valid object reference" unless ref $object && ref $object ne 'HASH' && ref $object ne 'ARRAY' && ref $object ne 'SCALAR';

    # Validate $existing_method
    die "Invalid method name. Method name must be a string" unless defined $existing_method && $existing_method =~ /^\w+$/;

    # Validate $new_name
    die "Invalid alias name. Alias name must be a string" unless defined $new_name && $new_name =~ /^\w+$/;

    # Create the alias within the package where $object is blessed into
    {
        no strict 'refs';
        no warnings 'redefine';
        my $pkg = ref($object);
        *{$pkg . "::$new_name"} = \&{$pkg . "::$existing_method"};
    }

    return $object;
}

################################################################################

sub AddMethod {
    my ($object, $method_name, $code_ref) = @_;

    # Validate method name
    die "Method name must be a string" unless defined $method_name && $method_name =~ /^\w+$/;

    # Validate code reference
    die "Code reference required" unless ref($code_ref) eq 'CODE';

    no strict 'refs';
    *{ref($object) . "::$method_name"} = $code_ref;

    return $object;
}

################################################################################

sub Decorate {
    my ($object, $method_name, $decorator) = @_;

    # Check if $object is an object or a class name
    my $is_object = ref($object) ? 1 : 0;

    # Fetch the original method reference
    my $original_method;
    if ($is_object) {
        no strict 'refs';
        my $coderef = $object->can($method_name);
        die "Method $method_name does not exist in the object" unless $coderef;
        $original_method = $coderef;
    } else {
        no strict 'refs';
        $original_method = *{$object . '::' . $method_name}{CODE};
        die "Method $method_name does not exist in the package" unless defined $original_method;
    }

    # Replace the method with a decorated version
    if ($is_object) {
        no strict 'refs';
        my $class = ref $object;
        no warnings 'redefine';
        *{$class . "::$method_name"} = sub {
            my $self = shift;
            return $decorator->($self, $original_method, @_);
        };
    } else {
        no strict 'refs';
        no warnings 'redefine';
        *{$object . "::$method_name"} = sub {
            my $self = shift;
            return $decorator->($self, $original_method, @_);
        };
    }

    return $object
}

################################################################################

sub ApplyRole {

    my ($object, $role_class) = @_;

    die "Object must be provided for role application" unless defined $object;
    die "Role class must be specified" unless defined $role_class && $role_class =~ /^\w+$/;

    # Ensure role class is loaded
    unless (exists $INC{$role_class} || defined *{"${role_class}::"}) {
        eval "require $role_class";
        return undef if $@;
    }

    # Apply the role's methods to the object if the apply method exists
    eval {
        no strict 'refs';
        my $apply_method = $role_class->can('apply');
        if ($apply_method) {
            $apply_method->($role_class, $object);
        } else {
            die "Role $role_class does not implement apply method";
        }
    };
    if ($@) {
        if ($@ =~ /Role $role_class does not implement apply method/) {
            return undef;  # Return gracefully if the apply method is missing
        } else {
            die "Failed to apply role $role_class to object: $@";
        }
    }

    return $object
}

################################################################################

sub InitHook {
    my ($class, $hook_name, $hook_code) = @_;

    # Validate arguments
    die "Class name must be specified" unless defined $class && $class =~ /^\w+$/;
    die "Unsupported hook name '$hook_name'" unless $hook_name =~ /^(INIT|DESTRUCT)$/;

    no strict 'refs';

    # Initialize hooks array if not already present
    $class->{"_${hook_name}_hooks"} ||= [];

    # Register the hook code
    push @{$class->{"_${hook_name}_hooks"}}, $hook_code;

    # If INIT hook, wrap the new method to execute hooks
    if ($hook_name eq 'INIT') {
        my $original_new = $class->can('new');
        no warnings 'redefine';
        *{$class . "::new"} = sub {
            my $self = $original_new->(@_);
            for my $hook (@{$class->{"_INIT_hooks"} || []}) {
                $hook->($self);
            }
            return $self;
        };
    }

    # If DESTRUCT hook, wrap the DESTROY method to execute hooks
    elsif ($hook_name eq 'DESTRUCT') {
        my $original_destroy = $class->can('DESTROY');
        no warnings 'redefine';
        *{$class . "::DESTROY"} = sub {
            my $self = shift;
            for my $hook (@{$class->{"_DESTRUCT_hooks"} || []}) {
                $hook->($self);
            }
            $original_destroy->($self) if $original_destroy && ref($self);
        };
    }

    return $class;
}

################################################################################

sub Unload {
    my ($object, @methods) = @_;

    # Check if $object is a valid reference and not a CODE reference
    my $ref_type = ref $object;
    die "Not a valid object reference" unless $ref_type && $ref_type ne 'CODE';

    # Validate @methods
    die "No methods specified for unloading" unless @methods;

    # Determine the package or type of the reference
    my $pkg = ref $object;
    if ($ref_type eq 'GLOB') {
        # Use the GLOB reference directly as the package
        $pkg = *{$object}{PACKAGE};
    }
    die "Cannot determine package for object reference" unless $pkg;

    no strict 'refs';

    foreach my $method (@methods) {
        next unless defined $method;  # Skip if method is undefined

        # Check if the method exists in the package's symbol table
        if (exists ${$pkg."::"}{$method}) {
            # Remove the method from the package's symbol table
            delete ${$pkg."::"}{$method};
        }
    }

    return $object;
}

################################################################################

1; # EOF Extender.pm (C) 2024 OnEhIppY - Domero Sofware