#!/usr/bin/perl
# menus -- lintian check script

# Copyright (C) 1998 by Christian Schwarz
# 
# 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.

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

sub check_script {
  my ($script,$pres) = @_;

  my ($no_check_menu,$no_check_installdocs);
  open(IN,"control/$script") or fail("cannot open maintainer script control/$script for reading: $!");
  while (<IN>) {
    # skip comments
    s/\#.*$//o;

    # does the script check whether update-menus exists?
    if (s/-x\s+\S*update-menus//o or /which\s+update-menus/o or s/command\s+-v.*?update-menus//o) {
      # yes, it does.
      $pres->{'checks-for-updatemenus'} = 1;
    }

    # does the script call update-menus?
    if (/update-menus/) {
      # yes, it does.
      $pres->{'calls-updatemenus'} = 1;

      # checked first?
      if (not $pres->{'checks-for-updatemenus'} and $pkg ne 'menu') {
	print "E: $pkg $type: maintainer-script-does-not-check-for-existence-of-updatemenus $script:$.\n" unless $no_check_menu++;
      }
    }

    # does the script set a link in /usr/doc?
	if (m,ln\s+(-\w+)?\s+\"?\.\./share/doc/\S+, ) 
	{ 	# yes, it does.
    	$pres->{'sets-link'} = 1;
	}	

    # does the script remove a link in /usr/doc?
	if (m,rm\s+(-\w+)?\s+\"?/usr/doc/\S+, ) 
	{ 	# yes, it does.
    	$pres->{'removes-link'} = 1;
	}	

    # does the script check whether install-docs exists?
    if (s/-x\s+\S*install-docs//o or /which\s+install-docs/o or s/command\s+-v.*?install-docs//o) {
      # yes, it does.
      $pres->{'checks-for-installdocs'} = 1;
    }

    # does the script call install-docs?
    if (/install-docs/o) {
      # yes, it does.  Does it remove or add a doc?
      if (/install-docs\s+(-r|--remove)\b/) {
	$pres->{'calls-installdocs-r'} = 1;
      } else {
	$pres->{'calls-installdocs'} = 1;
      }
      # checked first?
      if (not $pres->{'checks-for-installdocs'}) {
	print "E: $pkg $type: maintainer-script-does-not-check-for-existence-of-installdocs $script\n" unless $no_check_installdocs++;
      }
    }
  }
}

# check preinst script
if ( -f "control/preinst" ) {
  # parse script...
  check_script("preinst",\%preinst);

  # preinst scripts should not call either update-menus nor installdocs
  if ($preinst{'calls-updatemenus'}) {
    print "E: $pkg $type: preinst-calls-updatemenus\n";
  }
  if ($preinst{'calls-installdocs'}) {
    print "E: $pkg $type: preinst-calls-installdocs\n";
  }
}

# check postinst script
if ( -f "control/postinst" ) {
  # parse script...
  check_script("postinst",\%postinst);
}
#had better set the /usr/doc link
if (!$postinst{'sets-link'}) 
	{ print "W: $pkg $type: postinst-does-not-set-usr-doc-link\n"; }

# check prerm script
if ( -f "control/prerm" ) {
  # parse script...
  check_script("prerm",\%prerm);

  # prerm scripts should not call update-menus
  if ($prerm{'calls-updatemenus'}) {
    print "E: $pkg $type: prerm-calls-updatemenus\n";
  }
}
# prerm scripts should rm /usr/doc directories
if (!$prerm{ 'removes-link'}) 
	{ print "W: $pkg $type: prerm-does-not-remove-usr-doc-link\n"; }

# check postrm script
if ( -f "control/postrm" ) {
  # parse script...
  check_script("postrm",\%postrm);

  # postrm scripts should not call install-docs
  if ($postrm{'calls-installdocs'} or $postrm{'calls-installdocs-r'}) {
    print "E: $pkg $type: postrm-calls-installdocs\n";
  }
}

# read package contents
open(IN,"index") or fail("cannot open index file index: $!");
while (<IN>) 
{ 	chop;
  	my ($perm,$owner,$size,$date,$time,$file) = split(' ', $_, 6);
  	$file =~ s,^(\./),,;
  	$file =~ s/ link to .*//;
  	$file =~ s/ -> .*//;

  	my $operm = perm2oct($perm);

  	# menu file?
  	if ($file =~ m,^usr/lib/menu/\S,o) 
	{ 	# correct permissions?
    	if (($perm =~ m,^-,o) and ($perm =~ m,x,o)) 
		{ printf "E: $pkg $type: executable-in-usr-lib-menu $file %04o\n",$operm; }

    	next if $file eq 'usr/lib/menu/README';

    	$menu_file = $file;

    	if ($file eq 'usr/lib/menu/menu' and $pkg ne 'menu') 
		{ printf "E: $pkg $type: bad-menu-file-name $file\n"; }
	}
  	# doc-base file?
  	elsif ($file =~ m,^usr/share/doc-base/\S,o) 
	{ 	# correct permissions?
    	if (($perm =~ m,^-,o) and ($perm =~ m,x,o)) 
		{ printf "E: $pkg $type: executable-in-usr-share-docbase $file %04o\n",$operm; }

    	$docbase_file = $file;
  	}
	#menu-methods file?
	elsif ( $file =~ m,^etc/menu-methods/\S,o )
	{	#correct permissions?  (skipped for menu package)
		if ( $pkg ne 'menu' )
		{	if( ($perm =~ m,^-,o) and ($perm !~ m,x,o) )
			{ printf "E: $pkg $type: non-executable-in-etc-menu-methods $file %04o\n", $operm; }
		}

		$menumethod_file = $file;
	}
}

$anymenu_file = $menu_file || $menumethod_file;

# check consistency
# docbase file?
if ($docbase_file) 
{	# postinst has to call install-docs
  	if (not $postinst{'calls-installdocs'}) 
	{ print "E: $pkg $type: postinst-does-not-call-installdocs $docbase_file\n"; }
  	# prerm has to call install-docs -r
  	if (not $prerm{'calls-installdocs-r'}) 
	{ print "E: $pkg $type: prerm-does-not-call-installdocs $docbase_file\n"; }

  	# does postinst also call update-menus?
  	if ($postinst{'calls-updatemenus'}) 
	{ 	# is there a menu file or menu-methods files?
    	if ($anymenu_file) 
		{ 	# postrm has to call update-menus
      		if (not $postrm{'calls-updatemenus'}) 
			{ 	print "E: $pkg $type: postrm-does-not-call-updatemenus $anymenu_file\n" 
				unless $pkg eq 'menu';
      		}
    	} else #no!
		{ print "W: $pkg $type: postinst-has-useless-call-to-update-menus\n"; }
  	}
}
# no docbase file, but menu file?
elsif ($anymenu_file) 
{ 	# postinst has to call update-menus
  	if (not $postinst{'calls-updatemenus'}) 
	{ print "E: $pkg $type: postinst-does-not-call-updatemenus $anymenu_file\n"; }
  	# postrm has to call update-menus
  	if (not $postrm{'calls-updatemenus'}) 
	{ print "E: $pkg $type: postrm-does-not-call-updatemenus $anymenu_file\n"; }
}
# no menu files and no doc-base files...
else {
  # postinst and postrm should not need to call update-menus
  if ($postinst{'calls-updatemenus'}) {
    print "W: $pkg $type: postinst-has-useless-call-to-update-menus\n";
  }
  if ($postinst{'calls-installdocs'} or $postinst{'calls-installdocs-r'}) {
    print "E: $pkg $type: postinst-has-useless-call-to-install-docs\n";
  }
  if ($postrm{'calls-updatemenus'}) {
    print "W: $pkg $type: postrm-has-useless-call-to-update-menus\n";
  }
  if ($postrm{'calls-installdocs'} or $postrm{'calls-installdocs-r'}) {
    print "E: $pkg $type: postrm-has-useless-call-to-install-docs\n";
  }
}

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

# translate permission strings like `-rwxrwxrwx' into an octal number
sub perm2oct {
  my ($t) = @_;

  my $o = 0;

  $t =~ /^.(.)(.)(.)(.)(.)(.)(.)(.)(.)/o;
  
  $o += 04000 if $3 eq 's'; # set-uid
  $o += 02000 if $6 eq 's'; # set-gid
  $o += 01000 if $9 eq 't'; # sticky bit
  $o += 00400 if $1 ne '-'; # owner read
  $o += 00200 if $2 ne '-'; # owner write
  $o += 00100 if $3 ne '-'; # owner execute
  $o += 00040 if $4 ne '-'; # owner read
  $o += 00020 if $5 ne '-'; # owner write
  $o += 00010 if $6 ne '-'; # owner execute
  $o += 00004 if $7 ne '-'; # owner read
  $o += 00002 if $8 ne '-'; # owner write
  $o += 00001 if $9 ne '-'; # owner execute

  return $o;
}
