# -*- Mode: Perl -*-
##############################################################################
##
##      $Id: yard_utils.pl,v 1.4 1998/05/27 19:56:50 fawcett Exp $
##      YARD_UTILS.PL -- Utilities for the Yard scripts.
##
##	Tom Fawcett (fawcett@croftj.net)
##	1/25/96
##
##############################################################################
package main;
use strict;
use English;
use File::Basename;
use Cwd;
use yardconfig;

# constant.pm not introduced until 5.003_96, so these are
# just global variables.
# Constants from /usr/src/linux/arch/i386/kernel/setup.c:
$::RAMDISK_IMAGE_START_MASK   =	0x07FF;
$::RAMDISK_PROMPT_FLAG        =	0x8000;
$::RAMDISK_LOAD_FLAG          = 0x4000;

# ioctls from /usr/include/linux/fs.h:
$::BLKGETSIZE_ioctl = 4704;
$::BLKFLSBUF_ioctl  = 4705;

# ext2 fs constants, both in bytes
$::EXT2_BLOCK_SIZE   = 1024;
$::INODE_SIZE        = 1024;

# Get device number of /proc filesystem
my($proc_dev) = (stat("/proc"))[0];

sub info {
  my($level, @msgs) = @_;
  (print @msgs) if $CFG::verbosity >= $level;
  print LOGFILE @msgs;
}

sub error {
  print STDERR "Error: ", @_;
  print LOGFILE "Error: ", @_;
  close(LOGFILE);
  exit(-1);
}

sub start_logging_output {
  my($logfile) = basename($PROGRAM_NAME, ('.pl','.perl')) . ".log";
  if (defined($CFG::yard_temp) and $CFG::yard_temp) {
    $logfile = $CFG::yard_temp . "/$logfile";
  }
  open(LOGFILE, ">$logfile") or die "open($logfile): $!\n";
  print "Logging output to $logfile\n";
}

#####  Same as system() but obeys $CFG::verbosity setting for both STDOUT
#####  and STDERR.
sub sys {
  open(SYS, "@_ 2>&1 |") or die "open on sys(@_) failed: $!";
  while (<SYS>) {
    print LOGFILE;
    print if $CFG::verbosity > 0;
  }
  close(SYS) or die "Command failed: @_\nSee logfile for error message.\n";
  0;				# like system()
}



sub load_mount_info {
  undef %::mounted;
  undef %::fs_type;

  open(MTAB, "</etc/mtab") or die "Can't read /etc/mtab: $!\n";
  while (<MTAB>) {
    my($dev, $mp, $type) = split;
    next if $dev eq 'none';
    $::mounted{$dev} = $mp;
    $::mounted{$mp}  = $dev;
    $::fs_type{$dev} = $type;
  }
  close(MTAB);
}

sub mount_device_if_necessary {
  load_mount_info();

  if (defined($::mounted{$CFG::device})) {

    if ($::mounted{$CFG::device} eq $CFG::mount_point) {
      print "Device $CFG::device already mounted on $CFG::mount_point\n";

    } else {
      print "$CFG::device is mounted (on $::mounted{$CFG::device})\n";
      print "Can't mount it under $CFG::mount_point.\n";
      exit;
    }

  } elsif ($::mounted{$CFG::mount_point} eq $CFG::device) {
    print "Another device (", $::mounted{$CFG::mount_point};
    print ") is already mounted on $CFG::mount_point\n";
    exit;
  }
}


sub must_be_abs {
  my($file) = @_;
  #  Matches / or ./ or ../
  $file =~ m|^\.{0,2}/|
      or info 0, "file $file must be absolute but isn't.\n";
}


#  resolve_file: Resolve a file name.
#  NB. This now resolves relative names WRT config_dest rather than cwd.
sub resolve_file {
  my($file) = @_;

  if ($file =~ m|^/|) {
    $file;			# File is absolute, just return it
  } else {
     "$config_dest/$file";
  }
}

sub sync {
  #  Parts of unix are still a black art
  system("sync") and die "Couldn't sync!";
  system("sync") and die "Couldn't sync!";
}


