view release on metacpan or  search on metacpan

lib/Apache2/SSI.pm  view on Meta::CPAN

{
    my $self = shift( @_ );
    return( $_[0] =~ /$IS_UTF8/ );
}

sub _interp_vars
{
    # Find all $var and ${var} expressions in the string and fill them in.
    my $self = shift( @_ );
    # Because ssi_echo may change $1, $2, ...
    my( $a, $b, $c );
    $_[0] =~ s{ (^|[^\\]) (\\\\)* \$(\{)?(\w+)(\})? }
              { ($a,$b,$c) = ($1,$2,$4);
                $a . ( length( $b ) ? substr( $b, length( $b ) / 2 ) : '' ) . $self->parse_echo({ var => $c }) }exg;
}

sub _ipmatch
{
    my $self = shift( @_ );
    my $subnet = shift( @_ ) || return( $self->error( "No subnet provided" ) );
    my $ip   = shift( @_ ) || $self->remote_ip;
    local $@;
    # try-catch
    my $rv = eval
    {
        local $SIG{__WARN__} = sub{};
        require Net::Subnet;
        my $net = Net::Subnet::subnet_matcher( $subnet );
        my $res = $net->( $ip );
        return( $res ? 1 : 0 );
    };
    if( $@ )
    {
        $self->error( "Error while calling Net::Subnet: $@" );
        return(0);
    }
    return( $rv );
}

sub _is_ip
{
    my $self = shift( @_ );
    my $ip   = shift( @_ );
    return( 0 ) if( !length( $ip ) );
    # We need to return either 1 or 0. By default, perl return undef for false
    return( $ip =~ /^(?:$RE{net}{IPv4}|$RE{net}{IPv6})$/ ? 1 : 0 );
}

sub _is_number
{
    my $self = shift( @_ );
    my $word = shift( @_ );
    return( 0 ) if( !length( $word ) );
    return( $word =~ /^(?:$RE{num}{int}|$RE{num}{real})$/ ? 1 : 0 );
}

sub _is_perl_script
{
    my $self = shift( @_ );
    my $file = shift( @_ );
    return( $self->error( "No file was provided to check if it looks like a perl script." ) ) if( !length( "$file" ) );
    if( -T( "$file" ) )
    {
        my $io = IO::File->new( "<$file" ) || return( $self->error( "Unable to open file \"$file\" in read mode: $!" ) );
        my $shebang = $io->getline;
        chomp( $shebang );
        $io->close;
        # We explicitly return 1 or 0, because otherwise upon failure perl would return undef which we reserve for errors
        return( $shebang =~ /^\#\!(.*?)\bperl\b/i ? 1 : 0 );
    }
    return( 0 );
}

sub _lastmod                                                                                                                                                                                                                                              ...
{
    my( $self, $file, $format ) = @_;
    return( $self->_format_time( ( stat( "$file" ) )[9], $format ) );
}

# This is different from the env() method. This one is obviously private
# whereas the env() one has triggers that could otherwise create an infinite loop.
sub _set_env
{
    my $self = shift( @_ );
    my $name = shift( @_ );
    return( $self->error( "No environment variable name provided." ) ) if( !length( $name ) );
    $self->{_env} = {} if( !ref( $self->{_env} ) );
    my $env = $self->{_env};
    $env->{ $name } = shift( @_ );
    return( $self );
}

sub _set_var
{
    my $self = shift( @_ );
    my $r    = shift( @_ );
    if( $r )
    {
        $r->subprocess_env( $_[0], $_[1] );
    }
    else
    {
        my $env = $self->env;
        $env->{ $_[0] } = $_[1];
    }
    return( $_[1] );
}

sub _time_args
{
    # This routine must respect the caller's wantarray() context.
    my( $self, $time, $zone ) = @_;
    return( ( $zone && $zone =~ /GMT/ ) ? gmtime( $time ) : localtime( $time ) );
}

# Credits: Torsten Förtsch
{
    # NOTE: Apache2::SSI::Filter class
    package
        Apache2::SSI::Filter;