← Index
NYTProf Performance Profile   « line view »
For svc/members/upsert
  Run on Tue Jan 13 11:50:22 2015
Reported on Tue Jan 13 12:09:50 2015

Filename/usr/share/perl5/MIME/Types.pm
StatementsExecuted 21 statements in 2.26ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
1111.62ms1.75msMIME::Types::::BEGIN@13MIME::Types::BEGIN@13
11114µs84µsMIME::Types::::BEGIN@16MIME::Types::BEGIN@16
11112µs30µsMIME::Types::::BEGIN@7MIME::Types::BEGIN@7
11110µs81µsMIME::Types::::BEGIN@218MIME::Types::BEGIN@218
1119µs39µsMIME::Types::::BEGIN@262MIME::Types::BEGIN@262
1118µs33µsMIME::Types::::BEGIN@15MIME::Types::BEGIN@15
1116µs16µsMIME::Types::::BEGIN@11MIME::Types::BEGIN@11
1114µs4µsMIME::Types::::BEGIN@14MIME::Types::BEGIN@14
0000s0sMIME::Types::::_MojoExtTableMIME::Types::_MojoExtTable
0000s0sMIME::Types::::__ANON__[:183]MIME::Types::__ANON__[:183]
0000s0sMIME::Types::::__ANON__[:185]MIME::Types::__ANON__[:185]
0000s0sMIME::Types::::_read_dbMIME::Types::_read_db
0000s0sMIME::Types::::addTypeMIME::Types::addType
0000s0sMIME::Types::::by_mediatypeMIME::Types::by_mediatype
0000s0sMIME::Types::::by_suffixMIME::Types::by_suffix
0000s0sMIME::Types::::create_type_indexMIME::Types::create_type_index
0000s0sMIME::Types::::extensionsMIME::Types::extensions
0000s0sMIME::Types::::httpAcceptMIME::Types::httpAccept
0000s0sMIME::Types::::httpAcceptBestMIME::Types::httpAcceptBest
0000s0sMIME::Types::::httpAcceptSelectMIME::Types::httpAcceptSelect
0000s0sMIME::Types::::import_mime_typesMIME::Types::import_mime_types
0000s0sMIME::Types::::initMIME::Types::init
0000s0sMIME::Types::::listTypesMIME::Types::listTypes
0000s0sMIME::Types::::mimeTypeOfMIME::Types::mimeTypeOf
0000s0sMIME::Types::::newMIME::Types::new
0000s0sMIME::Types::::typeMIME::Types::type
0000s0sMIME::Types::::typesMIME::Types::types
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1# Copyrights 1999,2001-2014 by [Mark Overmeer].
2# For other contributors see ChangeLog.
3# See the manual pages for details on the licensing terms.
4# Pod stripped from pm file by OODoc 2.01.
5
6package MIME::Types;
7231µs248µs
# spent 30µs (12+18) within MIME::Types::BEGIN@7 which was called: # once (12µs+18µs) by C4::Letters::BEGIN@23 at line 7
use vars '$VERSION';
# spent 30µs making 1 call to MIME::Types::BEGIN@7 # spent 18µs making 1 call to vars::import
81300ns$VERSION = '2.09';
9
10
11219µs226µs
# spent 16µs (6+10) within MIME::Types::BEGIN@11 which was called: # once (6µs+10µs) by C4::Letters::BEGIN@23 at line 11
use strict;
# spent 16µs making 1 call to MIME::Types::BEGIN@11 # spent 10µs making 1 call to strict::import
12
132650µs11.75ms
# spent 1.75ms (1.62+126µs) within MIME::Types::BEGIN@13 which was called: # once (1.62ms+126µs) by C4::Letters::BEGIN@23 at line 13
use MIME::Type ();
# spent 1.75ms making 1 call to MIME::Types::BEGIN@13
14220µs14µs
# spent 4µs within MIME::Types::BEGIN@14 which was called: # once (4µs+0s) by C4::Letters::BEGIN@23 at line 14
use File::Spec ();
# spent 4µs making 1 call to MIME::Types::BEGIN@14
15225µs258µs
# spent 33µs (8+25) within MIME::Types::BEGIN@15 which was called: # once (8µs+25µs) by C4::Letters::BEGIN@23 at line 15
use File::Basename qw(dirname);
# spent 33µs making 1 call to MIME::Types::BEGIN@15 # spent 25µs making 1 call to Exporter::import
1621.27ms296µs
# spent 84µs (14+70) within MIME::Types::BEGIN@16 which was called: # once (14µs+70µs) by C4::Letters::BEGIN@23 at line 16
use List::Util qw(first);
# spent 84µs making 1 call to MIME::Types::BEGIN@16 # spent 11µs making 1 call to List::Util::import
17
18
191200nsmy %typedb;
20sub new(@) { (bless {}, shift)->init( {@_} ) }
21
22sub init($)
23{ my ($self, $args) = @_;
24 keys %typedb or $self->_read_db($args);
25 $self;
26}
27
28sub _read_db($)
29{ my ($self, $args) = @_;
30 my $skip_extensions = $args->{skip_extensions};
31 my $only_complete = $args->{only_complete};
32 my $only_iana = $args->{only_iana};
33
34 my $db = $args->{db_file}
35 || File::Spec->catfile(dirname(__FILE__), 'types.db');
36
37 local *DB;
38 open DB, '<:encoding(utf8)', $db
39 or die "cannot open type database in $db: $!\n";
40
41 while(1)
42 { my $header = <DB>;
43 defined $header or last;
44 chomp $header;
45
46 # This logic is entangled with the bin/collect_types script
47 my ($count, $major, $is_iana, $has_ext) = split /\:/, $header;
48 my $skip_section = $major eq 'EXTENSIONS' ? $skip_extensions
49 : (($only_iana && !$is_iana) || ($only_complete && !$has_ext));
50
51#warn "Skipping section $header\n" if $skip_section;
52 (my $section = $major) =~ s/^x-//;
53 if($major eq 'EXTENSIONS')
54 { local $_;
55 while(<DB>)
56 { last if m/^$/;
57 next if $skip_section;
58 chomp;
59 $typedb{$section}{$1} = $2 if m/(.*);(.*)/;
60 }
61 }
62 else
63 { local $_;
64 while(<DB>)
65 { last if m/^$/;
66 next if $skip_section;
67 chomp;
68 $typedb{$section}{$1} = "$major/$_" if m/^(?:x-)?([^;]+)/;
69 }
70 }
71 }
72
73 close DB;
74}
75
76# Catalyst-Plugin-Static-Simple uses it :(
77sub create_type_index {}
78
79#-------------------------------------------
80
81sub type($)
82{ my $spec = lc $_[1];
83 $spec = 'text/plain' if $spec eq 'text'; # old mailers
84
85 $spec =~ m!^(?:x\-)?([^/]+)/(?:x-)?(.*)!
86 or return;
87
88 my $section = $typedb{$1} or return;
89 my $record = $section->{$2} or return;
90 return $record if ref $record; # already extended
91
92 my $simple = $2;
93 my ($type, $ext, $enc) = split m/\;/, $record;
94 my $os = undef; # XXX TODO
95
96 $section->{$simple} = MIME::Type->new
97 ( type => $type
98 , extensions => [split /\,/, $ext]
99 , encoding => $enc
100 , system => $os
101 );
102}
103
104
105sub mimeTypeOf($)
106{ my ($self, $name) = @_;
107 (my $ext = lc $name) =~ s/.*\.//;
108 my $type = $typedb{EXTENSIONS}{$ext} or return;
109 $self->type($type);
110}
111
112
113sub addType(@)
114{ my $self = shift;
115
116 foreach my $type (@_)
117 { my ($major, $minor) = split m!/!, $type->simplified;
118 $typedb{$major}{$minor} = $type;
119 $typedb{EXTENSIONS}{$_} = $type for $type->extensions;
120 }
121 $self;
122}
123
124
125sub types()
126{ my $self = shift;
127 my @types;
128 foreach my $section (keys %typedb)
129 { next if $section eq 'EXTENSIONS';
130 push @types, map $_->type("$section/$_"),
131 sort keys %{$typedb{$section}};
132 }
133 @types;
134}
135
136
137sub listTypes()
138{ my $self = shift;
139 my @types;
140 foreach my $section (keys %typedb)
141 { next if $section eq 'EXTENSIONS';
142 foreach my $sub (sort keys %{$typedb{$section}})
143 { my $record = $typedb{$section}{$sub};
144 push @types, ref $record ? $record->type
145 : $record =~ m/^([^;]+)/ ? $1 : die;
146 }
147 }
148 @types;
149}
150
151
152sub extensions { keys %{$typedb{EXTENSIONS}} }
153sub _MojoExtTable() {$typedb{EXTENSIONS}}
154
155#-------------
156
157sub httpAccept($)
158{ my $self = shift;
159 my @listed;
160
161 foreach (split /\,\s*/, shift)
162 {
163 m!^ ([a-zA-Z0-9-]+ | \*) / ( [a-zA-Z0-9+-]+ | \* )
164 \s* (?: \;\s*q\=\s* ([0-9]+(?:\.[0-9]*)?) \s* )?
165 (\;.* | )
166 $ !x or next;
167
168 my $mime = "$1/$2$4";
169 my $q = $3 || ($1 eq '*' ? -2 : $2 eq '*' ? -1 : 1);
170 push @listed, [ $mime, $q-@listed*0.001 ];
171 }
172 map $_->[0], sort {$b->[1] <=> $a->[1]} @listed;
173}
174
175
176sub httpAcceptBest($@)
177{ my $self = shift;
178 my @accept = ref $_[0] eq 'ARRAY' ? @{(shift)} : $self->httpAccept(shift);
179 my $match;
180
181 foreach my $acc (@accept)
182 { $acc =~ s/\s*\;.*//; # remove attributes
183 my $m = $acc !~ s#/\*$## ? first { $_->equals($acc) } @_
184 : $acc eq '*' ? $_[0] # $acc eq */*
185 : first { $_->mediaType eq $acc } @_;
186 return $m if defined $m;
187 }
188
189 ();
190}
191
192
193sub httpAcceptSelect($@)
194{ my ($self, $accept) = (shift, shift);
195 my $fns = !@_ ? return () : ref $_[0] eq 'ARRAY' ? shift : [@_];
196
197 unless(defined $accept)
198 { my $fn = $fns->[0];
199 return ($fn, $self->mimeTypeOf($fn));
200 }
201
202 # create mapping type -> filename
203 my (%have, @have);
204 foreach my $fn (@$fns)
205 { my $type = $self->mimeTypeOf($fn) or next;
206 $have{$type->simplified} = $fn;
207 push @have, $type;
208 }
209
210 my $type = $self->httpAcceptBest($accept, @have);
211 defined $type ? ($have{$type}, $type) : ();
212}
213
214#-------------------------------------------
215# OLD INTERFACE (version 0.06 and lower)
216
217
2182197µs2151µs
# spent 81µs (10+70) within MIME::Types::BEGIN@218 which was called: # once (10µs+70µs) by C4::Letters::BEGIN@23 at line 218
use base 'Exporter';
# spent 81µs making 1 call to MIME::Types::BEGIN@218 # spent 70µs making 1 call to base::import
2191700nsour @EXPORT_OK = qw(by_suffix by_mediatype import_mime_types);
220
221
22210smy $mime_types;
223
224sub by_suffix($)
225{ my $filename = shift;
226 $mime_types ||= MIME::Types->new;
227 my $mime = $mime_types->mimeTypeOf($filename);
228
229 my @data = defined $mime ? ($mime->type, $mime->encoding) : ('','');
230 wantarray ? @data : \@data;
231}
232
233
234sub by_mediatype($)
235{ my $type = shift;
236 $mime_types ||= MIME::Types->new;
237
238 my @found;
239 if(!ref $type && index($type, '/') >= 0)
240 { my $mime = $mime_types->type($type);
241 @found = $mime if $mime;
242 }
243 else
244 { my $search = ref $type eq 'Regexp' ? $type : qr/$type/i;
245 @found = map $mime_types->type($_),
246 grep $_ =~ $search,
247 $mime_types->listTypes;
248 }
249
250 my @data;
251 foreach my $mime (@found)
252 { push @data, map [$_, $mime->type, $mime->encoding],
253 $mime->extensions;
254 }
255
256 wantarray ? @data : \@data;
257}
258
259
260sub import_mime_types($)
261{ my $filename = shift;
262244µs270µs
# spent 39µs (9+30) within MIME::Types::BEGIN@262 which was called: # once (9µs+30µs) by C4::Letters::BEGIN@23 at line 262
use Carp;
# spent 39µs making 1 call to MIME::Types::BEGIN@262 # spent 30µs making 1 call to Exporter::import
263 croak <<'CROAK';
264import_mime_types is not supported anymore: if you have types to add
265please send them to the author.
266CROAK
267}
268
26913µs1;
270__END__
Report produced by the NYTProf 5.06 Perl profiler, developed by Tim Bunce and Adam Kaplan.