view release on metacpan or  search on metacpan

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

## under the same terms as Perl itself.
##----------------------------------------------------------------------------
package Apache2::SSI::URI;
BEGIN
{
    use strict;
    use warnings::register;
    use parent qw( Apache2::SSI::Common );
    use vars qw( $VERSION $DEBUG $DIR_SEP );
    use Apache2::SSI::Finfo;
    use Cwd;
    use File::Spec ();
    use Scalar::Util ();
    require constant;
    use URI;
    use constant URI_CLASS => 'URI';
    use URI::file;
    if( $ENV{MOD_PERL} )
    {
        require Apache2::RequestRec;
        require Apache2::RequestUtil;
        require Apache2::SubRequest;
        require Apache2::Access;
        require Apache2::Const;
        Apache2::Const->import( compile => qw( :common :http OK DECLINED ) );
    }
    our( $DEBUG );
    use overload (
        q{""}    => sub    { $_[0]->document_uri->as_string },
        bool     => sub () { 1 },
        fallback => 1,
    );
    our $VERSION = 'v0.1.3';
    our $DIR_SEP = $Apache2::SSI::Common::DIR_SEP;
};

use strict;
use warnings;

# document_root = /home/joe/www
# base_uri      = /my/uri/file.html/some/path/info?q=something&l=ja_JP
# base_uri is the current reference document
# document_uri  = ./about.html
# document_uri is the uri which is the purpose of this object. It will be made absolute and its dots flattened
# Example: ../about.html?q=hello would become /my/about.html?q=hello
sub init
{
    my $self = shift( @_ );
    $self->{apache_request} = '';
    $self->{base_uri}       = '/' unless( length( $self->{base_uri} ) );
    # By default
    $self->{code}           = 200;
    $self->{document_path}  = '';
    $self->{document_root}  = '';
    # Reference document for the main request
    $self->{document_uri}   = '';
    $self->{filepath}       = '';
    $self->{finfo}          = '';
    $self->{_init_params_order} = [qw( apache_request document_root base_uri document_uri document_path filepath )];
    $self->{_init_strict_use_sub} = 1;
    $self->SUPER::init( @_ ) || return;
    $self->{_env}            = {};
    $self->{_path_info_processed} = 0;
    $self->{_uri_reset}      = 0;
    $self->{document_root} ||= $self->env( 'DOCUMENT_ROOT' );
    $self->{base_uri}      ||= $self->env( 'DOCUMENT_URI' );
    return( $self->error( "No document root was provided." ) ) if( !length( $self->{document_root} ) );
    return( $self->error( "No base uri was provided." ) ) if( !length( $self->{base_uri} ) );
    return( $self->error( "No document uri was provided." ) ) if( !length( $self->{document_uri} ) );
    # Small correction if necessary. If the base uri is a directory, it needs to have a trailing "/", so URI knows this is a directory and not a file.
    # URI->new( "./file.pl" )->abs( "/ssi/plop" ) becomes "/ssi/file.pl" whereas it should be /ssi/plop/file.pl
    # $self->{base_uri} .= '/' if( length( $self->{base_uri} ) && -d( "$self->{document_root}$self->{base_uri}" ) && substr( $self->{base_uri}, -1, 1 ) ne '/' );
    return( $self );
}

sub apache_request { return( shift->_set_get_object_without_init( 'apache_request', 'Apache2::RequestRec', @_ ) ); }

sub base_dir
{
    my $self = shift( @_ );
    return( $self->{base_dir} ) if( length( $self->{base_dir} ) );
    # Just in case
    return( $self->root ) if( !length( $self->{base_uri} ) );
    my $base = $self->base_uri;
    return( $self->error( "No base uri defined." ) ) if( !length( $base ) );
    my $path = $base->document_path;
    my @segments = split( '/', $path, -1 );
    pop( @segments );
    return( $base ) if( !scalar( @segments ) );
    my $r = $self->apache_request;
    my $dir_path = join( '/', @segments );
    
    my $hash = {};
    if( $r )
    {
        my $rr = $self->lookup_uri( $dir_path );
        if( !defined( $rr ) )
        {
            return;
        }
        elsif( $rr->status != &Apache2::Const::HTTP_OK )
        {
            return( $self->error( "Could not look up base directory \"$dir_path\". Returned code is: ", $rr->status ) );
        }
        elsif( $rr->finfo->filetype == &APR::Const::FILETYPE_NOFILE )
        {
            return( $self->error( "Could not find base directory \"$dir_path\"." ) );
        }
        # Remove trailing slash
        my $u = $self->_trim_trailing_slash( $rr->uri );
        
        $hash =
        {
        apache_request => $self->apache_request,
        base_dir => $self->root,
        base_uri => $self->root,
        document_path => "$u",
        document_root => $rr->document_root,
        document_uri => "$u",
        filename => $rr->filename,
        path_info => $rr->path_info,