# 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.

package Lintian::menu_format;
use strict;
use Tags;
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 WindowManagers context
# (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=qw(Apps Games Screen WindowManagers XShells Help);

# This is a list of all valid sections a menu item or submenu can go in.
# Note: toplevel sections that are by letter of policy allowed ('Apps',
# 'Games' and 'Screen') are not included anyway, as their use is discouraged.
my @sections=qw(
		Apps/Databases
		Apps/Editors
		Apps/Education
		Apps/Emulators
		Apps/Graphics
		Apps/Hamradio
		Apps/Math
		Apps/Net
		Apps/Programming
		Apps/Science
		Apps/Tools
		Apps/Technical
		Apps/Text
		Apps/Shells
		Apps/Sound
		Apps/Viewers
		Apps/System
		Games/Adventure
		Games/Arcade
		Games/Board
		Games/Card
		Games/Puzzles
		Games/Simulation
		Games/Sports
		Games/Strategy
		Games/Tetris-like
		Games/Toys
		Help
		Screen/Lock
		Screen/Save
		Screen/Root-window
		WindowManagers
		WindowManagers/Modules
		XShells
	       );

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

my %known_tags_hash;
my %needs_tag_vals_hash;
my %root_sections_hash;
my %sections_hash;

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

sub run {

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

# Things worth hashing.
foreach my $tag (@known_tags) {
    $known_tags_hash{$tag}=1;
}
foreach my $val (@needs_tag_vals) {
    $needs_tag_vals_hash{$val}=1;
}
foreach my $section (@root_sections) {
    $root_sections_hash{$section}=1;
}
foreach my $section (@sections) {
    $sections_hash{$section}=1;
}

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;

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

    # 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,$type,$menufile,$fullname,$line,$lc);
	    $line="";
	}
    } while ($menufile_line = <IN>);
    VerifyLine($pkg,$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, $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 or ! $line;

    # 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.
    $section =~ s:/$::;		# remove trailing slash.
	
    # Read the file index:
    my %file_index;
    open(FILE_INDEX,"index") or fail("cannot open index file index: $!");
    while(<FILE_INDEX>) {
	$file_index{(split /\s+/, $_)[5]} = 1;
    }
    close FILE_INDEX;

    # Handle su wrappers.  The option parsing here is ugly and dead-simple,
    # but it's hopefully good enough for what will show up in menu 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(' ',$vals{'command'});
    my $cmd;
    if ($com[0] eq "/usr/sbin/su-to-root") {
	tag "su-to-root-with-usr-sbin", "$fullname:$linecount";
    } elsif ($com[0] =~ m,^(?:/usr/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$/) {
	    $cmd = $com[0];
	} elsif (!$cmd) {
	    tag "su-wrapper-without--c", "$fullname:$linecount $wrapper";
	}
    } else {
	$cmd = $com[0];
    }
    tag "menu-command-not-in-package", "$fullname:$linecount $cmd"
	if ($cmd
	    && !($file_index{".$cmd"} || grep {$file_index{".".$_.$cmd}} @path)
	    && ($tested_packages < 2)
	    && ($section !~ m:^WindowManagers/Modules:));

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

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

    if ($section =~ m:^WindowManagers/Modules:) {
	# 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:^WindowManagers:) {
	# 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/::;
	}

	# 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 {
	    # Check to see if the section is valid.
	    # It's ok to subdivide existing sections,
	    # the section just has to be rooted at
	    # a valid section.
	    my $s = undef;
	    my $ok = undef;
	    foreach (split(m:/:, $section)) {
		$s .= "/" if $s;
		$s .= $_;
		if ($sections_hash{$s}) {
		    $ok = 1;
		    last;
		}
	    }
	    if (! $ok) {
		tag "menu-item-creates-new-section", "$vals{section} $fullname:$linecount";
	    }
	}
}


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

    if ($icon eq 'none') {
	tag "menu-item-uses-icon-none", "$fullname:$linecount";
	return;
    }
    
    if (not ($icon =~ m/\.xpm$/i)) {
	tag "menu-icon-not-in-xpm-format", "$icon";
	return;
    }

    # try the explicit location, but if not, try one of the standard paths
    my $iconfile = "unpacked/$icon";
    if (! -f $iconfile) {
	$iconfile = "unpacked/usr/X11R6/include/X11/pixmaps/$icon";
    }
    if (! -f $iconfile) {
	$iconfile = "unpacked/usr/X11R6/include/X11/bitmaps/$icon";
    }
    if (! -f $iconfile) {
	$iconfile = "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;
}

1;

# vim: syntax=perl ts=8 sw=4