File Coverage

lib/File/Type/WebImages.pm

Criterion	Covered	Total	%
statement	42	46	91.3
branch	19	24	79.1
condition	5	8	62.5
subroutine	8	8	100.0
pod	0	3	0.0
total	74	89	83.1

package File::Type::WebImages;
use strict;
use warnings;
use base 'Exporter';
use vars '@EXPORT_OK';
@EXPORT_OK = 'mime_type';

use IO::File;

our $VERSION = "1.01";

sub mime_type {
  # magically route argument

  my $argument = shift;
  return undef unless defined $argument;

  if (length $argument > 1024 || $argument =~ m/\n/) {
    # assume it's data. Saves a stat call if the data's long
    # also avoids stat warning if there's a newline
    return checktype_contents($argument);
  }

  if (-e $argument) {
    if (!-d $argument) {
      return checktype_filename($argument);
    } else {
      return undef; # directories don't have mime types
    }
  }
  # otherwise, fall back to checking the string as if it's data again
  return checktype_contents($argument);
}

# reads in 16k of selected file, or returns undef if can't open,
# then checks contents
sub checktype_filename {
  my $filename = shift;
  my $fh = IO::File->new($filename) || return undef;
  my $data;
  $fh->read($data, 16*1024);
  $fh->close;
  return checktype_contents($data);
}

# Matches $data against the magic database criteria and returns the MIME
# type of the file.
sub checktype_contents {
  my $data = shift;
  my $substr;

  return undef unless defined $data;

  if ($data =~ m[^\x89PNG]) {
    return q{image/png};
  }
  elsif ($data =~ m[^GIF8]) {
    return q{image/gif};
  }
  elsif ($data =~ m[^BM]) {
    return q{image/bmp};
  }

  if (length $data > 1) {
    $substr = substr($data, 1, 1024);
    if (defined $substr && $substr =~ m[^PNG]) {
      return q{image/png};
    }
  }
  if (length $data > 0) {
    $substr = substr($data, 0, 2);
    if (pack('H*', 'ffd8') eq $substr ) {
      return q{image/jpeg};
    }
  }

  return undef;
}

1;

__END__