home *** CD-ROM | disk | FTP | other *** search
/ Chip 2000 May / Chip_2000-05_cd1.bin / zkuste / Perl / ActivePerl-5.6.0.613.msi / 䆊䌷䈹䈙䏵-䞅䞆䞀㡆䞃䄦䠥 / _dad0235a35a1f749cd43b6e972f9b1f5 < prev    next >
Text File  |  2000-03-15  |  7KB  |  307 lines
  1. #
  2. # $Id: MediaTypes.pm,v 1.25 1999/03/20 07:37:36 gisle 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);
  35. $VERSION = sprintf("%d.%02d", q$Revision: 1.25 $ =~ /(\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'  => 'h',
  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. );
  65.  
  66. sub _dump {
  67.     require Data::Dumper;
  68.     Data::Dumper->new([\%suffixType, \%suffixExt, \%suffixEncoding],
  69.               [qw(*suffixType *suffixExt *suffixEncoding)])->Dump;
  70. }
  71.  
  72. read_media_types();
  73.  
  74.  
  75.  
  76. =item guess_media_type($filename_or_url, [$header_to_modify])
  77.  
  78. This function tries to guess media type and encoding for a file or url.
  79. It returns the content-type, which is a string like C<"text/html">.
  80. In array context it also returns any content-encodings applied (in the
  81. order used to encode the file).  You can pass a URI object
  82. reference, instead of the file name.
  83.  
  84. If the type can not be deduced from looking at the file name,
  85. then guess_media_type() will let the C<-T> Perl operator take a look.
  86. If this works (and C<-T> returns a TRUE value) then we return
  87. I<text/plain> as the type, otherwise we return
  88. I<application/octet-stream> as the type.
  89.  
  90. The optional second argument should be a reference to a HTTP::Headers
  91. object or any object that implements the $obj->header method in a
  92. similar way.  When it is present the values of the
  93. 'Content-Type' and 'Content-Encoding' will be set for this header.
  94.  
  95. =cut
  96.  
  97. sub guess_media_type
  98. {
  99.     my($file, $header) = @_;
  100.     return undef unless defined $file;
  101.  
  102.     my $fullname;
  103.     if (ref($file)) {
  104.     # assume URI object
  105.     $file = $file->path;
  106.     #XXX should handle non http:, file: or ftp: URIs differently
  107.     } else {
  108.     $fullname = $file;  # enable peek at actual file
  109.     }
  110.  
  111.     my @encoding = ();
  112.     my $ct = undef;
  113.     for (file_exts($file)) {
  114.     # first check this dot part as encoding spec
  115.     if (exists $suffixEncoding{$_}) {
  116.         unshift(@encoding, $suffixEncoding{$_});
  117.         next;
  118.     }
  119.     if (exists $suffixEncoding{lc $_}) {
  120.         unshift(@encoding, $suffixEncoding{lc $_});
  121.         next;
  122.     }
  123.  
  124.     # check content-type
  125.     if (exists $suffixType{$_}) {
  126.         $ct = $suffixType{$_};
  127.         last;
  128.     }
  129.     if (exists $suffixType{lc $_}) {
  130.         $ct = $suffixType{lc $_};
  131.         last;
  132.     }
  133.  
  134.     # don't know nothing about this dot part, bail out
  135.     last;
  136.     }
  137.     unless (defined $ct) {
  138.     # Take a look at the file
  139.     if (defined $fullname) {
  140.         $ct = (-T $fullname) ? "text/plain" : "application/octet-stream";
  141.     } else {
  142.         $ct = "application/octet-stream";
  143.     }
  144.     }
  145.  
  146.     if ($header) {
  147.     $header->header('Content-Type' => $ct);
  148.     $header->header('Content-Encoding' => \@encoding) if @encoding;
  149.     }
  150.  
  151.     wantarray ? ($ct, @encoding) : $ct;
  152. }
  153.  
  154.  
  155. =item media_suffix($type,...)
  156.  
  157. This function will return all suffixes that can be used to denote the
  158. specified media type(s).  Wildcard types can be used.  In a scalar
  159. context it will return the first suffix found.
  160.  
  161. Examples:
  162.  
  163.   @suffixes = media_suffix('image/*', 'audio/basic');
  164.   $suffix = media_suffix('text/html');
  165.  
  166. =cut
  167.  
  168. sub media_suffix {
  169.     if (!wantarray && @_ == 1 && $_[0] !~ /\*/) {
  170.     return $suffixExt{$_[0]};
  171.     }
  172.     my(@type) = @_;
  173.     my(@suffix, $ext, $type);
  174.     foreach (@type) {
  175.     if (s/\*/.*/) {
  176.         while(($ext,$type) = each(%suffixType)) {
  177.         push(@suffix, $ext) if $type =~ /^$_$/;
  178.         }
  179.     } else {
  180.         while(($ext,$type) = each(%suffixType)) {
  181.         push(@suffix, $ext) if $type eq $_;
  182.         }
  183.     }
  184.     }
  185.     wantarray ? @suffix : $suffix[0];
  186. }
  187.  
  188.  
  189. sub file_exts 
  190. {
  191.     require File::Basename;
  192.     my @parts = reverse split(/\./, File::Basename::basename($_[0]));
  193.     pop(@parts);        # never consider first part
  194.     @parts;
  195. }
  196.  
  197.  
  198. =back
  199.  
  200. The following functions are only exported by explict request:
  201.  
  202. =over 4
  203.  
  204. =item add_type($type, @exts)
  205.  
  206. Associate a list of file extensions with the given media type.
  207.  
  208. Example:
  209.  
  210.     add_type("x-world/x-vrml" => qw(wrl vrml));
  211.  
  212. =cut
  213.  
  214. sub add_type 
  215. {
  216.     my($type, @exts) = @_;
  217.     for my $ext (@exts) {
  218.     $ext =~ s/^\.//;
  219.     $suffixType{$ext} = $type;
  220.     }
  221.     $suffixExt{$type} = $exts[0] if @exts;
  222. }
  223.  
  224.  
  225. =item add_encoding($type, @ext)
  226.  
  227. Associate a list of file extensions with an encoding type.
  228.  
  229. Example:
  230.  
  231.  add_encoding("x-gzip" => "gz");
  232.  
  233. =cut
  234.  
  235. sub add_encoding
  236. {
  237.     my($type, @exts) = @_;
  238.     for my $ext (@exts) {
  239.     $ext =~ s/^\.//;
  240.     $suffixEncoding{$ext} = $type;
  241.     }
  242. }
  243.  
  244.  
  245. =item read_media_types(@files)
  246.  
  247. Parse media types files and add the type mappings found there.
  248.  
  249. Example:
  250.  
  251.     read_media_types("conf/mime.types");
  252.  
  253. =cut
  254.  
  255. sub read_media_types 
  256. {
  257.     my(@files) = @_;
  258.  
  259.     local($/, $_) = ("\n", undef);  # ensure correct $INPUT_RECORD_SEPARATOR
  260.  
  261.     my @priv_files = ();
  262.     if($^O eq "MacOS") {
  263.     push(@priv_files, "$ENV{HOME}:media.types", "$ENV{HOME}:mime.types")
  264.         if defined $ENV{HOME};  # Some does not have a home (for instance Win32)
  265.     } else {
  266.     push(@priv_files, "$ENV{HOME}/.media.types", "$ENV{HOME}/.mime.types")
  267.         if defined $ENV{HOME};  # Some doesn't have a home (for instance Win32)
  268.     }
  269.  
  270.     # Try to locate "media.types" file, and initialize %suffixType from it
  271.     my $typefile;
  272.     unless (@files) {
  273.     if($^O eq "MacOS") {
  274.         @files = map {$_."LWP:media.types"} @INC;
  275.     } else {
  276.         @files = map {"$_/LWP/media.types"} @INC;
  277.     }
  278.     push @files, @priv_files;
  279.     }
  280.     for $typefile (@files) {
  281.     local(*TYPE);
  282.     open(TYPE, $typefile) || next;
  283.         LWP::Debug::debug("Reading media types from $typefile");
  284.     while (<TYPE>) {
  285.         next if /^\s*#/; # comment line
  286.         next if /^\s*$/; # blank line
  287.         s/#.*//;         # remove end-of-line comments
  288.         my($type, @exts) = split(' ', $_);
  289.         add_type($type, @exts);
  290.     }
  291.     close(TYPE);
  292.     }
  293. }
  294.  
  295. 1;
  296.  
  297. =back 
  298.  
  299. =head1 COPYRIGHT
  300.  
  301. Copyright 1995-1999 Gisle Aas.
  302.  
  303. This library is free software; you can redistribute it and/or
  304. modify it under the same terms as Perl itself.
  305.  
  306. =cut
  307.