File Coverage

blib/lib/File/DesktopEntry.pm
Criterion Covered Total %
statement 264 276 95.6
branch 130 170 76.4
condition 39 61 63.9
subroutine 39 39 100.0
pod 17 17 100.0
total 489 563 86.8


line stmt bran cond sub pod time code
1             package File::DesktopEntry;
2              
3 6     6   44663 use strict;
  6         13  
  6         156  
4 6     6   31 use warnings;
  6         11  
  6         190  
5              
6 6     6   38 use vars qw/$AUTOLOAD/;
  6         12  
  6         735  
7 6     6   129 use Carp;
  6         10  
  6         448  
8 6     6   5900 use Encode;
  6         70906  
  6         501  
9 6     6   39 use File::Spec;
  6         9  
  6         196  
10 6     6   5130 use File::BaseDir 0.03 qw/data_files data_home/;
  6         8466  
  6         442  
11 6     6   4542 use URI::Escape;
  6         10878  
  6         28364  
12              
13             our $VERSION = '0.20';
14             our $VERBOSE = 0;
15              
16             if ($^O eq 'MSWin32') {
17             eval q/use Win32::Process/;
18             die $@ if $@;
19             }
20              
21             =head1 NAME
22              
23             File::DesktopEntry - Object to handle .desktop files
24              
25             =head1 SYNOPSIS
26              
27             use File::DesktopEntry;
28              
29             my $entry = File::DesktopEntry->new('firefox');
30              
31             print "Using ".$entry->Name." to open http://perl.org\n";
32             $entry->run('http://perl.org');
33              
34             =head1 DESCRIPTION
35              
36             This module is designed to work with F<.desktop> files. The format of these files
37             is specified by the freedesktop "Desktop Entry" specification. This module can
38             parse these files but also knows how to run the applications defined by these
39             files.
40              
41             For this module version 1.0 of the specification was used.
42              
43             This module was written to support L.
44              
45             Please remember: case is significant for the names of Desktop Entry keys.
46              
47             =head1 VARIABLES
48              
49             You can set the global variable C<$File::DesktopEntry::VERBOSE>. If set the
50             module prints a warning every time a command gets executed.
51              
52             The global variable C<$File::DesktopEntry::LOCALE> tells you what the default
53             locale being used is. However, changing it will not change the default locale.
54              
55             =head1 AUTOLOAD
56              
57             All methods that start with a capital are autoloaded as C where
58             key is the autoloaded method name.
59              
60             =head1 METHODS
61              
62             =over 4
63              
64             =item C
65              
66             =item C
67              
68             =item C
69              
70             Constructor. FILE, NAME or TEXT are optional arguments.
71              
72             When a name is given (a string without 'C', 'C<\>' or 'C<.>') a lookup is
73             done using File::BaseDir. If the file found in this lookup is not writable or
74             if no file was found, the XDG_DATA_HOME path will be used when writing.
75              
76             =cut
77              
78             our $LOCALE = 'C';
79              
80             # POSIX setlocale(LC_MESSAGES) not supported on all platforms
81             # so we do it ourselves ...
82             # string might look like lang_COUNTRY.ENCODING@MODIFIER
83             for (qw/LC_ALL LC_MESSAGES LANGUAGE LANG/) {
84             next unless $ENV{$_};
85             $LOCALE = $ENV{$_};
86             last;
87             }
88             our $_locale = _parse_lang($LOCALE);
89              
90             sub new {
91 19     19 1 4514 my ($class, $file) = @_;
92 19         43 my $self = bless {}, $class;
93 19 100       101 if (! defined $file) { # initialize new file
    100          
    100          
94 4         19 $self->set(Version => '1.0', Encoding => 'UTF-8');
95             }
96 4         14 elsif (ref $file) { $self->read($file) } # SCALAR
97 10         28 elsif ($file =~ /[\/\\\.]/) { $$self{file} = $file } # file
98             else {
99 1         4 $$self{file} = $class->lookup($file); # name
100 1         3 $$self{name} = $file;
101             }
102 19         52 return $self;
103             }
104              
105             sub AUTOLOAD {
106 3     3   17 $AUTOLOAD =~ s/.*:://;
107 3 50       11 return if $AUTOLOAD eq 'DESTROY';
108 3 50       14 croak "No such method: File::DesktopEntry::$AUTOLOAD"
109             unless $AUTOLOAD =~ /^[A-Z][A-Za-z0-9-]+$/;
110 3         9 return $_[0]->get($AUTOLOAD);
111             }
112              
113             =item C
114              
115             Returns a filename for a desktop entry with desktop file id NAME.
116              
117             =cut
118              
119             sub lookup {
120 2     2 1 48 my (undef, $name) = @_;
121 2         4 $name .= '.desktop';
122 2         9 my $file = data_files('applications', $name);
123 2 50 33     124 if (! $file and $name =~ /-/) {
124             # name contains "-" and was not found
125 0         0 my @name = split /-/, $name;
126 0         0 $file = data_files('applications', @name);
127             }
128 2         12 return $file;
129             }
130              
131             sub _parse_lang {
132             # lang might look like lang_COUNTRY.ENCODING@MODIFIER
133 17     17   1547 my $lang = shift;
134 17 100 66     166 return '' if !$lang or $lang eq 'C' or $lang eq 'POSIX';
      100        
135 7 50       38 $lang =~ m{^
136             ([^_@\.]+) # lang $1
137             (?: _ ([^@\.]+) )? # COUNTRY $2
138             (?: \. [^@]+ )? # ENCODING
139             (?: \@ (.+) )? # MODIFIER $3
140             $}x or return '';
141 7         19 my ($l, $c, $m) = ($1, $2, $3);
142 7 100 100     44 my @locale = (
    100          
    100          
143             $l,
144             ($m ? "$l\@$m" : ()),
145             ($c ? "$l\_$c" : ()),
146             (($m && $c) ? "$l\_$c\@$m" : ()) );
147 7         33 return join '|', reverse @locale;
148             }
149              
150             =item C
151              
152             Returns true if the Exec string for this desktop entry specifies that the
153             application uses URIs instead of paths. This can be used to determine
154             whether an application uses a VFS library.
155              
156             =item C
157              
158             Returns true if the Exec string for this desktop entry specifies that the
159             application can handle multiple arguments at once.
160              
161             =cut
162              
163              
164             sub wants_uris {
165 1     1 1 2 my $self = shift;
166 1         3 my $exec = $self->get('Exec');
167 1 50       5 croak "No Exec string defined for desktop entry" unless length $exec;
168 1         3 $exec =~ s/\%\%//g;
169 1         9 return $exec =~ /\%U/i;
170             }
171              
172             sub wants_list {
173 1     1 1 3 my $self = shift;
174 1         4 my $exec = $self->get('Exec');
175 1 50       4 croak "No Exec string defined for desktop entry" unless length $exec;
176 1         4 $exec =~ s/\%\%//g;
177 1         7 return $exec !~ /\%[fud]/; # we default to %F if no /\%[FUD]/i is found
178             }
179              
180             =item C
181              
182             Forks and runs the application specified in this Desktop Entry
183             with arguments FILES as a background process. Returns the pid.
184              
185             The child process fails when this is not a Desktop Entry of type Application
186             or if the Exec key is missing or invalid.
187              
188             If the desktop entry specifies that the program needs to be executed in a
189             terminal the $TERMINAL environment variable is used. If this variable is not
190             set C is used as default.
191              
192             (On Windows this method returns a L object.)
193              
194             =item C
195              
196             Like C but using the C system call.
197             It only return after the application has ended.
198              
199             =item C
200              
201             Like C but using the C system call. This method
202             is expected not to return but to replace the current process with the
203             application you try to run.
204              
205             On Windows this method doesn't always work the way you want it to
206             due to the C emulation on this platform. Try using C or
207             C instead.
208              
209             =cut
210              
211             sub run {
212 3     3 1 2784 my $pid = fork;
213 3 100       315 return $pid if $pid; # parent process
214 1         86 unshift @_, 'exec'; goto \&_run;
  1         88  
215             }
216              
217 5     5 1 34 sub system { unshift @_, 'system'; goto \&_run }
  5         33  
