# 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::Tags qw(tag);
use Util;

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);

# Authorative source of menu sections:
# http://www.debian.org/doc/packaging-manuals/menu-policy/ch2#s2.1

# This is a list of all valid section on the root menu.
my @root_sections = ('Applications', 'Games', 'Help', 'Screen',
                     'Window Managers', 'FVWM Modules', 'Window Maker');

# This is a list of all valid sections a menu item or submenu can go in.
my @sections = ('Applications/Accessibility',
                'Applications/Amateur Radio',
                'Applications/Data Management',
                'Applications/Editors',
                'Applications/Education',
                'Applications/Emulators',
                'Applications/File Management',
                'Applications/Graphics',
                'Applications/Mobile Devices',
                'Applications/Network/Communication',
                'Applications/Network/File Transfer',
                'Applications/Network/Monitoring',
                'Applications/Network/Web Browsing',
                'Applications/Network/Web News',
                'Applications/Office',
                'Applications/Programming',
                'Applications/Project Management',
                'Applications/Science/Astronomy',
                'Applications/Science/Biology',
                'Applications/Science/Chemistry',
                'Applications/Science/Data Analysis',
                'Applications/Science/Electronics',
                'Applications/Science/Engineering',
                'Applications/Science/Geoscience',
                'Applications/Science/Mathematics',
                'Applications/Science/Medicine',
                'Applications/Science/Physics',
                'Applications/Science/Social',
                'Applications/Shells',
                'Applications/Sound',
                'Applications/System/Administration',
                'Applications/System/Hardware',
                'Applications/System/Language Environment',
                'Applications/System/Monitoring',
                'Applications/System/Package Management',
                'Applications/System/Security',
                'Applications/Terminal Emulators',
                'Applications/Text',
                'Applications/TV and Radio',
                'Applications/Video',
                'Applications/Viewers',
                'Applications/Web Development',
                'Games/Action',
                'Games/Adventure',
                'Games/Blocks',
                'Games/Board',
                'Games/Card',
                'Games/Puzzles',
                'Games/Simulation',
                'Games/Strategy',
                'Games/Tools',
                'Games/Toys',
                'Help',
                'Screen/Saving',
                'Screen/Locking',
                'Window Managers',
                'FVWM Modules',
                'Window Maker'
               );

# 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 %categories = map { $_ => 1 }
    qw(
       Building
       Debugger
       IDE
       GUIDesigner
       Profiling
       RevisionControl
       Translation
       Calendar
       ContactManagement
       Database
       Dictionary
       Chart
       Email
       Finance
       FlowChart
       PDA
       ProjectManagement
       Presentation
       Spreadsheet
       WordProcessor
       2DGraphics
       VectorGraphics
       RasterGraphics
       3DGraphics
       Scanning
       OCR
       Photography
       Publishing
       Viewer
       TextTools
       DesktopSettings
       HardwareSettings
       Printing
       PackageManager
       Dialup
       InstantMessaging
       Chat
       IRCClient
       FileTransfer
       HamRadio
       News
       P2P
       RemoteAccess
       Telephony
       TelephonyTools
       VideoConference
       WebBrowser
       WebDevelopment
       Midi
       Mixer
       Sequencer
       Tuner
       TV
       AudioVideoEditing
       Player
       Recorder
       DiscBurning
       ActionGame
       AdventureGame
       ArcadeGame
       BoardGame
       BlocksGame
       CardGame
       KidsGame
       LogicGame
       RolePlaying
       Simulation
       SportsGame
       StrategyGame
       Art
       Construction
       Music
       Languages
       Science
       ArtificialIntelligence
       Astronomy
       Biology
       Chemistry
       ComputerScience
       DataVisualization
       Economy
       Electricity
       Geography
       Geology
       Geoscience
       History
       ImageProcessing
       Literature
       Math
       NumericalAnalysis
       MedicalSoftware
       Physics
       Robotics
       Sports
       ParallelComputing
       Amusement
       Archiving
       Compression
       Electronics
       Emulator
       Engineering
       FileTools
       FileManager
       TerminalEmulator
       Filesystem
       Monitor
       Security
       Accessibility
       Calculator
       Clock
       TextEditor
       Documentation
       Core
       KDE
       GNOME
       GTK
       Qt
       Motif
       Java
       ConsoleOnly
      );

# 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;
my %root_sections_hash = map { $_ => 1 } @root_sections;
my %sections_hash = map { $_ => 1 } @sections;

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

sub run {

my $pkg = shift;
my $type = shift;
my $info = shift;

my @menufiles;
opendir (MENUDIR, 'menu/lib') or fail('cannot read menu/lib file directory.');
push @menufiles, map { "menu/lib/$_" } readdir(MENUDIR);
closedir MENUDIR;
opendir (MENUDIR, 'menu/share') or fail('cannot read menu/share file directory.');
push @menufiles, map { "menu/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->{type} =~ m/[-h]/ &&
        $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,^menu/lib/,o;

    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, $type, $menufile, $fullname, $line, $lc);
            $line='';
        }
    } while ($menufile_line = <IN>);
    VerifyLine($pkg, $info, $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, $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, $menufile, $fullname, $linecount, $vals{'icon'}, 32);
    }
    if (exists($vals{'icon32x32'})) {
        VerifyIcon($info, $menufile, $fullname, $linecount, $vals{'icon32x32'}, 32);
    }
    if (exists($vals{'icon16x16'})) {
        VerifyIcon($info, $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 ($rootsection) = $section =~ m:([^/]*):;
    if (not $root_sections_hash{$rootsection}) {
        if (not $rootsection =~ m/$pkg/i) {
            tag 'menu-item-creates-new-root-section', "$rootsection $fullname:$linecount";
        }
    } else {
        if (not $sections_hash{$section}) {
            tag 'menu-item-creates-new-section', "$vals{section} $fullname:$linecount";
        }
    }
}


sub VerifyIcon {
    my ($info, $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 (! 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 $categories{$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