File Coverage

blib/lib/LooksLike.pm

Criterion	Covered	Total	%
statement	115	121	95.0
branch	93	148	62.8
condition	19	24	79.1
subroutine	21	22	95.4
pod	18	18	100.0
total	266	333	79.8

use v5.12.0;

use strict;
use warnings;

package LooksLike;
# ABSTRACT: See if a number looks like a number, integer, numeric, infinity, not-a-number, zero, non-zero, positive, negative, even, or odd.


use B ();


our $VERSION = 'v0.20.060'; # VERSION


my $digits = '[0123456789]';
my $int    = qr/$digits+/;
my $bits   = '[01]';
my $binary = qr/0b$bits+/i;
my $octits = '[01234567]';
my $octal  = qr/0$octits+/;
my $xigits = '[[:xdigit:]]';
my $hex    = qr/0x$xigits+/i;


### The following can only be tested with regular expressions ###


our $Binary  = $binary;


sub binary {
    local $_ = shift if @_;
    return undef unless defined;
    return undef if ref;

    return /\A\s*$Binary\s*\z/;
}



our $Octal   = $octal;


sub octal {
    local $_ = shift if @_;
    return undef unless defined;
    return undef if ref;

    return /\A\s*$Octal\s*\z/;
}



our $Hex     = $hex;


sub hex {
    local $_ = shift if @_;
    return undef unless defined;
    return undef if ref;

    return /\A\s*$Hex\s*\z/;
}



our $Decimal = qr/[+-]?(?:$int(?:\.$digits*)?|\.$int)/;


sub decimal {
    local $_ = shift if @_;
    return undef unless defined;
    return undef if ref;

    return /\A\s*$Decimal\s*\z/;
}



my $infinity = 8888e8888;
my $inf = do {
    my $inf = qr/inf(?:inity)?/i;
    if ( $^O eq 'MSWin32' || $^V ge v5.22.0 ) {
        # Some versions of Perl accept a broader
        # range of representations of infinity.
        # 1.#infinity, 1.#inf*
        my $dotinf = qr/1\.\#inf(?:inity|0*)/i;
        qr/$dotinf|$inf/;
    } elsif ( $infinity !~ $inf ) {
        $inf = join( '|',
            sort { length($b) <=> length($a) } $inf, quotemeta($infinity)
        );
        qr/$inf/;
    } else {
        $inf;
    }
};