218              
219 1     1 1 1866 sub exec { unshift @_, 'exec'; goto \&_run }
  1         101  
220              
221             sub _run {
222 7     7   42 my $call = shift;
223 7         43 my $self = shift;
224              
225 7 50       121 croak "Desktop entry is not an Application"
226             unless $self->get('Type') eq 'Application';
227              
228 7         75 my @exec = $self->parse_Exec(@_);
229              
230 7         47 my $t = $self->get('Terminal');
231 7 50 33     35 if ($t and $t eq 'true') {
232 0   0     0 my $term = $ENV{TERMINAL} || 'xterm -e';
233 0         0 unshift @exec, _split($term);
234             }
235              
236 7         13 my $cwd;
237 7 100       27 if (my $path = $self->get('Path')) {
238 3         124 require Cwd;
239 3         68 $cwd = Cwd::getcwd();
240 3 50       305 chdir $path or croak "Could not change to dir: $path";
241 3         71 $ENV{PWD} = $path;
242 3 50       28 warn "Running from directory: $path\n" if $VERBOSE;
243             }
244              
245 7 50       49 warn "Running: "._quote(@exec)."\n" if $VERBOSE;
246              
247 7 100       27 if ($call eq 'exec') { CORE::exec {$exec[0]} @exec; exit 1 }
  2         15  
  2         0  
  0         0  
248 5         12 else { CORE::system {$exec[0]} @exec }
  5         30759  
249 5 0 33     127 warn "Error: $!\n" if $VERBOSE and $?;
250              
251 5 100       153 if (defined $cwd) {
252 2 50       274 chdir $cwd or croak "Could not change back to dir: $cwd";
253 2         126 $ENV{PWD} = $cwd;
254             }
255             }
256              
257             =item C
258              
259             Expands the Exec format in this desktop entry with. Returns a properly quoted
260             string in scalar context or a list of words in list context. Dies when the
261             Exec key is invalid.
262              
263             It supports the following fields:
264              
265             %f single file
266             %F multiple files
267             %u single url
268             %U multiple urls
269             %i Icon field prefixed by --icon
270             %c Name field, possibly translated
271             %k location of this .desktop file
272             %% literal '%'
273              
274             If necessary this method tries to convert between paths and URLs but this
275             is not perfect.
276              
277             Fields that are deprecated, but (still) supported by this module:
278              
279             %d single directory
280             %D multiple directories
281              
282             The fields C<%n>, C<%N>, C<%v> and C<%m> are deprecated and will cause a
283             warning if C<$VERBOSE> is used. Any other unknown fields will cause an error.
284              
285             The fields C<%F>, C<%U>, C<%D> and C<%i> can only occur as separate words
286             because they expand to multiple arguments.
287              
288             Also see L.
289              
290             =cut
291              
292             sub parse_Exec {
293 23     23 1 1570 my ($self, @argv) = @_;
294 23         90 my @format = _split( $self->get('Exec') );
295              
296             # Check format
297 23         124 my $seen = 0;
298 23         54 for (@format) {
299 62         111 my $s = $_; # copy;
300 62         178 $s =~ s/\%\%//g;
301 62         154 $seen += ($s =~ /\%[fFuUdD]/);
302              
303 62 50 66     381 die "Exec key for '".$self->get('Name')."' contains " .
304             "'\%F\', '\%U' or '\%D' at the wrong place\n"
305             if $s !~ /^\%[FUD]$/ and $s =~ /\%[FUD]/;
306              
307 62 100       172 die "Exec key for '".$self->get('Name')."' contains " .
308             "unknown field code '$1'\n"
309             if $s =~ /(\%[^fFuUdDnNickvm])/;
310              
311 61 100 100     249 croak "Application '".$self->get('Name')."' ".
312             "takes only one argument"
313             if @argv > 1 and $s =~ /\%[fud]/;
314              
315 60 50 33     288 warn "Exec key for '".$self->get('Name')."' contains " .
316             "deprecated field codes\n"
317             if $VERBOSE and $s =~ /%([nNvm])/;
318             }
319 21 100       127 if ($seen == 0) { push @format, '%F' }
  9 50       24  
320             elsif ($seen > 1) {
321             # not allowed according to the spec
322 0         0 warn "Exec key for '".$self->get('Name')."' contains " .
323             "multiple fields for files or uris.\n"
324             }
325              
326             # Expand format
327 21         36 my @exec;
328              
329 21         111 for (@format) {
330 67 100       280 if (/^\%([FUD])$/) {
    100          
331 17 100       136 push @exec,
    100          
332             ($1 eq 'F') ? _paths(@argv) :
333             ($1 eq 'U') ? _uris(@argv) : _dirs(@argv) ;
334             }
335             elsif ($_ eq '%i') {
336 1         4 my $icon = $self->get('Icon');
337 1 50       5 push @exec, '--icon', $icon if defined($icon);
338             }
339             else { # expand with word ( e.g. --input=%f )
340 49         63 my $bad;
341 49         119 s/\%(.)/
342             ($1 eq '%') ? '%' :
343             ($1 eq 'f') ? (_paths(@argv))[0] :
344             ($1 eq 'u') ? (_uris(@argv) )[0] :
345             ($1 eq 'd') ? (_dirs(@argv) )[0] :
346             ($1 eq 'c') ? $self->get('Name') :
347 11 100       69 ($1 eq 'k') ? $$self{file} : '' ;
    100          
    100          
    100          
    100          
    100          
348             /eg;
349              
350 49         121 push @exec, $_;
351             }
352             }
353              
354 21 50 66     269 if (wantarray and $^O eq 'MSWin32') {
355             # Win32 requires different quoting *sigh*
356 0         0 for (grep /"/, @exec) {
357 0         0 s#"#\\"#g;
358 0         0 $_ = qq#"$_"#;
359             }
360             }
361 21 100       161 return wantarray ? (@exec) : _quote(@exec);
362             }
363              
364             sub _split {
365             # Reverse quoting and break string in words.
366             # It allows single quotes to be used, which the spec doesn't.
367 46     46   86 my $string = shift;
368 46         68 my @args;
369 46         259 while ($string =~ /\S/) {
370 126 100       388 if ($string =~ /^(['"])/) {
371 33         150 my $q = $1;
372 33         1607 $string =~ s/^($q(\\.|[^$q])*$q)//s;
373 33 50       203 push @args, $1 if defined $1;
374             }
375 126         794 $string =~ s/(\S*)\s*//; # also fallback for above regex
376 126 50       836 push @args, $1 if defined $1;
377             }
378 46         300 @args = grep length($_), @args;
379 46         334 for (@args) {
380 127 100       521 if (/^(["'])(.*)\1$/s) {
381 32         126 $_ = $2;
382 32         142 s/\\(["`\$\\])/$1/g; # remove backslashes
383             }
384             }
385 46         207 return @args;
386             }
387              
388             sub _quote {
389             # Turn a list of words in a properly quoted Exec key
390 32     32   83 my @words = @_; # copy;
391             return join ' ', map {
392 32 100       93 if (/([\s"'`\\<>~\|\&;\$\*\?#\(\)])/) { # reserved chars
  91         312  
393 19         277 s/(["`\$\\])/\\$1/g; # add backslashes
394 19         57 $_ = qq/"$_"/; # add quotes
395             }
396 91         309 $_;
397             } grep defined($_), @words;
398             }
399              
400             sub _paths {
401             # Check if we need to convert file:// uris to paths
402             # support file:/path file://localhost/path and file:///path
403             # A path like file://host/path is replace by smb://host/path
404             # which the app probably can't open
405             map {
406 21 100   21   1711 $_ = _uri_to_path($_) if s#^file:(?://localhost/+|/|///+)(?!/)#/#i;
  19         91  
407 19         247 s#^file://(?!/)#smb://#i;
408 19         60 $_;
409             } @_;
410             }
411              
412             sub _dirs {
413             # Like _paths, but makes the path a directory
414             map {
415 2 100   2   5 if (-d $_) { $_ }
  3         226  
  2         8  
416             else {
417 1         22 my ($vol, $dirs, undef) = File::Spec->splitpath($_);
418 1         15 File::Spec->catpath($vol, $dirs, '');
419             }
420             } _paths(@_);
421             }
422              
423             sub _uris {
424             # Convert paths to file:// uris
425             map {
426 4 100   4   7 m#^\w+://# ? $_ : 'file://'._path_to_uri(File::Spec->rel2abs($_));
  6         115  
427             } @_;
428             }
429              
430             sub _uri_to_path {
431 7     7   26 my $x = Encode::encode('utf8', $_);
432 7         213 $x = uri_unescape($x);
433 7         79 return Encode::decode('utf8', $x);
434             }
435              
436             sub _path_to_uri {
437 3     3   16 return join '/', map { uri_escape_utf8($_) } split '/', $_;
  9         125  
438             }
439              
440             =item C
441              
442             =item C
443              
444             Get a value for KEY from GROUP. If GROUP is not specified 'Desktop Entry' is
445             used. All values are treated as string, so e.g. booleans will be returned as
446             the literal strings "true" and "false".
447              
448             When KEY does not contain a language code you get the translation in the
449             current locale if available or a sensible default. The request a specific
450             language you can add the language part. E.g. C<< $entry->get('Name[nl_NL]') >>
451             can return either the value of the 'Name[nl_NL]', the 'Name[nl]' or the 'Name'
452             key in the Desktop Entry file. Exact language parsing order can be found in the
453             spec. To force you get the untranslated key use either 'Name[C]' or
454             'Name[POSIX]'.
455              
456             =cut
457              
458             # used for (un-)escaping strings
459             my %Chr = (s => ' ', n => "\n", r => "\r", t => "\t", '\\' => '\\');
460             my %Esc = reverse %Chr;
461              
462             sub get {
463 115 100   115 1 1182 my ($self, $group, $key) =
464             (@_ == 2) ? ($_[0], '', $_[1]) : (@_) ;
465 115         202 my $locale = $_locale;
466 115 100       404 if ($key =~ /^(.*?)\[(.*?)\]$/) {
467 6         14 $key = $1;
468 6         12 $locale = _parse_lang($2);
469             }
470              
471 115         342 my @lang = split /\|/, $locale;
472              
473             # Get values that match locale from group
474 115 100       361 $self->read() unless $$self{groups};
475 115         297 my $i = $self->_group($group);
476 115 100       307 return undef unless defined $i;
477 114   100     590 my $lang = join('|', map quotemeta($_), @lang) || 'C';
478 114         6973 my %matches = ( $$self{groups}[$i] =~
479             /^(\Q$key\E\[(?:$lang)\]|\Q$key\E)[^\S\n]*=[^\S\n]*(.*?)\s*$/gm );
480 114 100       510 return undef unless keys %matches;
481              
482             # Find preferred value
483 98         230 my @keys = (map($key."[$_]", @lang), $key);
484 98         391 my ($value) = grep defined($_), @matches{@keys};
485              
486             # Parse string (replace \n, \t, etc.)
487 98 50       235 $value =~ s/\\(.)/$Chr{$1}||$1/eg;
  28         251  
488 98         857 return $value;
489             }
490              
491             sub _group { # returns index for a group name
492 151     151   298 my ($self, $group, $dont_die) = @_;
493 151   100     764 $group ||= 'Desktop Entry';
494 151 50       578 croak "Group name contains invalid characters: $group"
495             if $group =~ /[\[\]\r\n]/;
496 151         211 for my $i (0 .. $#{$$self{groups}}) {
  151         607  
497 158 100       1606 return $i if $$self{groups}[$i] =~ /^\[\Q$group\E\]/;
498             }
499 7         17 return undef;
500             }
501              
502             =item C VALUE, ...)>
503              
504             =item C VALUE, ...)>
505              
506             Set values for one or more keys. If GROUP is not given "Desktop Entry" is used.
507             All values are treated as strings, backslashes, newlines and tabs are escaped.
508             To set a boolean key you need to use the literal strings "true" and "false".
509              
510             Unlike the C call languages are not handled automatically for C.
511             KEY should include the language part if you want to set a translation.
512             E.g. C<< $entry->set("Name[nl_NL]" => "Tekst Verwerker") >> will set a Dutch
513             translation for the Name key. Using either "Name[C]" or "Name[POSIX]" will
514             be equivalent with not giving a language argument.
515              
516             When setting the Exec key without specifying a group it will be parsed
517             and quoted correctly as required by the spec. You can use quoted arguments
518             to include whitespace in a argument, escaping whitespace does not work.
519             To circumvent this quoting explicitly give the group name 'Desktop Entry'.
520              
521             =cut
522              
523             sub set {
524 34     34 1 800265 my $self = shift;
525 34 100       198 my ($group, @data) = ($#_ % 2) ? (undef, @_) : (@_) ;
526              
527 34 100 100     259 $self->read() unless $$self{groups} or ! $$self{file};
528 34         126 my $i = $self->_group($group);
529 34 100       113 unless (defined $i) {
530 6   100     28 $group ||= 'Desktop Entry';
531 6         13 push @{$$self{groups}}, "[$group]\n";
  6         26  
532 6         89 $i = $#{$$self{groups}};
  6         15  
533             }
534              
535 34         101 while (@data) {
536 48         146 my ($k, $v) = splice(@data, 0, 2);
537 48         117 $k =~ s/\[(C|POSIX)\]$//; # remove default locale
538 48         319 my ($word) = ($k =~ /^(.*?)(\[.*?\])?$/);
539             # separate key and locale
540 48 50       128 croak "BUG: Key missing: $k" unless length $word;
541 48 50       143 carp "Key contains invalid characters: $k"
542             if $word =~ /[^A-Za-z0-9-]/;
543 48 100 100     318 $v = _quote( _split($v) ) if ! $group and $k eq 'Exec';
544             # Exec key needs extra quoting
545 48         229 $v =~ s/([\\\n\r\t])/\\$Esc{$1}/g; # add escapes
546 48 100       815 $$self{groups}[$i] =~ s/^\Q$k\E=.*$/$k=$v/m and next;
547 25         169 $$self{groups}[$i] .= "$k=$v\n";
548             }
549             }
550              
551             =item C
552              
553             Returns the (modified) text of the file.
554              
555             =cut
556              
557             sub text {
558 3 100   3 1 20 $_[0]->read() unless $_[0]{groups};
559 3 50       9 return '' unless $_[0]{groups};
560 3         4 s/\n?$/\n/ for @{$_[0]{groups}}; # just to be sure
  3         31  
561 3         5 return join "\n", @{$_[0]{groups}};
  3         17  
562             }
563              
564             =item C
565              
566             =item C
567              
568             Read Desktop Entry data from file or memory buffer.
569             Without argument defaults to file given at constructor.
570              
571             If you gave a file, text buffer or name to the constructor this method will
572             be called automatically.
573              
574             =item C
575              
576             Read Desktop Entry data from filehandle or IO object.
577              
578             =cut
579              
580             sub read {
581 14     14 1 41 my ($self, $file) = @_;
582 14   66     56 $file ||= $$self{file};
583 14 50       36 croak "DesktopEntry has no filename to read from" unless length $file;
584              
585 14         20 my $fh;
586 14 100       33 unless (ref $file) {
587 10 50       414 open $fh, "<$file" or croak "Could not open file: $file";
588             }
589             else {
590 3 50   3   17 open $fh, '<', $file or croak "Could not open SCALAR ref !?";
  3         6  
  3         21  
  4         100  
591             }
592 14         3578 binmode $fh, ':utf8';
593 14         40 $self->read_fh($fh);
594 14         123 close $fh;
595             }
596              
597             sub read_fh {
598 14     14 1 22 my ($self, $fh) = @_;
599 14         49 $$self{groups} = [];
600              
601             # Read groups
602 14         39 my $group = '';
603 14         179 while (my $l = <$fh>) {
604 437         1643 $l =~ s/\r?\n$/\n/; # DOS to Unix conversion
605 437 100       1206 if ($l =~ /^\[(.*?)\]\s*$/) {
606 32 100       96 push @{$$self{groups}}, $group
  18         47  
607             if length $group;
608 32         55 $group = '';
609             }
610 437         1712 $group .= $l;
611             }
612 14         22 push @{$$self{groups}}, $group;
  14         50  
613 14         22 s/\n\n$/\n/ for @{$$self{groups}}; # remove last empty line
  14         190  
614              
615             # Some checks
616 14         29 for (qw/Name Type/) {
617 28 50       76 carp "Required key missing in Desktop Entry: $_"
618             unless defined $self->get($_);
619             }
620 14         34 my $enc = $self->get('Encoding');
621 14 50 66     81 carp "Desktop Entry uses unsupported encoding: $enc"
622             if $enc and $enc ne 'UTF-8';
623             }
624              
625             =item C
626              
627             Write the Desktop Entry data to FILE. Without arguments it writes to
628             the filename given to the constructor if any.
629              
630             The keys Name and Type are required. Type can be either C,
631             C or C. For an application set the optional key C. For
632             a link set the C key.
633              
634             =cut
635              
636             # Officially we should check lines end with LF - this is \n on Unix
637             # but on Windows \n is CR LF, which breaks the spec
638              
639             sub write {
640 1     1 1 5 my $self = shift;
641 1   33     5 my $file = shift || $$self{file};
642 1 50       5 unless ($$self{groups}) {
643 0 0       0 if ($$self{file}) { $self->read() }
  0         0  
644 0         0 else { croak "Can not write empty Desktop Entry file" }
645             }
646              
647             # Check keys
648 1         2 for (qw/Name Type/) {
649 2 50       5 croak "Can not write a desktop file without a $_ field"
650             unless defined $self->get($_);
651             }
652 1         4 $self->set(Version => '1.0', Encoding => 'UTF-8');
653              
654             # Check file writable
655             $file = $self->_data_home_file
656 1 50 33     27 if (! $file or ! -w $file) and defined $$self{name};
      33        
657 1 50       4 croak "No file given for writing Desktop Entry" unless length $file;
658              
659             # Write file
660 1         2 s/\n?$/\n/ for @{$$self{groups}}; # just to be sure
  1         9  
661 1 50       71 open OUT, ">$file" or die "Could not write file: $file\n";
662 1 50       7 binmode OUT, ':utf8' unless $] < 5.008;
663 1         3 print OUT join "\n", @{$$self{groups}};
  1         19  
664 1         104 close OUT;
665             }
666              
667             sub _data_home_file {
668             # create new file name in XDG_DATA_HOME from name
669 1     1   2 my $self = shift;
670 1         4 my @parts = split /-/, $$self{name};
671 1         3 $parts[-1] .= '.desktop';
672 1         8 my $dir = data_home('applications', @parts[0 .. $#parts-1]);
673 1 50       47 unless (-d $dir) { # create dir if it doesn't exist
674 1         6 require File::Path;
675 1         221 File::Path::mkpath($dir);
676             }
677 1         6 return data_home('applications', @parts);
678             }
679              
680             =back
681              
682             =head2 Backwards Compatibility
683              
684             Methods supported for backwards compatibility with 0.02.
685              
686             =over 4
687              
688             =item C
689              
690             Alias for C.
691              
692             =item C
693              
694             Alias for C.
695              
696             =item C
697              
698             Identical to C.
699             LANG defaults to 'C', GROUP is optional.
700              
701             =cut
702              
703 1     1 1 372 sub new_from_file { $_[0]->new($_[1]) }
704              
705 2     2 1 18 sub new_from_data { $_[0]->new(\$_[1]) }
706              
707             sub get_value {
708 2     2 1 4 my ($self, $key, $group, $locale) = @_;
709 2   50     11 $locale ||= 'C';
710 2         5 $key .= "[$locale]";
711 2 100       9 $group ? $self->get($group, $key) : $self->get($key);
712             }
713              
714             =back
715              
716             =head1 NON-UNIX PLATFORMS
717              
718             This module has a few bits of code to make it work on Windows. It handles
719             C uri a bit different and it uses L. On other
720             platforms your mileage may vary.
721              
722             Please note that the specification is targeting Unix platforms only and
723             will only have limited relevance on other platforms. Any platform-dependent
724             behavior in this module should be considered an extension of the spec.
725              
726             =cut
727              
728             if ($^O eq 'MSWin32') {
729             # Re-define some modules - I assume this block gets optimized away by the
730             # interpreter when not running on windows.
731 6     6   41 no warnings;
  6         11  
  6         6367  
732              
733             # Wrap _paths() to remove first '/'
734             # As a special case translate SMB file:// uris
735             my $_paths = \&_paths;
736             *_paths = sub {
737             my @paths = map {
738             s#^file:////(?!/)#smb://#;
739             $_;
740             } @_;
741             map {
742             s#^/+([a-z]:/)#$1#i;
743             $_;
744             } &$_paths(@paths);
745             };
746              
747             # Wrap _uris() to remove '\' in path
748             my $_uris = \&_uris;
749             *_uris = sub {
750             map {
751             s#\\#/#g;
752             $_;
753             } &$_uris(@_);
754             };
755              
756             # Using Win32::Process because fork is not native on win32
757             # Effect is that closing an application spawned with fork
758             # can kill the parent process as well when using Gtk2
759             *run = sub {
760             my ($self, @files) = @_;
761              
762             my $cmd = eval { $self->parse_Exec(@files) };
763             warn $@ if $@; # run should not die
764              
765             my $bin = (_split($cmd))[0];
766             unless (-f $bin) { # we need the real binary path
767             my ($b) = grep {-f $_}
768             map File::Spec->catfile($_, $bin),
769             split /[:;]/, $ENV{PATH} ;
770             if (-f $b) { $bin = $b }
771             else {
772             warn "Could not find application: $bin\n";
773             return;
774             }
775             }
776              
777             my $dir = $self->get('Path') || '.';
778              
779             if ($VERBOSE) {
780             warn "Running from directory: $dir" unless $dir eq '.';
781             warn "Running: $cmd\n";
782             }
783             my $obj;
784             eval {
785             Win32::Process::Create(
786             $obj, $bin, $cmd, 0, &NORMAL_PRIORITY_CLASS, $dir );
787             };
788             warn $@ if $@;
789             return $obj;
790             };
791              
792             }
793              
794             1;
795              
796             __END__