File Coverage

blib/lib/Paranoid/Input.pm

Criterion	Covered	Total	%
statement	117	119	98.3
branch	59	72	81.9
condition	7	12	58.3
subroutine	12	12	100.0
pod	3	3	100.0
total	198	218	90.8

# Paranoid::Input -- Paranoid Input functions
#
# $Id: lib/Paranoid/Input.pm, 2.10 2022/03/08 00:01:04 acorliss Exp $
#
# This software is free software.  Similar to Perl, you can redistribute it
# and/or modify it under the terms of either:
#
#   a)     the GNU General Public License
#           as published by the
#          Free Software Foundation ; either version 1
#          , or any later version
#          , or
#   b)     the Artistic License 2.0
#          ,
#
# subject to the following additional term:  No trademark rights to
# "Paranoid" have been or are conveyed under any of the above licenses.
# However, "Paranoid" may be used fairly to describe this unmodified
# software, in good faith, but not as a trademark.
#
# (c) 2005 - 2020, Arthur Corliss ([e-mail])
# (tm) 2008 - 2020, Paranoid Inc. (www.paranoid.com)
#
#####################################################################

#####################################################################
#
# Environment definitions
#
#####################################################################

package Paranoid::Input;

use 5.008;

use strict;
use warnings;
use vars qw($VERSION @EXPORT @EXPORT_OK %EXPORT_TAGS);
use base qw(Exporter);
use Paranoid;
use Paranoid::Debug qw(:all);
use Carp;

($VERSION) = ( q$Revision: 2.10 $ =~ /(\d+(?:\.\d+)+)/sm );

@EXPORT      = qw(detaint stringMatch pchomp);
@EXPORT_OK   = ( @EXPORT, qw(NEWLINE_REGEX) );
%EXPORT_TAGS = ( all => [@EXPORT_OK], );

use constant NEWLINE_REGEX => qr#(?:\15\12|\15|\12)#so;

#####################################################################
#
# Module code follows
#
#####################################################################

sub pchomp (;\[$@%]) {

    # Purpose:  Platform neutral chomping
    # Returns:  same as chomp
    # Usage:    $n = pchomp($string);

    my ($ref) = @_;
    my $rv    = 0;
    my $nl    = NEWLINE_REGEX;
    my $e;

    # If no args were passed work on $_
    $ref = \$_ unless @_;

    # slurp-mode bypass
    return $rv unless defined $/;

    if ( ref $ref eq 'SCALAR' and defined $$ref ) {
        if ( $/ =~ /^$nl$/so ) {
            $e = length $$ref;
            $$ref =~ s/$nl$//so;
            $rv = $e - length $$ref;
        } else {
            $rv = chomp $$ref;
        }
    } elsif ( ref $ref eq 'ARRAY' ) {
        if ( $/ =~ /^$nl$/so ) {
            foreach (@$ref) {
                next unless defined;
                $e = length $_;
                $_ =~ s/$nl$//so;
                $rv += $e - length $_;
            }
        } else {
            $rv = chomp @$ref;
        }
    } elsif ( ref $ref eq 'HASH' ) {
        if ( $/ =~ /^$nl$/so ) {
            foreach ( keys %$ref ) {
                next unless defined $$ref{$_};
                $e = length $$ref{$_};
                $$ref{$_} =~ s/$nl$//so;
                $rv += $e - length $$ref{$_};
            }
        } else {
            $rv = chomp %$ref;
        }
    }

    return $rv;
}

