File Coverage

blib/lib/File/MimeInfo/Rox.pm
Criterion Covered Total %
statement 27 52 51.9
branch 3 30 10.0
condition 0 3 0.0
subroutine 8 12 66.6
pod 3 3 100.0
total 41 100 41.0


line stmt bran cond sub pod time code
1             package File::MimeInfo::Rox;
2              
3 2     2   1314 use strict;
  2         5  
  2         47  
4 2     2   8 use warnings;
  2         4  
  2         39  
5 2     2   8 use Carp;
  2         4  
  2         90  
6 2     2   389 use File::BaseDir qw/config_home data_dirs/;
  2         1077  
  2         106  
7 2     2   13 use File::Spec;
  2         3  
  2         1307  
8             require Exporter;
9              
10             our @ISA = qw(Exporter);
11             our @EXPORT = qw(mime_exec mime_system);
12             our @EXPORT_OK = qw(suggest_script_name);
13             our %EXPORT_TAGS = (magic => \@EXPORT);
14             our $VERSION = '0.33';
15             our @choicespath = (
16             config_home('rox.sourceforge.net'),
17             File::Spec->catdir($ENV{HOME}, 'Choices'),
18             data_dirs('Choices'),
19             );
20             our ($DEBUG);
21              
22             sub import {
23 1 50   1   8 my $parent = (grep {$_ eq q/:magic/} @_)
  1         5  
24             ? q/File::MimeInfo::Magic/
25             : q/File::MimeInfo/;
26 1     1   55 eval "use $parent";
  1         384  
  1         3  
  1         35  
27 1 50       4 die $@ if $@;
28 1         28 goto \&Exporter::import;
29             }
30              
31 0     0 1 0 sub mime_system { _do_mime('system', @_) }
32 0     0 1 0 sub mime_exec { _do_mime('exec', @_) }
33              
34             sub _do_mime {
35 0     0   0 my ($act, $file, $mimet) = (shift, shift, shift);
36              
37 0   0     0 $mimet ||= mimetype($file);
38 0 0       0 return undef unless $mimet;
39 0 0       0 print "Using mimetype: $mimet\n" if $DEBUG;
40              
41 0         0 my $script = _locate_script($mimet);
42 0 0       0 return undef unless $script;
43              
44 0 0       0 print "Going to $act: $script $file\n" if $DEBUG;
45 0 0       0 ($act eq 'exec')
    0          
46             ? exec($script, $file, @_)
47             : (system($script, $file, @_) == 0)
48             or croak "couldn't $act: $script $file";
49 0         0 42;
50             }
51              
52             sub _locate_script {
53 0     0   0 my $mime = shift;
54 0         0 $mime =~ /^(\w+)/;
55 0         0 my $media = $1;
56 0         0 $mime =~ s#/#_#;
57             my @p = $ENV{CHOICESPATH}
58             ? split(/:/, $ENV{CHOICESPATH})
59 0 0       0 : (@choicespath);
60 0         0 my $script;
61 0         0 for (
62             map("$_/MIME-types/$mime", @p),
63             map("$_/MIME-types/$media", @p)
64             ) {
65 0 0       0 print "looking for: $_\n" if $DEBUG;
66 0 0       0 next unless -e $_;
67 0         0 $script = $_;
68 0         0 last;
69             }
70 0 0       0 return undef unless $script;
71 0 0       0 $script = "$script/AppRun" if -d $script;
72 0 0       0 return -f $script ? $script : undef;
73             }
74              
75             sub suggest_script_name {
76 1     1 1 444 my $m = pop;
77 1         4 $m =~ s#/#_#;
78             my @p = $ENV{CHOICESPATH}
79             ? split(/:/, $ENV{CHOICESPATH})
80 1 50       6 : (@choicespath);
81 1         7 return "$p[0]/MIME-types", $m;
82             }
83              
84             1;
85              
86             __END__