File Coverage

blib/lib/LWP/MediaTypes.pm
Criterion Covered Total %
statement 82 87 94.2
branch 40 52 76.9
condition 4 6 66.6
subroutine 9 9 100.0
pod 5 6 83.3
total 140 160 87.5


line stmt bran cond sub pod time code
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 1     1   72661 use strict;
  1         13  
  1         32  
10 1     1   6 use Scalar::Util qw(blessed);
  1         2  
  1         44  
11 1     1   5 use Carp qw(croak);
  1         2  
  1         1122  
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 29     29 1 20746 my($file, $header) = @_;
49 29 50       68 return undef unless defined $file;
50              
51 29         41 my $fullname;
52 29 100       72 if (ref $file) {
53 9 100       252 croak("Unable to determine filetype on unblessed refs") unless blessed($file);
54 8 100       62 if ($file->can('path')) {
    100          
55 4         12 $file = $file->path;
56             }
57             elsif ($file->can('filename')) {
58 2         6 $fullname = $file->filename;
59             }
60             else {
61 2         34 $fullname = "" . $file;
62             }
63             }
64             else {
65 20         27 $fullname = $file; # enable peek at actual file
66             }
67              
68 28         95 my @encoding = ();
69 28         40 my $ct = undef;
70 28         50 for (file_exts($file)) {
71             # first check this dot part as encoding spec
72 28 100       71 if (exists $suffixEncoding{$_}) {
73 10         25 unshift(@encoding, $suffixEncoding{$_});
74 10         15 next;
75             }
76 18 100       42 if (exists $suffixEncoding{lc $_}) {
77 2         7 unshift(@encoding, $suffixEncoding{lc $_});
78 2         4 next;
79             }
80              
81             # check content-type
82 16 100       40 if (exists $suffixType{$_}) {
83 14         25 $ct = $suffixType{$_};
84 14         19 last;
85             }
86 2 50       7 if (exists $suffixType{lc $_}) {
87 0         0 $ct = $suffixType{lc $_};
88 0         0 last;
89             }
90              
91             # don't know nothing about this dot part, bail out
92 2         4 last;
93             }
94 28 100       65 unless (defined $ct) {
95             # Take a look at the file
96 14 100       30 if (defined $fullname) {
97 12 100       482 $ct = (-T $fullname) ? "text/plain" : "application/octet-stream";
98             }
99             else {
100 2         3 $ct = "application/octet-stream";
101             }
102             }
103              
104 28 100       83 if ($header) {
105 1         21 $header->header('Content-Type' => $ct);
106 1 50       19 $header->header('Content-Encoding' => \@encoding) if @encoding;
107             }
108              
109 28 100       111 wantarray ? ($ct, @encoding) : $ct;
110             }
111              
112              
113             sub media_suffix {
114 3 50 66 3 1 1959 if (!wantarray && @_ == 1 && $_[0] !~ /\*/) {
      66        
115 1         7 return $suffixExt{lc $_[0]};
116             }
117 2         6 my(@type) = @_;
118 2         4 my(@suffix, $ext, $type);
119 2         6 foreach (@type) {
120 2 50       12 if (s/\*/.*/) {
121 2         11 while(($ext,$type) = each(%suffixType)) {
122 1766 100       6487 push(@suffix, $ext) if $type =~ /^$_$/i;
123             }
124             }
125             else {
126 0         0 my $ltype = lc $_;
127 0         0 while(($ext,$type) = each(%suffixType)) {
128 0 0       0 push(@suffix, $ext) if lc $type eq $ltype;
129             }
130             }
131             }
132 2 50       27 wantarray ? @suffix : $suffix[0];
133             }
134              
135              
136             sub file_exts
137             {
138 28     28 0 135 require File::Basename;
139 28         826 my @parts = reverse split(/\./, File::Basename::basename($_[0]));
140 28         122 pop(@parts); # never consider first part
141 28         70 @parts;
142             }
143              
144              
145             sub add_type
146             {
147 2065     2065 1 3644 my($type, @exts) = @_;
148 2065         2896 for my $ext (@exts) {
149 2651         3446 $ext =~ s/^\.//;
150 2651         4999 $suffixType{$ext} = $type;
151             }
152 2065 50       7881 $suffixExt{lc $type} = $exts[0] if @exts;
153             }
154              
155              
156             sub add_encoding
157             {
158 2     2 1 6 my($type, @exts) = @_;
159 2         5 for my $ext (@exts) {
160 2         4 $ext =~ s/^\.//;
161 2         6 $suffixEncoding{$ext} = $type;
162             }
163             }
164              
165              
166             sub read_media_types
167             {
168 1     1 1 3 my(@files) = @_;
169              
170 1         7 local($/, $_) = ("\n", undef); # ensure correct $INPUT_RECORD_SEPARATOR
171              
172 1         2 my @priv_files = ();
173             push(@priv_files, "$ENV{HOME}/.media.types", "$ENV{HOME}/.mime.types")
174 1 50       8 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 1         2 my $typefile;
178 1 50       4 unless (@files) {
179 1         2 @files = map {"$_/LWP/media.types"} @INC;
  11         26  
180 1         3 push @files, @priv_files;
181             }
182 1         2 for $typefile (@files) {
183 13         41 local(*TYPE);
184 13 100       370 open(TYPE, $typefile) || next;
185 3         71 while () {
186 4437 100       12805 next if /^\s*#/; # comment line
187 2064 50       4099 next if /^\s*$/; # blank line
188 2064         2860 s/#.*//; # remove end-of-line comments
189 2064         5156 my($type, @exts) = split(' ', $_);
190 2064         3565 add_type($type, @exts);
191             }
192 3         49 close(TYPE);
193             }
194             }
195              
196             1;
197              
198              
199             __END__