File::MimeInfo::Applications - Find programs to open a file by mimetype

  use File::MimeInfo::Magic;
  use File::MimeInfo::Applications;

  my $file = '/foo/bar';
  my $mimetype = mimetype($file)
      || die "Could not find mimetype for $file\n";

  my ($default, @other) = mime_applications($mimetype);

  if (defined $default) {
      $default->system($file)
  }
  else {
	  # prompt user with choice from @others
	  # ...
  }

package File::MimeInfo::Applications;

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

our $VERSION = '0.15';

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_2fdesktop_2dfile_2dutils
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,
		NoDsiplay => '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 $file = data_home(qw/applications defaults.list/);
	return undef unless -f $file && -r _;
	
	$Carp::CarpLevel++;
	my @list = _read_list($mimetype, $file);
	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, $file) = @_;
	my @list;
	open LIST, '<', $file or croak "Could not read file: $file";
	while (<LIST>) {
		/^$mimetype=(.*)$/ or next;
		push @list, grep defined($_), split ';', $1;
	}
	close LIST;

	return @list;
}

sub _write_list {
	my ($mimetype, $desktop_file) = @_;
	my $file = data_home(qw/applications defaults.list/);
	my $text;
	if (-f $file) {
		open LIST, '<', $file or croak "Could not read file: $file";
		while (<LIST>) {
			$text .= $_ unless /^$mimetype=/;
		}
		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__