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

package File::MimeInfo::Applications;

use strict;
use warnings;
use Carp;
use File::Spec;
use File::BaseDir qw/config_home config_dirs data_home data_dirs data_files/;
use File::MimeInfo qw/mimetype_canon mimetype_isa/;
use File::DesktopEntry;
require Exporter;

our $VERSION = '0.32';

our @ISA = qw(Exporter);
our @EXPORT = qw(
    mime_applications mime_applications_all
    mime_applications_set_default mime_applications_set_custom
);

print STDERR << 'EOT' unless data_files(qw/applications mimeinfo.cache/);
WARNING: You don't seem to have any mimeinfo.cache files.
Try running the update-desktop-database command. If you
don't have this command you should install the
desktop-file-utils package. This package is available from
http://freedesktop.org/wiki/Software/desktop-file-utils/
EOT

sub mime_applications {
    croak "usage: mime_applications(MIMETYPE)" unless @_ == 1;
    my $mime = mimetype_canon(shift @_);
    local $Carp::CarpLevel = $Carp::CarpLevel + 1;
    return wantarray ? (_default($mime), _others($mime)) : _default($mime);
}

sub mime_applications_all {
    croak "usage: mime_applications(MIMETYPE)" unless @_ == 1;
    my $mime = shift;
    return mime_applications($mime),
        grep defined($_), map mime_applications($_), mimetype_isa($mime);
}

sub mime_applications_set_default {
    croak "usage: mime_applications_set_default(MIMETYPE, APPLICATION)"
        unless @_ == 2;
    my ($mimetype, $desktop_file) = @_;
    (undef, undef, $desktop_file) =
        File::Spec->splitpath($desktop_file->{file})
        if ref $desktop_file;
    croak "missing desktop entry filename for application"
        unless length $desktop_file;
    $desktop_file .= '.desktop' unless $desktop_file =~ /\.desktop$/;
    _write_list($mimetype, $desktop_file);
}

sub mime_applications_set_custom {
    croak "usage: mime_applications_set_custom(MIMETYPE, COMMAND)"
        unless @_ == 2;
    my ($mimetype, $command) = @_;
    $command =~ /(\w+)/;
    my $word = $1 or croak "COMMAND does not contain a word !?";

    # Algorithm to generate name copied from other implementations
    my $i = 1;
    my $desktop_file =
        data_home('applications', $word.'-usercreated-'.$i.'.desktop');
    while (-e $desktop_file) {
        $i++;
        $desktop_file =
        data_home('applications', $word.'-usercreated-'.$i.'.desktop');
    }

    my $object = File::DesktopEntry->new();
    $object->set(
        Type      => 'Application',
        Name      => $word,
        NoDisplay => 'true',
        Exec      => $command,
    );
    my (undef, undef, $df) = File::Spec->splitpath($desktop_file);
    _write_list($mimetype, $df); # creates dir if needed
    $object->write($desktop_file);
    return $object;
}

sub _default {
    my $mimetype = shift;

    my $user       = config_home(qw/mimeapps.list/);
    my $system     = config_dirs(qw/mimeapps.list/);
    my $deprecated = data_home(qw/applications mimeapps.list/);
    my $distro     = data_dirs(qw/applications mimeapps.list/);
    my $legacy     = data_home(qw/applications defaults.list/);

    unless ( ( -f $user
        || ($system && -f $system)
        || ($deprecated && -f $deprecated)
        || ($distro && -f $distro)
        || ($legacy && -f $legacy) )
        && -r _ ) {
        return undef;
    }

    $Carp::CarpLevel++;
    my @paths = grep defined, ($mimetype, $user, $system, $deprecated, $distro, $legacy);
    my @list = _read_list(@paths);
    my $desktop_file = _find_file(reverse @list);
    $Carp::CarpLevel--;

    return $desktop_file;
}

sub _others {
    my $mimetype = shift;

    $Carp::CarpLevel++;
    my (@list, @done);
    for my $dir (data_dirs('applications')) {
        my $cache = File::Spec->catfile($dir, 'mimeinfo.cache');
        next if grep {$_ eq $cache} @done;
        push @done, $cache;
        next unless -f $cache and -r _;
        for (_read_list($mimetype, $cache)) {
            my $file = File::Spec->catfile($dir, $_);
            next unless -f $file and -r _;
            push @list, File::DesktopEntry->new($file);
        }
    }
    $Carp::CarpLevel--;

    return @list;
}

sub _read_list { # read list with "mime/type=foo.desktop;bar.desktop" format
    my $mimetype = shift;

    my @list;
    my $succeeded;

    for my $file (@_) {
        if (open LIST, '<', $file) {
            $succeeded = 1;
            while () {
                /^\Q$mimetype\E=(.*)$/ or next;
                push @list, grep defined($_), split ';', $1;
            }
            close LIST;
        }
    }

    unless ($succeeded) {
        croak "Could not read any defaults, tried:\n" . join("\t\n", @_);
    }

    return @list;
}

sub _write_list {
    my ($mimetype, $desktop_file) = @_;
    my $file = config_home(qw/mimeapps.list/);
    my $text;
    if (-f $file) {
        open LIST, '<', $file or croak "Could not read file: $file";
        while () {
            $text .= $_ unless /^\Q$mimetype\E=/;
        }
        close LIST;
        $text =~ s/[\n\r]?$/\n/; # just to be sure
    }
    else {
        _mkdir($file);
        $text = "[Default Applications]\n";
    }

    open LIST, '>', $file or croak "Could not write file: $file";
    print LIST $text;
    print LIST "$mimetype=$desktop_file;\n";
    close LIST or croak "Could not write file: $file";
}

sub _find_file {
    my @list = shift;
    for (@list) {
        my $file = data_files('applications', $_);
        return File::DesktopEntry->new($file) if $file;
    }
    return undef;
}

sub _mkdir {
    my $dir = shift;
    return if -d $dir;

    my ($vol, $dirs, undef) = File::Spec->splitpath($dir);
    my @dirs = File::Spec->splitdir($dirs);
    my $path = File::Spec->catpath($vol, shift @dirs);
    while (@dirs) {
        mkdir $path; # fails silently
        $path = File::Spec->catdir($path, shift @dirs);
    }

    die "Could not create dir: $path\n" unless -d $path;
}

1;

__END__