gbootroot/yard_chrooted_tests

#!/usr/bin/perl -w

#############################################################################
##
##  YARD_CHROOT_TEST
##  Code from CHECK_ROOT_FS by Tom Fawcett
##  Copyright (C) 1996,1997,1998  Tom Fawcett (fawcett@croftj.net)
##  Copyright (C) 2000 Modifications by the gBootRoot Team
##
##  This program is free software; you may 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, write to the Free Software
##  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
##
#####
##
##  The purpose of this program is to run chrooted processes separately from
##  gBootRoot so that gBootRoot can continue to operate on "/", not on the 
### chroot "/".
##
##############################################################################

use strict;
use BootRoot::Yard;
use File::Path;
use File::Find;

my $login_binary;
my $mount_point = $ARGV[0];

my %checked;
my $checked_for_getty_files;

which_test();

sub which_test {

    my $test_fstab   = $ARGV[1];
    my $test_inittab = $ARGV[2];
    my $test_scripts = $ARGV[3];

    if ( $test_fstab   == 1 ) {
	print "\nTEST: fstab";
	fork_chroot_and(\&check_fstab);   
    }
    if ( $test_inittab == 1 ) {
	print "\nTEST: inittab";
	fork_chroot_and(\&check_inittab); 
    }
    if ( $test_scripts == 1 ) {
	print "\nTEST: scripts";
	fork_chroot_and(\&check_scripts);
    }
} # end sub which_test

#  This takes a procedure call, forks off a subprocess, chroots to
#  $mount_point and runs the procedure.
sub fork_chroot_and {
   my($call) = @_;

   my($Godot) = fork;

   unless (defined $Godot) {
 
      die "Can't fork: $!"; 
   }

   if (!$Godot) {
      # Child process
      chdir($mount_point);
      chroot($mount_point); #####  chroot to the root filesystem
      &$call;
      exit;
   } else {
      # Parent here
      waitpid($Godot, 0);
   }
}

sub check_fstab {
  my($FSTAB) = "/etc/fstab";
  my($proc_seen);


  open(FSTAB, "<$FSTAB") or error_test ("$FSTAB: $!");
  if (-z $FSTAB) {
      error_test ("fstab is an empty file");
  }
  print "\nChecking $FSTAB\n";

  while (<FSTAB>) {
      chomp;
      next if /^\#/ or /^\s*$/;

      my($dev, $mp, $type, $opts) = split;
      next if $mp eq 'none' or $type eq 'swap';
      next if $dev eq 'none';

      if (!-e $mp) {
	  print "$FSTAB($.): $_\n\tCreating $mp on root filesystem\n";
	  mkpath($mp);
      }

      if ($dev !~ /:/ and !-e $dev) {
	  warning("$FSTAB($.): $_\n\tDevice $dev does not exist "
	      . "on root filesystem\n");
      }

      #####  If you use the file created by create_fstab, these tests
      #####  are superfluous.

      if ($dev =~ m|^/dev/hd| and $opts !~ /noauto/) {
	  warning("\t($.):  You probably should include \"noauto\" option\n",
	  "\tin the fstab entry of a hard disk.  When the rescue floppy\n",
	  "\tboots, the \"mount -a\" will try to mount $dev\n");

      } elsif ($dev eq $::floppy and $type ne 'ext2' and $type ne 'auto') {
	  warning("\t($.): You've declared your floppy drive $::floppy",
	       " to hold\n",
	       "\ta $type filesystem, which is not ext2.  The rescue floppy\n",
	       "\tis ext2, which may confuse 'mount -a' during boot.\n");

      } elsif ($type eq 'proc') {
	  $proc_seen = 1;

      }
  }
  close(FSTAB);
  warning("\tNo /proc filesystem defined.\n") unless $proc_seen;
  print "Done with $FSTAB\n";
}


