local-lib5/lib/perl5/File/Type/WebImages.pm

   1 package File::Type::WebImages;
   2 use strict;
   3 use warnings;
   4 use base 'Exporter';
   5 use vars '@EXPORT_OK';
   6 @EXPORT_OK = 'mime_type';
   7
   8 use IO::File;
   9
  10 our $VERSION = "1.01";
  11
  12 sub mime_type {
  13   # magically route argument
  14
  15   my $argument = shift;
  16   return undef unless defined $argument;
  17
  18   if (length $argument > 1024 || $argument =~ m/\n/) {
  19     # assume it's data. Saves a stat call if the data's long
  20     # also avoids stat warning if there's a newline
  21     return checktype_contents($argument);
  22   }
  23
  24   if (-e $argument) {
  25     if (!-d $argument) {
  26       return checktype_filename($argument);
  27     } else {
  28       return undef; # directories don't have mime types
  29     }
  30   }
  31   # otherwise, fall back to checking the string as if it's data again
  32   return checktype_contents($argument);
  33 }
  34
  35 # reads in 16k of selected file, or returns undef if can't open,
  36 # then checks contents
  37 sub checktype_filename {
  38   my $filename = shift;
  39   my $fh = IO::File->new($filename) || return undef;
  40   my $data;
  41   $fh->read($data, 16*1024);
  42   $fh->close;
  43   return checktype_contents($data);
  44 }
  45
  46 # Matches $data against the magic database criteria and returns the MIME
  47 # type of the file.
  48 sub checktype_contents {
  49   my $data = shift;
  50   my $substr;
  51
  52   return undef unless defined $data;
  53
  54   if ($data =~ m[^\x89PNG]) {
  55     return q{image/png};
  56   }
  57   elsif ($data =~ m[^GIF8]) {
  58     return q{image/gif};
  59   }
  60   elsif ($data =~ m[^BM]) {
  61     return q{image/bmp};
  62   }
  63
  64   if (length $data > 1) {
  65     $substr = substr($data, 1, 1024);
  66     if (defined $substr && $substr =~ m[^PNG]) {
  67       return q{image/png};
  68     }
  69   }
  70   if (length $data > 0) {
  71     $substr = substr($data, 0, 2);
  72     if (pack('H*', 'ffd8') eq $substr ) {
  73       return q{image/jpeg};
  74     }
  75   }
  76
  77   return undef;
  78 }
  79
  80 1;
  81
  82 __END__
  83
  84 =head1 NAME
  85
  86 File::Type::WebImages - determine web image file types using magic
  87
  88 =head1 SYNOPSIS
  89
  90     use File::Type::WebImages 'mime_type';
  91
  92     my $type_1 = mime_type($file);
  93     my $type_2 = mime_type($data);
  94
  95 =head1 DESCRIPTION
  96
  97 C<mime_type()> can use either a filename, or file contents, to determine the
  98 type of a file. The process involves looking the data at the beginning of the file,
  99 sometimes called "magic numbers".
 100
 101 =head1 THE BIG TRADE OFF
 102
 103 For minimum memory consumption, only the following common web image  file types are supported:
 104
 105 BMP, GIF, JPEG and PNG.
 106 ( image/bmp, image/gif, image/jpeg and image/png ).
 107
 108 Unlike with L<File::Type> and L<File::MMagic>, 'undef', not
 109 "application/octet-stream" will be returned for unknown formats.
 110
 111 Unlike L<File::Type>, we return "image/png" for PNGs, I<not> "image/x-png";
 112
 113 If you want more mime types detected use L<File::Type> or some other module.
 114
 115 =head1 TODO
 116
 117 It would be even better to have a pluggable system that would allow you
 118 to plug-in different sets of MIME-types you care about.
 119
 120 =head1 SEE ALSO
 121
 122 L<File::Type>. Similar, but supports over 100 file types.
 123
 124 =head1 ACKNOWLEDGMENTS
 125
 126 File::Type::WebImages is built from a mime-magic file from cleancode.org. The original
 127 can be found at L<http://cleancode.org/cgi-bin/viewcvs.cgi/email/mime-magic.mime?rev=1.1.1.1>.
 128
 129 =head1 AUTHORS
 130
 131 Paul Mison <pmison@fotango.com> - wrote original File::Type
 132 Mark Stosberg <mark@summersault.com> - hacked up this.
 133
 134 =head1 COPYRIGHT
 135
 136 Copyright 2003-2004 Fotango Ltd.
 137
 138 =head1 LICENSE
 139
 140 Licensed under the same terms as Perl itself.
 141
 142 =cut