view release on metacpan or  search on metacpan

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

    use overload (
        q{""}    => sub    { $_[0]->{filepath} },
        bool     => sub () { 1 },
        fallback => 1,
    );
    if( exists( $ENV{MOD_PERL} ) )
    {
        require APR::Pool;
        require APR::Finfo;
        require APR::Const;
        APR::Const->import( -compile => qw( :filetype FINFO_NORM ) );
    }
    use constant FINFO_DEV => 0;
    use constant FINFO_INODE => 1;
    use constant FINFO_MODE => 2;
    use constant FINFO_NLINK => 3;
    use constant FINFO_UID => 4;
    use constant FINFO_GID => 5;
    use constant FINFO_RDEV => 6;
    use constant FINFO_SIZE => 7;
    use constant FINFO_ATIME => 8;
    use constant FINFO_MTIME => 9;
    use constant FINFO_CTIME => 10;
    use constant FINFO_BLOCK_SIZE => 11;
    use constant FINFO_BLOCKS => 12;
    # Sames constant value as in APR::Const
    #  the file type is undetermined.
    use constant FILETYPE_NOFILE => 0;
    # a file is a regular file.
    use constant FILETYPE_REG => 1;
    # a file is a directory
    use constant FILETYPE_DIR => 2;
    # a file is a character device
    use constant FILETYPE_CHR => 3;
    # a file is a block device
    use constant FILETYPE_BLK => 4;
    # a file is a FIFO or a pipe.
    use constant FILETYPE_PIPE => 5;
    # a file is a symbolic link
    use constant FILETYPE_LNK => 6;
    # a file is a [unix domain] socket.
    use constant FILETYPE_SOCK => 7;
    # a file is of some other unknown type or the type cannot be determined.
    use constant FILETYPE_UNKFILE => 127;
    our %EXPORT_TAGS = ( all => [qw( FILETYPE_NOFILE FILETYPE_REG FILETYPE_DIR FILETYPE_CHR FILETYPE_BLK FILETYPE_PIPE FILETYPE_LNK FILETYPE_SOCK FILETYPE_UNKFILE )] );
    our @EXPORT_OK = qw( FILETYPE_NOFILE FILETYPE_REG FILETYPE_DIR FILETYPE_CHR FILETYPE_BLK FILETYPE_PIPE FILETYPE_LNK FILETYPE_SOCK FILETYPE_UNKFILE );
    our $VERSION = 'v0.1.3';
};

use strict;
use warnings;

sub init
{
    my $self = shift( @_ );
    my $file = shift( @_ ) || return( $self->error( "No file provided to instantiate a ", ref( $self ), " object." ) );
    # return( $self->error( "File or directory \"$file\" does not exist." ) ) if( !-e( $file ) );
    $self->{apache_request} = '';
    $self->{apr_finfo} = '';
    $self->{_init_strict_use_sub} = 1;
    $self->SUPER::init( @_ );
    $self->{filepath} = $file;
    $self->{_data} = [];
    my $r = $self->{apache_request};
    if( $r )
    {
        # <https://perl.apache.org/docs/2.0/api/Apache2/RequestRec.html#toc_C_filename_>
        local $@;
        # try-catch
        eval
        {
            my $finfo;
            if( $r->filename eq $file )
            {
                $finfo = $r->finfo;
            }
            else
            {
                $finfo = APR::Finfo::stat( $file, &APR::Const::FINFO_NORM, $r->pool );
                $r->finfo( $finfo );
            }
            $self->{apr_finfo} = $finfo;
        };
        if( $@ )
        {
            # This makes it possible to query this api even if provided with a non-existing file
            if( $@ =~ /No[[:blank:]\h]+such[[:blank:]\h]+file[[:blank:]\h]+or[[:blank:]\h]+directory/i )
            {
                $self->{_data} = [];
            }
            else
            {
                return( $self->error( "Unable to set the APR::Finfo object: $@" ) );
            }
        }
    }
    else
    {
        $self->{_data} = [CORE::stat( $file )];
    }
    return( $self );
}

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

sub apr_finfo { return( shift->_set_get_object( 'apr_finfo', 'APR::Finfo', @_ ) ); }

sub atime
{
    my $self = shift( @_ );
    my $f = $self->apr_finfo;
    my $t;
    if( $f )
    {
        $t = $f->atime;
    }
    else
    {
        my $data = $self->{_data};
        return( '' ) if( !scalar( @$data ) );
        $t = $data->[ FINFO_ATIME ];