view release on metacpan or  search on metacpan

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

        {
            $self->dump( $subtests, $depth + 1 );
        }
    }
}

sub error_returns_undef { return( shift->_set_get_boolean( 'error_returns_undef', @_ ) ); }

sub file 
{
    my $self = shift( @_ );
    # The description line. append info to this string
    my $desc = '';
    my $type = '';
    # Iterate over each file explicitly so we can seek
    my $file = shift( @_ ) || do
    {
        if( $self->{error_returns_undef} )
        {
            return( $self->error( "Missing file arguement. Usage: \$magic->file( \$some_file_name )" ) );
        }
        else
        {
            $desc .= "no file provided.";
            return( "x-system/x-error; $desc" );
        }
    };
    
    # No need to let everybody know what is our server file system
    my $base_file = File::Basename::basename( $file );
    # 0) Check existence
    if( !-e( $file ) )
    {
        if( $self->{error_returns_undef} )
        {
            return( $self->error( "File $file does not exist." ) );
        }
        else
        {
            $desc .= "file '$file' does not exist.";
            return( "x-system/x-error; $desc" );
        }
    }
    # 1) Check permission
    elsif( !-r( $file ) ) 
    {
        if( $self->{error_returns_undef} )
        {
            return( $self->error( "Unable to read file '$file'; lacking permission" ) );
        }
        else
        {
            $desc .= "unable to read '$base_file': Permission denied.";
            return( "x-system/x-error; $desc" );
        }
    }
    
    # 2) Check for various special files first
    if( $self->follow_links ) 
    {
        CORE::stat( $file ); 
    } 
    else 
    {
        CORE::lstat( $file );
    }
    # Avoid doing many useless redondant system stat, use '_'. See perlfunc man page
    if( !-f( _ ) || -z( _ ) ) 
    {
        if( !$self->follow_links && -l( _ ) ) 
        { 
            #$desc .= " symbolic link to ". readlink( $file );
            return( 'application/x-link' );
        }
        elsif( -d( _ ) ) { return( 'application/x-directory' ); }
        # Named pipe
        elsif( -p( _ ) ) { return( 'application/x-pipe' ); }
        elsif( -S( _ ) ) { return( 'application/x-socket' ); }
        # Block special file
        elsif( -b( _ ) ) { return( 'application/x-block' ); }
        # Character special file
        elsif( -c( _ ) ) { return( 'application/x-character' ); }
        elsif( -z( _ ) ) { return( 'application/x-empty' ); }
        else 
        {
            return( $self->{default_type} ? $self->{default_type} : 'application/x-unknown' );
        }
    }
    
    # Current file handle. or undef if check_magic (-c option) is true.
    my $io;
    $io = IO::File->new( "<$file" ) || do
    {
        if( $self->{error_returns_undef} )
        {
            return( $self->error( "Unable to open file '$file': $!" ) );
        }
        else
        {
            return( "x-system/x-error; $base_file: $!" );
        }
    };
    $io->binmode;
    
    # 3) Check for script
    # if( ( -x( $file ) || ( $^O =~ /^(dos|mswin32|NetWare|symbian|win32)$/i && $file =~ /\.(?:pl|cgi)$/ ) ) && 
#     if( ( -x( $file ) || $file =~ /\.(?:cgi|pl|t)$/ ) && 
#         -T( _ ) ) 
    my $default;
    if( -x( $file ) && -T( _ ) ) 
    {
        # Note, some magic files include elaborate attempts to match #! header lines 
        # and return pretty responses but this slows down matching and is unnecessary.
        my $line1 = $io->getline;
        if( $line1 =~ /^\#![[:blank:]\h]*(\S+)/ ) 
        {
            # Returns the binary name, without file path
            my $bin_name = File::Basename::basename( $1 );
            #$desc .= " executable $bin_name script text";
            # $io->close;
            # return( "text/x-${bin_name}" );
            $default = "text/x-${bin_name}";
        }
    }
    my $out = $self->handle( $io, $desc, { default => $default } );