# menu format -- lintian check script -*- perl -*-

# Copyright (C) 1998 by Joey Hess
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, you can find it on the World Wide
# Web at http://www.gnu.org/copyleft/gpl.html, or write to the Free
# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
# MA 02110-1301, USA.

# This script also checks desktop entries, since they share quite a bit of
# code.  At some point, it would make sense to try to refactor this so that
# shared code is in libraries.
#
# Further things that the desktop file validation should be checking:
#
#  - Encoding of the file should be UTF-8.
#  - Additional Categories should be associated with Main Categories.
#  - List entries (MimeType, Categories) should end with a semicolon.
#  - Check for GNOME/GTK/X11/etc. dependencies and require the relevant
#    Additional Category to be present.
#  - Check all the escape characters supported by Exec.
#  - Review desktop-file-validate to see what else we're missing.

package Lintian::menu_format;
use strict;
use warnings;

use Lintian::Data;
use Lintian::Tags qw(tag);
use Lintian::Util qw(fail);

use File::Basename;

# This is a list of all tags that should be in every menu item.
my @req_tags=qw(needs section title command);

# This is a list of all known tags.
my @known_tags=qw(
        needs
        section
        title
        sort
        command
        longtitle
        icon
        icon16x16
        icon32x32
        description
        hotkey
        hints
    );

# These 'needs' tags are always valid, no matter the context, and no other
# values are valid outside the Window Managers context (don't include wm here,
# in other words).  It's case insensitive, use lower case here.
my @needs_tag_vals=qw(x11 text vc);

sub _menu_sections {
    my ($key, $val, $cur) = @_;
    my $ret = undef;
    $ret = $cur = {} unless defined $cur;
    # $val is empty if this is just a root section
    $cur->{$val} = 1 if $val;
    return $ret;
}

my $MENU_SECTIONS = Lintian::Data->new ('menu-format/menu-sections',
                                        qr|/|, \&_menu_sections);

# Authorative source of desktop keys:
# http://standards.freedesktop.org/desktop-entry-spec/1.0/
#
# This is a list of all keys that should be in every desktop entry.
my @req_desktop_keys = qw(Type Name);

# This is a list of all known keys.
my %known_desktop_keys = map { $_ => 1 }
    qw(
       Type
       Version
       Name
       GenericName
       NoDisplay
       Comment
       Icon
       Hidden
       OnlyShowIn
       NotShowIn
       TryExec
       Exec
       Path
       Terminal
       MimeType
       Categories
       MimeType
       Categories
       StartupNotify
       StartupWMClass
       URL
      );

my %deprecated_desktop_keys = map { $_ => 1 }
    qw(
       Encoding
       MiniIcon
       TerminalOptions
       Protocols
       Extensions
       BinaryPattern
       MapNotify
       SwallowTitle
       SwallowExec
       SortOrder
       FilePattern
      );

# KDE uses some additional keys that should start with X-KDE but don't for
# historical reasons.  Actions will in theory be in a later version of the
# standard (it's not mentioned in the current standard, but is implemented by
# KDE and widely used).
my %kde_desktop_keys = map { $_ => 1 }
    qw(
       ServiceTypes
       DocPath
       Keywords
       InitialPreference
       Dev
       FSType
       MountPoint
       ReadOnly
       UnmountIcon
       Actions
      );

# Known types of desktop entries.
# http://standards.freedesktop.org/desktop-entry-spec/1.0/ar01s05.html
my %known_desktop_types = map { $_ => 1 }
    qw(
       Application
       Link
       Directory
      );

# Authorative source of desktop categories:
# http://standards.freedesktop.org/menu-spec/1.0/apa.html

# This is a list of all Main Categories for .desktop files.  Application is
# added as an exception; it's not listed in the standard, but it's widely used
# and used as an example in the GNOME documentation.  GNUstep is added as an
# exception since it's used by GNUstep packages.
my %main_categories = map { $_ => 1 }
    qw(
       AudioVideo
       Audio
       Video
       Development
       Education
       Game
       Graphics
       Network
       Office
       Settings
       System
       Utility
       Application
       GNUstep
      );

# This is a list of all Additional Categories for .desktop files.  Ideally we
# should be checking to be sure the associated Main Categories are present,
# but we don't have support for that yet.
my $ADD_CATEGORIES = Lintian::Data->new ('menu-format/add-categories');