#  find_file_in_path(file, path)
#  Finds filename in path.  Path defaults to @pathlist if not provided.
#  If file is relative, file is resolved relative to config_dest and lib_dest.
my(@pathlist);
sub find_file_in_path {
  my($file, @path) = @_;

  if (!@path) {
    #####  Initialize @pathlist if necessary
    if (@pathlist == 0) {
      @pathlist = split(':', $ENV{'PATH'});
      if (defined(@CFG::additional_dirs)) {
	unshift(@pathlist, @CFG::additional_dirs);
	###  Changed this to work as documented
	$ENV{"PATH"} = join(":", @CFG::additional_dirs) .
	    ":$ENV{'PATH'}";
      }
      info 1, "Using search path:\n", join(" ", @pathlist), "\n";
    }
    @path = @pathlist;
  }


  if ($file =~ m|/|) {
    #####  file contains a slash; don't search for it.
    resolve_file($file);

  } else {

    #####  Relative filename, search for it
    my($dir);
    foreach $dir (@path, $config_dest, $lib_dest) {
      my($abs_file) = "$dir/$file";
      return $abs_file if -e $abs_file;
    }
    undef;
  }
}

#  Note that this does not verify existence of the returned file.
sub make_link_absolute {
  my($file, $target) = @_;

  if ($target =~ m|^/|) {
    $target;			# Target is absolute, just return it
  } else {
    cleanup_link(dirname($file) . "/$target");
  }
}


sub cleanup_link {
  my($link) = @_;
  # Collapse all occurrences of /./
  1 while $link =~ s|/\./|/|g;
  # Cancel occurrences of /somedir/../
  # Make sure somedir isn't ".."
  1 while $link =~ s|/(?!\.\.)[^/]+/\.\./|/|g;
  $link
}


#  Given an absolute file name and a symlink, make the symlink relative
#  if it's not already.
sub make_link_relative {
  my($abs_file, $link) = @_;
  my($newlink);

  if ($link =~ m|^/(.*)$|) {
    #  It's absolute -- we have to relativize it
    #  The abs_file guaranteed not to have any funny
    #  stuff like "/./" or "/foo/../../bar" already in it.
    $newlink = ("../" x path_length($abs_file)) . $1;

  } else {
    #  Already relative
    $newlink = $link;
  }
  cleanup_link($newlink);
}

#  I don't know if this information is worth caching.
my(%path_length);
sub path_length {
  my($path) = @_;
  return $path_length{$path} if defined($path_length{$path});
  my($length) = -1;
  while ($path =~ m|/|g) { $length++ } # count slashes
  $path_length{$path} = $length;
  $length
}


sub bytes_to_K {
  my($bytes) = @_;
  int($bytes / 1024) + ($bytes % 1024 ? 1 : 0);
}



#  Device capacity in K
sub get_device_size_K  {
  my($device) = @_;
  my($DEV_BSIZE)  = 512;	# Blocksize, from sys/param.h

  my($result) = pack("L", 0);
  open(FD, $device) or die "open($device): $!";
  my($return) = ioctl(FD, $::BLKGETSIZE_ioctl, $result);
  close(FD);
  if ($return) {
    my($bytes) = unpack("L", $result) * $DEV_BSIZE;
    bytes_to_K( $bytes );
  } else {
    warn "Can't get size of $device";
    undef;
  }
}

#####  Thanks to Rick Lyons for this: "If you do a BLKFLSBUF on a device, you
#####  get a sync (via fsync()) as well as an invalidation of all of the
#####  buffers.  That is, anything stored in the buffer cache for that device
#####  is tossed out and any accesses to the device needs to go to the
#####  hardware.  BLKFLSBUF is slightly different for /dev/ram in that no
#####  dirty buffers are written (since there's no corresponding hardware),
#####  and the buffer invalidation causes all of the memory allocated to the
#####  ramdisk to be unlocked and made available for reuse."
sub flush_device_buffer_cache {
  my($device) = @_;
  my($junk) = "stuff";

  open(FD, $device) && ioctl(FD, $::BLKFLSBUF_ioctl, $junk);
  close(FD);
}


