#! /usr/bin/perl
###############################################################################
#
# Update-MIME: Install programs into "/etc/mailcap", resolve conflicts,
# auto-uninstall, make dinner, and wash dishes.
#
# Written by Brian White <bcwhite@pobox.com>.
#
# This program has been placed in the public domain (the only true "free").
# Do whatever you wish with it, though I'd appreciate it if my name stayed
# on it as the original author.
#
###############################################################################
umask(022);
# These are pretty well always a Good Idea(tm)
use strict;
use warnings;
#
# Program Constants
#
my $debug = 0;
my $conffile = "/etc/update-mime.conf";
my $mailcap = "/etc/mailcap";
my $mailcapdef = "/usr/lib/mime/mailcap";
my $mimedir = "/usr/lib/mime/packages";
my $appsdir = "/usr/share/applications";
my $orderfile = "/etc/mailcap.order";
my $defpriority = 5;
my $localgen = 0;
# If the call comes from dpkg, only accept it if --triggered is passed
# This is so that we don't get useless calls from packages' postinsts
# that call update-mime due to dh_installmime adding that call for
# when there was no triggers support.
#
# When this 'hack' is removed, mime-support's postinst should be updated
# to not pass --triggered anymore in 'triggered'.
if (defined $ENV{"DPKG_RUNNING_VERSION"} && defined $ARGV[0] && $ARGV[0] ne "--triggered") {
exit (0);
}
# Allow local run
if (defined $ARGV[0] && $ARGV[0] eq "--local") {
$conffile = "$ENV{HOME}/.update-mime.conf";
$mailcap = "$ENV{HOME}/.mailcap";
$orderfile = "$ENV{HOME}/.mailcap.order";
$localgen = 1;
}
#
# Allow local customizations
#
do $conffile if -f $conffile;
#
# Global Variables
#
my %entries;
my %packages;
my %priorities;
my @order;
my $counter=1;
sub ReadEntries
{
my($pkg,$priority);
# foreach my $file (glob "$mimedir/*") {
foreach my $file (map { glob $_.'/*' } split ':',$mimedir) {
next if ($file =~ m!(^|/)(\.|\#)|(\~)$!);
($pkg) = ($file =~ m|/([^/]*)$|);
print STDERR "$pkg:\n" if $debug;
if (!defined $packages{$pkg}) {
$packages{$pkg} = [];
}
if (open(FILE,"<$file")) {
while (<FILE>) {
chomp;
next if m/^\s*$|^\s*\#/;
if (! m(^[a-zA-Z0-9*][a-zA-Z0-9!#\$&^_.+-]*/[a-zA-Z0-9*][a-zA-Z0-9!#\$&^_.+-]*;) ) {
print STDERR "Warning: mailcap line not starting with a media type in $pkg\n";
print STDERR "Problematic line: $_\n";
}
if (m/priority\s*=\s*(\d+)\s*($|;)/i) {
$priority=$1;
} else {
$priority=$defpriority;
}
if ($priority < 0 || $priority > 9) {
print STDERR "Error: priority of $priority is out of range (0 <= pri <= 9)\n";
print STDERR " $_\n";
$priority=$defpriority;
}
$entries{$counter} = $_;
push @{$packages{$pkg}},$counter;
push @{$priorities{$priority}},$counter;
print STDERR "$counter: $_\n" if $debug;
$counter++;
}
close(FILE);
} else {
print STDERR "Warning: could not open file '$file' -- $!\n";
}
}
}
sub RecurseIntoDirectories
{
my @files;
foreach my $dir (@_) {
next if ($dir =~ m!(^|/)(\.|\#)|(\~)$!);
my @entries = glob "$dir/*";
push @files, RecurseIntoDirectories(grep { -d $_ } @entries);
push @files, grep { -f $_ } @entries;
}
return @files;
}
sub ReadDesktopEntries
{
my($pkg,$priority);
foreach my $file (RecurseIntoDirectories(split ':',$appsdir)) {
next if ($file =~ m!(^|/)(\.|\#)|(\~)$!);
next unless ($file =~ m/\.desktop$/);
($pkg) = ($file =~ m|/([^/]*)\.desktop$|);
print STDERR "$pkg:\n" if $debug;
next if (defined $packages{$pkg});
$packages{$pkg} = [];
if (open(FILE,"<$file")) {
my($terminal, $name, $icon, $exec, @types) = ("test=test -n \"\$DISPLAY\"", $pkg);
my $in_desktop_group = 0;
while (<FILE>) {
chomp;
next if (m/^\s*$|^\s*\#/);
if (m/^\[Desktop Entry\]$/) {
$in_desktop_group = 1;
next;
}
if (m/^\[.*\]$/) {
$in_desktop_group = 0;
next;
}
next unless $in_desktop_group;
if (m/^Terminal=(\w+)/i) {
$terminal = "needsterminal" if ($1 eq "true");
}
elsif (m/^Name=(.+)/i) {
$name = $1;
}
elsif (m/^Icon=(.+)/i) {
$icon = $1;
}
elsif (m/Exec=(.*)$/i) {
$exec = $1;
$exec =~ s/%[fFuU]/%s/g;
$exec .= " %s" if ($exec !~ m/%s/);
}
elsif (m/MimeType=(.*)/i) {
my $err = 0;
push @types, grep { if (length>0) {1} else {++$err;0} }
split(/\s*;\s*/, $1);
print STDERR "Warning: $file:$.: ignoring empty entries in MimeType\n" if $err;
}
}
if (!defined($exec) || !scalar(@types)) {
close(FILE);
next;
}
$exec =~ s/%c/$name/g;
$exec =~ s/%i/--icon $icon/g;
foreach my $type (@types) {
my $entry = "$type; $exec; $terminal";
$priority=$defpriority;
$entries{$counter} = $entry;
push @{$packages{$pkg}},$counter;
push @{$priorities{$priority}},$counter;
print STDERR "$counter: $entry\n" if $debug;
$counter++;
}
close(FILE);
} else {
print STDERR "Warning: could not open file '$file' -- $!\n";
}
}
}
sub ReadOrder
{
if (-e $orderfile) {
if (open(FILE,"<$orderfile")) {
while (<FILE>) {
chomp;
s/\s*\#.*$//;
next if m/^\s*$/;
push @order,$_;
/(.*):/;
my $pkg = $1;
unless( grep {/^$pkg$/} keys(%packages)) {
print STDERR "Warning: package $pkg listed in /etc/mailcap.order does not have mailcap entries.\n";
}
}
close(FILE);
} else {
print STDERR "Warning: could not open file '$orderfile' -- $!\n";
}
}
}
sub OrderEntries
{
my(@entrylist,@orderlist,@templist,$priority,$entrycode,$ordercode);
foreach $priority (sort {$b <=> $a} keys %priorities) {
print STDERR " - Priority $priority:" if $debug;
@templist = @{$priorities{$priority}};
@templist = sort {
my $ae = $entries{$a};
my $ac = 0;
$ac += 1 if $ae =~ m!^\S+/\*!;
$ac += 2 if $ae =~ m!^\*/!;
my $be = $entries{$b};
my $bc = 0;
$bc += 1 if $be =~ m!^\S+/\*!;
$bc += 2 if $be =~ m!^\*/!;
$ac <=> $bc;
} @templist;
foreach my $entry (@templist) {
print STDERR " $entry" if $debug;
push @entrylist,$entry;
}
print STDERR "\n" if $debug;
}
print STDERR "entrylist: @entrylist\n" if $debug;
foreach $ordercode (@order) {
my($pkg,$typ);
if ($ordercode =~ m/:/) {
($pkg,$typ) = ($ordercode =~ m/^(.*):(\S*)/);
} else {
$pkg = $ordercode;
$typ = "*/*";
}
$typ = "*/*" unless $typ;
print STDERR " - Ordering '$ordercode'... (package=$pkg, type=$typ, orderlist=@orderlist)\n" if $debug;
$typ =~ s/\*/\.\*/g;
foreach $entrycode (@entrylist) {
next if grep(/^\Q$entrycode\E$/,@orderlist);
print STDERR " - Checking entrycode '$entrycode' against (@{$packages{$pkg}})...\n" if $debug;
if (grep(/^\Q$entrycode\E$/,@{$packages{$pkg}})) {
my $entry = $entries{$entrycode};
my($etype) = ($entry =~ m/^(.*?)(;|\s)/);
print STDERR " - entry found, type=$etype, checking against '$typ'\n" if $debug;
if ($etype =~ m!^$typ$!) {
# print STDERR " - matched!\n" if $debug;
# my($oaction) = ($ordercode =~ m/action=([^\s;]*)/i);
# my($eaction) = ($entry =~ m/action=([^\s;]*)/i);
# $eaction="view" unless $eaction;
# print STDERR " - checking entry action '$eaction' against '$oaction'\n" if $debug;
# if (!$oaction || $eaction =~ m/^($oaction)$/) {
push @orderlist,$entrycode;
print STDERR " - matched! (orderlist=@orderlist)\n" if $debug;
# }
}
}
}
}
foreach $entrycode (@entrylist) {
next if grep(/^\Q$entrycode\E$/,@orderlist);
push @orderlist,$entrycode;
}
print STDERR "orderlist: @orderlist\n" if $debug;
return @orderlist;
}
#
# Generate new mailcap file
#
sub UpdateMailcap
{
my(@entrylist) = @_;
my(@above,@user,@below,$state,$entrycode);
$state = 0;
if (!open(PATH,"<$mailcap")) {
if (!open(PATH,"<$mailcapdef")) {
# print STDERR "Warning: could not read '$mailcap' (update stopped) -- $!\n";
# print STDERR " restore from backup or delete and re-install mime-support package";
return;
}
}
while (<PATH>) {
s/install-mime/update-mime/g;
if ($state == 0) {
push @above,$_;
}
$state=2 if ($state == 1 && /^\# ----- .* Ends /);
if ($state == 1) {
push @user,$_;
}
$state=1 if ($state == 0 && /^\# ----- .* Begins /);
if ($state == 2) {
push @below,$_;
}
$state=3 if ($state == 2);
}
close PATH;
if ($state == 3) {
my $newfile = join('',@above,@user,@below);
$newfile .= "\n###############################################################################\n\n";
foreach $entrycode (@entrylist) {
my $entry = $entries{$entrycode};
$entry =~ s/\s*priority\s*=\s*\d+\s*($|;)//;
$entry =~ s/\s*;\s*$//;
$newfile .= $entry."\n";
}
if (!open(PATH,">$mailcap.new")) {
print STDERR "Error: could not write '$mailcap.new' -- $!\n";
exit(1) unless ($debug);
open(PATH,">-");
}
print PATH $newfile;
close PATH;
if (!open(PATH,"<$mailcap.new")) {
die "Error: could not read generated '$mailcap.new' -- $!\n";
}
my $savfile = "";
$savfile .= $_ while (<PATH>);
if ($savfile ne $newfile) {
die "Error: contents of '$mailcap.new' do not match what was written -- abort\n";
}
rename "$mailcap.new","$mailcap";
} else {
print STDERR "Error: '$mailcap' is not in required format -- not updated\n";
print STDERR " Restore from backup or delete and re-install mime-support package";
}
}
ReadEntries();
ReadDesktopEntries();
ReadOrder();
my @list = OrderEntries();
UpdateMailcap(@list);
Mini Shell