#!/usr/bin/perl
# menu format -- lintian check script

# 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., 59 Temple Place - Suite 330, Boston,
# MA 02111-1307, USA.


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

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

# This is a list of all known uses of the needs= tag.
# (It's case insensitive, use lower case here.).
@needs_tag_vals=qw(x11 text vc fvwmmodule fvwm2module fvwm95module
fvwmother wm dwww wmaker);

# This is a list of all valid section on the root menu.
@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.
@sections=qw(
	Apps/Databases
	Apps/Editors
	Apps/Emulators
	Apps/Graphics
	Apps/Hamradio
	Apps/Math
	Apps/Net
	Apps/Programming
	Apps/Technical
	Apps/Tools
	Apps/Text
	Apps/Shells
	Apps/Sound
	Apps/Viewers
	Apps/System
	Games/Adventure
	Games/Arcade
	Games/Board
	Games/Card
	Games/Puzzles
	Games/Sports
	Games/Strategy
	Games/Tetris-like
	Games/Toys
	Help
	Screen/Lock
	Screen/Save
	Screen/Root-window
	WindowManagers
	WindowManagers/Modules
	XShells
);

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

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

($#ARGV == 1) or fail("syntax: menu-format <pkg> <type>");
$pkg = shift;
$type = shift;

opendir (MENUDIR,"menu/") or fail("cannot read menu file directory.");
while ($menufile = readdir(MENUDIR)) {
  next if -x "menu/$menufile"; # don't try to parse executables
  next if $menufile eq "README"; # README is a special case

  open (IN,"menu/$menufile") or fail("cannot open menu file $menufile for reading.");
  do { $_=<IN>; } while defined && (/^\s*#/ || /^\s*$/);

  # Check first line of file to see if it matches the old menu file format.
  if (/^(?!\?package\(.*\)).* .* .* .* "?.*"? .*$/o) {
    print "E: $pkg $type: old-format-menu-file /usr/lib/menu/$menufile\n";
  }
  else {
    # Parse entire file as a new format menu file.
    my $line="";
    my $lc=0;
    do {
    	$lc++;
	
        # Ignore lines that are comments.
	if (! /^#/o) {
	    	$line.=$_;
		# Note that I allow whitespace after the continuation character.
		# This is caught by VerifyLine().
    		if (! m/\\\s*?$/) {
			VerifyLine($line,$lc);
			$line="";

		}
    	}
    } while (<IN>);
    VerifyLine($line);
  }

  close IN;
}
closedir MENUDIR;

exit 0;

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

sub fail {
  if ($_[0]) {
    print STDERR "internal error: $_[0]\n";
  } elsif ($!) {
    print STDERR "internal error: $!\n";
  } else {
    print STDERR "internal error.\n";
  }
  exit 1;
}

# Pass this a line of a menu file, it sanitizes it and
# verifies that it is correct.
sub VerifyLine { my $line=shift; my $linecount=shift;
#	my %vals=undef;
	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) {
		print "E: $pkg $type: whitespace-after-continuation-character /usr/lib/menu/$menufile:$linecount\n";
	}
	
	# 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 ($line=~m/^\?package\((.*?)\):/o) {
		if ($1 ne $pkg) {
			print "E: $pkg $type: incorrect-package-test $1 /usr/lib/menu/$menufile\n";
		}
		$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 avdances 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 possability is a non-quoted string
			 (?:
			  [^"\s]# a non-quote, non-whitespace character
			  *	# match as many times as we can
			 )
			)
			/ogcx) {
			$tag=$1;
			$value=$2;
			
			if ($vals{$tag} ne undef) {
				print "W: duplicated-tag-in-menu-item /usr/lib/menu/$menufile $1:$linecount\n";
			}

			# If the value was quoted, remove those quotes.
			if ($value=~m/^"(.*)"$/) {
				$value=$1;
			}
			
			# 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)) {
			print "E: $pkg $type: unparsable-menu-item /usr/lib/menu/$menufile:$linecount\n";
			# 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 $tag (@req_tags) {
			if ($vals{$tag} eq undef) {
				print "W: $pkg $type: menu-item-missing-important-tag $tag /usr/lib/menu/$menufile:$linecount\n";
			}
		}
		
		# Make sure all tags are known.
		foreach $tag (keys %vals) {
			if (! $known_tags_hash{$tag}) {
				print "W: $pkg $type: menu-item-contains-unknown-tag $tag /usr/lib/menu/$menufile:$linecount\n";
			}
		}
		
		# Check for icon=none.
		if ($vals{icon} eq 'none') {
			print "W: $pkg $type: menu-item-uses-icon-none /usr/lib/menu/$menufile:$linecount\n";
		}
		
		# Check the needs tag.
		if (! $needs_tag_vals_hash{lc($vals{needs})}) {
			print "W: $pkg $type: menu-item-needs-tag-has-unknown-value $vals{needs} /usr/lib/menu/$menufile:$linecount\n";
                        last; # don't check section tag for weird needs values.
		}

		# Check the section tag.
		my $section=$vals{section};
		$section=~tr:/:/:s; # eliminate duplicate slashes.
		$section=~s:/$::; # remove trailing slash.
		
		# If the section tag does not exist then the item will go
		# right in the root menu, which is just Evil.
		if ($section eq undef) {
			print "E: $pkg $type: menu-item-adds-to-root-menu /usr/lib/menu/$menufile:$linecount\n";
		}
		else {
			# Check for historical changes in the section tree.
			if ($section=~m:^Apps/Games:) {
				print "W: $pkg $type: menu-item-uses-apps-games-section /usr/lib/menu/$menufile:$linecount\n";
				$section=~s:^Apps/::;
			}

			# Check for Evil new root sections.
			my ($rootsection)=$section=~m:([^/]*):;
			if (! $root_sections_hash{$rootsection}) {
				print "E: $pkg $type: menu-item-creates-new-root-section $rootsection /usr/lib/menu/$menufile:$linecount\n";
			}
			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) {
					print "W: $pkg $type: menu-item-creates-new-section $vals{section} /usr/lib/menu/$menufile:$linecount\n";
				}
			}
		}
	}
	else {
		print "E: $pkg $type: bad-test-in-menu-item /usr/lib/menu/$menufile:$linecount\n";
		return;
	}
}