#####  This is a kludge but is probably the best way to check for
#####  module support.
sub warn_about_module_dependencies {
  my($version)        = @_;

  if (defined($version)) {

    my($ramdisk_module) = "/lib/modules/$version/block/rd.o";
    my($ext2fs_module)  = "/lib/modules/$version/fs/ext2.o";
    my($floppy_module)  = "/lib/modules/$version/block/floppy.o";

    if (-e $ramdisk_module) {
      info 0, "***** Warning:  Chosen kernel ($version) may have\n",
      "      modular ramdisk support.  ($ramdisk_module exists)\n",
      "      The kernel used for the ",
      " rescue disk must have BUILT-IN ramdisk support.\n";
    }
    if (-e $ext2fs_module) {
      info 0, "***** Warning:  Chosen kernel ($version) may have\n",
      "      modular ext2 fs support.  ($ext2fs_module exists)\n",
      "      The kernel used for the ",
      " rescue disk must have BUILT-IN ext2 fs support.\n";
    }
    if (-e $floppy_module) {
      info 0, "***** Warning:  Chosen kernel ($version) may have\n",
      "      modular floppy support.  ($floppy_module exists)\n",
      "      The kernel used for the ",
      " rescue disk must have BUILT-IN floppy support.\n";
    }
  }
}


#####  This is a hack but there's no system command to return a
#####  (non-running) kernel version.  Returns undef if it can't
#####  determine the version.
# sub kernel_version {
#   my($image)  = @_;

#   my($str)	       = "phlogiston";
#   my($version_start)   = 1164;
#   my($version_length)  = 10;

#   open(DATA, $image) or return(undef);
#   seek(DATA, $version_start, 0);
#   read(DATA, $str, $version_length);
#   close(DATA);
#   ######  Do careful matching in case we got some random string.
#   my($version) = $str =~ /^(\d+\.\d+\.\d+)\s/;
#   $version
# }


# kernel_version supplied by Andreas Degert <ad@papyrus.hamburg.com>.
# This procedure is tested with kernels v2.0.33 and v2.1.103 on i386
# Returns undef if it can't determine the version (or bails out with error)
sub kernel_version {
  my($image)  = @_;

  # check if we have a normal file (-f dereferences symbolic links)
  if (!-f $image) {
    error "Kernel image ($image) is not a plain file.\n";

  } else {
    my($str)	       = "";
    my($version_start) = "";

    open(DATA, $image) or error "can't open $image.\n";
    # check signature of kernel image
    seek(DATA, 514, 0);
    read(DATA, $str, 4);
    error("Kernel image file ($image) does not have Linux kernel signature\n")
	unless $str =~ "HdrS";
    # setup header version should be 0x201
    read(DATA, $str, 2);
    $str = unpack("S",$str);
    if (!($str == 0x201 or $str == 0x202)) {
       info 0, "Kernel setup header version is 0x".
	   sprintf("%04x",$str)." (expected 0x0201 or 0x0202).\n";
    }
    # get ofset of version string (indirect) and read version string
    seek(DATA, 526, 0);
    read(DATA, $version_start, 2) or error "can't read from $image.\n";
    $version_start = unpack("S",$version_start) + 512;
    seek(DATA, $version_start, 0);
    read(DATA, $str, 30) or
      error "can't read from offset $version_start of $image.\n";
    close(DATA);
    #  Extract the version number.
    #  Usually this is something like 2.2.15, but because of kernel packages
    #  it can also be something like 2.2.15-27mdk.  Don't make any assumptions
    #  except that beginning must be dotted triple and it's space delimited.
    my($version) = $str =~ /^(\d+\.\d+\.\d+\S*)\s/;
    $version
  }
}


#####  Eventually move this into configure since it doesn't have to be
#####  done with every make_root_fs.  But yard_glob would have to be
#####  configured, and yard_utils.pl isn't configured.
my($glob_broken);
sub test_glob {
  my($globbed) = join(' ', glob("/*"));
  my($echoed)  = join(' ', `echo /*`);
  chop($echoed);

  if ($globbed ne $echoed) {
    info 0, "\n*****  The glob() function seems to be broken here ",
    "(Perl version $PERL_VERSION)\n",
    "I'll use a slower version that works.\n";
    $glob_broken = 1;
  } else {
    $glob_broken = 0;
  }
}


