local-lib5/lib/perl5/LWP/MediaTypes.pm

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