lib/LWP/MediaTypes.pm

   1 #
   2 # $Id: MediaTypes.pm,v 1.1.1.1 2003/08/02 23:39:53 takezoe Exp $
   3
   4 package LWP::MediaTypes;
   5
   6 =head1 NAME
   7
   8 LWP::MediaTypes - guess media type for a file or a URL
   9
  10 =head1 SYNOPSIS
  11
  12  use LWP::MediaTypes qw(guess_media_type);
  13  $type = guess_media_type("/tmp/foo.gif");
  14
  15 =head1 DESCRIPTION
  16
  17 This module provides functions for handling media (also known as
  18 MIME) types and encodings.  The mapping from file extentions to media
  19 types is defined by the F<media.types> file.  If the F<~/.media.types>
  20 file exists it is used instead.
  21 For backwards compatability we will also look for F<~/.mime.types>.
  22
  23 The following functions are exported by default:
  24
  25 =over 4
  26
  27 =cut
  28
  29 ####################################################################
  30
  31 require Exporter;
  32 @ISA = qw(Exporter);
  33 @EXPORT = qw(guess_media_type media_suffix);
  34 @EXPORT_OK = qw(add_type add_encoding read_media_types);
  35 $VERSION = sprintf("%d.%02d", q$Revision: 1.1.1.1 $ =~ /(\d+)\.(\d+)/);
  36
  37 require LWP::Debug;
  38 use strict;
  39
  40 # note: These hashes will also be filled with the entries found in
  41 # the 'media.types' file.
  42
  43 my %suffixType = (
  44     'txt'   => 'text/plain',
  45     'html'  => 'text/html',
  46     'gif'   => 'image/gif',
  47     'jpg'   => 'image/jpeg',
  48 );
  49
  50 my %suffixExt = (
  51     'text/plain' => 'txt',
  52     'text/html'  => 'html',
  53     'image/gif'  => 'gif',
  54     'image/jpeg' => 'jpg',
  55 );
  56
  57 #XXX: there should be some way to define this in the media.types files.
  58 my %suffixEncoding = (
  59     'Z'   => 'compress',
  60     'gz'  => 'gzip',
  61     'hqx' => 'x-hqx',
  62     'uu'  => 'x-uuencode',
  63     'z'   => 'x-pack',
  64     'bz2' => 'x-bzip2',
  65 );
  66
  67 sub _dump {
  68     require Data::Dumper;
  69     Data::Dumper->new([\%suffixType, \%suffixExt, \%suffixEncoding],
  70                       [qw(*suffixType *suffixExt *suffixEncoding)])->Dump;
  71 }
  72
  73 read_media_types();
  74
  75
  76
  77 =item guess_media_type($filename_or_url, [$header_to_modify])
  78
  79 This function tries to guess media type and encoding for a file or url.
  80 It returns the content-type, which is a string like C<"text/html">.
  81 In array context it also returns any content-encodings applied (in the
  82 order used to encode the file).  You can pass a URI object
  83 reference, instead of the file name.
  84
  85 If the type can not be deduced from looking at the file name,
  86 then guess_media_type() will let the C<-T> Perl operator take a look.
  87 If this works (and C<-T> returns a TRUE value) then we return
  88 I<text/plain> as the type, otherwise we return
  89 I<application/octet-stream> as the type.
  90
  91 The optional second argument should be a reference to a HTTP::Headers
  92 object or any object that implements the $obj->header method in a
  93 similar way.  When it is present the values of the
  94 'Content-Type' and 'Content-Encoding' will be set for this header.
  95
  96 =cut
  97
  98 sub guess_media_type
  99 {
 100     my($file, $header) = @_;
 101     return undef unless defined $file;
 102
 103     my $fullname;
 104     if (ref($file)) {
 105         # assume URI object
 106         $file = $file->path;
 107         #XXX should handle non http:, file: or ftp: URIs differently
 108     } else {
 109         $fullname = $file;  # enable peek at actual file
 110     }
 111
 112     my @encoding = ();
 113     my $ct = undef;
 114     for (file_exts($file)) {
 115         # first check this dot part as encoding spec
 116         if (exists $suffixEncoding{$_}) {
 117             unshift(@encoding, $suffixEncoding{$_});
 118             next;
 119         }
 120         if (exists $suffixEncoding{lc $_}) {
 121             unshift(@encoding, $suffixEncoding{lc $_});
 122             next;
 123         }
 124
 125         # check content-type
 126         if (exists $suffixType{$_}) {
 127             $ct = $suffixType{$_};
 128             last;
 129         }
 130         if (exists $suffixType{lc $_}) {
 131             $ct = $suffixType{lc $_};
 132             last;
 133         }
 134
 135         # don't know nothing about this dot part, bail out
 136         last;
 137     }
 138     unless (defined $ct) {
 139         # Take a look at the file
 140         if (defined $fullname) {
 141             $ct = (-T $fullname) ? "text/plain" : "application/octet-stream";
 142         } else {
 143             $ct = "application/octet-stream";
 144         }
 145     }
 146
 147     if ($header) {
 148         $header->header('Content-Type' => $ct);
 149         $header->header('Content-Encoding' => \@encoding) if @encoding;
 150     }
 151
 152     wantarray ? ($ct, @encoding) : $ct;
 153 }
 154
 155
 156 =item media_suffix($type,...)
 157
 158 This function will return all suffixes that can be used to denote the
 159 specified media type(s).  Wildcard types can be used.  In a scalar
 160 context it will return the first suffix found.
 161
 162 Examples:
 163
 164   @suffixes = media_suffix('image/*', 'audio/basic');
 165   $suffix = media_suffix('text/html');
 166
 167 =cut
 168
 169 sub media_suffix {
 170     if (!wantarray && @_ == 1 && $_[0] !~ /\*/) {
 171         return $suffixExt{$_[0]};
 172     }
 173     my(@type) = @_;
 174     my(@suffix, $ext, $type);
 175     foreach (@type) {
 176         if (s/\*/.*/) {
 177             while(($ext,$type) = each(%suffixType)) {
 178                 push(@suffix, $ext) if $type =~ /^$_$/;
 179             }
 180         } else {
 181             while(($ext,$type) = each(%suffixType)) {
 182                 push(@suffix, $ext) if $type eq $_;
 183             }
 184         }
 185     }
 186     wantarray ? @suffix : $suffix[0];
 187 }
 188
 189
 190 sub file_exts
 191 {
 192     require File::Basename;
 193     my @parts = reverse split(/\./, File::Basename::basename($_[0]));
 194     pop(@parts);        # never consider first part
 195     @parts;
 196 }
 197
 198
 199 =back
 200
 201 The following functions are only exported by explict request:
 202
 203 =over 4
 204
 205 =item add_type($type, @exts)
 206
 207 Associate a list of file extensions with the given media type.
 208
 209 Example:
 210
 211     add_type("x-world/x-vrml" => qw(wrl vrml));
 212
 213 =cut
 214
 215 sub add_type
 216 {
 217     my($type, @exts) = @_;
 218     for my $ext (@exts) {
 219         $ext =~ s/^\.//;
 220         $suffixType{$ext} = $type;
 221     }
 222     $suffixExt{$type} = $exts[0] if @exts;
 223 }
 224
 225
 226 =item add_encoding($type, @ext)
 227
 228 Associate a list of file extensions with an encoding type.
 229
 230 Example:
 231
 232  add_encoding("x-gzip" => "gz");
 233
 234 =cut
 235
 236 sub add_encoding
 237 {
 238     my($type, @exts) = @_;
 239     for my $ext (@exts) {
 240         $ext =~ s/^\.//;
 241         $suffixEncoding{$ext} = $type;
 242     }
 243 }
 244
 245
 246 =item read_media_types(@files)
 247
 248 Parse media types files and add the type mappings found there.
 249
 250 Example:
 251
 252     read_media_types("conf/mime.types");
 253
 254 =cut
 255
 256 sub read_media_types
 257 {
 258     my(@files) = @_;
 259
 260     local($/, $_) = ("\n", undef);  # ensure correct $INPUT_RECORD_SEPARATOR
 261
 262     my @priv_files = ();
 263     if($^O eq "MacOS") {
 264         push(@priv_files, "$ENV{HOME}:media.types", "$ENV{HOME}:mime.types")
 265             if defined $ENV{HOME};  # Some does not have a home (for instance Win32)
 266     } else {
 267         push(@priv_files, "$ENV{HOME}/.media.types", "$ENV{HOME}/.mime.types")
 268             if defined $ENV{HOME};  # Some doesn't have a home (for instance Win32)
 269     }
 270
 271     # Try to locate "media.types" file, and initialize %suffixType from it
 272     my $typefile;
 273     unless (@files) {
 274         if($^O eq "MacOS") {
 275             @files = map {$_."LWP:media.types"} @INC;
 276         } else {
 277             @files = map {"$_/LWP/media.types"} @INC;
 278         }
 279         push @files, @priv_files;
 280     }
 281     for $typefile (@files) {
 282         local(*TYPE);
 283         open(TYPE, $typefile) || next;
 284         LWP::Debug::debug("Reading media types from $typefile");
 285         while (<TYPE>) {
 286             next if /^\s*#/; # comment line
 287             next if /^\s*$/; # blank line
 288             s/#.*//;         # remove end-of-line comments
 289             my($type, @exts) = split(' ', $_);
 290             add_type($type, @exts);
 291         }
 292         close(TYPE);
 293     }
 294 }
 295
 296 1;
 297
 298 =back
 299
 300 =head1 COPYRIGHT
 301
 302 Copyright 1995-1999 Gisle Aas.
 303
 304 This library is free software; you can redistribute it and/or
 305 modify it under the same terms as Perl itself.
 306
 307 =cut