my $notanumber = $infinity / $infinity;
my $nan = do {
    my $nan = qr/nan/i;
    if ( $^O eq 'MSWin32' || $^V ge v5.22.0 ) {
        # Some versions of Perl accept a broader
        # range of representations of NaN.
        # https://en.wikipedia.org/wiki/NaN#Display
        # nan[qs]?, [qs]nan,
        # nan\($int\), nan\($hex\), nan\(\"$octal\"\), nan\($binary\)
        # 1\.\#nan[qs]?, 1\.\#[qs]nan, 1\.\#ind0*
        my $nan    = qr/nan[qs]?|[qs]nan/i;
        my $nandig = qr/$nan\((?:$binary|\"$octal\"|$hex|$int)\)/i;
        my $ind    = qr/ind0*/i;
        my $dotnan = qr/1\.\#(?:$nandig|$nan|$ind)/;
        qr/$dotnan|$nandig|$nan/
    } elsif ( $notanumber !~ $nan ) {
        $nan = join( '|',
            sort { length($b) <=> length($a) } $nan, quotemeta($notanumber)
        );
        qr/$nan/;
    } else {
        $nan;
    }
};

sub grok_number {
    local $_ = shift if @_;
    return unless defined;
    return if ref;

    my ( $sign, $number, $frac, $exp_sign, $exp_number, $excess );

    ( $sign, $number ) = m/\A\s*([+-]?)($inf|$nan|$int?)/cg;
    if ( $number =~ m/\A(?:$inf|$nan)\z/ ) {
        $frac = $1
            if ( $^V ge v5.22.0
            && $number =~ s/\A1\.\#//
            && $number =~ s/(?:\(($binary|\"$octal\"|$hex|$int)\)|0*)\z// );

        # There should be no additional fractional
        # nor exponent portion to parse.
    } else {
        ( $frac, $exp_sign, $exp_number )
            = /\G(?:\.($int?))?(?:[Ee]([+-]?)($int))?/cg;
    }
    if ( !length($number) && !length($frac) ) {
        # Nope, this is not a legitimate number.
        $sign = $number = $frac = $exp_sign = $exp_number = undef;
        pos() = 0;
    }
    m/\G\s*/cg if pos();
    $excess = substr( $_, pos() );

    return ( $sign, $number, $frac, $exp_sign, $exp_number, $excess );
}


# The following can be tested with mathematics or regular expressions.


our $Infinity = qr/[+-]?$inf/;


sub infinity {
    local $_ = shift if @_;
    return undef unless defined;
    return undef if ref;

    if ( B::svref_2object( \$_ )->FLAGS & B::SVp_NOK ) {
        return $_ == $infinity || $_ == -$infinity;
    }
    return /\A\s*$Infinity\s*\z/;
}



our $NaN = qr/[+-]?$nan/;


sub nan {
    local $_ = shift if @_;
    return undef unless defined;
    return undef if ref;

    if ( B::svref_2object( \$_ )->FLAGS & B::SVp_NOK ) {
        return not defined( $_ <=> 0 );
    }
    return /\A\s*$NaN\s*\z/;
}



our $Integer = qr/[+-]?$int/;


sub integer {
    local $_ = shift if @_;
    return undef unless defined;
    return undef if ref;

    my $flags = B::svref_2object( \$_ )->FLAGS;
    if ( $flags & B::SVp_IOK && !( $flags & B::SVp_NOK ) ) {
        return 1;
    }
    return /\A\s*$Integer\s*\z/;
}



my $exponent = qr/[Ee]$Integer/;
our $Numeric = qr/$Decimal$exponent?/;


sub numeric {
    local $_ = shift if @_;
    return undef unless defined;
    return undef if ref;

    if ( B::svref_2object( \$_ )->FLAGS & ( B::SVp_NOK | B::SVp_IOK ) ) {
        return defined( $_ <=> 0 ) && $_ != $infinity && $_ != -$infinity;
    }
    return /\A\s*$Numeric\s*\z/;
}



# NaN is not comparable.
sub comparable {
    local $_ = shift if @_;
    return undef unless defined;
    return undef if ref;

    if ( B::svref_2object( \$_ )->FLAGS & ( B::SVp_NOK | B::SVp_IOK ) ) {
        return defined( $_ <=> 0 );
    }
    return /\A\s*(?:$Infinity|$Integer|$Numeric)\s*\z/;
}



sub number {
    local $_ = shift if @_;
    return undef unless defined;
    return undef if ref;

    if ( B::svref_2object( \$_ )->FLAGS & ( B::SVp_NOK | B::SVp_IOK ) ) {
        return 1;
    }
    return /\A\s*(?:$Infinity|$Integer|$NaN|$Numeric)\s*\z/;
}



# 0, 0.0*, .0+, 0E0, 0.0E0, .0E100, ...
my $zero  = qr/(?:0+(?:[.]0*)?|[.]0+)$exponent?/;
our $Zero = qr/[+-]?$zero/;


sub zero {
    local $_ = shift if @_;
    return undef unless defined;
    return undef if ref;

    if ( B::svref_2object( \$_ )->FLAGS & ( B::SVp_NOK | B::SVp_IOK ) ) {
        return $_ == 0;
    }
    return /\A\s*$Zero\s*\z/;
}



my $nonzero = do {
    my $digits19     = '[123456789]';
    my $nonzeroint   = qq/$digits*$digits19+$digits*/;
    my $nonzerofloat = qq/[.]$nonzeroint/;
    my $nonzeronum   = qr/$nonzeroint(?:[.]$digits*)?|$digits*$nonzerofloat/;
    qr/$inf|$nonzeronum$exponent?/;
};
our $NonZero = qr/[+-]?$nonzero/;


sub nonzero {
    local $_ = shift if @_;
    return undef unless defined;
    return undef if ref;

    if ( B::svref_2object( \$_ )->FLAGS & ( B::SVp_NOK | B::SVp_IOK ) ) {
        return $_ != 0;
    }
    return /\A\s*$NonZero\s*\z/;
}



our $Positive = qr/[+]?$nonzero/;


# Returns true if number would be greater than 0
sub positive {
    local $_ = shift if @_;
    return undef unless defined;
    return undef if ref;

    if ( B::svref_2object( \$_ )->FLAGS & ( B::SVp_NOK | B::SVp_IOK ) ) {
        return $_ > 0;
    }
    return /\A\s*$Positive\s*\z/;
}


our $Negative = qr/[-]$nonzero/;


# Returns true if number would be less than 0
sub negative {
    local $_ = shift if @_;
    return undef unless defined;
    return undef if ref;

    if ( B::svref_2object( \$_ )->FLAGS & ( B::SVp_NOK | B::SVp_IOK ) ) {
        return $_ < 0;
    }
    return /\A\s*$Negative\s*\z/;
}



my $evens = '[02468]';
our $Even = qr/[+-]?$digits*$evens/;


# Returns true if integer would be divisible by 2
sub even {
    local $_ = shift if @_;
    return undef unless defined;
    return undef if ref;

    my $flags = B::svref_2object( \$_ )->FLAGS;
    if ( $flags & B::SVp_IOK && !( $flags & B::SVp_NOK ) ) {
        return 0 == ( $_ % 2 );
    }
    return /\A\s*$Even\s*\z/;
}



my $odds = '[13579]';
our $Odd = qr/[+-]?$digits*$odds/;


# Returns true if integer would not be divisible by 2
sub odd {
    local $_ = shift if @_;
    return undef unless defined;
    return undef if ref;

    my $flags = B::svref_2object( \$_ )->FLAGS;
    if ( $flags & B::SVp_IOK && !( $flags & B::SVp_NOK ) ) {
        return 0 != ( $_ % 2 );
    }
    return /\A\s*$Odd\s*\z/;
}


our %representation = (
     "infinity" =>  "inf",
    "-infinity" => "-inf",
     "nan"      =>  "nan",
);


sub representation {
    local $_ = shift if @_ % 2;
    return undef unless defined;
    return undef if ref;

    my %repr = ( %representation, @_ );

    return nan($_)                    ? $repr{"nan"}
        : infinity($_) ? positive($_) ? $repr{"infinity"}
                       :                $repr{"-infinity"}
        : exists( $repr{$_} )         ? $repr{$_}
        :                               $_
        ;
}

1;

__END__