File Coverage

blib/lib/MIME/Detect.pm
Criterion Covered Total %
statement 16 18 88.8
branch n/a
condition n/a
subroutine 6 6 100.0
pod n/a
total 22 24 91.6


line stmt bran cond sub pod time code
1             package MIME::Detect;
2 4     4   53443 use Moo;
  4         36245  
  4         16  
3 4     4   5923 use if $] < 5.020, 'Filter::signatures';
  4         28  
  4         20  
4 4     4   117 use feature 'signatures';
  4         7  
  4         297  
5 4     4   13 no warnings 'experimental::signatures';
  4         4  
  4         101  
6 4     4   14 use Carp qw(croak);
  4         4  
  4         172  
7 4     4   2469 use XML::LibXML;
  0            
  0            
8             use MIME::Detect::Type;
9              
10             use vars '$VERSION';
11             $VERSION = '0.08';
12              
13             =head1 NAME
14              
15             MIME::Detect - MIME file type identification
16              
17             =head1 SYNOPSIS
18              
19             my $mime = MIME::Detect->new();
20              
21             for my $file (@ARGV) {
22             print sprintf "%s: %s\n", $file, $_->mime_type
23             for $mime->mime_types($file);
24             };
25              
26             =head1 METHODS
27              
28             =head2 C<< MIME::Detect->new( ... ) >>
29              
30             my $mime = MIME::Detect->new();
31              
32             Creates a new instance and reads the database distributed with this module.
33              
34             my $mime = MIME::Detect->new(
35             files => [
36             '/usr/share/freedesktop.org/mimeinfo.xml',
37             't/mimeinfo.xml',
38             ],
39             );
40              
41             =cut
42              
43             sub BUILD( $self, $args ) {
44             my %db_args = map { exists( $args->{$_} )? ($_ => $args->{$_}) : () } (qw(xml files));
45             $self->read_database( %db_args );
46             }
47              
48             has 'typeclass' => (
49             is => 'ro',
50             default => 'MIME::Detect::Type',
51             );
52              
53             has 'types' => (
54             is => 'rw',
55             default => sub { [] },
56             );
57              
58             # References into @types
59             has 'known_types' => (
60             is => 'rw',
61             default => sub { {} },
62             );
63              
64             # The XPath context we use
65             has 'xpc' => (
66             is => 'lazy',
67             default => sub {
68             my $XPC = XML::LibXML::XPathContext->new;
69             $XPC->registerNs('x', 'http://www.freedesktop.org/standards/shared-mime-info');
70             $XPC
71             },
72             );
73              
74             =head2 C<< $mime->read_database %options >>
75              
76             $mime->read_database(
77             xml => MIME::Detect::FreeDesktopOrgDB->get_xml,
78             files => [
79             'mymime/mymime.xml',
80             '/usr/share/freedesktop.org/mime.xml',
81             ],
82             );
83              
84             If you want rules in addition to the default
85             database included with the distribution, you can load the rules from another file.
86             Passing in multiple filenames will join the multiple
87             databases. Duplicate file type definitions will not be detected
88             and will be returned as duplicates.
89              
90             The rules will be sorted according to the priority specified in the database
91             file(s).
92              
93             By default, the XML database stored alongside
94             L
95             will be loaded after all custom files have been loaded.
96             To pass in a different fallback database, either pass in a reference
97             to the XML string or the name of a package that has an C subroutine.
98              
99             To prevent loading the default database, pass undef
100             for the C key.
101              
102             =cut
103              
104             sub read_database( $self, %options ) {
105             $options{ files } ||= [];
106             if( ! exists $options{ xml }) {
107             $options{ xml } = 'MIME::Detect::FreeDesktopOrgDB';
108             };
109            
110             if( $options{ xml } and not ref $options{ xml }) {
111             # Load the class name
112             if( !eval "require $options{ xml }; 1") {
113             croak $@;
114             };
115             $options{ xml } = $options{ xml }->get_xml;
116             };
117            
118             my @types = map {
119             my @args = ref $_ eq 'SCALAR' ? (string => $_) :
120             ref $_ ? (IO => $_) :
121             (location => $_);
122             my $doc = XML::LibXML->load_xml(
123             no_network => 1,
124             load_ext_dtd => 0,
125             @args
126             );
127             $self->_parse_types($doc);
128             } @{$options{ files }}, $options{ xml };
129             $self->reparse(@types);
130             }
131              
132             sub _parse_types( $self, $document ) {
133             map { $self->fragment_to_type( $_ ) }
134             $self->xpc->findnodes('/x:mime-info/x:mime-type',$document);
135             }
136              
137             sub reparse($self, @types) {
138             @types = sort { ($b->priority || 50 ) <=> ($a->priority || 50 ) }
139             @types;
140             $self->types(\@types);
141              
142             # Build the map from mime_type to object
143             my %mime_map;
144             for my $t (@types) {
145             $mime_map{ $t->mime_type } = $t;
146             for my $a (@{$t->aliases}) {
147             $mime_map{ $a } ||= $t;
148             };
149             };
150             $self->known_types(\%mime_map);
151              
152             # Now, upgrade the strings to objects:
153             my $m = $self->known_types;
154             for my $t (@types) {
155             my $s = $t->superclass;
156             if( $s ) {
157             if( my $sc = $m->{ $s } ) {
158             $t->superclass( $sc );
159             } else {
160             warn sprintf "No superclass found for '%s' used by '%s'",
161             $s,
162             $t->mime_type;
163             };
164             };
165             };
166             };
167              
168             sub fragment_to_type( $self, $frag ) {
169             my $mime_type = $frag->getAttribute('type');
170             my $comment = $self->xpc->findnodes('./x:comment', $frag);
171             my @globs = map { $_->getAttribute('pattern')} $self->xpc->findnodes('./x:glob', $frag);
172             (my $superclass) = $self->xpc->findnodes('./x:sub-class-of',$frag);
173             $superclass = $superclass->getAttribute('type')
174             if $superclass;
175              
176             my @aliases = map { $_->getAttribute('type') } $self->xpc->findnodes('./x:alias',$frag);
177              
178             (my $magic) = $self->xpc->findnodes('./x:magic', $frag);
179             my( $priority, @rules );
180             if( $magic ) {
181             $priority = $magic->getAttribute('priority');
182             $priority = 50 if !defined $priority;
183             @rules = grep { $_->nodeType != 3 } # exclude text nodes
184             $magic->childNodes;
185             for my $rule (@rules) {
186             $rule = $self->parse_rule( $rule );
187             };
188             };
189              
190             $self->typeclass->new(
191             aliases => \@aliases,
192             priority => $priority,
193             mime_type => $mime_type,
194             comment => $comment,
195             superclass => $superclass,
196             rules => \@rules,
197             globs => \@globs,
198             );
199             }
200              
201             sub parse_rule( $self, $rule ) {
202             my $value = $rule->getAttribute('value');
203             my $offset = $rule->getAttribute('offset');
204             my $type = $rule->getAttribute('type');
205              
206             my @and = map { $self->parse_rule( $_ ) } grep { $_->nodeType != 3 } $rule->childNodes;
207             my $and = @and ? \@and : undef;
208              
209             return {
210             value => $value,
211             offset => $offset,
212             type => $type,
213             and => $and,
214             };
215             }
216              
217             =head2 C<< $mime->mime_types >>
218              
219             my @types = $mime->mime_types( 'some/file' );
220             for( @types ) {
221             print $type->mime_type, "\n";
222             };
223              
224             Returns the list of MIME types according to their priority.
225             The first type is the most likely. The returned objects
226             are of type L.
227              
228             =cut
229              
230             sub mime_types( $self, $file ) {
231             if( ! ref $file) {
232             open my $fh, '<', $file
233             or croak "Couldn't read '$file': $!";
234             binmode $fh;
235             $file = $fh;
236             };
237             my $buffer = MIME::Detect::Buffer->new(fh => $file);
238             $buffer->request(0,4096); # should be enough for most checks
239              
240             my @candidates;
241             my $m = $self->known_types;
242              
243             # Already sorted by priority
244             my @types = @{ $self->{types} };
245              
246             # Let's just hope we don't have infinite subtype loops in the XML file
247             for my $k (@types) {
248             my $t = ref $k ? $k : $m->{ $k };
249             if( $t->matches($buffer) ) {
250             #warn sprintf "*** found '%s'", $t->mime_type;
251             push @candidates, $m->{$t->mime_type};
252             };
253             };
254              
255             @candidates;
256             }
257              
258             =head2 C<< $mime->mime_type >>
259              
260             my $type = $mime->mime_type( 'some/file' );
261             print $type->mime_type, "\n"
262             if $type;
263              
264             Returns the most likely type of a file as L. Returns
265             C if no file type can be determined.
266              
267             =cut
268              
269             sub mime_type( $self, $file ) {
270             ($self->mime_types($file))[0]
271             }
272              
273             =head2 C<< $mime->mime_types_from_name >>
274              
275             my $type = $mime->mime_types_from_name( 'some/file.ext' );
276             print $type->mime_type, "\n"
277             if $type;
278              
279             Returns the list of MIME types for a file name based on the extension
280             according to their priority.
281             The first type is the most likely. The returned objects
282             are of type L.
283              
284             =cut
285              
286             sub mime_types_from_name( $self, $file ) {
287             my @candidates;
288             my $m = $self->known_types;
289              
290             # Already sorted by priority
291             my @types = @{ $self->{types} };
292              
293             # Let's just hope we don't have infinite subtype loops in the XML file
294             for my $k (@types) {
295             my $t = ref $k ? $k : $m->{ $k };
296             if( $t->valid_extension($file) ) {
297             #warn sprintf "*** found '%s'", $t->mime_type;
298             push @candidates, $m->{$t->mime_type};
299             };
300             };
301              
302             @candidates;
303             }
304              
305             =head2 C<< $mime->mime_type_from_name >>
306              
307             my $type = $mime->mime_type_from_name( 'some/file.ext' );
308             print $type->mime_type, "\n"
309             if $type;
310              
311             Returns the most likely type of a file name as L. Returns
312             C if no file type can be determined.
313              
314             =cut
315              
316             sub mime_type_from_name( $self, $file ) {
317             ($self->mime_types_from_name($file))[0]
318             }
319              
320             package MIME::Detect::Buffer;
321             use Moo;
322             use if $] < 5.020, 'Filter::signatures';
323             use feature 'signatures';
324             no warnings 'experimental::signatures';
325             use Fcntl 'SEEK_SET';
326              
327             has 'offset' => (
328             is => 'rw',
329             default => 0,
330             );
331              
332             has 'buffer' => (
333             is => 'rw',
334             default => undef,
335             );
336              
337             has 'fh' => (
338             is => 'ro',
339             );
340              
341             sub length($self) {
342             length $self->buffer || 0
343             };
344              
345             sub request($self,$offset,$length) {
346             my $fh = $self->fh;
347              
348             if( $offset =~ m/^(\d+):(\d+)$/) {
349             $offset = $1;
350             $length += $2;
351             };
352              
353             #warn sprintf "At %d to %d (%d), want %d to %d (%d)",
354             # $self->offset, $self->offset+$self->length, $self->length,
355             # $offset, $offset+$length, $length;
356             if( $offset < $self->offset
357             or $self->offset+$self->length < $offset+$length ) {
358             # We need to refill the buffer
359             my $buffer;
360             my $updated = 0;
361             if (ref $fh eq 'GLOB') {
362             if( seek($fh, $offset, SEEK_SET)) {
363             read($fh, $buffer, $length);
364             $updated = 1;
365             };
366             } else {
367             # let's hope you have ->seek and ->read:
368             if( $fh->seek($offset, SEEK_SET) ) {
369             $fh->read($buffer, $length);
370             $updated = 1;
371             };
372             }
373            
374             # Setting all three in one go would be more object-oriented ;)
375             if( $updated ) {
376             $self->offset($offset);
377             $self->buffer($buffer);
378             };
379             };
380              
381             if( $offset >= $self->offset
382             and $self->offset+$self->length >= $offset+$length ) {
383             substr $self->buffer, $offset-$self->offset, $length
384             } elsif( $offset >= $self->offset ) {
385             substr $self->buffer, $offset-$self->offset
386             } else {
387             return ''
388             };
389             }
390              
391             1;
392              
393             =head1 SEE ALSO
394              
395             L - the website
396             where the XML file is distributed
397              
398             L - module to read your locally installed and converted MIME database
399              
400             L - if you can install C and the appropriate C files
401              
402             L - if you have the appropriate C files
403              
404             L - if you have the appropriate C files but want more speed
405              
406             L - inlines its database, unsupported since 2004?
407              
408             L - if you're only interested in determining whether
409             a file is an image or not
410              
411             L - for extension-based detection
412              
413             =head1 REPOSITORY
414              
415             The public repository of this module is
416             L.
417              
418             =head1 SUPPORT
419              
420             The public support forum of this module is
421             L.
422              
423             =head1 BUG TRACKER
424              
425             Please report bugs in this module via the RT CPAN bug queue at
426             L
427             or via mail to L.
428              
429             =head1 AUTHOR
430              
431             Max Maischein C
432              
433             =head1 COPYRIGHT (c)
434              
435             Copyright 2015-2016 by Max Maischein C.
436              
437             =head1 LICENSE
438              
439             This module is released under the same terms as Perl itself.
440              
441             =cut