view release on metacpan or  search on metacpan

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

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

sub filename
{
    my $self = shift( @_ );
    my $newfile;
    if( @_ )
    {
        $newfile = shift( @_ );
        return( $self->error( "New file provided, but it was an empty string." ) ) if( !defined( $newfile ) || !length( $newfile ) );
    }
    
    my $r = $self->apache_request;
    if( $r )
    {
        if( defined( $newfile ) )
        {
            $r = $r->is_initial_req ? $r : $r->main;
            my $rr = $r->lookup_file( $newfile );
            # Amazingly, lookup_file will return ok  even if it does not find the file
            if( $rr->status == &Apache2::Const::HTTP_OK &&
                $rr->finfo && 
                $rr->finfo->filetype != &APR::Const::FILETYPE_NOFILE )
            {
                $self->apache_request( $rr );
                $newfile = $rr->filename;
                my $finfo = $rr->finfo;
                if( $finfo )
                {
                }
            }
            else
            {
                $self->code( 404 );
                $newfile = $self->collapse_dots( $newfile, { separator => $DIR_SEP });
                # We don't pass it the Apache2::RequestRec object, because it would trigger a fatal error since the file does not exist. Instead, we use the api without Apache2::RequestRec which is more tolerant
                # We do this so the user can call our object $file->finfo->filetype == Apache2::SSI::Finfo::FILETYPE_NOFILE
                $self->{finfo} = Apache2::SSI::Finfo->new( $newfile );
            }
            $self->{filename} = $newfile;
        }
        elsif( !length( $self->{filename} ) )
        {
            $self->{filename} = $r->filename;
        }
    }
    else
    {
        if( defined( $newfile ) )
        {
            my $base_dir = $self->base_dir;
            $base_dir .= $DIR_SEP unless( substr( $base_dir, -length( $DIR_SEP ), length( $DIR_SEP ) ) eq $DIR_SEP );
            # If we provide a string for the abs() method it works on Unix, but not on Windows
            # By providing an object, we make it work
            $newfile = URI::file->new( $newfile )->abs( URI::file->new( $base_dir ) )->file( $^O );
            $self->{filename} = $self->collapse_dots( $newfile, { separator => $DIR_SEP })->file( $^O );
            $self->finfo( $newfile );
            my $finfo = $self->finfo;
            if( !$finfo->exists )
            {
                $self->code( 404 );
            }
            # Force to create new Apache2::SSI::URI object
        }
    }
    return( $self->{filename} );
}

# Alias
sub filepath { return( shift->filename( @_ ) ); }

sub finfo
{
    my $self = shift( @_ );
    my $r = $self->apache_request;
    my $newfile;
    if( @_ )
    {
        $newfile = shift( @_ );
        return( $self->error( "New file path specified but is an empty string." ) ) if( !defined( $newfile ) || !length( $newfile ) );
    }
    elsif( !$self->{finfo} )
    {
        $newfile = $self->filename;
        return( $self->error( "No file path set. This should not happen." ) ) if( !$newfile );
    }
    
    if( defined( $newfile ) )
    {
        $self->{finfo} = Apache2::SSI::Finfo->new( $newfile, ( $r ? ( apache_request => $r ) : () ), debug => $self->debug );
        return( $self->pass_error( Apache2::SSI::Finfo->error ) ) if( !$self->{finfo} );
    }
    return( $self->{finfo} );
}

sub parent
{
    my $self = shift( @_ );
    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
    # 2021-03-27: Was working well, but only on Unix systems...
    # my @segments = split( '/', $self->filename, -1 );
    my( $vol, $parent, $file ) = File::Spec->splitpath( $self->filename );
    $vol //= '';
    $file //= '';
    my @segments = File::Spec->splitpath( File::Spec->catfile( $parent, $file ) );
    pop( @segments );
    return( $self ) if( !scalar( @segments ) );
    # return( $self->new( join( '/', @segments ), ( $r ? ( apache_request => $r ) : () ) ) );
    return( $self->new( $vol . File::Spec->catdir( @segments ), ( $r ? ( apache_request => $r ) : () ) ) );
}

sub _make_abs
{
    my $self = shift( @_ );
    my $field = shift( @_ ) || return( $self->error( "No field provided." ) );
    if( @_ )
    {
        my $this = shift( @_ );
        if( Scalar::Util::blessed( $this ) && $this->isa( 'URI::file' ) )
        {
            $this = URI->new_abs( $this )->file( $^O );
        }
        # elsif( substr( $this, 0, 1 ) ne '/' )
        elsif( !File::Spec->file_name_is_absolute( $this ) )
        {
            $this = URI::file->new_abs( $this )->file( $^O );
        }
        $self->{ $field } = $this;
    }
    return( $self->{ $field } );
}

1;
# NOTE: POD
__END__

=encoding utf-8

=head1 NAME

Apache2::SSI::File - Apache2 Server Side Include File Object Class

=head1 SYNOPSIS

    my $f = Apache2::SSI::File->new(
        '/some/file/path/file.html',
        apache_request => $r,
        base_dir => '/home/john/www',
    );
    $f->base_dir( '/home/joe/www' );
    my $f2 = $f->clone;
    unless( $f->code == Apache2::Const::HTTP_OK )
    {
        die( "File is not there!\n" );
    }
    # You can also use $f->filepath which is an alias to $f->filename
    print "Actual file is here: ", $f->filename, "\n";
    my $finfo = $f->finfo;
    if( $finfo->can_exec )
    {