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