Apache2-SSI
view release on metacpan or search on metacpan
lib/Apache2/SSI/File.pm view on Meta::CPAN
sub base_file { return( shift->_make_abs( 'base_file', @_ ) ); }
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};
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( $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' ) )
{
lib/Apache2/SSI/File.pm view on Meta::CPAN
v0.1.2
=head1 DESCRIPTION
This packages serves to resolve files whether inside Apache scope with mod_perl or outside, providing a unified api.
=head1 METHODS
=head2 new
This instantiates an object that is used to access other key methods. It takes the following parameters:
=over 4
=item C<apache_request>
This is the L<Apache2::RequestRec> object that is provided if running under mod_perl.
it can be retrieved from L<Apache2::RequestUtil/request> or via L<Apache2::Filter/r>
You can get this L<Apache2::RequestRec> object by requiring L<Apache2::RequestUtil> and calling its class method L<Apache2::RequestUtil/request> such as C<Apache2::RequestUtil->request> and assuming you have set C<PerlOptions +GlobalRequest> in your ...
Note that there is a main request object and subprocess request object, so to find out which one you are dealing with, use L<Apache2::RequestUtil/is_initial_req>, such as:
use Apache2::RequestUtil (); # extends Apache2::RequestRec objects
my $r = $r->is_initial_req ? $r : $r->main;
=back
=head2 apache_request
Sets or gets the L<Apache2::RequestRec> object. As explained in the L</new> method, you can get this Apache object by requiring the package L<Apache2::RequestUtil> and calling L<Apache2::RequestUtil/request> such as C<Apache2::RequestUtil->request> a...
When running under Apache mod_perl this is set automatically from the special L</handler> method, such as:
my $r = $f->r; # $f is the Apache2::Filter object provided by Apache
=head2 base_dir
Sets or gets the base directory to be used as a reference to the files provided so they can be transformed into absolute file path.
my $f = Apache2::SSI::File->new( './index.html',
base_dir => '/home/joe/www',
);
# This would now be /home/joe/www/index.html
$f->filename;
=head2 base_file
Returns the base file for this file object.
=head2 clone
Create a clone of the object and return it.
=head2 code
Sets or gets the http code for this file.
$f->code( 404 );
=head2 collapse_dots
Provided with an uri or a file path, and this will resolve the path and removing the dots, such as C<.> and C<..> and return an L<URI> object.
This is done as per the L<RFC 3986 section 5.2.4 algorithm|https://tools.ietf.org/html/rfc3986#page-33>
my $file = $f->collapse_dots( '/../a/b/../c/./d.html' );
# would become /a/c/d.html
=head2 filename
Sets or gets the system file path to the file, as a string.
If a new file name is provided, under Apache/mod_perl2, this will perform a query with L<Apache2::SubRequest/lookup_file>
Any filename provided will be resolved with its dots flattened and transformed into an absolute system file path if it is not already.
=head2 filepath
Returns the file path for this file object.
=head2 finfo
Returns a L<Apache2::SSI::Finfo> object. This provides access to L<perlfunc/stat> information as methods, taking advantage of L<APR::Finfo> when running under Apache, and an identical interface otherwise. See L<Apache2::SSI::Finfo> for more informati...
=head2 parent
Returns the parent of the file, or if there is no parent, it returns the current object itself.
my $up = $f->parent;
# would return /home/john/some/path assuming the file was /home/john/some/path/file.html
=head2 slurp
It returns the content of the L</filename>
it takes an hash reference of parameters:
=over 4
=item C<binmode>
my $content = $uri->slurp({ binmode => ':utf-8' });
=back
It will return undef and sets an L<Module::Generic/error> if there is no L</filename> value set or if the file cannot be opened.
=head2 slurp_utf8
It returns the content of the file L</filename> utf-8 decoded.
This is equivalent to:
my $content = $uri->slurp({ binmode => ':utf8' });
C<:utf8> is slightly a bit more lax than C<:utf-8>, so it you want strict utf8, you can do:
my $content = $uri->slurp({ binmode => ':utf-8' });
( run in 0.968 second using v1.01-cache-2.11-cpan-5837b0d9d2c )