File Coverage

blib/lib/File/MimeInfo/Applications.pm
Criterion Covered Total %
statement 59 119 49.5
branch 11 48 22.9
condition 4 12 33.3
subroutine 11 17 64.7
pod 4 4 100.0
total 89 200 44.5


line stmt bran cond sub pod time code
1             package File::MimeInfo::Applications;
2              
3 2     2   31033 use strict;
  2         5  
  2         47  
4 2     2   15 use warnings;
  2         3  
  2         41  
5 2     2   8 use Carp;
  2         3  
  2         79  
6 2     2   10 use File::Spec;
  2         2  
  2         105  
7 2     2   11 use File::BaseDir qw/config_home config_dirs data_home data_dirs data_files/;
  2         2  
  2         116  
8 2     2   12 use File::MimeInfo qw/mimetype_canon mimetype_isa/;
  2         2  
  2         76  
9 2     2   12 use File::DesktopEntry;
  2         3  
  2         2622  
10             require Exporter;
11              
12             our $VERSION = '0.33';
13              
14             our @ISA = qw(Exporter);
15             our @EXPORT = qw(
16             mime_applications mime_applications_all
17             mime_applications_set_default mime_applications_set_custom
18             );
19              
20             print STDERR << 'EOT' unless data_files(qw/applications mimeinfo.cache/);
21             WARNING: You don't seem to have any mimeinfo.cache files.
22             Try running the update-desktop-database command. If you
23             don't have this command you should install the
24             desktop-file-utils package. This package is available from
25             http://freedesktop.org/wiki/Software/desktop-file-utils/
26             EOT
27              
28             sub mime_applications {
29 2 50   2 1 1131 croak "usage: mime_applications(MIMETYPE)" unless @_ == 1;
30 2         6 my $mime = mimetype_canon(shift @_);
31 2         4 local $Carp::CarpLevel = $Carp::CarpLevel + 1;
32 2 50       5 return wantarray ? (_default($mime), _others($mime)) : _default($mime);
33             }
34              
35             sub mime_applications_all {
36 0 0   0 1 0 croak "usage: mime_applications(MIMETYPE)" unless @_ == 1;
37 0         0 my $mime = shift;
38 0         0 return mime_applications($mime),
39             grep defined($_), map mime_applications($_), mimetype_isa($mime);
40             }
41              
42             sub mime_applications_set_default {
43 0 0   0 1 0 croak "usage: mime_applications_set_default(MIMETYPE, APPLICATION)"
44             unless @_ == 2;
45 0         0 my ($mimetype, $desktop_file) = @_;
46             (undef, undef, $desktop_file) =
47             File::Spec->splitpath($desktop_file->{file})
48 0 0       0 if ref $desktop_file;
49 0 0       0 croak "missing desktop entry filename for application"
50             unless length $desktop_file;
51 0 0       0 $desktop_file .= '.desktop' unless $desktop_file =~ /\.desktop$/;
52 0         0 _write_list($mimetype, $desktop_file);
53             }
54              
55             sub mime_applications_set_custom {
56 0 0   0 1 0 croak "usage: mime_applications_set_custom(MIMETYPE, COMMAND)"
57             unless @_ == 2;
58 0         0 my ($mimetype, $command) = @_;
59 0         0 $command =~ /(\w+)/;
60 0 0       0 my $word = $1 or croak "COMMAND does not contain a word !?";
61              
62             # Algorithm to generate name copied from other implementations
63 0         0 my $i = 1;
64 0         0 my $desktop_file =
65             data_home('applications', $word.'-usercreated-'.$i.'.desktop');
66 0         0 while (-e $desktop_file) {
67 0         0 $i++;
68 0         0 $desktop_file =
69             data_home('applications', $word.'-usercreated-'.$i.'.desktop');
70             }
71              
72 0         0 my $object = File::DesktopEntry->new();
73 0         0 $object->set(
74             Type => 'Application',
75             Name => $word,
76             NoDisplay => 'true',
77             Exec => $command,
78             );
79 0         0 my (undef, undef, $df) = File::Spec->splitpath($desktop_file);
80 0         0 _write_list($mimetype, $df); # creates dir if needed
81 0         0 $object->write($desktop_file);
82 0         0 return $object;
83             }
84              
85             sub _default {
86 2     2   2 my $mimetype = shift;
87              
88 2         5 my $user = config_home(qw/mimeapps.list/);
89 2         70 my $system = config_dirs(qw/mimeapps.list/);
90 2         1055 my $deprecated = data_home(qw/applications mimeapps.list/);
91 2         34 my $distro = data_dirs(qw/applications mimeapps.list/);
92 2         136 my $legacy = data_home(qw/applications defaults.list/);
93              
94 2 50 33     90 unless ( ( -f $user
      33        
95             || ($system && -f $system)
96             || ($deprecated && -f $deprecated)
97             || ($distro && -f $distro)
98             || ($legacy && -f $legacy) )
99             && -r _ ) {
100 2         10 return undef;
101             }
102              
103 0         0 $Carp::CarpLevel++;
104 0         0 my @paths = grep defined, ($mimetype, $user, $system, $deprecated, $distro, $legacy);
105 0         0 my @list = _read_list(@paths);
106 0         0 my $desktop_file = _find_file(reverse @list);
107 0         0 $Carp::CarpLevel--;
108              
109 0         0 return $desktop_file;
110             }
111              
112             sub _others {
113 2     2   3 my $mimetype = shift;
114              
115 2         3 $Carp::CarpLevel++;
116 2         3 my (@list, @done);
117 2         5 for my $dir (data_dirs('applications')) {
118 4         196 my $cache = File::Spec->catfile($dir, 'mimeinfo.cache');
119 4 100       11 next if grep {$_ eq $cache} @done;
  2         6  
120 2         3 push @done, $cache;
121 2 50 33     28 next unless -f $cache and -r _;
122 2         8 for (_read_list($mimetype, $cache)) {
123 2         15 my $file = File::Spec->catfile($dir, $_);
124 2 50 33     40 next unless -f $file and -r _;
125 2         10 push @list, File::DesktopEntry->new($file);
126             }
127             }
128 2         5 $Carp::CarpLevel--;
129              
130 2         10 return @list;
131             }
132              
133             sub _read_list { # read list with "mime/type=foo.desktop;bar.desktop" format
134 2     2   3 my $mimetype = shift;
135              
136 2         3 my @list;
137             my $succeeded;
138              
139 2         5 for my $file (@_) {
140 2 50       51 if (open LIST, '<', $file) {
141 2         4 $succeeded = 1;
142 2         48 while () {
143 6 100       59 /^\Q$mimetype\E=(.*)$/ or next;
144 2         19 push @list, grep defined($_), split ';', $1;
145             }
146 2         30 close LIST;
147             }
148             }
149              
150 2 50       6 unless ($succeeded) {
151 0         0 croak "Could not read any defaults, tried:\n" . join("\t\n", @_);
152             }
153              
154 2         7 return @list;
155             }
156              
157             sub _write_list {
158 0     0     my ($mimetype, $desktop_file) = @_;
159 0           my $file = config_home(qw/mimeapps.list/);
160 0           my $text;
161 0 0         if (-f $file) {
162 0 0         open LIST, '<', $file or croak "Could not read file: $file";
163 0           while () {
164 0 0         $text .= $_ unless /^\Q$mimetype\E=/;
165             }
166 0           close LIST;
167 0           $text =~ s/[\n\r]?$/\n/; # just to be sure
168             }
169             else {
170 0           _mkdir($file);
171 0           $text = "[Default Applications]\n";
172             }
173              
174 0 0         open LIST, '>', $file or croak "Could not write file: $file";
175 0           print LIST $text;
176 0           print LIST "$mimetype=$desktop_file;\n";
177 0 0         close LIST or croak "Could not write file: $file";
178             }
179              
180             sub _find_file {
181 0     0     my @list = @_;
182 0           for (@list) {
183 0           my $file = data_files('applications', $_);
184 0 0         return File::DesktopEntry->new($file) if $file;
185             }
186 0           return undef;
187             }
188              
189             sub _mkdir {
190 0     0     my $dir = shift;
191 0 0         return if -d $dir;
192              
193 0           my ($vol, $dirs, undef) = File::Spec->splitpath($dir);
194 0           my @dirs = File::Spec->splitdir($dirs);
195 0           my $path = File::Spec->catpath($vol, shift @dirs);
196 0           while (@dirs) {
197 0           mkdir $path; # fails silently
198 0           $path = File::Spec->catdir($path, shift @dirs);
199             }
200              
201 0 0         die "Could not create dir: $path\n" unless -d $path;
202             }
203              
204             1;
205              
206             __END__