Apache2-SSI

 view release on metacpan or  search on metacpan

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

        path_info => $ref->{path_info},
        query_string => $ref->{query_string},
        _path_info_processed => 1,
        };
        my $tmp = $self->new_uri( $ref->{path_info} ? join( '', $ref->{path}, $ref->{path_info} ) : $ref->{path} );
        $tmp->query( $ref->{query_string} ) if( $ref->{query_string} );
        $hash->{document_uri} = $tmp;
        $self->{base_dir} = bless( $hash => ref( $self ) ) if( -d( $ref->{path} ) );
        $self->{base_uri} = bless( $hash => ref( $self ) );
    }
    return( $self->{base_uri} );
}

sub clone
{
    my $self = shift( @_ );
    my $new = {};
    my @fields = grep( !/^(apache_request|finfo)$/, keys( %$self ) );
    @$new{ @fields } = @$self{ @fields };
    $new->{apache_request} = $self->{apache_request};
    my $env = {};
    %$env = %{$self->{_env}};
    $new->{_env} = $env;
    return( bless( $new => ( ref( $self ) || $self ) ) );
}

sub code
{
    my $self = shift( @_ );
    my $r = $self->apache_request;
    if( $r )
    {
        $r->status( @_ ) if( @_ );
        return( $r->status );
    }
    else
    {
        $self->{code} = shift( @_ ) if( @_ );
        return( int( $self->{code} ) );
    }
}

sub document_dir { return( shift->document_directory( @_ ) ); }

sub document_directory
{
    my $self = shift( @_ );
    my $doc_path = $self->document_path || return( $self->error( "No document path set." ) );
    my $doc_root = $self->document_root || return( $self->error( "No document root set." ) );
    return( $self->make( document_uri => $doc_path ) ) if( -e( "${doc_root}${doc_path}" ) && -d( _ ) );
    my $parent = $self->parent;
    return( $parent );
}

sub document_filename { return( shift->filename( @_ ) ); }

sub document_path
{
    my $self = shift( @_ );
    my $class = ref( $self );
    my $caller = (caller(1))[3] // '';
    # my $caller = substr( $sub, rindex( $sub, ':' ) + 1 );
    my $r = $self->apache_request;
    if( $r )
    {
        if( @_ )
        {
            my $uri = shift( @_ );
            $r = $r->is_initial_req ? $r : $r->main;
            my $rr = $self->lookup_uri( $uri );
            if( !defined( $rr ) )
            {
                return;
            }
            my $u = APR::URI->parse( $rr->pool, $r->uri );
            # Remove trailing slash
            my $u2 = $self->_trim_trailing_slash( $u->rpath );
            $self->{document_path} = $u2;
            $self->{_uri_reset} = 'document_path' unless( $caller eq "${class}\::document_uri" );
        }
        elsif( !length( $self->{document_path} ) )
        {
            my $u = APR::URI->parse( $r->pool, $r->uri );
            $self->{document_path} = $self->new_uri( $u->rpath );
        }
    }
    else
    {
        if( @_ )
        {
            my $uri = shift( @_ );
            $self->{document_path} = $self->new_uri( $self->collapse_dots( $uri ) );
            $self->{_uri_reset} = 'document_path' unless( $caller eq "${class}\::document_uri" );
        }
    }
    return( $self->{document_path} );
}

