#! /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); while (<FILE>) { chomp; next if (m/^\s*$|^\s*\#/); 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);