view release on metacpan or  search on metacpan

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

##----------------------------------------------------------------------------
#----------------------------------------------------------------------------
# Apache2 Server Side Include Parser - ~/lib/Apache2/SSI/File.pm
# Version v0.1.1
# Copyright(c) 2021 DEGUEST Pte. Ltd.
# Author: Jacques Deguest <jack@deguest.jp>
# Created 2020/12/18
# Modified 2022/10/21
# All rights reserved
# 
# This program is free software; you can redistribute  it  and/or  modify  it
# under the same terms as Perl itself.
#----------------------------------------------------------------------------
package Apache2::SSI::File;
BEGIN
{
    use strict;
    use warnings;
    use warnings::register;
    use parent qw( Apache2::SSI::Common );
    use vars qw( $DEBUG $VERSION $DIR_SEP );
    use Apache2::SSI::Finfo;
    use File::Spec ();
    use Scalar::Util ();
    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 ) );
        require APR::Const;
        APR::Const->import( -compile => qw( :filetype FINFO_NORM ) );
    }
    our( $DEBUG );
    use overload (
        q{""}    => sub    { $_[0]->filename },
        bool     => sub () { 1 },
        fallback => 1,
    );
    our $VERSION = 'v0.1.2';
    our $DIR_SEP = $Apache2::SSI::Common::DIR_SEP;
};

use strict;
use warnings;

sub init
{
    my $self = shift( @_ );
    my $file = shift( @_ );
    return( $self->error( "No file was provided." ) ) if( !defined( $file ) || !length( $file ) );
    $self->{apache_request} = '';
    $self->{base_dir}       = '' unless( length( $self->{base_dir} ) );
    $self->{base_file}      = '';
    $self->{code}           = 200;
    $self->{finfo}          = '';
    $self->{_init_strict_use_sub} = 1;
    $self->SUPER::init( @_ ) || return;
    my $base_dir = '';
    if( length( $self->{base_file} ) )
    {
        if( -d( $self->{base_file} ) )
        {
            $base_dir = $self->{base_file};
        }
        else
        {
            my @segments = split( "\Q${DIR_SEP}\E", $self->{base_file}, -1 );
            pop( @segments );
            $base_dir = join( $DIR_SEP, @segments );
        }
        $self->{base_dir} = $base_dir;
    }
    elsif( !length( $self->{base_dir} ) )
    {
        $base_dir = URI->new( URI::file->cwd )->file( $^O );
        $self->{base_dir} = $base_dir;
    }
    $self->filename( $file ) || return;
    return( $self );
}

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

sub base_dir { return( shift->_make_abs( 'base_dir', @_ ) ); }

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;