home *** CD-ROM | disk | FTP | other *** search
/ CLIX - Fazer Clix Custa Nix / CLIX-CD.cdr / mac / lib / LWP / MediaTypes.pm < prev    next >
Text File  |  1997-11-18  |  6KB  |  220 lines
  1. #
  2. # $Id: MediaTypes.pm,v 1.1 1997/11/18 00:33:05 neeri Exp $
  3.  
  4. package LWP::MediaTypes;
  5.  
  6. =head1 NAME
  7.  
  8. guess_media_type - guess media type for a file or a URL.
  9.  
  10. media_suffix - returns file extentions for a media type
  11.  
  12. =head1 SYNOPSIS
  13.  
  14.  use LWP::MediaTypes qw(guess_media_type);
  15.  $type = guess_media_type("/tmp/foo.gif");
  16.  
  17. =head1 DESCRIPTION
  18.  
  19. This module provides functions for handling of media (also known as
  20. MIME) types and encodings.  The mapping from file extentions to media
  21. types is defined by the F<media.types> file.  If the F<~/.media.types>
  22. file exist it is used as a replacement.
  23.  
  24. For backwards compatability we will also look for F<~/.mime.types>.
  25.  
  26. =cut
  27.  
  28. ####################################################################
  29.  
  30. require Exporter;
  31. @ISA = qw(Exporter);
  32. @EXPORT = qw(guess_media_type media_suffix);
  33.  
  34. require LWP::Debug;
  35. use strict;
  36. use File::Basename;
  37.  
  38. # note: These hashes will also be filled with the entries found in
  39. # the 'media.types' file.
  40.  
  41. my %suffixType = (
  42.     'txt'   => 'text/plain',
  43.     'html'  => 'text/html',
  44.     'gif'   => 'image/gif',
  45.     'jpg'   => 'image/jpeg',
  46. );
  47.  
  48. my %suffixExt = (
  49.     'text/plain' => 'txt',
  50.     'text/html'  => 'h',
  51.     'image/gif'  => 'gif',
  52.     'image/jpeg' => 'jpg',
  53. );
  54.  
  55. #XXX: there should be some way to define this in the media.types files.
  56. my %suffixEncoding = (
  57.     'Z'   => 'compress',
  58.     'gz'  => 'gzip',
  59.     'hqx' => 'x-hqx',
  60.     'uu'  => 'x-uuencode',
  61.     'z'   => 'x-pack'
  62. );
  63.  
  64. local($/, $_) = ("\n", undef);  # ensure correct $INPUT_RECORD_SEPARATOR
  65.  
  66. my @priv_files = ();
  67. if ($^O eq "MacOS") {
  68.   push(@priv_files, "$ENV{HOME}/.media.types", "$ENV{HOME}/.mime.types")
  69.     if defined $ENV{HOME}; 
  70. } else {
  71.   push(@priv_files, "$ENV{HOME}:media.types", "$ENV{HOME}:mime.types")
  72.     if defined $ENV{HOME};  # Some does not have a home (for instance Win32)
  73. }
  74.  
  75. # Try to locate "media.types" file, and initialize %suffixType from it
  76. my $typefile;
  77. my @mediatypes =
  78.   ($^O eq "MacOS") ? (map {m/:$/ ? $_."LWP:media.types" : "$_:LWP:media.types"} @INC)
  79.   : (map {"$_/LWP/media.types"} @INC);
  80. for $typefile (@mediatypes, @priv_files) {
  81.     local(*TYPE);
  82.     open(TYPE, $typefile) || next;
  83.     LWP::Debug::debug("Reading media types from $typefile");
  84.     while (<TYPE>) {
  85.     next if /^\s*#/; # comment line
  86.     next if /^\s*$/; # blank line
  87.     s/#.*//;         # remove end-of-line comments
  88.     my($type, @exts) = split(' ', $_);
  89.     $suffixExt{$type} = $exts[0] if @exts;
  90.     my $ext;
  91.     for $ext (@exts) {
  92.         $suffixType{$ext} = $type;
  93.     }
  94.     }
  95.     close(TYPE);
  96. }
  97.  
  98.  
  99. ####################################################################
  100.  
  101. =head1 FUNCTIONS
  102.  
  103. =head2 guess_media_type($filename_or_url, [$header_to_modify])
  104.  
  105. This function tries to guess media type and encoding for given file.
  106. In scalar context it returns only the content-type.  In array context
  107. it returns an array consisting of content-type followed by any
  108. content-encodings applied.
  109.  
  110. The guess_media_type function also accepts a URI::URL object as argument.
  111.  
  112. If the type can not be deduced from looking at the file name only,
  113. then guess_media_type() will take a look at the actual file using the
  114. C<-T> perl operator in order to determine if this is a text file
  115. (text/plain).  If this does not work it will return
  116. I<application/octet-stream> as the type.
  117.  
  118. The optional second argument should be a reference to a HTTP::Headers
  119. object (or some HTTP::Message object).  When present this function
  120. will set the value of the 'Content-Type' and 'Content-Encoding' for
  121. this header.
  122.  
  123. =cut
  124.  
  125. sub guess_media_type
  126. {
  127.     my($file, $header) = @_;
  128.     return undef unless defined $file;
  129.  
  130.     my $fullname;
  131.     if (ref($file)) {
  132.     # assume URI::URL object
  133.     $file = $file->path;
  134.     #XXX should handle non http:, file: or ftp: URLs differently
  135.     } else {
  136.     $fullname = $file;  # enable peek at actual file
  137.     }
  138.     $file = basename($file);   # only basename left
  139.     my @parts = reverse split(/\./, $file);
  140.     pop(@parts);        # never concider first part
  141.  
  142.     my @encoding = ();
  143.     my $ct = undef;
  144.     for (@parts) {
  145.     # first check this dot part as encoding spec
  146.     if (exists $suffixEncoding{$_}) {
  147.         unshift(@encoding, $suffixEncoding{$_});
  148.         next;
  149.     }
  150.     if (exists $suffixEncoding{lc $_}) {
  151.         unshift(@encoding, $suffixEncoding{lc $_});
  152.         next;
  153.     }
  154.  
  155.     # check content-type
  156.     if (exists $suffixType{$_}) {
  157.         $ct = $suffixType{$_};
  158.         last;
  159.     }
  160.     if (exists $suffixType{lc $_}) {
  161.         $ct = $suffixType{lc $_};
  162.         last;
  163.     }
  164.  
  165.     # don't know nothing about this dot part, bail out
  166.     last;
  167.     }
  168.     unless (defined $ct) {
  169.     # Take a look at the file
  170.     if (defined $fullname) {
  171.         $ct = (-T $fullname) ? "text/plain" : "application/octet-stream";
  172.     } else {
  173.         $ct = "application/octet-stream";
  174.     }
  175.     }
  176.  
  177.     if ($header) {
  178.     $header->header('Content-Type' => $ct);
  179.     $header->header('Content-Encoding' => \@encoding) if @encoding;
  180.     }
  181.  
  182.     wantarray ? ($ct, @encoding) : $ct;
  183. }
  184.  
  185.  
  186. =head2 media_suffix($type,...)
  187.  
  188. This function will return all suffixes that can be used to denote the
  189. specified media type(s).  Wildcard types can be used.  In scalar
  190. context it will return the first suffix found.
  191.  
  192. Examples:
  193.  
  194.   @suffixes = media_suffix('image/*', 'audio/basic');
  195.   $suffix = media_suffix('text/html');
  196.  
  197. =cut
  198.  
  199. sub media_suffix {
  200.     if (!wantarray && @_ == 1 && $_[0] !~ /\*/) {
  201.     return $suffixExt{$_[0]};
  202.     }
  203.     my(@type) = @_;
  204.     my(@suffix, $ext, $type);
  205.     foreach (@type) {
  206.     if (s/\*/.*/) {
  207.         while(($ext,$type) = each(%suffixType)) {
  208.         push(@suffix, $ext) if $type =~ /^$_$/;
  209.         }
  210.     } else {
  211.         while(($ext,$type) = each(%suffixType)) {
  212.         push(@suffix, $ext) if $type eq $_;
  213.         }
  214.     }
  215.     }
  216.     wantarray ? @suffix : $suffix[0];
  217. }
  218.  
  219. 1;
  220.