view release on metacpan or  search on metacpan

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

    if( substr( $path, 0, 2 ) eq ".${sep}" )
    {
        substr( $path, 0, 2 ) = '';
    }
    elsif( substr( $path, 0, 3 ) eq "..${sep}" )
    {
        substr( $path, 0, 3 ) = '';
    }
    # "if the input buffer begins with a prefix of "/./" or "/.", where "." is a complete path segment, then replace that prefix with "/" in the input buffer"
    elsif( substr( $path, 0, 3 ) eq "${sep}.${sep}" )
    {
        substr( $path, 0, 3 ) = $sep;
    }
    elsif( substr( $path, 0, 2 ) eq "${sep}." && 2 == $len )
    {
        substr( $path, 0, 2 ) = $sep;
    }
    elsif( $path eq '..' || $path eq '.' )
    {
        $path = '';
    }
    elsif( $path eq $sep )
    {
        return( $u );
    }
    
    # -1 is used to ensure trailing blank entries do not get removed
    my @segments = split( "\Q$sep\E", $path, -1 );
    for( my $i = 0; $i < scalar( @segments ); $i++ )
    {
        my $segment = $segments[$i];
        # "if the input buffer begins with a prefix of "/../" or "/..", where ".." is a complete path segment, then replace that prefix with "/" in the input buffer and remove the last segment and its preceding "/" (if any) from the output buffer"
        if( $segment eq '..' )
        {
            pop( @new );
        }
        elsif( $segment eq '.' )
        {
            next;
        }
        else
        {
            push( @new, ( defined( $segment ) ? $segment : '' ) );
        }
    }
    # Finally, the output buffer is returned as the result of remove_dot_segments.
    my $new_path = join( $sep, @new );
    # substr( $new_path, 0, 0 ) = $sep unless( substr( $new_path, 0, 1 ) eq '/' );
    substr( $new_path, 0, 0 ) = $sep unless( File::Spec->file_name_is_absolute( $new_path ) );
    if( $opts->{separator} )
    {
        $u = URI::file->new( $new_path );
    }
    else
    {
        $u->path( $new_path );
    }
    return( $u );
}

# Credits: Path::Tiny
sub slurp
{
    my $self = shift( @_ );
    my $args = {};
    no warnings 'uninitialized';
    $args = Scalar::Util::reftype( $_[0] ) eq 'HASH'
        ? shift( @_ )
        : !( scalar( @_ ) % 2 )
            ? { @_ }
            : {};
    my $file = $args->{filename} || $args->{file} || $self->filename;
    return( $self->error( "No filename found." ) ) if( !length( $file ) );
    my $binmode = $args->{binmode} // '';
    local $@;
    # try-catch
    my $rv = eval
    {
        my $fh = IO::File->new( "<$file" ) ||
        return( $self->error( "Unable to open file \"$file\" in read mode: $!" ) );
        $fh->binmode( $binmode ) if( length( $binmode ) );
        my $size;
        if( $binmode eq ':unix' && ( $size = -s( $fh ) ) )
        {
            my $buf;
            $fh->read( $buf, $size );
            return( $buf );
        }
        else
        {
            local $/;
            return( scalar( <$fh> ) );
        }
    };
    if( $@ )
    {
        return( $self->error( "An error occured while trying to open and read file \"$file\": $@" ) );
    }
    return( $rv );
}

sub slurp_utf8
{
    my $self = shift( @_ );
    my $args = {};
    no warnings 'uninitialized';
    $args = Scalar::Util::reftype( $_[0] ) eq 'HASH'
        ? shift( @_ )
        : !( scalar( @_ ) % 2 )
            ? { @_ }
            : {};
    $args->{binmode} = ':utf8';
    my $file = $args->{filename} || $args->{file} || $self->filename;
    return( $self->error( "No filename found." ) ) if( !length( $file ) );
    $args->{filename} = $file;
    return( $self->slurp( $args ) );
}


1;
# NOTE: POD