#!/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 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\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);
}

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

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

# 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?
    if ($menu_file) {
      # postrm has to call update-menus
      if (not $postrm{'calls-updatemenus'}) {
	print "E: $pkg $type: postrm-does-not-call-updatemenus $menu_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 ($menu_file) {
  # postinst has to call update-menus
  if (not $postinst{'calls-updatemenus'}) {
    print "E: $pkg $type: postinst-does-not-call-updatemenus $menu_file\n";
  }
  # postrm has to call update-menus
  if (not $postrm{'calls-updatemenus'}) {
    print "E: $pkg $type: postrm-does-not-call-updatemenus $menu_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 "error: $_[0]\n";
  } elsif ($!) {
    print STDERR "error: $!\n";
  } else {
    print STDERR "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;
}