#####  Check glob() --  In some Perl versions it's reported not to work.
sub yard_glob {
   my($expr) = @_;

   #  Perl's glob() no longer expands environment variables as of 5.6,
   #  so do this explicitly.
   $expr =~ s/\${(\w+)}/$ENV{$1}/g;
   $expr =~ s/\$(\w+)/$ENV{$1}/g;

   if ($glob_broken) {
      my($line) = `echo $expr`;
      chomp($line);
      my(@files) = split(' ', $line);

   } else {
      my(@files) = glob($expr);
      @files;
   }
}


sub mount_device {
  my($options);
  if (-f $CFG::device) {
    $options = "-o loop ";
  } else {
    $options = "";
  }

  sys("mount $options -t ext2 $CFG::device $CFG::mount_point");
}


#####  Called by make_root_fs to do basic checks on choice of $CFG::device.
sub check_device {
  if (!-e $CFG::device) {
    error "Device $CFG::device does not exist\n";

  } elsif (-l $CFG::device) {
    error "$CFG::device is a symbolic link\n",
    "Please provide a real device to avoid confusion.\n";

  } elsif (-f $CFG::device) {
    info 0, "Device $CFG::device is a normal file.\n",
    "Assuming loopback device is being used.\n";

  } elsif (-c $CFG::device) {
    error "\$CFG::device ($CFG::device) is a character special file\n",
    "It must be a block device\n";

  } elsif (-b $CFG::device) {

    if ($CFG::device =~ m|^/dev/[hs]d[abcd]$|) {
      error "You've specified an entire hard disk ($CFG::device) as the device\n",
      "on which to build the root filesystem.\n",
      "Please specify a single partition.\n";
    }
    #####  If we can check device size, make sure it isn't less than
    #####  what's declared.

    my($max) = get_device_size_K($CFG::device);

    if (defined($max)) {
      if ($max < $CFG::fs_size) {
	info 0, "You've declared file system size (fs_size) to be ",
	"$CFG::fs_size K\n",
	"but Linux says $CFG::device may only hold $max K\n";
	if ($CFG::device =~ m|^/dev/ram|) {
	  info 0, "(Increase ramdisk size";
	  (info 0, " in lilo.conf") if -e "/etc/lilo.conf";
	  info 0, ")\n";
	}
	exit;
      }
    } else {
      info 0, "Warning: Yard can't determine the real size of ",
      "$CFG::device.\n",
      "Assuming it's $CFG::fs_size as declared.\n",
      "I hope you're not lying.\n";
    }

  } else {
    error "I have no idea what your \$device ($CFG::device) is!\n",
    "It should either be a block special file (eg, /dev/ram or\n",
    "/dev/hda2) or a plain file for use with a loopback device.\n";
  }
}



#  Copy a file, substituting values for variables in the file.
#  First try using a configuration variable (in CFG package),
#  then issue a warning.
sub copy_file_with_substitution {
  my($from, $to) = @_;

  open(FROM, "<$from") or error "Can't open $from: $!\n";
  open(TO,   ">$to")   or error "$to: $!";

  local($WARNING) = 0;		# Turn off warnings from eval
  while (<FROM>) {
    s/\$(\w+)/(eval("\$CFG::$1")
	       or info 0, "Warning: $1 (in $from) has no known value\n")
	/eg;
    print TO;
  }

  close(FROM);
  close(TO);
}

sub bytes_allocated {
  my($file) = @_;

  my($size) = -s $file;

  if ($size % $::EXT2_BLOCK_SIZE == 0) {
    $size
  } else {
    (int($size / $::EXT2_BLOCK_SIZE) + 1) * $::EXT2_BLOCK_SIZE
  }
}


sub onto_proc_filesystem {
  my($file) = @_;
  my($sdev) = (stat($file))[0];
  return 1 if defined($sdev) and $sdev == $proc_dev;
  my($ldev) = (lstat($file))[0];
  return 1 if defined($ldev) and $ldev == $proc_dev;
  0;
}


1;##### End of yard_utils.pl