sub document_root
{
    my $self = shift( @_ );
    my $r = $self->apache_request;
    my $new;
    if( @_ )
    {
        $new = shift( @_ );
        # unless( substr( $new, 0, 1 ) eq '/' )
        unless( File::Spec->file_name_is_absolute( $new ) )
        {
            $new = URI::file->new_abs( $new )->file( $^O );
        }
    }
    
    if( $r )
    {
        $r->document_root( $new ) if( defined( $new ) );
        $r->subprocess_env( DOCUMENT_ROOT => $r->document_root );
        return( $r->document_root );
    }
    else
    {

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

    my $self = shift( @_ );
    # The user wants the entire hash reference
    unless( @_ )
    {
        my $r = $self->apache_request;
        if( $r )
        {
            # $r = $r->is_initial_req ? $r : $r->main;
            return( $r->subprocess_env )
        }
        else
        {
            unless( scalar( keys( %{$self->{_env}} ) ) )
            {
                $self->{_env} = {%ENV};
            }
            return( $self->{_env} );
        }
    }
    my $name = shift( @_ );
    return( $self->error( "No environment variable name was provided." ) ) if( !length( $name ) );
    my $opts = {};
    no warnings 'uninitialized';
    $opts = pop( @_ ) if( scalar( @_ ) && Scalar::Util::reftype( $_[-1] ) eq 'HASH' );
    # return( $self->error( "Environment variable value provided is a reference data (", overload::StrVal( $val ), ")." ) ) if( ref( $val ) && ( !overload::Overloaded( $val ) || ( overload::Overloaded( $val ) && !overload::Method( $val, '""' ) ) ) );
    my $r = $opts->{apache_request} || $self->apache_request;
    if( $r )
    {
        # $r = $r->is_initial_req ? $r : $r->main;
        $r->subprocess_env( $name => shift( @_ ) ) if( @_ );
        my $v = $r->subprocess_env( $name );
        return( $v );
    }
    else
    {
        my $env = {};
        unless( scalar( keys( %{$self->{_env}} ) ) )
        {
            # Make a copy of the environment variables
            $self->{_env} = {%ENV};
        }
        $env = $self->{_env};
        if( @_ )
        {
            $env->{ $name } = shift( @_ );
            my $meth = lc( $name );
            if( $self->can( $meth ) )
            {
                $self->$meth( $env->{ $name } );
            }
        }
        return( $env->{ $name } );
    }
}

# This is set by document_uri
sub filename
{
    my $self = shift( @_ );
    my $class = ref( $self );
    my $caller = (caller(1))[3] // '';
    # my $caller = substr( $sub, rindex( $sub, ':' ) + 1 );
    my $r = $self->apache_request;
    my $newfile;
    if( @_ )
    {
        $newfile = shift( @_ );
        return( $self->error( "New file provided, but it was an empty string." ) ) if( !defined( $newfile ) || !length( $newfile ) );
    }
    
    if( $r )
    {
        if( defined( $newfile ) )
        {
            $r = $r->is_initial_req ? $r : $r->main;
            my $rr = $r->lookup_file( $newfile );
            if( $rr->status == &Apache2::Const::HTTP_OK )
            {
                $newfile = $rr->filename;
            }
            else
            {
                $r->filename( $self->collapse_dots( $newfile, { separator => $DIR_SEP }) );
                # <https://perl.apache.org/docs/2.0/api/Apache2/RequestRec.html#toc_C_filename_>
                $r->finfo( APR::Finfo::stat( $newfile, &APR::Const::FINFO_NORM, $r->pool ) );
                $self->finfo( $newfile );
            }
            $r->subprocess_env( SCRIPT_FILENAME => $newfile );
            # Force to create new Apache2::SSI::URI object
            $self->{filename} = $newfile;
            $self->{_uri_reset} = 'filename' unless( $caller eq "${class}\::document_uri" );
        }
        elsif( !length( $self->{filename} ) )
        {
            $self->{filename} = $r->filename;
        }
    }
    else
    {
        if( defined( $newfile ) )
        {
            my $try = Cwd::realpath( $newfile );
            # Cwd::realpath would convert
            # Z:\perl\Apache2-SSI\t\htdocs\ssi\include.cgi
            # into 
            # Z:/perl/Apache2-SSI/t/htdocs/ssi/include.cgi
            # amazingly enough, so to make sure this keeps working on windows related platform, we need to call URI::file
            $newfile = URI::file->new( $try )->file( $^O ) if( defined( $try ) );
            unless( File::Spec->file_name_is_absolute( $newfile ) )
            {
                $newfile = URI::file->new_abs( $newfile )->file( $^O );
            }
            $self->env( SCRIPT_FILENAME => $newfile );
            $self->finfo( $newfile );
            # Force to create new Apache2::SSI::URI object
            # Either a URI object or an URI::file object
            $self->{filename} = $self->collapse_dots( $newfile, { separator => $DIR_SEP })->file( $^O );
            # Pass the file as new argument to URI::file which will create an object based on the value of the current OS
            # and transform it into a path à la linux, which is same as web, which is what we want
            # All this is unnecessary for linux type system or those who use / as directory separator,
            # but for windows type systems this is necessary

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

        {
            $self->error( "An error occurred while creating URI object for \"$hdrs->{Location}\": $@" );
            return( $rr );
        }
        return( $rv );
    }   
    return( $rr );
}

sub make
{
    my $self = shift( @_ );
    return( $self->error( "Must be called with an existing object and not as ", __PACKAGE__, "->make()" ) ) if( !Scalar::Util::blessed( $self ) );
    my $p = $self->_get_args_as_hash( @_ );
    my $r = $self->apache_request;
    my $d = $self->document_root;
    my $b = $self->base_uri;
    my $f = $self->document_uri;
    $p->{apache_request} = $r if( !$p->{apache_request} && $r );
    $p->{document_root} = "$d" if( !$p->{document_root} && length( $d ) );
    $p->{base_uri} = "$b" if( !$p->{base_uri} && length( $b ) );
    $p->{document_uri} = "$f" if( !$p->{document_uri} );
    $p->{debug} = $self->debug if( !length( $p->{debug} ) );
    return( $self->new( $p ) );
}

sub new_uri
{
    my $self = shift( @_ );
    my $class = URI_CLASS;
    my $uri = shift( @_ );
    local $@;
    # try-catch
    my $rv = eval
    {
        return( $class->new( $uri ) );
    };
    if( $@ )
    {
        return( $self->error( "Unable to instantiate an URI object with \"$uri\": $@" ) );
    }
    return( $rv );
}

sub parent
{
    my $self = shift( @_ );
    my $path = $self->document_path;
    my $r = $self->apache_request;
    # I deliberately did not do split( '/', $path, -1 ) so that if there is a trailing '/', it will not be counted
    my @segments = $self->document_path->path_segments;
    pop( @segments );
    return( $self ) if( !scalar( @segments ) );
    return( $self->make( document_uri => join( '/', @segments ) ) );
}

sub path_info
{
    my $self = shift( @_ );
    my $class = ref( $self );
    my $caller = (caller(1))[3] // '';
    # my $caller = substr( $sub, rindex( $sub, ':' ) + 1 );
    my $r = $self->apache_request;
    if( $r )
    {
        if( @_ )
        {
            $r->path_info( shift( @_ ) );
            $self->_set_env( PATH_INFO => $r->path_info );
            $self->{_uri_reset} = 'path_info' unless( $caller eq "${class}\::document_uri" );
        }
        return( $r->path_info );
    }
    else
    {
        if( @_ )
        {
            $self->{path_info} = shift( @_ );
            $self->_set_env( PATH_INFO => $self->{path_info} );
            $self->{_uri_reset} = 'path_info' unless( $caller eq "${class}\::document_uri" );
        }
        return( $self->{path_info} );
    }
}

sub query_string
{
    my $self = shift( @_ );
    my $class = ref( $self );
    my $caller = (caller(1))[3] // '';
    # my $caller = substr( $sub, rindex( $sub, ':' ) + 1 );
    my $r = $self->apache_request;
    if( $r )
    {
        if( @_ )
        {
            my $qs = shift( @_ );
            $r->args( $qs );
            $self->_set_env( QUERY_STRING => $qs );
            $self->{_uri_reset} = 'query_string' unless( $caller eq "${class}\::document_uri" );
        }
        return( $r->args );
    }
    else
    {
        if( @_ )
        {
            $self->{query_string} = shift( @_ );
            $self->_set_env( QUERY_STRING => $self->{query_string} );
            $self->{_uri_reset} = 'query_string' unless( $caller eq "${class}\::document_uri" );
        }
        return( $self->{query_string} );
    }
}

sub root
{
    my $self = shift( @_ );
    return( $self->{root} ) if( $self->{root} );
    my $hash = 
    {
    code => 200,
    document_uri => $self->new_uri( '/' ),
    document_root => $self->document_root,
    debug => $self->debug,
    path_info => '',
    query_string => '',
    _path_info_processed => 1,
    };
    $hash->{document_path} = $hash->{document_uri};
    $hash->{apache_request} = $self->apache_request if( $self->apache_request );
    my $root = bless( $hash => ref( $self ) );
    # Scalar::Util::weaken( $copy );
    $root->{base_dir} = $root;
    $root->{base_uri} = $root;
    $self->{root} = $root;
    return( $root );
}

# shortcut
sub uri { return( shift->document_uri( @_ ) ); }

# Path info works as a path added to a document uri, such as:
# /my/doc.html/path/info
# But we need to distinguish with missing document hierarchy inside a directory, such as:
# /my/folder/missing_doc.html/path/info
# otherwise we would be treating /missing_doc.html/path/info as a path info
sub _find_path_info
{
    my $self = shift( @_ );