sub check_inittab {
  my($INITTAB) =  "/etc/inittab";
  print "\nChecking $INITTAB\n";

  if (!open(INITTAB, "<$INITTAB")) {
     warning("$INITTAB: $!\n");
     return
  }
  if (-z $INITTAB) {
      error_test ("fstab is an empty file");
  }

  my($default_rl, $saw_line_for_default_rl);

  while (<INITTAB>) {
    chomp;
    my($line) = $_;		# Copy for errors
    s/\#.*$//;			# Delete comments
    next if /^\s*$/;		# Skip empty lines

    my($code, $runlevels, $action, $command) = split(':');

    if ($action eq 'initdefault') { #####   The initdefault runlevel
      $default_rl = $runlevels;
      next;
    }
    if ($runlevels =~ /$default_rl/) {
      $saw_line_for_default_rl = 1;
    }
    if ($command) {
      my($exec, @args) = split(' ', $command);

      if (!-f $exec) {
	warning("$INITTAB($.): $line\n",
		"\t$exec: non-existent or non-executable\n");

      } elsif (!-x $exec) {
	  print "$INITTAB($.): $line\n";
	print "\tMaking $exec executable\n";
	chmod(0777, $exec) or error_test("chmod failed: $!");

      } else {
	#####  executable but not binary ==> script
	scan_command_file($exec, @args) if !-B $exec;
      }

      if ($exec =~ m|getty|) {	# matches *getty* call
	check_getty_type_call($exec, @args);
      }
    }
  }
  close(INITTAB) or error_test("close(INITTAB): $!");

  if (!$saw_line_for_default_rl) {
    warning("\tDefault runlevel is $default_rl, but no entry for it.\n");
  }
  print "Done with $INITTAB\n";
}

sub check_scripts {
  print "\nChecking script interpreters\n";
  local($::prog);

  sub check_interpreter {
    if (-x $File::Find::name and -f _ and -T _) {
      open(SCRIPT, $File::Find::name)		or error_test("$File::Find::name: $!");
      my($prog, $firstline);

      chomp($firstline = <SCRIPT>);
      if (($prog) = $firstline =~ /^\#!\s*(\S+)/) {
	if (!-e $prog) {
	  warning("Warning: \$File::Find::name needs $prog which is missing\n");
	} elsif (!-x $prog) {
	  warning("Warning: \$File::Find::name needs $prog, " .
	      "which is not executable.\n");
	}
      }
      close(SCRIPT);
    }
  }				# End of sub check_interpreter

  find(\&check_interpreter, "/");
}

#####  This could be made much more complete, but for typical rc type
#####  files it seems to catch the common problems.
sub scan_command_file {
  my($cmdfile, @args) = @_;
  my(%warned, $line);

  return if $checked{$cmdfile};
  print "\nScanning $cmdfile\n";
  open(CMDFILE, "<$cmdfile")			or error "$cmdfile: $!";

  while ($line = <CMDFILE>) {
    chomp($line);
    next if $line =~ /^\#/ or /^\s*$/;

    next if $line =~ /^\w+=/;

    while ($line =~ m!(/(usr|var|bin|sbin|etc|dev)/\S+)(\s|$)!g) {
	my($abs_file) = $1;
	# next if $abs_file =~ m/[*?]/; # Skip meta chars - we don't trust glob
	next if $warned{$abs_file}; # Only warn once per file
	if (!-e $abs_file) {
	    warning ("$cmdfile($.): $line\n\t$1: missing on root filesystem\n");
	    $warned{$abs_file} = 1;
	}
    }
  }
  close(CMDFILE)				or error "close($cmdfile): $!";

  $checked{$cmdfile} = 1;
  print "Done scanning $cmdfile\n";

} # end sub scan_command_file

sub check_getty_type_call {
  my($prog, @args) = @_;

  if ($prog eq 'getty') {
    my($tty, $speed, $type) = @args;

    if (!-e "$mount_point/dev/$tty") {
      warning ("\tLine $.: $prog for $tty, but /dev/$tty doesn't exist.\n");
    }
    ##if (!defined($Termcap{$type})) {
    ##  warning ("\tLine $.: Type $type not defined in termcap\n");
    ##}
  }
  ##  If getty or getty_ps, look for /etc/gettydefs, /etc/issue
  ##  Check that term type matches one in termcap db.

  if ($prog =~ /^getty/) {
    if (!$checked_for_getty_files) {
      warning ("\tLine $.: $prog expects /etc/gettydefs, which is missing.\n")
	unless -e "$mount_point/etc/gettydefs";
      warning ("\tLine $.: $prog expects /etc/issue, which is missing.\n")
	unless -e "$mount_point/etc/issue";
      $checked_for_getty_files = 1;
    }
  }

} # end sub check_getty_type_call

sub warning {
    print "\n", @_;                                                   
} 

sub error_test {
  print STDERR "\nError: ", @_, "\n";                             
  exit(-1);                                              
}