home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _e953055ad903648cd08779c191620672 < prev    next >
Text File  |  2004-06-01  |  7KB  |  300 lines
  1. package LWP::MediaTypes;
  2.  
  3. # $Id: MediaTypes.pm,v 1.31 2004/04/09 15:07:04 gisle Exp $
  4.  
  5. require Exporter;
  6. @ISA = qw(Exporter);
  7. @EXPORT = qw(guess_media_type media_suffix);
  8. @EXPORT_OK = qw(add_type add_encoding read_media_types);
  9. $VERSION = sprintf("%d.%02d", q$Revision: 1.31 $ =~ /(\d+)\.(\d+)/);
  10.  
  11. require LWP::Debug;
  12. use strict;
  13.  
  14. # note: These hashes will also be filled with the entries found in
  15. # the 'media.types' file.
  16.  
  17. my %suffixType = (
  18.     'txt'   => 'text/plain',
  19.     'html'  => 'text/html',
  20.     'gif'   => 'image/gif',
  21.     'jpg'   => 'image/jpeg',
  22. );
  23.  
  24. my %suffixExt = (
  25.     'text/plain' => 'txt',
  26.     'text/html'  => 'html',
  27.     'image/gif'  => 'gif',
  28.     'image/jpeg' => 'jpg',
  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.  
  300.