# This is a list of Reserved Categories for .desktop files.  To use one of
# these, the desktop entry must also have an OnlyShowIn key limiting the
# environment to one that supports this category.
my %reserved_categories = map { $_ => 1 }
    qw(
       Screensaver
       TrayIcon
       Applet
       Shell
      );

# Path in which to search for binaries referenced in menu entries.  These must
# not have leading slashes.
my @path = qw(usr/local/bin/ usr/bin/ bin/ usr/X11R6/bin/ usr/games/);

my %known_tags_hash = map { $_ => 1 } @known_tags;
my %needs_tag_vals_hash = map { $_ => 1 } @needs_tag_vals;

# -----------------------------------

sub run {

my ($pkg, $type, $info, $proc, $group) = @_;

my $mdir = $info->lab_data_path ('menu');
my @menufiles;
opendir MENUDIR, "$mdir/lib" or fail 'cannot read menu/lib file directory';
push @menufiles, map { "$mdir/lib/$_" } readdir (MENUDIR);
closedir MENUDIR;
opendir MENUDIR, "$mdir/share" or fail 'cannot read menu/share file directory';
push @menufiles, map { "$mdir/share/$_" } readdir (MENUDIR);
closedir MENUDIR;

# Find the desktop files in the package for verification.
my @desktop_files;
foreach my $file ($info->sorted_index) {
    my $index_info = $info->index ($file);
    my $operm = $index_info->operm;

    tag 'deprecated-kdelnk-file', $file if ($file =~ m,\.kdelnk$,);

    if ($index_info->is_file &&
        $file =~ m,^usr/share/applications/.*\.desktop$,) {

        if ($operm & 0111) {
           tag 'executable-desktop-file', sprintf('%s %04o',$file,$operm);
        }
        unless ($file =~ m,template,o) {
            push (@desktop_files, $file);
        }
    }
}

# Verify all the desktop files.
for my $desktop_file (@desktop_files) {
    VerifyDesktopFile($desktop_file, $desktop_file, $pkg, $info);
}

# Now all the menu files.
foreach my $menufile (@menufiles) {
    next if -x $menufile; # don't try to parse executables

    my $basename = basename $menufile;
    my $fullname = "usr/share/menu/$basename";
    $fullname = "usr/lib/menu/$basename" if $menufile =~ m,^\Q$mdir\E/lib/,;

    next if $basename eq 'README'; # README is a special case

    my $menufile_line ='';
    open (IN, '<', $menufile) or
        fail("cannot open menu file $menufile for reading.");
    # line below is commented out in favour of the while loop
    # do { $_=<IN>; } while defined && (m/^\s* \#/ || m/^\s*$/);
    while (<IN>) {
        if (m/^\s*\#/ || m/^\s*$/) {
            next;
        } else {
            $menufile_line = $_;
            last;
        }
    }

    # Check first line of file to see if it matches the old menu file format.
    if ($menufile_line =~ m/^(?!\?package\(.*\)).* .* .* .* "?.*"? .*$/o) {
        tag 'old-format-menu-file', $fullname;
        close IN;
        next;
    } elsif ($menufile_line =~ m/^!C\s*menu-2/o) {
        # we can't parse that yet
        close IN;
        next;
    }

    # Parse entire file as a new format menu file.
    my $line='';
    my $lc=0;
    do {
        $lc++;

        # Ignore lines that are comments.
        if ($menufile_line =~ m/^\s*\#/o) {
            next;
        }
        $line .= $menufile_line;
        # Note that I allow whitespace after the continuation character.
        # This is caught by VerifyLine().
        if (! ($menufile_line =~ m/\\\s*?$/)) {
            VerifyLine($pkg, $info, $proc, $group, $type, $menufile, $fullname, $line, $lc);
            $line='';
        }
    } while ($menufile_line = <IN>);
    VerifyLine($pkg, $info, $proc, $group, $type, $menufile, $fullname, $line, $lc);

    close IN;
}

}

# -----------------------------------

