view release on metacpan or  search on metacpan

lib/Validation/Class/Util.pm  view on Meta::CPAN

        }

        no strict 'refs';
        no warnings 'redefine';

        my $class = caller(0);

        *{"$class\::$attr"} = $code;

    }

    return;

}

sub hold {

    my ( $attrs, $default ) = @_;

    return unless $attrs;

    confess "Error creating accessor, default is required and must be a coderef"
        if ref $default ne 'CODE';

    $attrs = [$attrs] unless ref $attrs eq 'ARRAY';

    for my $attr (@$attrs) {

        confess "Error creating accessor '$attr', name has invalid characters"
            unless $attr =~ /^[a-zA-Z_]\w*$/;

        my $code;

        $code = sub {

            if ( @_ == 1 ) {
                return $_[0]->{$attr} if exists $_[0]->{$attr};
                return $_[0]->{$attr} = $default->( $_[0] );
            }

            # values are read-only cannot be changed
            confess "Error attempting to modify the read-only attribute ($attr)";

        };

        no strict 'refs';
        no warnings 'redefine';

        my $class = caller(0);

        *{"$class\::$attr"} = $code;

    }

    return;

}

sub import {

    strict->import;
    warnings->import;

    __PACKAGE__->export_to_level(1, @_);

    return;

}

sub isa_arrayref {

    return "ARRAY" eq ref(shift) ? 1 : 0;

}

sub isa_classref {

    my ($object) = @_;

    return blessed(shift) ? 1 : 0;

}

sub isa_coderef {

    return "CODE" eq ref(shift) ? 1 : 0;

}

sub isa_hashref {

    return "HASH" eq ref(shift) ? 1 : 0;

}

sub isa_listing {

    return "Validation::Class::Listing" eq ref(shift) ? 1 : 0;

}

sub isa_mapping {

    return "Validation::Class::Mapping" eq ref(shift) ? 1 : 0;

}

sub isa_prototype {

    return prototype_registry->has(shift) ? 1 : 0;

}

sub isa_regexp {

    return "REGEXP" eq uc(ref(shift)) ? 1 : 0;

}

sub prototype_registry {