—

              
package WWW::Suffit::RefUtil;
use strict;
use utf8;
HideShow 213 lines of Pod
=encoding utf8
=head1 NAME
WWW::Suffit::RefUtil - Pure Perl Utility functions for checking references and data
=head1 SYNOPSIS
    use WWW::Suffit::RefUtil qw/ :all /;
=head1 DESCRIPTION
Pure Perl Utility functions for checking references and data
=head2 AS
The 'as' functions are introduced by the C<:as> import tag, which check
the type of passed argument and returns it as required type
=over 4
=item as_array_ref
This method returns the argument as a array reference
    my $arr = as_array_ref( "foo" ); # ['foo']
    my $arr = as_array_ref( "foo", "bar" ); # ['foo', 'bar']
    my $arr = as_array_ref( ["foo", "bar"] ); # ['foo', 'bar']
    my $arr = as_array_ref(); # []
    my $arr = as_array_ref(undef); # []
    my $arr = as_array_ref([undef]); # [undef]
=item as_array, as_list
This method returns argument as array-reference (see L</"as_array_ref">) or regular array (list) in list context
    my $arr = as_array( "foo", "bar" ); # ['foo', 'bar']
    my @arr = as_array( "foo", "bar" ); # ('foo', 'bar')
=item as_first, as_first_val
This method returns the first scalar value from argument(s)
    my $foo = as_first( [qw/foo bar baz/] );
    my $foo = as_first( qw/foo bar baz/ );
=item as_hash_ref
This method returns the argument as a hash reference
    my $hash = as_hash_ref( {foo => 'one'} ); {foo => 'one'}
    my $hash = as_hash_ref( foo => 'one', bar => 2 );
        # {foo => 'one', bar => 2 }
    my $hash = as_hash_ref(); # {}
    my $hash = as_hash_ref(undef); # {}
=item as_hash
This method returns argument as hash-reference (see L</"as_hash_ref">) or regular hash in list context
    my $hash = as_hash( "foo", "bar" ); # {'foo' => 'bar'}
    my %hash = as_hash( "foo", "bar" ); # ('foo', 'bar')
=item as_last, as_last_val, as_latest
This method returns the last scalar value from argument(s)
    my $baz = as_last( [qw/foo bar baz/] );
    my $baz = as_last( qw/foo bar baz/ );
=back
=head2 CHECK
Check functions are introduced by the C<:check> import tag, which check
the argument type and return a bool
=over 4
=item is_ref
Checks for a any reference
=item is_scalar_ref
Checks for a SCALAR reference
=item is_array_ref
Checks for an ARRAY reference
=item is_hash_ref
Checks for a HASH reference
=item is_code_ref
Checks for a CODE reference
=item is_glob_ref
Checks for a GLOB reference
=item is_regexp_ref, is_regex_ref, is_rx
Checks for a regular expression reference generated by the C<qr//> operator
=item is_value
Checks whether I<value> is a primitive value, i.e. a defined, non-ref, and
non-type-glob value
=item is_string
Checks whether I<value> is a string with non-zero-length contents,
equivalent to is_value($value) && length($value) > 0
=item is_number
Checks whether I<value> is a number
=item is_integer, is_int8, is_int16, is_int32, is_int64
Checks whether I<value> is an integer
=item is_undef
Checks for a undef value
=back
=head2 VOID
Void functions are introduced by the C<:void> import tag, which check
the argument type in void value and return a bool
=over 4
=item is_void
    print "Void" if is_void({});
Returns true if the structure contains useful data.
Useful data - this data is different from the value undef
=item isnt_void
    print "NOT Void" if isnt_void({foo=>undef});
Returns true if the structure does not contain any nested useful data.
Useful data - this data is different from the value undef
=back
=head2 FLAG
=over 4
=item is_false_flag
    print "Disabled" if is_false_flag("off");
If specified argument value is set to false then will be normalised to 1.
The following values will be considered as false:
    no, off, 0, false, disable
This effect is case-insensitive, i.e. both "No" or "no" will result in 1.
=item is_true_flag
    print "Enabled" if is_true_flag("on");
If specified argument value is set to true then will be normalised to 1.
The following values will be considered as true:
    yes, on, 1, true, enable
This effect is case-insensitive, i.e. both "Yes" or "yes" will result in 1.
=back
=head1 HISTORY
See C<Changes> file
=head1 TO DO
See C<TODO> file
=head1 SEE ALSO
L<Data::Util::PurePerl>, L<Params::Classify>, L<Ref::Util>, L<CTK::TFVals>, L<CTK::ConfGenUtil>
=head1 AUTHOR
Serż Minus (Sergey Lepenkov) L<https://www.serzik.com> E<lt>abalama@cpan.orgE<gt>
=head1 COPYRIGHT
Copyright (C) 1998-2023 D&D Corporation. All Rights Reserved
=head1 LICENSE
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See C<LICENSE> file and L<https://dev.perl.org/licenses/>
=cut
our $VERSION = '1.02';
use base qw/Exporter/;
our @EXPORT = (qw/
        is_ref is_undef
        is_scalar_ref is_array_ref is_hash_ref is_code_ref
        is_glob_ref is_regexp_ref is_regex_ref is_rx
        is_value is_string is_number is_integer
        is_int8 is_int16 is_int32 is_int64
    /);
# Required
our @EXPORT_OK = (qw/
        is_void isnt_void
        is_true_flag is_false_flag
        as_array as_list as_array_ref as_hash as_hash_ref
        as_first as_first_val as_last as_last_val as_latest
    /, @EXPORT);
