view release on metacpan or  search on metacpan

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

            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 } );
    $io->close;
    return( $out );
}

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

sub handle 
{
    my $self = shift( @_ );
    my $io = shift( @_ );
    my $desc = shift( @_ );
    my $opts = $self->_get_args_as_hash( @_ );
    $opts->{default} = $self->default_type if( !length( $opts->{default} ) );
    my $type = '';
    
    # 3) Iterate over each magic entry.
    my $match_found = 0;
    for( my $m = 0; $m <= $#{ $self->{magic_data} }; $m++ ) 
    {
        # Check if the m-th magic entry matches and if it does, then $desc will contain 
        # an updated description
        my $test;
        if( ( $test = $self->_magic_match( $self->{magic_data}->[$m], \$desc, $io ) ) ) 
        {
            if( defined( $desc ) && $desc ne '' ) 
            {
                $match_found = 1;
                $type = $desc;
                last;
            }
        }
        elsif( !defined( $test ) )
        {
            warnings::warn( "Error occurred while checking for match: ", $self->error ) if( warnings::enabled() && $self->debug );
        }
    
        # Read another entry from the magic file if we've exhausted all the entries 
        # already buffered. read_magic_entry will add to the end of the array 
        # if there are more.
        if( $m == $#{ $self->{magic_data} } &&
            $self->{magic}->{io} && 
            !$self->{magic}->{io}->eof )
        {
            $self->read_magic_entry();
        }
    }
    
    # 4) Check if it's text or binary.
    # if It's text, then do a bunch of searching for special tokens
    if( !$match_found ) 
    {
        my $data = '';
        $io->seek( 0, 0 );
        $io->read( $data, 0x8564 );
        $type = $self->with_data( $data );
    }
    if( !defined( $type ) )
    {
        $type = $opts->{default} ? $opts->{default} : '';
    }
    return( $type );
}

sub parse_magic_file 
{
    my $self = shift( @_ );
    my $io   = shift( @_ );
    # Initialize values
    $self->{magic}->{io}     = $io;
    $self->{magic}->{buffer} = undef();
    $self->{magic}->{count}  = 0;
    while( !$io->eof() )
    {
        $self->read_magic_entry();
    }
    seek( $io, 0, 0 );
}

# parse_magic_line( $line, $line_num, $subtests )
#
# Parses the match info out of $line.  Returns a reference to an array.

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

        my( $token, %val );
        foreach my $type ( keys( %{$self->{SPECIALS}} ) ) 
        {
            my $token = '(' . ( join( '|', sort{ length( $a ) <=> length( $b ) } @{$self->{SPECIALS}->{ $type } } ) ) . ')';
            my $tdata = $data;
            if( $tdata =~ /$token/mg ) 
            {
                $val{ $type } = pos( $tdata );
            }
        }
        # Search latest match
        if( scalar( keys( %val ) ) )
        {
            my @skeys = sort{ $val{ $a } <=> $val{ $b } } keys( %val );
            $type = $skeys[0];
        }
    
        # ALLDONE:
        # $type = 'text/plain' if( !defined( $type ) );
    }
    # $type = 'text/plain' if( !defined( $type ) );
    return( $type );
}

sub with_filename 
{
    my $self  = shift( @_ );
    my $fname = shift( @_ );
    my $type  = '';
    
    my $file = $fname;
    $fname =~ s/^.*\///;
    for my $regex ( keys( %{$self->{FILE_EXTS}} ) )
    {
        if( $fname =~ /$regex/i ) 
        {
            if( ( defined( $type ) && $type !~ /;/ ) || 
                !defined( $type ) ) 
            {
                # has no x-type param
                $type = $self->{FILE_EXTS}->{ $regex };
            }
        }
    }
    return( $type );
}

sub with_magic 
{
    my $self = shift( @_ );
    my $data = shift( @_ );
    my $desc = '';
    my $type = '';
    
    return( 'application/octet-stream' ) if( length( $data ) <= 0 );
    
    # 3) Iterate over each magic entry.
    for( my $m = 0; $m <= $#{ $self->{magic_data} }; $m++ ) 
    {
        # Check if the m-th magic entry matches and if it does, then $desc will contain 
        # an updated description
        if( $self->_magic_match_str( $self->{magic_data}->[ $m ], \$desc, $data ) ) 
        {
            if( defined( $desc ) && $desc ne '' ) 
            {
                $type = $desc;
                last;
            }
        }
    
        # Read another entry from the magic file if we've exhausted all the entries 
        # already buffered. read_magic_entry will add to the end of the array if 
        # there are more.
        if( $m == $#{ $self->{magic_data} } && !$self->{magic}->{io}->eof() )
        {
            $self->read_magic_entry();
        }
    }
    return( $type );
}

sub _is_binary 
{
    my( $data ) = @_;
    my $len = length( $data );
    # Exclude TAB, ESC, nl, cr
    my $count = ( $data =~ tr/[\x00-\x08\x0b-\x0c\x0e-\x1a\x1c-\x1f]// );
    # No contents
    return( 1 ) if( $len <= 0 );
    # Binary
    return( 1 ) if( ( $count / $len ) > 0.1 );
    return( 0 );
}

# Compare the magic item with the filehandle.
# If success, print info and return true, otherwise return undef.
#
# This is called recursively if an item has subitems.
sub _magic_match
{
    my $self = shift( @_ );
    # $io is the file handle of the file being inspected
    my( $item, $p_desc, $io ) = @_;
    
    # $item could be undef if we ran into troubles while reading the entry.
    return unless( defined( $item ) && ref( $item // '' ) eq 'ARRAY' );
    
    # Delayed evaluation. If this is our first time considering this item, then parse out 
    # its structure. @$item is just the raw string, line number, and subtests until we 
    # need the real info. This saves time otherwise wasted parsing unused subtests.
    $item = $self->parse_magic_line( @$item ) if( @$item == 3 );
    
    # $io is not defined if -c. That way we always return false for every item which 
    # allows reading/checking the entire magic file.
    return( $self->error( "File handle is not defined." ) ) unless( defined( $io ) );
    # return unless( defined( fileno( $io ) ) );
    # return unless( Scalar::Util::openhandle( $io ) );
    
    my( $offtype, $offset, $numbytes, $type, $mask, $op, $testval, $template, $message, $subtests ) = @$item;
    $self->{trick}++;
    if( $self->{trick} > 186 && $self->{trick} < 192 )