# Pass this a line of a menu file, it sanitizes it and
# verifies that it is correct.
sub VerifyLine {
    my ($pkg, $info, $proc, $group, $type, $menufile, $fullname, $line, $linecount) = @_;

    my %vals;

    chomp $line;

    # Replace all line continuation characters with whitespace.
    # (do not remove them completely, because update-menus doesn't)
    $line =~ s/\\\n/ /mgo;

    # This is in here to fix a common mistake: whitespace after a '\'
    # character.
    if ($line =~ s/\\\s+\n/ /mgo) {
        tag 'whitespace-after-continuation-character', "$fullname:$linecount";
    }

    # Ignore lines that are all whitespace or empty.
    return if $line =~ m/^\s*$/o;

    # Ignore lines that are comments.
    return if $line =~ m/^\s*\#/o;

    # Start by testing the package check.
    if (not $line =~ m/^\?package\((.*?)\):/o) {
        tag 'bad-test-in-menu-item', "$fullname:$linecount";
        return;
    }
    my $pkg_test = $1;
    my %tested_packages = map { $_ => 1 } split( /\s*,\s*/, $pkg_test);
    my $tested_packages = scalar keys %tested_packages;
    unless (exists $tested_packages{$pkg}) {
        tag 'pkg-not-in-package-test', "$pkg_test $fullname";
    }
    $line =~ s/^\?package\(.*?\)://;

    # Now collect all the tag=value pairs. I've heavily commented
    # the killer regexp that's responsible.
    #
    # The basic idea here is we start at the beginning of the line.
    # Each loop pulls off one tag=value pair and advances to the next
    # when we have no more matches, there should be no text left on
    # the line - if there is, it's a parse error.
    while ($line =~ m/
           \s*?                 # allow whitespace between pairs
           (                    # capture what follows in $1, it's our tag
            [^\"\s=]            # a non-quote, non-whitespace, character
            *                   # match as many as we can
           )
           =
           (                    # capture what follows in $2, it's our value
            (?:
             \"                 # this is a quoted string
             (?:
              \\.               # any quoted character
              |                 # or
              [^\"]             # a non-quote character
             )
             *                  # repeat as many times as possible
             \"                 # end of the quoted value string
            )
            |                   # the other possibility is a non-quoted string
            (?:
             [^\"\s]            # a non-quote, non-whitespace character
             *                  # match as many times as we can
            )
           )
           /ogcx) {
        my $tag = $1;
        my $value = $2;

        if (exists $vals{$tag}) {
            tag 'duplicated-tag-in-menu-item', "$fullname $1:$linecount";
        }

        # If the value was quoted, remove those quotes.
        if ($value =~ m/^\"(.*)\"$/) {
            $value = $1;
        } else {
            tag 'unquoted-string-in-menu-item', "$fullname $1:$linecount";
        }

        # If the value has escaped characters, remove the
        # escapes.
        $value =~ s/\\(.)/$1/g;

        $vals{$tag} = $value;
    }

    # This is not really a no-op. Note the use of the /c
    # switch - this makes perl keep track of the current
    # search position. Notice, we did it above in the loop,
    # too. (I have a /g here just so the /c takes affect.)
    # We use this below when we look at how far along in the
    # string we matched. So the point of this line is to allow
    # trailing whitespace on the end of a line.
    $line =~ m/\s*/ogc;

    # If that loop didn't match up to end of line, we have a
    # problem..
    if (pos($line) < length($line)) {
        tag 'unparsable-menu-item', "$fullname:$linecount";
        # Give up now, before things just blow up in our face.
        return;
    }

    # Now validate the data in the menu file.

    # Test for important tags.
    foreach my $tag (@req_tags) {
        unless ( exists($vals{$tag}) && defined($vals{$tag}) ) {
            tag 'menu-item-missing-required-tag', "$tag $fullname:$linecount";
            # Just give up right away, if such an essential tag is missing,
            # chance is high the rest doesn't make sense either. And now all
            # following checks can assume those tags to be there
            return;
        }
    }

    # Make sure all tags are known.
    foreach my $tag (keys %vals) {
        if (! $known_tags_hash{$tag}) {
            tag 'menu-item-contains-unknown-tag', "$tag $fullname:$linecount";
        }
    }

    # Sanitize the section tag
    my $section = $vals{'section'};
    $section =~ tr:/:/:s;       # eliminate duplicate slashes. # Hallo emacs ;;
    $section =~ s:/$::;         # remove trailing slash.

    # Be sure the command is provided by the package.
    my ($okay, $command) = VerifyCmd ($fullname, $linecount, $vals{'command'},
                                      $pkg, $info);
    tag 'menu-command-not-in-package', "$fullname:$linecount $command"
        unless ($okay
                or not $command
                or ($tested_packages >= 2)
                or ($section =~ m:^(WindowManagers/Modules|FVWM Modules|Window Maker):));

    if (exists($vals{'icon'})) {
        VerifyIcon($info, $proc, $group, $menufile, $fullname, $linecount, $vals{'icon'}, 32);
    }
    if (exists($vals{'icon32x32'})) {
        VerifyIcon($info, $proc, $group, $menufile, $fullname, $linecount, $vals{'icon32x32'}, 32);
    }
    if (exists($vals{'icon16x16'})) {
        VerifyIcon($info, $proc, $group, $menufile, $fullname, $linecount, $vals{'icon16x16'}, 16);
    }

    # Check the needs tag.
    my $needs = lc($vals{'needs'}); # needs is case insensitive.

    if ($section =~ m:^(WindowManagers/Modules|FVWM Modules|Window Maker):) {
        # WM/Modules: needs must not be the regular ones nor wm
        if ($needs_tag_vals_hash{$needs} or $needs eq 'wm') {
            tag 'non-wm-module-in-wm-modules-menu-section', "$needs $fullname:$linecount";
        }
    } elsif ($section =~ m:^Window ?Managers:) {
        # Other WM sections: needs must be wm
        if ($needs ne 'wm') {
            tag 'non-wm-in-windowmanager-menu-section', "$needs $fullname:$linecount";
        }
    } else {
        # Any other section: just only the general ones
        if ($needs eq 'dwww') {
            tag 'menu-item-needs-dwww', "$fullname:$linecount";
        } elsif (not $needs_tag_vals_hash{$needs}) {
            tag 'menu-item-needs-tag-has-unknown-value', "$needs $fullname:$linecount";
        }
    }

    # Check the section tag
    # Check for historical changes in the section tree.
    if ($section =~ m:^Apps/Games:) {
        tag 'menu-item-uses-apps-games-section', "$fullname:$linecount";
        $section =~ s:^Apps/::;
    }
    if ($section =~ m:^Apps/:) {
        tag 'menu-item-uses-apps-section', "$fullname:$linecount";
        $section =~ s:^Apps/:Applications/:;
    }
    if ($section =~ m:^WindowManagers:) {
        tag 'menu-item-uses-windowmanagers-section', "$fullname:$linecount";
        $section =~ s:^WindowManagers:Window Managers:;
    }

    # Check for Evil new root sections.
    my ($rootsec, $sect) = split m:/:, $section, 2;
    my $root_data = $MENU_SECTIONS->value ($rootsec);
    if (not defined $root_data) {
        if (not $rootsec =~ m/$pkg/i) {
            tag 'menu-item-creates-new-root-section', "$rootsec $fullname:$linecount";
        }
    } else {
        my $ok = 1;
        if ($sect) {
            # Using unknown subsection of $rootsec?
            $ok = 0 if not exists $root_data->{$sect};
        } else {
            # Using root menu when a subsection exists?
            $ok = 0 if %$root_data;
        }
        unless ($ok) {
            tag 'menu-item-creates-new-section', "$vals{section} $fullname:$linecount";
        }
    }
}


sub VerifyIcon {
    my ($info, $proc, $group, $menufile, $fullname, $linecount, $icon, $size) = @_;
    local *IN;

    if ($icon eq 'none') {
        tag 'menu-item-uses-icon-none', "$fullname:$linecount";
        return;
    }

    $icon =~ s|^/*||og;

    if (not ($icon =~ m/\.xpm$/i)) {
        tag 'menu-icon-not-in-xpm-format', $icon;
        return;
    }

    # Try the explicit location, and if that fails, try the standard path.
    my $iconfile = $info->unpacked($icon);
    if (! -f $iconfile) {
        $iconfile = $info->unpacked("/usr/share/pixmaps/$icon");
        if (! -f $iconfile) {
            my $ginfo = $group->info;
            foreach my $depproc (@{ $ginfo->direct_dependencies ($proc) }) {
                my $dinfo = $depproc->info;
                $iconfile = $dinfo->unpacked($icon);
                last if -f $iconfile;
                $iconfile = $info->unpacked("/usr/share/pixmaps/$icon");
                last if -f $iconfile;
            }
        }
    }

    if (! open (IN, '<', $iconfile)) {
        tag 'menu-icon-missing', $icon;
        return;
    }

    my $parse = 'XPM header';
    my $line;
    do { defined ($line = <IN>) or goto parse_error; }
    until ($line =~ /\/\*\s*XPM\s*\*\//);

    $parse = 'size line';
    do { defined ($line = <IN>) or goto parse_error; }
    until ($line =~ /"\s*([0-9]+)\s*([0-9]+)\s*([0-9]+)\s*([0-9]+)\s*"/);
    my $width = $1 + 0;
    my $height = $2 + 0;
    my $numcolours = $3 + 0;
    my $cpp = $4 + 0;

    if ($width > $size || $height > $size) {
        tag 'menu-icon-too-big', "$icon: ${width}x${height} > ${size}x${size}";
    }

    close IN or die;
    return;

parse_error:
    close IN or die;
    tag 'menu-icon-cannot-be-parsed', "$icon: looking for $parse";
    return;
}


# Syntax-checks a .desktop file.
sub VerifyDesktopFile {
    my ($desktopfile, $file, $pkg, $info) = @_;
    my %vals;
    open (DESKTOP, '<', $info->unpacked($file))
        or fail("cannot open desktop file $file: $!");
    my ($line, $saw_first, $warned_cr);
    my @pending;
    while (defined ($line = <DESKTOP>)) {
        chomp $line;
        next if ($line =~ m/^\s*\#/ or $line =~ m/^\s*$/);
        if ($line =~ s/\r//) {
            tag 'desktop-entry-file-has-crs', "$file:$." unless $warned_cr;
            $warned_cr = 1;
        }

        # Err on the side of caution for now.  If the first non-comment line
        # is not the required [Desktop Entry] group, ignore this file.  Also
        # ignore any keys in other groups.
        last if ($saw_first and $line =~ /^\[(.*)\]\s*$/);
        unless ($saw_first) {
            return unless $line =~ /^\[(KDE )?Desktop Entry\]\s*$/;
            $saw_first = 1;
            tag 'desktop-contains-deprecated-header', "$file:$." if ($line =~ /^\[KDE Desktop Entry\]\s*$/);
        }

        # Tag = Value.  For most errors, just add the error to pending rather
        # than warning on it immediately since we want to not warn on tag
        # errors if we didn't know the file type.
        #
        # TODO: We do not check for properly formatted localised values for
        # keys but might be worth checking if they are properly formatted (not
        # their value)
        if ($line =~ /^(.*?)\s*=\s*(.*)$/) {
            my ($tag, $value) = ($1, $2);
            my $basetag = $tag;
            my ($encoding) = ($basetag =~ s/\[([^\]]+)\]$//);
            if (exists $vals{$tag}) {
                tag 'duplicated-key-in-desktop-entry', "$file:$. $tag";
            } elsif ($deprecated_desktop_keys{$basetag}) {
                if ($basetag eq 'Encoding') {
                    push (@pending, [ 'desktop-entry-contains-encoding-key', "$file:$. $tag" ]);
                } else {
                    push (@pending, [ 'desktop-entry-contains-deprecated-key', "$file:$. $tag" ]);
                }
            } elsif (    not $known_desktop_keys{$basetag}
                     and not $kde_desktop_keys{$basetag}
                     and not $basetag =~ /^X-/) {
                push (@pending, [ 'desktop-entry-contains-unknown-key', "$file:$. $tag" ]);
            }
            $vals{$tag} = $value;
        }
    }
    close DESKTOP;

    # Now validate the data in the desktop file, but only if it's a known type.
    return unless ($vals{'Type'} and $known_desktop_types{$vals{'Type'}});

    # Now we can issue any pending tags.
    for my $pending (@pending) {
        tag @$pending;
    }

    # Test for important keys.
    for my $tag (@req_desktop_keys) {
        unless (defined $vals{$tag}) {
            tag 'desktop-entry-missing-required-key', "$file $tag";
        }
    }

    # Only test whether the binary is in the package if the desktop file is
    # directly under /usr/share/applications.  Too many applications use
    # desktop files for other purposes with custom paths.
    #
    # TODO:  Should check quoting and the check special field
    # codes in Exec for desktop files.
    if ($file =~ m,^usr/share/applications/, and $vals{'Exec'} and $vals{'Exec'} =~ /\S/) {
        my ($okay, $command) = VerifyCmd ($file, undef, $vals{'Exec'}, $pkg,
                                          $info);
        tag 'desktop-command-not-in-package', "$file $command"
            unless $okay or $command eq 'kcmshell';
    }

    # Check the Category tag.
    my $in_reserved;
    if (defined $vals{'Categories'}) {
        my @cats = split (';', $vals{'Categories'});
        my $saw_main;
        for my $cat (@cats) {
            next if $cat =~ /^X-/;
            if ($reserved_categories{$cat}) {
                tag 'desktop-entry-uses-reserved-category', "$cat $file"
                    unless $vals{'OnlyShowIn'};
                $saw_main = 1;
                $in_reserved = 1;
            } elsif (not $ADD_CATEGORIES->known ($cat) and not $main_categories{$cat}) {
                tag 'desktop-entry-invalid-category', "$cat $file";
            } elsif ($main_categories{$cat}) {
                $saw_main = 1;
            }
        }
        unless ($saw_main) {
            tag 'desktop-entry-lacks-main-category', $file;
        }
    }

    # Check the OnlyShowIn tag.  If this is not an application in a reserved
    # category, warn about any desktop entry that specifies OnlyShowIn for
    # more than one environment.  In that case, the application probably
    # should be using NotShowIn instead.
    if (defined $vals{OnlyShowIn} and not $in_reserved) {
        my @envs = split (';', $vals{OnlyShowIn});
        if (@envs > 1) {
            tag 'desktop-entry-limited-to-environments', $file;
        }
    }
}

# Verify whether a command is shipped as part of the package.  Takes the full
# path to the file being checked (for error reporting) and the binary.
# Returns a list whose first member is true if the command is present and
# false otherwise, and whose second member is the command (minus any leading
# su-to-root wrapper).  Shared between the desktop and menu code.
sub VerifyCmd {
    my ($file, $line, $exec, $pkg, $info) = @_;
    my $location = ($line ? "$file:$line" : $file);

    # This routine handles su wrappers.  The option parsing here is ugly and
    # dead-simple, but it's hopefully good enough for what will show up in
    # desktop files.  su-to-root and sux require -c options, kdesu optionally
    # allows one, and gksu has the command at the end of its arguments.
    my @com = split (' ', $exec);
    my $cmd;
    if ($com[0] and $com[0] eq '/usr/sbin/su-to-root') {
        tag 'su-to-root-with-usr-sbin', $location;
    }
    if ($com[0] and $com[0] =~ m,^(?:/usr/s?bin/)?(su-to-root|gksu|kdesu|sux)$,) {
        my $wrapper = $1;
        shift @com;
        while (@com) {
            unless ($com[0]) {
                shift @com;
                next;
            }
            if ($com[0] eq '-c') {
                $cmd = $com[1];
                last;
            } elsif ($com[0] =~ /^-[Dfmupi]|^--(user|description|message)/) {
                shift @com;
                shift @com;
            } elsif ($com[0] =~ /^-/) {
                shift @com;
            } else {
                last;
            }
        }
        if (!$cmd && $wrapper =~ /^(gk|kde)su$/) {
            if (@com) {
                $cmd = $com[0];
            } else {
                $cmd = $wrapper;
                undef $wrapper;
            }
        }
        tag 'su-wrapper-without--c', "$location $wrapper" unless $cmd;
        if ($wrapper && $wrapper !~ /su-to-root/ && $wrapper ne $pkg) {
            tag 'su-wrapper-not-su-to-root', "$location $wrapper";
        }
    } else {
        $cmd = $com[0];
    }
    my $cmd_file = $cmd;
    if ($cmd_file) {
        $cmd_file =~ s,^/,,;
    }
    my $okay = $cmd
        && ($cmd =~ /^[\'\"]/
            || $info->index ($cmd_file)
            || $cmd =~ m,^(/bin/)?sh,
            || $cmd =~ m,^(/usr/bin/)?sensible-(pager|editor|browser),
            || grep { $info->index ($_ . $cmd) } @path);
    return ($okay, $cmd_file);
}

1;

# Local Variables:
# indent-tabs-mode: nil
# cperl-indent-level: 4
# End:
# vim: syntax=perl sw=4 sts=4 sr et
