view release on metacpan or  search on metacpan

lib/Module/Generic/Dynamic.pm  view on Meta::CPAN

##----------------------------------------------------------------------------
## Module Generic - ~/lib/Module/Generic/Dynamic.pm
## Version v1.2.4
## Copyright(c) 2023 DEGUEST Pte. Ltd.
## Author: Jacques Deguest <jack@deguest.jp>
## Created 2021/03/20
## Modified 2023/11/18
## All rights reserved
## 
## This program is free software; you can redistribute  it  and/or  modify  it
## under the same terms as Perl itself.
##----------------------------------------------------------------------------
package Module::Generic::Dynamic;
BEGIN
{
    use strict;
    use warnings;
    use parent qw( Module::Generic );
    use warnings::register;
    use vars qw( $VERSION $DEBUG );
    use Scalar::Util ();
    # use Class::ISA;
    our $DEBUG = 0;
    our $VERSION = 'v1.2.4';
};

use strict;
no warnings 'redefine';

sub new
{
    my $this = shift( @_ );
    my $class = ref( $this ) || $this;
    my $self = bless( {} => $class );
    my $data = $self->{_data} = {};
    # A Module::Generic object standard parameter
    $self->{_data_repo} = '_data';
    my $hash = {};
    @_ = () if( scalar( @_ ) == 1 && !defined( $_[0] ) );
    if( scalar( @_ ) == 1 && ( Scalar::Util::reftype( $_[0] ) // '' ) eq 'HASH' )
    {
        $hash = shift( @_ );
        $self->{debug} = $DEBUG if( $DEBUG && !CORE::exists( $hash->{debug} ) );
    }
    elsif( @_ )
    {
        CORE::warn( "Parameter provided is not an hash reference: '", join( "', '", @_ ), "'\n" ) if( $this->_warnings_is_enabled );
    }
    my $make_class = sub
    {
        my $k = shift( @_ );
        my $new_class = $k;
        $new_class =~ tr/-/_/;
        $new_class =~ s/\_{2,}/_/g;
        $new_class = join( '', map( ucfirst( lc( $_ ) ), split( /\_/, $new_class ) ) );
        $new_class = "${class}\::${new_class}";
        ## Sanitise the key which will serve as a method name
        my $clean_field = $k;
        $clean_field =~ tr/-/_/;
        $clean_field =~ s/\_{2,}/_/g;
        $clean_field =~ s/[^a-zA-Z0-9\_]+//g;
        $clean_field =~ s/^\d+//g;
        my $perl = <<EOT;
package $new_class;
BEGIN
{
    use strict;
    use Module::Generic;
    use parent -norequire, qw( Module::Generic::Dynamic );
};

1;

EOT
        local $@;
        my $rc = eval( $perl );
        die( "Unable to dynamically create module $new_class: $@" ) if( $@ );
        return( $new_class, $clean_field );
    };
    
    local $@;
    foreach my $k ( sort( keys( %$hash ) ) )
    {
        if( ref( $hash->{ $k } ) eq 'HASH' )
        {
            my( $new_class, $clean_field ) = $make_class->( $k );
            next unless( length( $clean_field ) );
            eval( "sub ${new_class}::${clean_field} { return( shift->_set_get_object( '$clean_field', '$new_class', \@_ ) ); }" );
            die( $@ ) if( $@ );
            my $rv = $self->$clean_field( $hash->{ $k } );
            return( $self->pass_error ) if( !defined( $rv ) && $self->error );
        }
        # elsif( ref( $hash->{ $k } ) eq 'ARRAY' )
        elsif( $self->_is_array( $hash->{ $k } ) )