# Tags
our %EXPORT_TAGS = (
        all      => [@EXPORT_OK],
        check    => [@EXPORT],
        void     => [qw/
            is_void isnt_void
        /],
        flag     => [qw/
            is_true_flag is_false_flag
        /],
        as       => [qw/
            as_array as_list as_array_ref as_hash as_hash_ref
            as_first as_first_val as_last as_last_val as_latest
        /],
    );
use constant MAX_DEPTH => 32;
# Base functions
sub is_ref { ref($_[0]) ? 1 : 0 }
sub is_undef { !defined($_[0]) }
sub is_scalar_ref { ref($_[0]) eq 'SCALAR' || ref($_[0]) eq 'REF' }
sub is_array_ref { ref($_[0]) eq 'ARRAY' }
sub is_hash_ref { ref($_[0]) eq 'HASH' }
sub is_code_ref { ref($_[0]) eq 'CODE' }
sub is_glob_ref { ref($_[0]) eq 'GLOB' }
sub is_regexp_ref { ref($_[0]) eq 'Regexp' }
sub is_regex_ref { goto &is_regexp_ref }
sub is_rx { goto &is_regexp_ref }
sub is_value { defined($_[0]) && !ref($_[0]) && ref(\$_[0]) ne 'GLOB' }
sub is_string { defined($_[0]) && !ref($_[0]) && (ref(\$_[0]) ne 'GLOB') && length($_[0]) }
sub is_number { (defined($_[0]) && !ref($_[0]) && $_[0] =~ /^[+-]?(?=\d|\.\d)\d*(\.\d*)?(?:[Ee](?:[+-]?\d+))?$/) ? 1 : 0 }
sub is_integer { (defined($_[0]) && !ref($_[0]) && $_[0] =~ /^[+-]?\d+$/) ? 1 : 0 }
sub is_int8 { (defined($_[0]) && !ref($_[0]) && ($_[0] =~ /^[0-9]{1,3}$/) && ($_[0] < 2**8)) ? 1 : 0 }
sub is_int16 { (defined($_[0]) && !ref($_[0]) && ($_[0] =~ /^[0-9]{1,5}$/) && ($_[0] < 2**16)) ? 1 : 0 }
sub is_int32 { (defined($_[0]) && !ref($_[0]) && ($_[0] =~ /^[0-9]{1,10}$/) && ($_[0] < 2**32)) ? 1 : 0 }
sub is_int64 { (defined($_[0]) && !ref($_[0]) && $_[0] =~ /^[0-9]{1,20}$/) ? 1 : 0 }
# Extended
sub is_void {
    my $struct = shift;
    my $depth = shift || 0;
    return 1 unless defined($struct); # CATCHED! THIS IS REAL UNDEFINED VALUE
    return 0 if defined($struct) && !ref($struct); # VALUE, NOT REFERENCE
    if (is_int8($depth) && $depth > 0) {
        return 1 unless is_int8($depth);
    } else {
        return 1 unless is_int8($depth);
    }
    $depth++;
    return 0 if $depth >= MAX_DEPTH; # Exit from the recursion
    my $t = ref($struct);
    if ($t eq 'SCALAR') {
        return is_void($$struct, $depth)
    } elsif ($t eq 'ARRAY') {
        for (@$struct) {
            return 0 unless is_void($_, $depth);
        }
        return 1; # DEFINED DATA NOT FOUND - VOID
    } elsif ($t eq 'HASH') {
        return 0 if keys(%$struct);
        return 1; # DEFINED DATA NOT FOUND - VOID
    }
    # CODE, REF, GLOB, LVALUE, FORMAT, IO, VSTRING and Regexp are not supported here
    return 0; # NOT VOID
}
sub isnt_void {is_void(@_) ? 0 : 1}
sub is_true_flag {
    my $f = shift || return 0;
    return $f =~ /^(on|y|true|enable|1)/i ? 1 : 0;
}
sub is_false_flag {
    my $f = shift || return 1;
    return $f =~ /^(off|n|false|disable|0)/i ? 1 : 0;
}
# As
sub as_array_ref {
    return [] unless scalar @_; # if no args
    return [@_] if scalar(@_) > 1; # if too many args
    return [] unless defined($_[0]); # if value is undef
    if (ref($_[0]) eq 'ARRAY') { return $_[0] } # Array
    elsif (ref($_[0]) eq 'HASH') { return [%{$_[0]}] } # Hash
    return [$_[0]];
}
sub as_array {
    my $r = as_array_ref(@_);
    return wantarray ? @$r : $r;
}
sub as_list { goto &as_array }
sub as_hash_ref {
    return {} unless scalar @_; # if no args passed
    return {@_} unless scalar(@_) % 2; # if even (not odd) args passed
    return {} unless defined($_[0]); # if arg is undef
    if (ref($_[0]) eq 'HASH') { return $_[0] } # Hash
    return {};
}
sub as_hash {
    my $r = as_hash_ref(@_);
    return wantarray ? %$r : $r;
}
sub as_first {
    return undef unless defined $_[0];
    my $r = as_array_ref(@_);
    return undef unless exists($r->[0]) && defined($r->[0]);
    my $v = $r->[0];
    if (!ref($v)) { return $v } # No ref
    elsif (ref($v) eq 'SCALAR' || ref($v) eq 'REF') { return $$v } # Scalar ref
    return $v;
}
sub as_first_val { goto &as_first }
sub as_last {
    return undef unless defined $_[0];
    my $r = as_array_ref(@_);
    return undef unless exists($r->[0]) && defined($r->[0]);
    my $v = $r->[-1];
    if (!ref($v)) { return $v } # No ref
    elsif (ref($v) eq 'SCALAR' || ref($v) eq 'REF') { return $$v } # Scalar ref
    return $v;
}
sub as_last_val { goto &as_last }
sub as_latest { goto &as_last }
1;
__END__