our %regexes = (
    alphabetic   => qr/[a-z]+/si,
    alphanumeric => qr/[a-z0-9]+/si,
    alphawhite   => qr/[a-z\s]+/si,
    alnumwhite   => qr/[a-z0-9\s]+/si,
    email        => qr/[a-z][\w\.\-]*\@(?:[a-z0-9][a-z0-9\-]*\.)*[a-z0-9]+/si,
    filename     => qr#[/ \w\-\.:,@\+]+\[?#s,
    fileglob     => qr#[/ \w\-\.:,@\+\*\?\{\}\[\]]+\[?#s,
    hostname     => qr#(?:[a-z0-9][a-z0-9\-]*)(?:\.[a-z0-9][a-z0-9\-]*)*\.?#s,
    ipv4addr =>
        qr/(?:(?:\d\d?|1\d\d|2[0-4][0-9]|25[0-5])\.){3}(?:\d\d?|1\d\d|2[0-4][0-9]|25[0-5])/s,
    ipv4netaddr =>
        qr#(?:(?:\d\d?|1\d\d|2[0-4][0-9]|25[0-5])\.){3}(?:\d\d?|1\d\d|2[0-4][0-9]|25[0-5])/(?:(?:\d|[12]\d|3[0-2])|(?:(?:\d\d?|1\d\d|2[0-4][0-9]|25[0-5])\.){3}(?:\d\d?|1\d\d|2[0-4][0-9]|25[0-5]))#s,
    ipv6addr => qr/
        :(?::[abcdef\d]{1,4}){1,7}                 |
        [abcdef\d]{1,4}(?:::?[abcdef\d]{1,4}){1,7} |
        (?:[abcdef\d]{1,4}:){1,7}:
        /six,
    ipv6netaddr => qr#(?::(?::[abcdef\d]{1,4}){1,7}|
        [abcdef\d]{1,4}(?:::?[abcdef\d]{1,4}){1,7} |
        (?:[abcdef\d]{1,4}:){1,7}:)/(?:\d\d?|1(?:[01]\d|2[0-8]))#six,
    login  => qr/[a-z][\w\.\-]*/si,
    nometa => qr/[^\%\`\$\!\@]+/s,
    number => qr/[+\-]?[0-9]+(?:\.[0-9]+)?/s,
    'int'  => qr/[-+]?\d+/s,
    uint   => qr/\d+/s,
    float  => qr/[-+]?\d+(?:\.\d+)/s,
    ufloat => qr/\d+(?:\.\d+)/s,
    bin    => qr/[01]+/s,
    octal  => qr/[0-7]+/s,
    'hex'  => qr/[a-z0-9]+/si,
    );

sub detaint (\[$@%]$;\[$@%]) {

    # Purpose:  Detaints and validates input in one call
    # Returns:  True (1) if detainting was successful,
    #           False (0) if there are any errors
    # Usage:    $rv = detaint($input, $dataType, $detainted);
    # Usage:    $rv = detaint(@input, $dataType, @detainted);
    # Usage:    $rv = detaint(%input, $dataType, %detainted);

    my $iref = shift;
    my $type = shift;
    my $oref = shift;
    my $po   = defined $oref;
    my $rv   = 0;
    my ( $regex, $tmp );

    subPreamble( PDLEVEL1, '\[$@%]$;\[$@%]', $iref, $type, $oref );

    # Make sure input and output data types match
    croak "$iref and $oref aren't compatible data types"
        unless !defined $oref
            or ref $iref eq ref $oref;

    # Warn on unknown regexes
    if ( ref $type eq 'Regexp' ) {
        $regex = $type;
        $type  = 'custom';
    } else {
        if ( defined $type and exists $regexes{$type} ) {
            $regex = $regexes{$type};
        } else {
            pdebug( 'unknown regex type requested: %s', PDLEVEL1, $type );
        }
    }

    # Create a reference structure under $oref if none was passed
    unless ( defined $oref ) {
        $oref =
              ref $iref eq 'ARRAY' ? []
            : ref $iref eq 'HASH'  ? {}
            :                        \$tmp;
    }

    # Make sure $oref is empty
    if ( ref $oref eq 'SCALAR' ) {
        $$oref = undef;
    } elsif ( ref $oref eq 'ARRAY' ) {
        @$oref = ();
    } else {
        %$oref = ();
    }

    # Start working
    if ( defined $regex ) {
        if ( ref $iref eq 'SCALAR' ) {
            pdebug( 'evaluating (%s)', PDLEVEL2, $$iref );
            ($$oref) = ( $$iref =~ /^($regex)$/s )
                if defined $$iref;
            $rv = defined $$oref;
        } elsif ( ref $iref eq 'ARRAY' ) {
            if ( scalar @$iref ) {
                $rv = 1;
                foreach (@$iref) {
                    pdebug( 'evaluating (%s)', PDLEVEL2, $_ );
                    ( $$oref[ $#{$oref} + 1 ] ) =
                        defined $_ ? m/^($regex)$/s : (undef);
                    $rv = 0 unless defined $$oref[-1];
                    pdebug( 'got (%s)', PDLEVEL2, $$oref[-1] );
                }
            }
            $rv = !scalar grep { !defined } @$oref;
        } else {
            if ( scalar keys %$iref ) {
                $rv = 1;
                foreach ( keys %$iref ) {
                    pdebug( 'evaluating (%s)', PDLEVEL2, $$iref{$_} );
                    ( $$oref{$_} ) =
                        defined $$iref{$_}
                        ? ( $$iref{$_} =~ m/^($regex)$/s )
                        : undef;
                    $rv = 0 unless defined $$oref{$_};
                }
            }
        }
    }

    # Copy everything back to $iref if needed
    unless ($po) {
        if ( ref $iref eq 'SCALAR' ) {
            $$iref = $$oref;
        } elsif ( ref $iref eq 'ARRAY' ) {
            @$iref = @$oref;
        } else {
            %$iref = %$oref;
        }
    }

    subPostamble( PDLEVEL1, '$', $rv );

    return $rv;
}

sub stringMatch ($@) {

    # Purpose:  Looks for occurrences of strings and/or regexes in the passed
    #           input
    # Returns:  True (1) any of the strings/regexes match,
    #           False (0), otherwise
    # Usage:    $rv = stringMatch($input, @words);

    my $input = shift;
    my @match = splice @_;
    my $rv    = 0;
    my @regex;

    subPreamble( PDLEVEL1, '$@', $input, @match );

    if ( defined $input and @match ) {

        # Populate @regex w/regexes
        @regex = grep { defined $_ && ref $_ eq 'Regexp' } @match;

        # Convert remaining strings to regexes
        foreach ( grep { defined $_ && ref $_ ne 'Regexp' } @match ) {
            push @regex, m#^/(.+)/$#s ? qr#$1#si : qr#\Q$_\E#si;
        }

        # Start comparisons
        study $input;
        foreach my $r (@regex) {
            if ( $input =~ /$r/si ) {
                $rv = 1;
                last;
            }
        }
    }

    subPostamble( PDLEVEL1, '$', $rv );

    return $rv;
}

1;

__END__