"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tlperl/site/lib/LWP/MediaTypes.pm" (7 Mar 2020, 6911 Bytes) of package /windows/misc/install-tl.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

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