#!/usr/bin/perl -w
# If your copy of perl is not in /usr/bin, please adjust the line above.
#
# Copyright 1998 VMware, Inc.  All rights reserved.
#
# Host configurator for VMware

use strict;

# Use Config module to update VMware host-wide configuration file
# BEGINNING_OF_CONFIG_DOT_PM
# END_OF_CONFIG_DOT_PM

# Constants
my $cKernelModuleDir = '/lib/modules';
my $cTmpDirPrefix = 'vmware-config';
my $cVmnixVersion = '@@VMNIXVERSION@@';
my $cConnectSocketDir = '/var/run/vmware';
my $machine = 'host';
my $os = 'host';
if (vmware_product() eq 'server') {
  $machine = 'machine';
  $os = "Console OS";
}
my $cServices = '/etc/services';
my $cMarkerBegin = "# Beginning of the block added by the VMware software\n";
my $cMarkerEnd = "# End of the block added by the VMware software\n";

my $cConfiguratorFileName = 'vmware-config.pl';

if (vmware_product() eq 'tools-for-linux') {
  $cConfiguratorFileName = 'vmware-config-tools.pl';
}

my $cModulesBuildEnv = ' you can install the driver by running '
                       . $cConfiguratorFileName
                       . ' again after making sure that gcc, binutils, make '
                       . 'and the kernel sources for your running kernel are '
                       . 'installed on your machine. These packages are '
                       . 'available on your distribution\'s installation CD.';

#
# Global variables
#
my $gRegistryDir;
my $gInstallerMainDB;
my $gConfFlag;
my %gSystem;
my %gHelper;
# List of all ethernet adapters on the system
my @gAllEthIf;
# List of ethernet adapters that have not been bridged
my @gAvailEthIf;
# By convention, vmnet1 is the virtual ethernet interface connected to the
# private virtual network that Samba uses.  We are also reserving vmnet0
# for bridged networks.  These are reserved vmnets.
my $gDefBridged = '0';
my $gDefHostOnly = '1';
my $gDefNat = '8';
# Reserved vmnets
my @gReservedVmnet = ($gDefBridged, $gDefHostOnly, $gDefNat);
# Constant defined as the smallest vmnet that is allowed
my $gMinVmnet = '0';
# Linux doesn't allow more than 7 characters in the names of network
# interfaces. We prefix host only interfaces with 'vmnet' leaving us only 2
# characters.
# Constant defined as the largest vmnet that is allowed
my $gMaxVmnet = '99';
# Constant defines as the number of vmnets to be pre-created
my $gNumVmnet = 10;
my $gFirstModuleBuild;
my $gDefaultAuthdPort = 902;

# BEGINNING OF THE SECOND LIBRARY FUNCTIONS
# Global variables
my %gDBAnswer;
my %gDBFile;
my %gDBDir;
my $cBackupExtension = '.BeforeVMwareToolsInstall';
my $cRestorePrefix = 'RESTORE_';
my $cRestoreBackupSuffix = '_BAK';
my $cRestoreBackList = 'RESTORE_BACK_LIST';
my $cSwitchedToHost = 'SWITCHED_TO_HOST';
my $cX4MouseDriverFile = '/usr/X11R6/lib/modules/input/vmmouse_drv.o';

# Load the installer database
sub db_load {
  undef %gDBAnswer;
  undef %gDBFile;
  undef %gDBDir;

  if (not open(INSTALLDB, '<' . $gInstallerMainDB)) {
    error('Unable to open the installer database ' . $gInstallerMainDB
          . ' in read-mode.' . "\n\n");
  }
  while (<INSTALLDB>) {
    chomp;
    if (/^answer (\S+) (.+)$/) {
      $gDBAnswer{$1} = $2;
    } elsif (/^answer (\S+)/) {
      $gDBAnswer{$1} = '';
    } elsif (/^remove_answer (\S+)/) {
      delete $gDBAnswer{$1};
    } elsif (/^file (.+) (\d+)$/) {
      $gDBFile{$1} = $2;
    } elsif (/^file (.+)$/) {
      $gDBFile{$1} = 0;
    } elsif (/^remove_file (.+)$/) {
      delete $gDBFile{$1};
    } elsif (/^directory (.+)$/) {
      $gDBDir{$1} = '';
    } elsif (/^remove_directory (.+)$/) {
      delete $gDBDir{$1};
    }
  }
  close(INSTALLDB);
}

# Open the database on disk in append mode
sub db_append {
  if (not open(INSTALLDB, '>>' . $gInstallerMainDB)) {
    error('Unable to open the installer database ' . $gInstallerMainDB
          . ' in append-mode.' . "\n\n");
  }
  # Force a flush after every write operation.
  # See 'Programming Perl', p. 110
  select((select(INSTALLDB), $| = 1)[0]);
}

# Add a file to the tar installer database
# flags:
#  0x1 write time stamp
sub db_add_file {
  my $file = shift;
  my $flags = shift;

  if ($flags & 0x1) {
    my @statbuf;

    @statbuf = stat($file);
    if (not (defined($statbuf[9]))) {
      error('Unable to get the last modification timestamp of the destination '
            . 'file ' . $file . '.' . "\n\n");
    }

    $gDBFile{$file} = $statbuf[9];
    print INSTALLDB 'file ' . $file . ' ' . $statbuf[9] . "\n";
  } else {
    $gDBFile{$file} = 0;
    print INSTALLDB 'file ' . $file . "\n";
  }
}

# Remove a file from the tar installer database
sub db_remove_file {
  my $file = shift;

  print INSTALLDB 'remove_file ' . $file . "\n";
  delete $gDBFile{$file};
}

# Remove a directory from the tar installer database
sub db_remove_dir {
  my $dir = shift;

  print INSTALLDB 'remove_directory ' . $dir . "\n";
  delete $gDBDir{$dir};
}

# Determine if a file belongs to the tar installer database
sub db_file_in {
  my $file = shift;

  return defined($gDBFile{$file});
}

# Determine if a directory belongs to the tar installer database
sub db_dir_in {
  my $dir = shift;

  return defined($gDBDir{$dir});
}

# Return the timestamp of an installed file
sub db_file_ts {
  my $file = shift;

  return $gDBFile{$file};
}

# Add a directory to the tar installer database
sub db_add_dir {
  my $dir = shift;

  $gDBDir{$dir} = '';
  print INSTALLDB 'directory ' . $dir . "\n";
}

# Remove an answer from the tar installer database
sub db_remove_answer {
  my $id = shift;

  if (defined($gDBAnswer{$id})) {
    print INSTALLDB 'remove_answer ' . $id . "\n";
    delete $gDBAnswer{$id};
  }
}

# Add an answer to the tar installer database
sub db_add_answer {
  my $id = shift;
  my $value = shift;

  db_remove_answer($id);
  $gDBAnswer{$id} = $value;
  print INSTALLDB 'answer ' . $id . ' ' . $value . "\n";
}

# Retrieve an answer that must be present in the database
sub db_get_answer {
  my $id = shift;

  if (not defined($gDBAnswer{$id})) {
    error('Unable to find the answer ' . $id . ' in the installer database ('
          . $gInstallerMainDB . ').  You may want to re-install '
          . vmware_product_name() . ".\n\n");
  }

  return $gDBAnswer{$id};
}


# Retrieves an answer if it exists in the database, else returns undef;
sub db_get_answer_if_exists {
  my $id = shift;
  if (not defined($gDBAnswer{$id})) {
    return undef;
  }
  if ($gDBAnswer{$id} eq '') {
    return undef;
  }
  return $gDBAnswer{$id};
}

# Save the tar installer database
sub db_save {
  close(INSTALLDB);
}
# END OF THE SECOND LIBRARY FUNCTIONS

# BEGINNING OF THE LIBRARY FUNCTIONS
# Constants
my $cTerminalLineSize = 80;

# Global variables
my %gOption;
my %gAnswerSize;
my %gCheckAnswerFct;

# Tell if the user is the super user
sub is_root {
  return $> == 0;
}

# Wordwrap system: append some content to the output
sub append_output {
  my $output = shift;
  my $pos = shift;
  my $append = shift;

  $output .= $append;
  $pos += length($append);
  if ($pos >= $cTerminalLineSize) {
    $output .= "\n";
    $pos = 0;
  }

  return ($output, $pos);
}

# Wordwrap system: deal with the next character
sub wrap_one_char {
  my $output = shift;
  my $pos = shift;
  my $word = shift;
  my $char = shift;
  my $reserved = shift;
  my $length;

  if (not (($char eq "\n") || ($char eq ' ') || ($char eq ''))) {
    $word .= $char;

    return ($output, $pos, $word);
  }

  # We found a separator.  Process the last word

  $length = length($word) + $reserved;
  if (($pos + $length) > $cTerminalLineSize) {
    # The last word doesn't fit in the end of the line. Break the line before
    # it
    $output .= "\n";
    $pos = 0;
  }
  ($output, $pos) = append_output($output, $pos, $word);
  $word = '';

  if ($char eq "\n") {
    $output .= "\n";
    $pos = 0;
  } elsif ($char eq ' ') {
    if ($pos) {
      ($output, $pos) = append_output($output, $pos, ' ');
    }
  }

  return ($output, $pos, $word);
}

# Wordwrap system: word-wrap a string plus some reserved trailing space
sub wrap {
  my $input = shift;
  my $reserved = shift;
  my $output;
  my $pos;
  my $word;
  my $i;

  $output = '';
  $pos = 0;
  $word = '';
  for ($i = 0; $i < length($input); $i++) {
    ($output, $pos, $word) = wrap_one_char($output, $pos, $word,
                                           substr($input, $i, 1), 0);
  }
  # Use an artifical last '' separator to process the last word
  ($output, $pos, $word) = wrap_one_char($output, $pos, $word, '', $reserved);

  return $output;
}

# Print an error message and exit
sub error {
  my $msg = shift;

  print STDERR wrap($msg . 'Execution aborted.' . "\n\n", 0);
  exit 1;
}

# Convert a string to its equivalent shell representation
sub shell_string {
  my $single_quoted = shift;

  $single_quoted =~ s/'/'"'"'/g;
  # This comment is a fix for emacs's broken syntax-highlighting code --hpreg
  return '\'' . $single_quoted . '\'';
}

# Contrary to a popular belief, 'which' is not always a shell builtin command.
# So we cannot trust it to determine the location of other binaries.
# Moreover, SuSE 6.1's 'which' is unable to handle program names beginning with
# a '/'...
#
# Return value is the complete path if found, or '' if not found
sub internal_which {
  my $bin = shift;

  if (substr($bin, 0, 1) eq '/') {
    # Absolute name
    if ((-f $bin) && (-x $bin)) {
      return $bin;
    }
  } else {
    # Relative name
    my @paths;
    my $path;

    if (index($bin, '/') == -1) {
      # There is no other '/' in the name
      @paths = split(':', $ENV{'PATH'});
      foreach $path (@paths) {
         my $fullbin;

         $fullbin = $path . '/' . $bin;
         if ((-f $fullbin) && (-x $fullbin)) {
               return $fullbin;
         }
      }
    }
  }

  return '';
}

# Remove leading and trailing whitespaces
sub remove_whitespaces {
  my $string = shift;

  $string =~ s/^\s*//;
  $string =~ s/\s*$//;
  return $string;
}

# Ask a question to the user and propose an optional default value
# Use this when you don't care about the validity of the answer
sub query {
    my $message = shift;
    my $defaultreply = shift;
    my $reserved = shift;
    my $reply;

    # Reserve some room for the reply
    print wrap($message . (($defaultreply eq '')
                            ? ''
                            : (' [' . $defaultreply . ']')),
               1 + $reserved);
    # This is what the 1 is for
    print ' ';

    if ($gOption{'default'} == 1) {
      # Simulate the enter key
      print "\n";
      $reply = '';
    } else {
      chomp($reply = <STDIN>);
    }

    print "\n";
    $reply = remove_whitespaces($reply);
    if ($reply eq '') {
      $reply = $defaultreply;
    }
    return $reply;
}

# Check the validity of an answer whose type is yesno
# Return a clean answer if valid, or ''
sub check_answer_binpath {
  my $answer = shift;
  my $source = shift;

  if (not (internal_which($answer) eq '')) {
    return $answer;
  }

  if ($source eq 'user') {
    print wrap('The answer "' . $answer . '" is invalid.  It must be the '
               . 'complete name of a binary file.' . "\n\n", 0);
  }
  return '';
}
$gAnswerSize{'binpath'} = 20;
$gCheckAnswerFct{'binpath'} = \&check_answer_binpath;

# Prompts the user if a binary is not found
# Return value is:
#  '': the binary has not been found
#  the binary name if it has been found
sub DoesBinaryExist_Prompt {
  my $bin = shift;
  my $answer;
  my $prefix = 'BIN_';

  $answer = check_answer_binpath($bin, 'default');
  if (not ($answer eq '')) {
    return $answer;
  } else {
    if (defined db_get_answer_if_exists($prefix . $bin)) {
      return db_get_answer($prefix . $bin);
    }
  }

  if (get_answer('Setup is unable to find the "' . $bin . '" program on your '
                 . 'machine.  Please make sure it is installed.  Do you want '
                 . 'to specify the location of this program by hand?', 'yesno',
                 'yes') eq 'no') {
    return '';
  }

  $answer = get_answer('What is the location of the "' . $bin . '" program on '
                    . 'your machine?', 'binpath', '');
  if (!defined db_get_answer_if_exists($prefix . $bin)) {
    db_add_answer($prefix . $bin, $answer);
  }
  return $answer;
}

# Execute the command passed as an argument
# _without_ interpolating variables (Perl does it by default)
sub direct_command {
  return `$_[0]`;
}

# chmod() that reports errors
sub safe_chmod {
  my $mode = shift;
  my $file = shift;

  if (chmod($mode, $file) != 1) {
    error('Unable to change the access rights of the file ' . $file . '.'
          . "\n\n");
  }
}

# chown() that reports errors
sub safe_chown {
  my $uid = shift;
  my $gid = shift;
  my $file = shift;

  if (chown($uid, $gid, $file) != 1) {
    error('Unable to change the owner of the file ' . $file . '.'
          . "\n\n");
  }
}

# Emulate a simplified ls program for directories
sub internal_ls {
  my $dir = shift;
  my @fn;

  opendir(LS, $dir);
  @fn = grep(!/^\.\.?$/, readdir(LS));
  closedir(LS);

  return @fn;
}

# Install a file permission
sub install_permission {
  my $src = shift;
  my $dst = shift;
  my @statbuf;

  @statbuf = stat($src);
  if (not (defined($statbuf[2]))) {
    error('Unable to get the access rights of source file "' . $src . '".'
          . "\n\n");
  }
  safe_chmod($statbuf[2] & 07777, $dst);
}

# Emulate a simplified sed program
# Return 1 if success, 0 if failure
# XXX as a side effect, if the string being replaced is '', remove
# the entire line.  Remove this, once we have better "block handling" of
# our config data in config files.
sub internal_sed {
  my $src = shift;
  my $dst = shift;
  my $append = shift;
  my $patchRef = shift;
  my @patchKeys;

  if (not open(SRC, '<' . $src)) {
    return 0;
  }
  if (not open(DST, (($append == 1) ? '>>' : '>') . $dst)) {
    return 0;
  }

  @patchKeys = keys(%$patchRef);
  if ($#patchKeys == -1) {
    while (defined($_ = <SRC>)) {
      print DST $_;
    }
  } else {
    while (defined($_ = <SRC>)) {
      my $patchKey;
      my $del = 0;

      foreach $patchKey (@patchKeys) {
        if (s/$patchKey/$$patchRef{$patchKey}/g) {
          if ($_ eq "\n") {
            $del = 1;
          }
        }
      }
      if ($del) {
        next;
      }
      print DST $_;
    }
  }

  close(SRC);
  close(DST);
  return 1;
}

# Check if a file name exists
sub file_name_exist {
  my $file = shift;

  # Note: We must test for -l before, because if an existing symlink points to
  #       a non-existing file, -e will be false
  return ((-l $file) || (-e $file))
}

# Check if a file name already exists and prompt the user
# Return 0 if the file can be written safely, 1 otherwise
sub file_check_exist {
  my $file = shift;

  if (not file_name_exist($file)) {
    return 0;
  }

  # The default must make sure that the product will be correctly installed
  # We give the user the choice so that a sysadmin can perform a normal
  # install on a NFS server and then answer 'no' NFS clients
  return (get_answer('The file ' . $file . ' that this program was about to '
                     . 'install already exists.  Overwrite?', 'yesno', 'yes')
            eq 'yes') ? 0 : 1;
}

# Install one file
# flags are forwarded to db_add_file()
sub install_file {
  my $src = shift;
  my $dst = shift;
  my $patchRef = shift;
  my $flags = shift;

  uninstall_file($dst);
  if (file_check_exist($dst)) {
    return;
  }
  # The file could be a symlink to another location.  Remove it
  unlink($dst);
  if (not internal_sed($src, $dst, 0, $patchRef)) {
    error('Unable to copy the source file ' . $src . ' to the destination '
          . 'file ' . $dst . '.' . "\n\n");
  }
  db_add_file($dst, $flags);
  install_permission($src, $dst);
}

# mkdir() that reports errors
sub safe_mkdir {
  my $file = shift;

  if (mkdir($file, 0000) == 0) {
    error('Unable to create the directory ' . $file . '.' . "\n\n");
  }
}

# Remove trailing slashes in a dir path
sub dir_remove_trailing_slashes {
  my $path = shift;

  for (;;) {
    my $len;
    my $pos;

    $len = length($path);
    if ($len < 2) {
      # Could be '/' or any other character.  Ok.
      return $path;
    }

    $pos = rindex($path, '/');
    if ($pos != $len - 1) {
      # No trailing slash
      return $path;
    }

    # Remove the trailing slash
    $path = substr($path, 0, $len - 1)
  }
}

# Emulate a simplified basename program
sub internal_basename {
  return substr($_[0], rindex($_[0], '/') + 1);
}

# Emulate a simplified dirname program
sub internal_dirname {
  my $path = shift;
  my $pos;

  $path = dir_remove_trailing_slashes($path);

  $pos = rindex($path, '/');
  if ($pos == -1) {
    # No slash
    return '.';
  }

  if ($pos == 0) {
    # The only slash is at the beginning
    return '/';
  }

  return substr($path, 0, $pos);
}

# Create a hierarchy of directories with permission 0755
# flags:
#  0x1 write this directory creation in the installer database
# Return 1 if the directory existed before
sub create_dir {
  my $dir = shift;
  my $flags = shift;

  if (-d $dir) {
    return 1;
  }

  if (index($dir, '/') != -1) {
    create_dir(internal_dirname($dir), $flags);
  }
  safe_mkdir($dir);
  if ($flags & 0x1) {
    db_add_dir($dir);
  }
  safe_chmod(0755, $dir);
  return 0;
}

# Get a valid non-persistent answer to a question
# Use this when the answer shouldn't be stored in the database
sub get_answer {
  my $msg = shift;
  my $type = shift;
  my $default = shift;
  my $answer;

  if (not defined($gAnswerSize{$type})) {
    die 'get_answer(): type ' . $type . ' not implemented :(' . "\n\n";
  }
  for (;;) {
    $answer = check_answer(query($msg, $default, $gAnswerSize{$type}), $type,
                           'user');
    if (not ($answer eq '')) {
      return $answer;
    }
  }
}

# Get a valid persistent answer to a question
# Use this when you want an answer to be stored in the database
sub get_persistent_answer {
  my $msg = shift;
  my $id = shift;
  my $type = shift;
  my $default = shift;
  my $answer;

  if (defined($gDBAnswer{$id})) {
    # There is a previous answer in the database
    $answer = check_answer($gDBAnswer{$id}, $type, 'db');
    if (not ($answer eq '')) {
      # The previous answer is valid.  Make it the default value
      $default = $answer;
    }
  }

  $answer = get_answer($msg, $type, $default);
  db_add_answer($id, $answer);
  return $answer;
}

# Find a suitable backup name and backup a file
sub backup_file {
  my $file = shift;
  my $i;

  for ($i = 0; $i < 100; $i++) {
    if (not file_name_exist($file . '.old.' . $i)) {
      my %patch;

      undef %patch;
      if (internal_sed($file, $file . '.old.' . $i, 0, \%patch)) {
         print wrap('File ' . $file . ' is backed up to ' . $file . '.old.'
                    . $i . '.' . "\n\n", 0);
      } else {
         print STDERR wrap('Unable to backup the file ' . $file . ' to '
                           . $file . '.old.' . $i .'.' . "\n\n", 0);
      }
      return;
    }
  }

  print STDERR wrap('Unable to backup the file ' . $file . '.  You have too '
                    . 'many backups files.  They are files of the form '
                    . $file . '.old.N, where N is a number.  Please delete '
                    . 'some of them.' . "\n\n", 0);
}

# Backup a file in the idea to restore it in the future.
sub backup_file_to_restore {
  my $file = shift;
  my $restoreStr = shift;
  if (file_name_exist($file) &&
      (not file_name_exist($file . $cBackupExtension))) {
    my %p;
    undef %p;
    rename $file, $file . $cBackupExtension;
    db_add_answer($cRestorePrefix . $restoreStr, $file);
    db_add_answer($cRestorePrefix . $restoreStr . $cRestoreBackupSuffix,
                  $file . $cBackupExtension);

    if (defined db_get_answer_if_exists($cRestoreBackList)) {
      my $allRestoreStr;
      $allRestoreStr = db_get_answer($cRestoreBackList);
      db_add_answer($cRestoreBackList,$allRestoreStr . ':' . $restoreStr);
    } else {
      db_add_answer($cRestoreBackList, $restoreStr);
    }
  }
}

# XXX Duplicated in pkg_mgr.pl
# format of the returned hash:
#          - key is the system file
#          - value is the backed up file.
# This function should never know about filenames. Only database
# operations.
sub db_get_files_to_restore {
  my %fileToRestore;
  undef %fileToRestore;

  if (defined db_get_answer_if_exists($cRestoreBackList)) {
    my $restoreStr;
    foreach $restoreStr (split(/:/, db_get_answer($cRestoreBackList))) {
      if (defined db_get_answer_if_exists($cRestorePrefix . $restoreStr)) {
        $fileToRestore{db_get_answer($cRestorePrefix . $restoreStr)} =
          db_get_answer($cRestorePrefix . $restoreStr
                        . $cRestoreBackupSuffix);
      }
    }
  }
  return %fileToRestore;
}

# Uninstall a file previously installed by us
sub uninstall_file {
  my $file = shift;

  if (not db_file_in($file)) {
    # Not installed by this program
    return;
  }

  if (file_name_exist($file)) {
    if (db_file_ts($file)) {
      my @statbuf;

      @statbuf = stat($file);
      if (defined($statbuf[9])) {
         if (db_file_ts($file) != $statbuf[9]) {
           # Modified since this program installed it
           backup_file($file);
         }
      } else {
        print STDERR wrap('Unable to get the last modification timestamp of '
                          . 'the file ' . $file . '.' . "\n\n", 0);
      }
    }

    if (not unlink($file)) {
      print STDERR wrap('Unable to remove the file ' . $file . '.' . "\n\n",
                        0);
    }
  } else {
    print wrap('This program previously created the file ' . $file . ', and '
               . 'was about to remove it.  Somebody else apparently did it '
               . 'already.' . "\n\n", 0);
  }

  db_remove_file($file);
}

# Uninstall a directory previously installed by us
sub uninstall_dir {
  my $dir = shift;

  if (not db_dir_in($dir)) {
    # Not installed by this program
    return;
  }

  if (-d $dir) {
    if (not rmdir($dir)) {
      print wrap('This program previously created the directory ' . $dir . ', '
                 . 'and was about to remove it. Since there are files in that '
                 . 'directory that this program did not create, it will not be '
                 . 'removed.' . "\n\n", 0);
      if (   defined($ENV{'VMWARE_DEBUG'})
          && ($ENV{'VMWARE_DEBUG'} eq 'yes')) {
        system('ls -AlR ' . shell_string($dir));
      }
    }
  } else {
    print wrap('This program previously created the directory ' . $dir
               . ', and was about to remove it. Somebody else apparently did '
               . 'it already.' . "\n\n", 0);
  }

  db_remove_dir($dir);
}

# Uninstall files and directories beginning with a given prefix
sub uninstall_prefix {
  my $prefix = shift;
  my $prefix_len;
  my $file;
  my $dir;

  $prefix_len = length($prefix);

  # Remove all files beginning with $prefix
  foreach $file (keys %gDBFile) {
    if (substr($file, 0, $prefix_len) eq $prefix) {
      uninstall_file($file);
    }
  }

  # Remove all directories beginning with $prefix
  # We sort them by decreasing order of their length, to ensure that we will
  # remove the inner ones before the outer ones
  foreach $dir (sort {length($b) <=> length($a)} keys %gDBDir) {
    if (substr($dir, 0, $prefix_len) eq $prefix) {
      uninstall_dir($dir);
    }
  }
}

# Return the version of VMware
sub vmware_version {
  my $buildNr;

  $buildNr = '4.5.2 build-8848';
  return remove_whitespaces($buildNr);
}

# Return product name and version
sub vmware_longname {
   my $name = vmware_product_name() . ' ' . vmware_version();

   if (not (vmware_product() eq 'server')) {
      $name .= ' for ' . $gSystem{'system'};
   }

   return $name;
}

# Check the validity of an answer whose type is yesno
# Return a clean answer if valid, or ''
sub check_answer_yesno {
  my $answer = shift;
  my $source = shift;

  if (lc($answer) =~ /^y(es)?$/) {
    return 'yes';
  }

  if (lc($answer) =~ /^n(o)?$/) {
    return 'no';
  }

  if ($source eq 'user') {
    print wrap('The answer "' . $answer . '" is invalid.  It must be one of '
               . '"y" or "n".' . "\n\n", 0);
  }
  return '';
}
$gAnswerSize{'yesno'} = 3;
$gCheckAnswerFct{'yesno'} = \&check_answer_yesno;

# Check the validity of an answer based on its type
# Return a clean answer if valid, or ''
sub check_answer {
  my $answer = shift;
  my $type = shift;
  my $source = shift;

  if (not defined($gCheckAnswerFct{$type})) {
    die 'check_answer(): type ' . $type . ' not implemented :(' . "\n\n";
  }
  return &{$gCheckAnswerFct{$type}}($answer, $source);
}
# END OF THE LIBRARY FUNCTIONS

# BEGINNING_OF_TMPDIR_DOT_PL
#!/usr/bin/perl

use strict;

# Create a temporary directory
#
# They are a lot of small utility programs to create temporary files in a
# secure way, but none of them is standard. So I wrote this --hpreg
sub make_tmp_dir {
  my $prefix = shift;
  my $tmp;
  my $serial;
  my $loop;

  $tmp = defined($ENV{'TMPDIR'}) ? $ENV{'TMPDIR'} : '/tmp';

  # Don't overwrite existing user data
  # -> Create a directory with a name that didn't exist before
  #
  # This may never succeed (if we are racing with a malicious process), but at
  # least it is secure
  $serial = 0;
  for (;;) {
    # Check the validity of the temporary directory. We do this in the loop
    # because it can change over time
    if (not (-d $tmp)) {
      error('"' . $tmp . '" is not a directory.' . "\n\n");
    }
    if (not ((-w $tmp) && (-x $tmp))) {
      error('"' . $tmp . '" should be writable and executable.' . "\n\n");
    }

    # Be secure
    # -> Don't give write access to other users (so that they can not use this
    # directory to launch a symlink attack)
    if (mkdir($tmp . '/' . $prefix . $serial, 0755)) {
      last;
    }

    $serial++;
    if ($serial % 200 == 0) {
      print STDERR 'Warning: The "' . $tmp . '" directory may be under attack.' . "\n\n";
    }
  }

  return $tmp . '/' . $prefix . $serial;
}

# END_OF_TMPDIR_DOT_PL


# Append a clearly delimited block to an unstructured text file --hpreg
# Result:
#  1 on success
#  -1 on failure
sub block_append {
   my $file = shift;
   my $begin = shift;
   my $block = shift;
   my $end = shift;

   if (not open(BLOCK, '>>' . $file)) {
      return -1;
   }

   print BLOCK $begin . $block . $end;

   if (not close(BLOCK)) {
      return -1;
   }

   return 1;
}


# Remove all clearly delimited blocks from an unstructured text file --hpreg
# Result:
#  >= 0 number of blocks removed on success
#  -1 on failure
sub block_remove {
   my $src = shift;
   my $dst = shift;
   my $begin = shift;
   my $end = shift;
   my $count;
   my $state;

   if (not open(SRC, '<' . $src)) {
      return -1;
   }

   if (not open(DST, '>' . $dst)) {
      close(SRC);
      return -1;
   }

   $count = 0;
   $state = 'outside';
   while (<SRC>) {
      if      ($state eq 'outside') {
         if ($_ eq $begin) {
            $state = 'inside';
            $count++;
         } else {
            print DST $_;
         }
      } elsif ($state eq 'inside') {
         if ($_ eq $end) {
            $state = 'outside';
         }
      }
   }

   if (not close(DST)) {
      close(SRC);
      return -1;
   }

   if (not close(SRC)) {
      return -1;
   }

   return $count;
}


# Set the name of the main /etc/vmware* directory.
sub initialize_globals {

  if (vmware_product() eq 'console') {
    $gRegistryDir = '/etc/vmware-console';
  } elsif (vmware_product() eq 'mui') {
    $gRegistryDir = '/etc/vmware-mui';
  } elsif (vmware_product() eq 'tools-for-linux' ||
           vmware_product() eq 'tools-for-freebsd') {
    $gRegistryDir = '/etc/vmware-tools';
  } else {
    $gRegistryDir = '/etc/vmware';
  }
  $gInstallerMainDB = $gRegistryDir . '/locations';
  $gConfFlag = $gRegistryDir . '/not_configured';

  $gOption{'default'} = 0;
  $gOption{'compile'} = 0;
  $gOption{'prebuilt'} = 0;
  $gOption{'try-modules'} = 0;
  $gOption{'tools-switch'} = 0;

}


# Set up the location of external helpers
sub initialize_external_helpers {
  my $program;
  my @programList;

  if (not defined($gHelper{'more'})) {
    $gHelper{'more'} = '';
    if (defined($ENV{'PAGER'})) {
      my @tokens;

      # The environment variable sometimes contains the pager name _followed by
      # a few command line options_.
      #
      # Isolate the program name (we are certain it does not contain a
      # whitespace) before dealing with it.
      @tokens = split(' ', $ENV{'PAGER'});
      $tokens[0] = DoesBinaryExist_Prompt($tokens[0]);
      if (not ($tokens[0] eq '')) {
        # This is _already_ a shell string
        $gHelper{'more'} = join(' ', @tokens);
      }
    }
    if ($gHelper{'more'} eq '') {
      $gHelper{'more'} = DoesBinaryExist_Prompt('more');
      if ($gHelper{'more'} eq '') {
        error('Unable to continue.' . "\n\n");
      }
      # Save it as a shell string
      $gHelper{'more'} = shell_string($gHelper{'more'});
    }
  }

  if (vmware_product() eq 'tools-for-freebsd') {
    @programList = ('uname', 'grep', 'ldd', 'mknod', 'kldload',
                    'kldunload');
  } else {
    @programList = ('uname', 'grep', 'ldd', 'mknod', 'insmod', 'modprobe',
                    'rmmod', 'ifconfig', 'lspci', 'rm');
  }

  foreach $program (@programList) {
    if (not defined($gHelper{$program})) {
      $gHelper{$program} = DoesBinaryExist_Prompt($program);
      if ($gHelper{$program} eq '') {
        error('Unable to continue.' . "\n\n");
      }
    }
  }

  $gHelper{'insserv'} = internal_which('insserv');
}


# Check the validity of an answer whose type is dirpath
# Return a clean answer if valid, or ''
sub check_answer_dirpath {
    my $answer = shift;
    my $source = shift;

    $answer = dir_remove_trailing_slashes($answer);
    
    if (-d $answer) {
	# The path is an existing directory
	return $answer;
    }
    
    # The path is not a directory
    if (file_name_exist($answer)) {
	if ($source eq 'user') {
	    print wrap('The path "' . $answer . '" exists, but is not a directory.'
		       . "\n\n", 0);
	}
	return '';
    }
    
    # The path does not exist
    if ($source eq 'user') {
	return (get_answer('The path "' . $answer . '" does not exist currently. '
			   . 'This program is going to create it, including needed '
			   . 'parent directories. Is this what you want?',
			   'yesno', 'yes') eq 'yes') ? $answer : '';
    } else {
	return $answer;
    }
}
$gAnswerSize{'dirpath'} = 20;
$gCheckAnswerFct{'dirpath'} = \&check_answer_dirpath;


# Check the validity of an answer whose type is headerdir
# Return a clean answer if valid, or ''
sub check_answer_headerdir {
  my $answer = shift;
  my $source = shift;
  my $pattern = '@@VMWARE@@';
  my $header_version_uts;
  my $header_smp;
  my $header_page_offset;

  $answer = dir_remove_trailing_slashes($answer);

  if (not (-d $answer)) {
    if ($source eq 'user') {
      print wrap('The path "' . $answer . '" is not an existing directory.'
                 . "\n\n", 0);
    }
    return '';
  }

  if ($answer =~ m|^/usr/include(/.*)?$|) { #/# Broken colorizer.
    if ($source eq 'user') {
      if (get_answer('The header files in /usr/include are generally for C '
                     . 'libraries, not for the running kernel. If you do not '
                     . 'have kernel header files in your /usr/src directory, '
                     . 'you probably do not have the kernel-source package '
                     . 'installed. Are you sure that /usr/include contains '
                     . 'the header files associated with your running kernel?',
                     'yesno', 'no') eq 'no') {
        return '';
      }
    }
  }

  if (   (not (-d $answer . '/linux'))
      || (not (-d $answer . '/asm'))
      || (not (-d $answer . '/net'))) {
    if ($source eq 'user') {
      print wrap('The path "' . $answer . '" is an existing directory, but it '
                 . 'does not contain at least one of these directories '
                 . '"linux", "asm", "net" as expected.' . "\n\n", 0);
    }
    return '';
  }

  #
  # Check that the running kernel matches the set of header files
  #

  if (not (-r $answer . '/linux/version.h')) {
    if ($source eq 'user') {
      print wrap('The path "' . $answer . '" is a kernel header file '
                 . 'directory, but it does not contain the file '
                 . '"linux/version.h" as expected.  This can happen if the '
                 . 'kernel has never been built, or if you have invoked the '
                 . '"make mrproper" command in your kernel directory.  In any '
                 . 'case, you may want to rebuild your kernel.' . "\n\n", 0);
    }
    return '';
  }
  $header_version_uts = direct_command(
    shell_string($gHelper{'echo'}) . ' '
    . shell_string('#include <linux/version.h>' . "\n" . $pattern
                   . ' UTS_RELEASE') . ' | ' . shell_string($gHelper{'gcc'})
    . ' ' . shell_string('-I' . $answer) . ' -E - | '
    . shell_string($gHelper{'grep'}) . ' ' . shell_string($pattern));
  chomp($header_version_uts);
  $header_version_uts =~ s/^$pattern \"([^\"]*)\".*$/$1/;
  if (not ($header_version_uts eq $gSystem{'uts_release'})) {
    if ($source eq 'user') {
      print wrap('The directory of kernel headers (version '
                 . $header_version_uts . ') does not match your running '
                 . 'kernel (version ' . $gSystem{'uts_release'} . ').  Even '
                 . 'if the module were to compile successfully, it would not '
                 . 'load into the running kernel.' . "\n\n", 0);
    }
    return '';
  }

  if (not (-r $answer . '/linux/autoconf.h')) {
    if ($source eq 'user') {
      print wrap('The path "' . $answer . '" is a kernel header file '
                 . 'directory, but it does not contain the file '
                 . '"linux/autoconf.h" as expected.  This can happen if the '
                 . 'kernel has never been built, or if you have invoked the '
                 . '"make mrproper" command in your kernel directory.  In any '
                 . 'case, you may want to rebuild your kernel.' . "\n\n", 0);
    }
    return '';
  }
  $header_smp = direct_command(shell_string($gHelper{'grep'}) . ' CONFIG_SMP '
                               . shell_string($answer . '/linux/autoconf.h'));
  if (not ($header_smp eq '')) {
    # linux/autoconf.h contains the up/smp information
    $header_smp = direct_command(
      shell_string($gHelper{'echo'}) . ' '
      . shell_string('#include <linux/autoconf.h>' . "\n" . $pattern
                     . ' CONFIG_SMP') . ' | ' . shell_string($gHelper{'gcc'})
      . ' ' . shell_string('-I' . $answer) . ' -E - | '
      . shell_string($gHelper{'grep'}) . ' ' . shell_string($pattern));
    chomp($header_smp);
    $header_smp =~ s/^$pattern (\S+).*$/$1/;
    $header_smp = ($header_smp eq '1') ? 'yes' : 'no';
    if (not (lc($header_smp) eq lc($gSystem{'smp'}))) {
      if ($source eq 'user') {
        print wrap('The kernel defined by this directory of header files is '
                   . (($header_smp eq 'yes') ? 'multiprocessor'
                                             : 'uniprocessor') . ', while '
                   . 'your running kernel is '
                   . (($gSystem{'smp'} eq 'yes') ? 'multiprocessor'
                                                 : 'uniprocessor') . '.'
                   . "\n\n", 0);
      }
      return '';
    }
  }

  if (not (-r $answer . '/asm/page.h')) {
    if ($source eq 'user') {
      print wrap('The path "' . $answer . '" is a kernel header file '
                 . 'directory, but it does not contain the file "asm/page.h" '
                 . 'as expected.' . "\n\n", 0);
    }
    return '';
  }
  $header_page_offset = direct_command(
    shell_string($gHelper{'echo'}) . ' '
    . shell_string('#define __KERNEL__' . "\n" . '#include <asm/page.h>'
                   . "\n" . $pattern . ' __PAGE_OFFSET') . ' | '
    . shell_string($gHelper{'gcc'}) . ' ' . shell_string('-I' . $answer)
    . ' -E - | ' . shell_string($gHelper{'grep'}) . ' '
    . shell_string($pattern));
  chomp($header_page_offset);
  $header_page_offset =~ s/^$pattern \(?0x([0-9a-fA-F]{8,}).*$/$1/;
  if ($header_page_offset =~ /[0-9a-fA-F]{8,}/) {
    # We found a valid page offset
    if (defined($gSystem{'page_offset'}) and
        not (lc($header_page_offset) eq lc($gSystem{'page_offset'}))) {
      if ($source eq 'user') {
        print wrap('The kernel defined by this directory of header files does '
                   . 'not have the same address space size as your running '
                   . 'kernel.' . "\n\n", 0);
      }
      return '';
    }
  }

  return $answer;
}
$gAnswerSize{'headerdir'} = 20;
$gCheckAnswerFct{'headerdir'} = \&check_answer_headerdir;

# Check the validity of an answer whose type is ip
# Return a clean answer if valid, or ''
sub check_answer_ip {
  my $answer = shift;
  my $source = shift;
  my $re;

  # I'm in love with regular expressions --hpreg
  $re = '^([0-9]|[1-9][0-9]|1[0-9][0-9]|2([0-4][0-9]|5[0-5]))'
        . '(\.([0-9]|[1-9][0-9]|1[0-9][0-9]|2([0-4][0-9]|5[0-5]))){3}$';
  # This comment fixes emacs's broken syntax highlighting
  if ($answer =~ /$re/) {
    return $answer;
  }

  if ($source eq 'user') {
    print wrap('The answer "' . $answer . '" is invalid.  It must be of the '
               . 'form a.b.c.d where a, b, c and d are decimal numbers '
               . 'between 0 and 255.' . "\n\n", 0);
  }
  return '';
}
$gAnswerSize{'ip'} = 15;
$gCheckAnswerFct{'ip'} = \&check_answer_ip;

# Check the validity of an answer whose type is editorwizardhelp
# Return a clean answer if valid, or ''
sub check_answer_editorwizardhelp {
  my $answer = shift;
  my $source = shift;

  if (lc($answer) =~ /^e(ditor)?$/) {
    return 'editor';
  }

  if (lc($answer) =~ /^w(izard)?$/) {
    return 'wizard';
  }

  if (lc($answer) =~ /^h(elp)?$/) {
    return 'help';
  }

  if ($source eq 'user') {
    print wrap('The answer "' . $answer . '" is invalid. It must be one of '
               . '"w", "e" or "h".' . "\n\n", 0);
  }
  return '';
}
$gAnswerSize{'editorwizardhelp'} = 6;
$gCheckAnswerFct{'editorwizardhelp'} = \&check_answer_editorwizardhelp;

# Check the validity of an answer whose type is yesnohelp
# Return a clean answer if valid, or ''
sub check_answer_yesnohelp {
  my $answer = shift;
  my $source = shift;

  if (lc($answer) =~ /^y(es)?$/) {
    return 'yes';
  }

  if (lc($answer) =~ /^n(o)?$/) {
    return 'no';
  }

  if (lc($answer) =~ /^h(elp)?$/) {
    return 'help';
  }

  if ($source eq 'user') {
    print wrap('The answer "' . $answer . '" is invalid.  It must be one of '
               . '"y", "n" or "h".' . "\n\n", 0);
  }
  return '';
}
$gAnswerSize{'yesnohelp'} = 4;
$gCheckAnswerFct{'yesnohelp'} = \&check_answer_yesnohelp;

# Check the validity of an answer whose type is vmnet
# Return a clean answer if valid, or ''
sub check_answer_vmnet {
  my $answer = shift;
  my $source = shift;

  if ($answer =~ /^\d+$/) {
    if ($answer >= $gMinVmnet && $answer <= $gMaxVmnet) {
      return $answer;
    }
  }

  if ($source eq 'user') {
    print wrap('The answer "' . $answer . '" is invalid. It must be an '
               . 'integer between ' . $gMinVmnet . ' and ' . $gMaxVmnet . '.'
               . "\n\n", 0);
  }

  return '';
}
$gAnswerSize{'vmnet'} = length("$gMaxVmnet");
$gCheckAnswerFct{'vmnet'} = \&check_answer_vmnet;

# Check the validity of an answer whose type is nettype
# Return a clean answer if valid, or ''
sub check_answer_nettype {
  my $answer = shift;
  my $source = shift;

  if (lc($answer) =~ /^h(ostonly)?$/) {
    return 'hostonly';
  }

  if (lc($answer =~ /^b(ridged)?$/)) {
    return 'bridged';
  }

  if (lc($answer =~ /^n(at)?$/)) {
    return 'nat';
  }

  if (lc($answer =~ /^none$/)) {
    return 'none';
  }

  if ($source eq 'user') {
    print wrap('The answer "' . $answer . '" is invalid. It must be either '
               . '"b", "h", "n", or "none".' . "\n\n", 0);
  }
  return '';
}
$gAnswerSize{'nettype'} = 8;
$gCheckAnswerFct{'nettype'} = \&check_answer_nettype;

# Check the validity of an answer whose type is availethif
# Return a clean answer if valid, or ''
sub check_answer_availethif {
  my $answer = shift;
  my $source = shift;

  if (grep($answer eq $_, @gAvailEthIf)) {
    return $answer;
  }

  if ($source eq 'user') {
    if (grep($answer eq $_, @gAllEthIf)) {
      print wrap('The ethernet device "' . $answer . '" is already configured '
                 . 'as a bridged device.' . "\n\n", 0);
      return '';
    }
    if (get_answer('The ethernet device "' . $answer . '" was not detected on '
                   . 'your system.  Available ethernet devices detected on '
                   . 'your system include ' . join(', ', @gAvailEthIf) . '.  '
                   . 'Are you sure you want to use this device? (yes/no)',
                   'yesno', 'no') eq 'no') {
      return '';
    } else {
      return $answer;
    }
  }
  return '';
}
$gAnswerSize{'availethif'} = 4;
$gCheckAnswerFct{'availethif'} = \&check_answer_availethif;

# check the validity of a user or group name
# return the answer if valid or ''
sub check_answer_usergp {
  my $answer = shift;
  my $source = shift;

  if (($answer=~/^\S+$/) && ($answer=~/^[a-zA-Z]/)) {
    return $answer;
  }

  if ($source eq 'user') {
    print wrap('The answer "' . $answer . '" is invalid. Please enter a valid'
               . ' name of length < 32 and beginning with a letter'
               . "\n\n", 0);
  }

  return '';
}

$gAnswerSize{'usergp'} = 32;
$gCheckAnswerFct{'usergp'} = \&check_answer_usergp;

# check the validity of a timeout value
# return the answer if valid or ''
sub check_answer_timeout {
  my $answer = shift;
  my $source = shift;

  if ($answer=~/^-?\d+$/ && $answer >= -1) {
    return $answer;
  }

  if ($source eq 'user') {
    print wrap('The answer "' . $answer . '" is invalid. Please enter a valid'
               . ' number of minutes in the range -1 to 99999' . "\n\n", 0);
  }

  return '';
}

$gAnswerSize{'timeout'} = 5;
$gCheckAnswerFct{'timeout'} = \&check_answer_timeout;


# Check the validity of an answer whose type is nocheck
# Always returns answer.
sub check_answer_anyethif {
  my $answer = shift;
  my $source = shift;

  return $answer;
}
$gAnswerSize{'anyethif'} = 4;
$gCheckAnswerFct{'anyethif'} = \&check_answer_anyethif;

# Check the validity of an answer whose type is authdport
# Return a clean answer if valid, or ''
sub check_answer_authdport {
  my $answer = shift;
  my $source = shift;

  if ($source eq 'default') {
    if (check_if_port_free($answer) != 1) {
      return '';
    }
  }

  if (($answer =~ /^\d+$/) && ($answer > 0) && ($answer < 65536)) {
    return $answer;
  }

  if ($source eq 'user') {
    print wrap('The answer "' . $answer . '" is invalid. Please enter a valid '
               . 'port number in the range 1 to 65535.' . "\n\n", 0);
  }

  return '';
}
$gAnswerSize{'authdport'} = 5;
$gCheckAnswerFct{'authdport'} = \&check_answer_authdport;

# Check the validity of an answer whose type is number
# Return a clean number if valid, or '0'
# Default value for the 'number' type of answer.
# This $gMaxNumber as well as the $gAnswerSize{'number'} has to be updated
# before calling get_*_answer functions so that wrap() leaves enough room
# for the reply.
my $gMaxNumber = 0;
sub check_answer_number {
  my $answer = shift;
  my $source = shift;

  if (($answer =~ /^\d+$/) && ($answer > 0) && ($answer <= $gMaxNumber)) {
    return $answer;
  }

  if ($source eq 'user') {
    print wrap('The answer "' . $answer . '" is invalid. Please enter a valid '
               . 'number in the range 1 to ' . $gMaxNumber . "\n\n", 0);
  }

  return '';
}
$gAnswerSize{'number'} = length($gMaxNumber);
$gCheckAnswerFct{'number'} = \&check_answer_number;

my %gPortCache;
# Check $cServices file for specified port
# If $cServices cant be read, return -1
# If port not in $cServices return 1
# If port is in $cServices return 0
sub check_port_not_registered {
  my $port = shift;
  if (defined($gPortCache{$port}) && $gPortCache{$port} == 2) {
    return 0;
  }
  if (not open(CONF, $cServices)) {
    return -1;
  }
  while (<CONF>) {
    if (/\b(\d+)\/(tcp)\b/i) {
      $gPortCache{$1} = 2;
    }
  }
  close(CONF);
  if (defined($gPortCache{$port}) && $gPortCache{$port} == 2) {
    return 0;
  }
  return 1;

}


# Check the $cServices file and use /proc/net/tcp to see 
# if the port is already in use.
# If we fail to check, return -1
# If port is free, return 1;
# If port is in use, return 0;
sub check_if_port_free {
  my $port = shift;
  if (defined($gPortCache{$port})) {
    return 0;
  }
  # Check /proc/net/tcp and /proc/net/udp
  if (open(TCP, "</proc/net/tcp")) {
    while (<TCP>) {
      if (/^\s*\d+:\s*[0-9a-fA-F]{8}:([0-9a-fA-F]{4})\s*[0-9a-fA-F]{8}:[0-9a-fA-F]{4}\s*([0-9a-fA-F]{2}).*$/) {
        # We'll consider a socket free if it is in TIME_WAIT state
        if ($2 ne "06") {
          $gPortCache{hex($1)} = 1;
        }
      }
    }
    close TCP;
  }
  if (defined($gPortCache{$port})) {
    return 0;
  }
  return check_port_not_registered($port);
}


# Display the end-user license agreement
sub show_EULA {
  if (   (not defined($gDBAnswer{'EULA_AGREED'}))
      || (db_get_answer('EULA_AGREED') eq 'no')) {
    if ($gOption{'default'} == 1) {
       print wrap('You must read and accept the End User License Agreement to '
                  . 'continue.' . "\n\n" . 'To display End User License '
                  . 'Agreement please restart ' . $0 . ' in the '
                  . 'interactive mode, without using `-d\' option.' . "\n\n", 0);
       exit 0;
    }
    query('You must read and accept the End User License Agreement to '
          . 'continue.' . "\n" . 'Press enter to display it.', '', 0);

    # $gHelper{'more'} is already a shell string
    system($gHelper{'more'} . ' ' . shell_string(db_get_answer('DOCDIR')
                                                 . '/EULA'));
    print "\n";

    # Make sure there is no default answer here
    if (get_persistent_answer('Do you accept? (yes/no)', 'EULA_AGREED',
                              'yesno', '') eq 'no') {
      print wrap('Please try again when you are ready to accept.' . "\n\n", 0);
      exit 0;
    }

    print wrap('Thank you.' . "\n\n", 0);
  }
}

# Build a Linux kernel integer version
sub kernel_version_integer {
  my $version = shift;
  my $patchLevel = shift;
  my $subLevel = shift;

  return $version * 65536 + $patchLevel * 256 + $subLevel;
}

# Retrieve distribution information
sub distribution_info {
  my $issue = '/etc/issue';
  my $system;

  # First use the accurate method that are intended to work reliably on recent
  # distributions (if an FHS guy is listening, we really need a generic way to
  # do this)
  if (-e '/etc/debian_version') {
    return 'debian';
  }
  if (-e '/etc/redhat-release') {
    return 'redhat';
  }
  if (-e '/etc/SuSE-release') {
    return 'suse';
  }
  if (-e '/etc/turbolinux-release') {
    return 'turbolinux';
  }
  if (-e '/etc/mandrake-release') {
    return 'mandrake';
  }

  # Then use less accurate methods that should work even on old distributions,
  # if people haven't customized their system too much
  if (-e $issue) {
    if (not (direct_command(shell_string($gHelper{'grep'}) . ' -i '
                            . shell_string('debian') . ' '
                            . shell_string($issue)) eq '')) {
      return 'debian';
    }
    if (not (direct_command(shell_string($gHelper{'grep'}) . ' -i '
                            . shell_string('red *hat') . ' '
                            . shell_string($issue)) eq '')) {
      return 'redhat';
    }
    if (not (direct_command(shell_string($gHelper{'grep'}) . ' -i '
                            . shell_string('suse\|s\.u\.s\.e') . ' '
                            . shell_string($issue)) eq '')) {
      return 'suse';
    }
    if (not (direct_command(shell_string($gHelper{'grep'}) . ' -i '
                            . shell_string('caldera') . ' '
                            . shell_string($issue)) eq '')) {
      return 'caldera';
    }
  }

  return 'unknown';
}

sub vmware_check_vm_app_name {
  return db_get_answer('SBINDIR') . '/vmware-checkvm';
}

sub vmware_vmx_app_name {
  return db_get_answer('LIBDIR') . '/bin/vmware-vmx';
}

sub is64BitSystem {
  if (direct_command(shell_string($gHelper{'uname'}) . ' -m') =~ /x86_64/) {
    return 1;
  } else {
    return 0;
  }
}


# Retrieve and check system information
sub system_info {
  my $fullVersion;
  my $version;
  my $patchLevel;
  my $subLevel;
  my $runSystem;

  $gSystem{'system'} = direct_command(shell_string($gHelper{'uname'}) . ' -s');
  chomp($gSystem{'system'});

  $runSystem = (vmware_product() eq 'tools-for-freebsd') ? 'FreeBSD' : 'Linux';

  if (not ($gSystem{'system'} eq $runSystem)) {
    error('You are not running ' . $runSystem . '. This version of the product '
          . 'only runs on ' . $runSystem . '.' . "\n\n");
  }

  if (vmware_product() eq 'server') {
    # Force the answer even if they're running Linux right now.
    $gSystem{'uts_release'} = '@@VMNIXVERSION@@';
  } else {
    $gSystem{'uts_release'} = direct_command(shell_string($gHelper{'uname'})
                                             . ' -r');
    chomp($gSystem{'uts_release'});
  }
  $gSystem{'uts_version'} = direct_command(shell_string($gHelper{'uname'})
                                           . ' -v');
  chomp($gSystem{'uts_version'});

  if ($runSystem eq 'Linux') {

    ($version, $patchLevel, $subLevel) = split(/\./, $gSystem{'uts_release'});
    # Clean the subLevel in case there is an extraversion
    ($subLevel) = split(/[^0-9]/, $subLevel);
    $gSystem{'version_utsclean'} = $version . '.' . $patchLevel . '.'
                                   . $subLevel;

    $gSystem{'version_integer'} = kernel_version_integer($version, $patchLevel,
                                                         $subLevel);
    if ($gSystem{'version_integer'} < kernel_version_integer(2, 0, 0)) {
      error('You are running Linux version ' . $gSystem{'version_utsclean'}
            . '.  This product only runs on 2.0.0 and later kernels.' . "\n\n");
    }

    if (vmware_product() eq 'server') {
      $gSystem{'smp'} = 'no';
      $gSystem{'versioned'} = 'yes';
    } else {
      $gSystem{'smp'} = (direct_command(shell_string($gHelper{'uname'})
                                        . ' -v') =~ / SMP /) ? 'yes' : 'no';
      $gSystem{'versioned'} = (direct_command(shell_string($gHelper{'grep'}) . ' '
        . shell_string('^[0-9a-fA-F]\{8\} Using_Versions') . ' /proc/ksyms 2> /dev/null')
          eq '') ? 'no' : 'yes';
    }

    $gSystem{'distribution'} = distribution_info();

    if (is64BitSystem()) {
      $gSystem{'page_offset'} = '0000010000000000';
    } else {
      $gSystem{'page_offset'} = 'C0000000';
    }

    if ($gSystem{'version_integer'} >= kernel_version_integer(2, 1, 0)) {
      # 2.1.0+ kernels have hardware verify_area() support --hpreg
      my @fields;

      @fields = split(' ', direct_command(
        shell_string($gHelper{'grep'}) . ' '
        . shell_string('^[0-9a-fA-F]\{8\} printk') . ' /proc/ksyms 2> /dev/null'));
      if (not defined($fields[0])) {
        @fields = split(' ', direct_command(
	  shell_string($gHelper{'grep'}) . ' '
	  . shell_string('^[0-9a-fA-F]\{8\} \w printk') . ' /proc/kallsyms 2> /dev/null'));
      }
      if (defined($fields[0])) {
        my $first;

        $first = lc(substr($fields[0], 0, 1));
        if ($first =~ /^[4567]$/) {
          $first = '40000000';
        } elsif ($first =~ /^[89ab]$/) {
          $first = '80000000';
        } elsif ($first =~ /^[cd]$/) {
          $first = 'C0000000';
        } elsif ($first =~ /^[ef]$/) {
          $first = 'E0000000';
        } else {
	  # Probably hugemem kernel. Or something went horribly wrong.
	  # hugemem base is 02xxxxxx, but better to ignore it, as it
	  # can be virtually any value, there is no requirement about
	  # base being 4gb-2**n anymore
	  $first = undef;
        }
        $gSystem{'page_offset'} = $first;
      } else {
        # Unable to find page_offset: accept anything
	$gSystem{'page_offset'} = undef;
      }
    }

    # Linux kernel build bug
    $gSystem{'build_bug'} = (direct_command(shell_string($gHelper{'grep'}) . ' '
      . shell_string('^[0-9a-fA-F]\{8\} __global_cli_R__ver___global_cli')
      . ' /proc/ksyms 2> /dev/null') eq '') ? 'no' : 'yes';
  }

  # Warning, the return after the end of the if statement
  # will void everything after.
  if (vmware_product() eq 'tools-for-linux' ||
      vmware_product() eq 'tools-for-freebsd') {
    $gSystem{'product'} =
      direct_command(shell_string(vmware_check_vm_app_name()) . ' -p');
    if (direct_command(shell_string(vmware_check_vm_app_name())) =~ /good/) {
      $gSystem{'invm'} = 'yes';
    } else {
      $gSystem{'invm'} = 'no';
    }
    $gSystem{'resolution'} =
      direct_command(shell_string(vmware_check_vm_app_name()) . ' -r');
    chomp($gSystem{'resolution'});
    return;
  }

  if (vmware_product() eq 'wgs') {
    if ($gSystem{'uts_release'} =~ m/2\.2\.14-(5|5\.0)/) {
         print wrap('You are running kernel ' . $gSystem{'uts_release'} . '. '
                    . 'There is a known issue with this specific kernel that '
                    . 'can cause corruption of memory on a system wide level '
                    . 'under heavy load, such as when running '
                    . vmware_product_name() . '.' . "\n\n" . 'We recommend '
                    . 'you download the patch from Red Hat, or upgrade your '
                    . 'kernel to 2.2.17.' . "\n" . 'See http://www.redhat.com'
                    . '/support/errata/RHBA-2000013-01.html and consult your '
                    . 'distribution\'s documentation for instructions on how '
                    . 'to upgrade your kernel.' . "\n\n", 0);
    }
  }

  # CONFIG_UMISC on 2.0 kernels
  if ($gSystem{'version_integer'} < kernel_version_integer(2, 1, 0)) {
    if (   (direct_command(shell_string($gHelper{'grep'}) . ' '
                           . shell_string('^[0-9a-fA-F]\{8\} misc_register')
                           . ' /proc/ksyms') eq '')
        || (direct_command(shell_string($gHelper{'grep'}) . ' '
                           . shell_string('^[0-9a-fA-F]\{8\} misc_deregister')
                           . ' /proc/ksyms') eq '')) {
      error('You are running a Linux kernel version '
            . $gSystem{'version_utsclean'} . ' that was not built with the '
            . 'CONFIG_UMISC configuration parameter set.  '
            . vmware_product_name() . ' will not run on this system.'
            . "\n\n");
    }
  }

  # 3Com bug on 2.0.3[45] kernels
  if (   ($gSystem{'version_integer'} >= kernel_version_integer(2, 0, 34))
      && ($gSystem{'version_integer'} <= kernel_version_integer(2, 0, 35))) {
    if (   (not (-r '/proc/ioports'))
        || (not (direct_command(shell_string($gHelper{'grep'}) . ' -i '
                                . shell_string('3c90\|3c59')
                                . ' /proc/ioports') eq ''))) {
      if (get_answer('You are running Linux version '
                     . $gSystem{'version_utsclean'} . ' possibly with a 3Com '
                     . 'networking card.  Linux kernel versions 2.0.34 and '
                     . '2.0.35 have a bug in the 3Com driver that interacts '
                     . 'badly with this product.  Specifically, your physical '
                     . 'machine will occasionally hang and will require a '
                     . 'hard reset.  This bug has been fixed in 2.0.36 and '
                     . 'later kernels.  Do you want to continue the '
                     . 'configuration anyway?', 'yesno', 'no') eq 'no') {
         exit 1;
      }
    }
  }

  # C library
  # XXX This relies on the locale
  if (system(shell_string($gHelper{'ldd'}) . ' '
             . shell_string(vmware_vmx_app_name()) . ' | '
             . shell_string($gHelper{'grep'}) . ' -q -i '
             . shell_string('not found')) == 0) {
    print wrap('The correct version of one or more libraries needed to run '
               . vmware_product_name()
               . ' may be missing.  This is the output of '
               . $gHelper{'ldd'} . ' ' . db_get_answer('BINDIR') . '/vmware:'
               . "\n", 0);
    system(shell_string($gHelper{'ldd'}) . ' '
           . shell_string(vmware_vmx_app_name()));
    print "\n";
    query('This program cannot tell for sure, but you may need to upgrade '
          . 'libc5 to glibc before you can run ' . vmware_product_name()
          . ".\n\n"
          . 'Hit enter ' . 'to continue.', '', 0);
  }

  # Processor
  foreach my $instruction ('^cpuid', 'cmov') {
    if (direct_command(shell_string($gHelper{'grep'}) . ' '
        . shell_string($instruction) . ' /proc/cpuinfo') eq '') {
      error('Your ' . (($gSystem{'smp'} eq 'yes') ? 'processors do'
                                                  : 'processor does') . ' not '
            . 'support the ' . $instruction . ' instruction. '
            . vmware_product_name() . ' will not run on this system.' . "\n\n");
    }
  }
  # The "flags" field became the "features" field in 2.4.0-test11-pre5 --hpreg
  if (direct_command(shell_string($gHelper{'grep'}) . ' '
                     . shell_string('^\(flags\|features\).* tsc')
                     . ' /proc/cpuinfo') eq '') {
    error('Your ' . (($gSystem{'smp'} eq 'yes') ? 'processors do'
                                                : 'processor does') . ' not '
          . 'have a Time Stamp Counter.  ' . vmware_product_name()
          . ' will not run on this system.' . "\n\n");
  }
}

# Point the user to a URL dealing with module-related problems and exits
sub module_error {
  error('For more information on how to troubleshoot module-related problems, '
        . 'please visit our Web site at "http://www.vmware.com/download'
        . '/modules/modules.html" and "http://www.vmware.com/support/reference'
        . '/linux/prebuilt_modules_linux.html".' . "\n\n");
}

# Install a module if it suitable
# Return 1 if success, 0 if failure
sub try_module {
  my $name = shift;
  my $mod = shift;
  my $force = shift;
  my $silent = shift;
  my $dst_dir;
  my %patch;

  if (not (-e $mod)) {
    # The module does not exist
    return 0;
  }

  if (not (vmware_product() eq 'server')) {
    # Probe the module without loading it or executing its code.  It is cool
    # because it avoids problems like 'Device or resource busy'
    # Note: -f bypasses only the kernel version check, not the symbol
    # resolution
    if (system(shell_string($gHelper{'insmod'}) . ' -p '
               . ($force ? '-f ' : '') . shell_string($mod)
               . ($silent ? ' >/dev/null 2>&1' : ''))) {
      return 0;
    }
    # If we are using new module-init-tools, they just ignore
    # '-p' option, and they just loaded module into the memory.
    # Just try rmmod-ing it. Silently.
    system(shell_string($gHelper{'rmmod'}) . ' ' . shell_string($name)
    	   . ' >/dev/null 2>&1');
  }

  if (-d $cKernelModuleDir . '/'. $gSystem{'uts_release'}) {
    $dst_dir = $cKernelModuleDir . '/' . $gSystem{'uts_release'};
  } else {
    print wrap('This program does not know where to install the ' . $name
               . ' module because the "' . $cKernelModuleDir . '/'
               . $gSystem{'uts_release'} . '" directory (the usual '
               . 'location where the running kernel would look for the '
               . 'module) is missing.  Please make sure that this '
               . 'directory exists before re-running this program.'
               . "\n\n", 0);
    return 0;
  }
  create_dir($dst_dir . '/misc', 0x1);
  undef %patch;
  # Install the module with a .o extension, as the Linux kernel does
  install_file($mod, $dst_dir . '/misc/' . $name . '.o', \%patch, 0x1);
  # The old installer allowed people to manually build modules without .o
  # extension.  Such modules were not removed by the old uninstaller, and
  # unfortunately, insmod tries them first.  Let's move them.
  if (file_name_exist($dst_dir . '/misc/' . $name)) {
    backup_file($dst_dir . '/misc/' . $name);
    if (not unlink($dst_dir . '/misc/' . $name)) {
      print STDERR wrap('Unable to remove the file ' . $dst_dir . '/misc/'
                        . $name . '.' . "\n\n", 0);
    }
  }

  return 1;
}

# Remove a temporary directory
sub remove_tmp_dir {
  my $dir = shift;

  if (system(shell_string($gHelper{'rm'}) . ' -rf ' . shell_string($dir))) {
    print STDERR wrap('Unable to remove the temporary directory ' . $dir . '.'
                      . "\n\n", 0);
  };
}

sub get_cc {
  $gHelper{'gcc'} = '';
  if (defined($ENV{'CC'}) && (not ($ENV{'CC'} eq ''))) {
    $gHelper{'gcc'} = internal_which($ENV{'CC'});
    if ($gHelper{'gcc'} eq '') {
      print wrap('Unable to find the compiler specified in the CC environnment variable: "'
                 . $ENV{'CC'} . '".' . "\n\n", 0);
    }
  }
  if ($gHelper{'gcc'} eq '') {
    $gHelper{'gcc'} = internal_which('gcc');
    if ($gHelper{'gcc'} eq '') {
      $gHelper{'gcc'} = internal_which('egcs');
      if ($gHelper{'gcc'} eq '') {
        $gHelper{'gcc'} = internal_which('kgcc');
        if ($gHelper{'gcc'} eq '') {
          $gHelper{'gcc'} = DoesBinaryExist_Prompt('gcc');
        }
      }
    }
  }
  print wrap('Using compiler "' . $gHelper{'gcc'}
             . '". Use environment variable CC to override.' . "\n\n", 0);
  return $gHelper{'gcc'};
}

# Verify gcc version
sub check_gcc_version {
  my ($gcc_version) = @_;
  my ($kernel_gcc_version) = undef;

  if (open(PROC_VERSION, '</proc/version')) {
    my $line;
    if (defined($line = <PROC_VERSION>)) {
      close PROC_VERSION;
      if ($line =~ /gcc version (egcs-)?(\d+(\.\d+)*)/) {
        $kernel_gcc_version = $2;
        if ($kernel_gcc_version eq $gcc_version) {
          return 'yes';
        }
      }
    } else {
      close PROC_VERSION;
    }
  }
  my $msg;
  my $g_m = '0';
  if ($gcc_version =~ /^(\d+)\./) {
    $g_m = $1;
  }
  if (defined($kernel_gcc_version)) {
    my $k_m = '0';

    if ($kernel_gcc_version =~ /^(\d+)\./) {
      $k_m = $1;
    }
    $msg = 'Your kernel was built with "gcc" version "' . $kernel_gcc_version .
           '", while you are trying to use "' . $gHelper{'gcc'} . 
           '" version "' . $gcc_version . '". ';
    if ($g_m ne $k_m) {
      $msg .= 'This configuration is not supported and ' . 
              vmware_product_name() . ' cannot work in such configuration. ' .
              'Please either recompile your kernel with "' . $gHelper{'gcc'} .
              '" version "'. $gcc_version . '", or restart ' . $0 . 
              ' with CC environment variable pointing to the "gcc" version "' .
              $kernel_gcc_version . '".' . "\n\n";
      print wrap($msg, 0);
      return 'no';
    }
    $msg .= 'This configuration is not recommended and ' .
            vmware_product_name() . ' may crash if you\'ll continue. ' .
            'Please try to use exactly same compiler as one used for ' .
            'building your kernel. Do you want to go with compiler "' .
            $gHelper{'gcc'} .'" version "' . $gcc_version .'" anyway?';
  } else {
    if ($g_m >= 3) {
      $msg = 'As of September 2003, the Linux kernel development team does not '
             . 'support gcc version 3 and later. See Documentation/Changes in '
             . 'your kernel source directory for information on installing the '
             . 'correct compiler. Do you want to use the version "'
             . $gcc_version . '" of compiler "' . $gHelper{'gcc'} . '"?';
    }
  }
  if (defined($msg) and get_answer($msg, 'yesno', 'no') eq 'no') {
    return 'no';
  }
  return 'yes';
}

# Build a module
sub build_module {
  my $name = shift;
  my $dir = shift;
  my $ideal = shift;
  my $build_dir;
  my $gcc_version;

  # Lazy initialization
  if ($gFirstModuleBuild == 1) {
    my $program;
    my $headerdir;

    foreach $program ('make', 'echo', 'tar', 'rm') {
      if (not defined($gHelper{$program})) {
        $gHelper{$program} = DoesBinaryExist_Prompt($program);
        if ($gHelper{$program} eq '') {
          return 'no';
        }
      }
    }

    if (get_cc() eq '') {
      return 'no';
    }

    $gcc_version = direct_command(shell_string($gHelper{'gcc'})
                                  . ' -dumpversion');
    chomp($gcc_version);
    if ($gcc_version =~ /^(egcs-)?(\d+(\.\d+)*)/) {
      $gSystem{'gcc_version'} = $2;
    } else {
      print wrap('Your compiler "' . $gHelper{'gcc'} . '" version "' .
		 $gcc_version . '" is not supported ' .
                 'by this version of ' . vmware_product_name() . '.' . 
		 "\n\n", 0);
      return 'no';
    }

    if (check_gcc_version($gSystem{'gcc_version'}) eq 'no') {
      return 'no';
    }

    # When installing the modules, kernels 2.4+ setup a symlink to the kernel
    # source directory
    $headerdir = $cKernelModuleDir . '/preferred/build/include';
    if (check_answer_headerdir($headerdir, 'default') eq '') {
      $headerdir = $cKernelModuleDir . '/' . $gSystem{'uts_release'}
                   . '/build/include';
      if (check_answer_headerdir($headerdir, 'default') eq '') {
        # Use a default usual location
        $headerdir = '/usr/src/linux/include';
      }
    }
    get_persistent_answer('What is the location of the directory of C header '
                          . 'files that match your running kernel?',
                          'HEADER_DIR', 'headerdir', $headerdir);

    $gFirstModuleBuild = 0;
  }

  print wrap('Extracting the sources of the ' . $name . ' module.' . "\n\n",
             0);
  $build_dir = make_tmp_dir($cTmpDirPrefix);

  if (system(shell_string($gHelper{'tar'}) . ' -C ' . shell_string($build_dir)
             . ' -xopf ' . shell_string($dir . '/' . $name . '.tar'))) {
    print wrap('Unable to untar the "' . $dir . '/' . $name . '.tar'
               . '" file in the "' . $build_dir . '" directory.' . "\n\n", 0);
    return 'no';
  }

  print wrap('Building the ' . $name . ' module.' . "\n\n", 0);
  if (system(shell_string($gHelper{'make'}) . ' -C '
             . shell_string($build_dir . '/' . $name . '-only')
             . ' auto-build ' . (($gSystem{'smp'} eq 'yes') ? 'SUPPORT_SMP=1 '
                                                            : '')
             . shell_string('HEADER_DIR=' . db_get_answer('HEADER_DIR')) . ' '
             . shell_string('CC=' . $gHelper{'gcc'}) . ' '
             . shell_string('GREP=' . $gHelper{'grep'}) . ' '
             . shell_string('IS_GCC_3='
             . (($gSystem{'gcc_version'} =~ /^3\./) ? 'yes' : 'no')))) {
    print wrap('Unable to build the ' . $name . ' module.' . "\n\n", 0);
    return 'no';
  }

  # Don't use the force flag: the module is supposed to perfectly load
  if (try_module($name, $build_dir . '/' . $name . '.o', 0, 1)) {
    print wrap('The module loads perfectly in the running kernel.' . "\n\n",
               0);
    remove_tmp_dir($build_dir);
    return 'yes';
  }

  # Don't remove the build dir so that the user can investiguate
  print wrap('Unable to make a ' . $name . ' module that can be loaded in the '
             . 'running kernel:' . "\n", 0);
  try_module($name, $build_dir . '/' . $name . '.o', 0, 0);
  # Try to analyze some usual suspects
  if ($gSystem{'build_bug'} eq 'yes') {
    print wrap('It appears that your running kernel has not been built from a '
               . 'kernel source tree that was completely clean (i.e. the '
               . 'person who built your running kernel did not use the "make '
               . 'mrproper" command).  You may want to ask the provider of '
               . 'your Linux distribution to fix the problem.  In the '
               . 'meantime, you can do it yourself by rebuilding a kernel '
               . 'from a kernel source tree that is completely clean.'
               . "\n\n", 0);
  } else {
    print wrap('There is probably a slight difference in the kernel '
               . 'configuration between the set of C header files you '
               . 'specified and your running kernel.  You may want to rebuild '
               . 'a kernel based on that directory, or specify another '
               . 'directory.' . "\n\n", 0);
  }
  return 'no';
}

# Create a list of modules suitable for the running kernel
# The kernel module loader does quite a good job when modules are versioned.
# But in the other case, we must be _very_ careful
sub get_suitable_modules {
  my $dir = shift;
  my @list;
  my $candidate;

  @list = ();
  foreach $candidate (internal_ls($dir)) {
    my %prop;

    # Read the properties file
    if (not open(PROP, '<' . $dir . '/' . $candidate . '/properties')) {
      print STDERR wrap('Unable to open the property file "' . $dir . '/'
                        . $candidate . '/properties".  Skipping this kernel.'
                        . "\n\n", 0);
      next;
    }
    undef %prop;
    while (<PROP>) {
      if (/^UtsVersion (.+)$/) {
        $prop{'UtsVersion'} = $1;
      } elsif (/^(\S+) (\S+)/) {
        $prop{$1} = $2;
      }
    }
    close(PROP);

    if (not (lc($gSystem{'smp'}) eq lc($prop{'SMP'}))) {
      # SMP does not match
      next;
    }
    if (defined($gSystem{'page_offset'}) and 
        not (lc($gSystem{'page_offset'}) eq lc($prop{'PageOffset'}))) {
      # Page offset does not match
      next;
    }

    if ($gSystem{'uts_release'} eq $prop{'UtsRelease'}
        && (!defined($prop{'UtsVersion'})
            || $gSystem{'uts_version'} eq $prop{'UtsVersion'})) {
      # Perfect match.  Try this module first
      unshift(@list, ($candidate, $prop{'ModVersion'}));
    } else {
      # This is a problem in some cases even with symbol versionning.
      # See bug number 18371.
      # --Jeremy Bar
      if ($gOption{'try-modules'} == 1) {
        push(@list, ($candidate, $prop{'ModVersion'}));
      }
    }
  }

  return @list;
}

# Configure a module
sub configure_module {
  my $name = shift;
  my $mod_dir;

  if (defined($gDBAnswer{'ALT_MOD_DIR'})
      && ($gDBAnswer{'ALT_MOD_DIR'} eq 'yes')) {
    $mod_dir = db_get_answer('LIBDIR') . '/modules.new';
  } else {
    $mod_dir = db_get_answer('LIBDIR') . '/modules';
  }

  if ($gOption{'compile'} == 1) {
    db_add_answer('BUILDR_' . $name, 'yes');
  } else {
    my @mod_list;

    print wrap('Trying to find a suitable ' . $name
               . ' module for your running kernel.' . "\n\n", 0);
    @mod_list = get_suitable_modules($mod_dir . '/binary');
    while ($#mod_list > -1) {
      my $candidate = shift(@mod_list);
      my $modversion = shift(@mod_list);

      # Note: When using the force flag,
      #        Non-versioned modules can load into a     versioned kernel.
      #            Versioned modules can load into a non-versioned kernel.
      #
      # Consequently, it is only safe to use the force flag if _both_ the
      # kernel and the module are versioned.
      # This is not always the case as demonstrated by bug 18371.

      if (try_module($name,
                     $mod_dir . '/binary/' . $candidate . '/objects/'
                     . $name . '.o',
                        ($gSystem{'versioned'} eq 'yes')
                     && ($modversion eq 'yes'), 1)) {
        print wrap('The module ' . $candidate . ' loads perfectly in the '
                   . 'running kernel.' . "\n\n", 0);
        return 'yes';
      }
    }

    if ($gOption{'prebuilt'} == 1) {
      db_add_answer('BUILDR_' . $name, 'no');
      print wrap('None of the pre-built ' . $name . ' modules for '
		 . vmware_product_name() . ' is suitable for your '
		 . 'running kernel.' . "\n\n", 0);
      return 'no';
    }

    if (get_persistent_answer('None of the pre-built ' . $name . ' modules for '
			      . vmware_product_name() . ' is suitable '
                              . 'for your running kernel.  Do you want this '
                              . 'program to try to build the ' . $name
                              . ' module for your system (you need to have a '
                              . 'C compiler installed on your system)?',
                              'BUILDR_' . $name, 'yesno', 'yes') eq 'no') {
      return 'no';
    }
  }

  if (build_module($name, $mod_dir . '/source') eq 'no') {
    return 'no';
  }
  $gOption{'compile'} = 1;
  return 'yes';
}

sub configure_module_bsd {
  my %patch;
  undef %patch;
  my $dir = db_get_answer('LIBDIR') . '/modules/binary/FreeBSD';
  if ($gSystem{'uts_version'} =~ /FreeBSD 3/) {
    install_file($dir . '3.2/vmmemctl.ko', '/modules/vmmemctl.ko',
                 \%patch, 0x1);
  } elsif ($gSystem{'uts_version'} =~ /FreeBSD 4/) {
    install_file($dir . '4.0/vmmemctl.ko', '/modules/vmmemctl.ko',
                 \%patch, 0x1);
  }
}

# Create a device name
sub configure_dev {
  my $name = shift;
  my $major = shift;
  my $minor = shift;
  my $chr = shift;
  my $type;
  my $typename;

  if ($chr == 1) {
    $type = 'c';
    $typename = 'character';
  }
  else {
    $type = 'b';
    $typename = 'block';
  }
  uninstall_file($name);
  if (-e $name) {
    if (-c $name) {
      my @statbuf;

      @statbuf = stat($name);
      if (   defined($statbuf[6])
          && (($statbuf[6] >> 8) == $major)
          && (($statbuf[6] & 0xFF) == $minor)
          && ($chr == 1 && ($statbuf[2] & 0020000) != 0 ||
               $chr == 0 && ($statbuf[2] & 0020000) == 0)) {
         # The device is already correctly configured
         return;
      }
    }

    if (get_answer('This program wanted to create the ' . $typename . ' device '
                   . $name . ' with major number ' . $major . ' and minor '
                   . 'number ' . $minor . ', but there is already a different '
                   . 'kind of file at this location.  Overwrite?', 'yesno',
                   'yes') eq 'no') {
      error('Unable to continue.' . "\n\n");
    }

    # mknod doesn't like when the file already exists
    unlink($name);
  }

  if (system(shell_string($gHelper{'mknod'}) . ' ' . shell_string($name) . ' '
             . shell_string($type) . ' ' . shell_string($major) . ' '
             . shell_string($minor))) {
    error('Unable to create the ' . $typename . ' device ' . $name . ' with '
          . 'major number ' . $major . ' and minor number ' . $minor . '.'
          . "\n\n");
  }
  safe_chmod(0600, $name);
  # These "files" don't have a content, don't timestamp them
  db_add_file($name, 0);
}

# Configuration related to the monitor
sub configure_mon {
  if (configure_module('vmmon') eq 'no') {
    module_error();
  }
  if (-e '/dev/.devfsd') {
    # The "devfs" filesystem is mounted on the "/dev" directory, so the
    # "/dev/vmmon" block device file is magically created/removed when the
    # "vmmon" module is loaded/unloaded (was bug 15571) --hpreg
  } else {
    configure_dev('/dev/vmmon', 10, 165, 1);
  }
}

# Configuration related to parallel ports
sub configure_pp {
  my $i;

  if ($gSystem{'version_integer'} < kernel_version_integer(2, 1, 127)) {
    query('You are running Linux version ' . $gSystem{'version_utsclean'}
          . ', and this kernel cannot provide ' . vmware_product_name()
          . ' with Bidirectional Parallel Port support.  A fully-featured '
          . vmware_product_name() . ' requires Linux version 2.1.127 or '
          . 'higher.' . "\n\n" . 'Without this support, '
          . vmware_product_name() . ' will run flawlessly, but will lack the '
          . 'ability to use parallel ports in a bidirectional way.  This '
          . 'means that it is possible that some parallel port devices '
          . '(scanners, dongles, ...) will not work inside a virtual machine.'
          . "\n\n" . 'Hit enter to continue.', '', 0);
    return;
  }

  if ($gSystem{'version_integer'} <= kernel_version_integer(2, 3, 9)) {
    # Those kernels don't support ppdev.  We need to supply our vmppuser module

    print wrap('Making sure that both the parport and parport_pc kernel '
               . 'services are available.' . "\n\n", 0);

    # The vmppuser module relies on the parport modules.  Let's
    # make sure it is loaded before beginning our tests
    if (direct_command(shell_string($gHelper{'grep'}) . '  '
                       . shell_string(' parport_release[^' . "\t" . ']*$')
                       . ' /proc/ksyms') eq '') {
      # This comment fixes emacs's broken syntax highlighting
      # parport support is not built in the kernel
      if (system(shell_string($gHelper{'modprobe'})
                 . ' parport >/dev/null 2>&1')) {
        query('Unable to load the parport module that is required by the '
              . 'vmppuser module.  You may want to load it manually before '
              . 're-running this program.' . "\n\n" . 'Without this support, '
              . vmware_product_name() . ' will run flawlessly, but will lack '
              . 'the ability to use parallel ports in a bidirectional way.  '
              . 'This means that it is possible that some parallel port '
              . 'devices (scanners, dongles, ...) will not work inside a '
              . 'virtual machine.' . "\n\n"
              . 'Hit enter to continue.', '', 0);
        return;
      }
    }

    # The vmppuser module relies on the parport_pc modules.  Let's
    # make sure it is loaded before beginning our tests
    if (direct_command(shell_string($gHelper{'grep'}) . '  '
                       . shell_string(' parport_pc_[^' . "\t" . ']*$')
                       . ' /proc/ksyms') eq '') {
      # This comment fixes emacs's broken syntax highlighting
      # parport_pc support is not built in the kernel
      if (system(shell_string($gHelper{'modprobe'})
                 . ' parport_pc >/dev/null 2>&1')) {
        query('Unable to load the parport_pc module that is required by the '
              . 'vmppuser module.  You may want to load it manually before '
              . 're-running this program.' . "\n\n" . 'Without this support, '
              . vmware_product_name() . ' will run flawlessly, but will lack '
              . 'the ability to use parallel ports in a bidirectional way.  '
              . 'This means that it is possible that some parallel port '
              . 'devices (scanners, dongles, ...) will not work inside a '
              . 'virtual machine.' . "\n\n" . 'Hit enter to continue.', '', 0);
        return;
      }
    }

    if (configure_module('vmppuser') eq 'no') {
      module_error();
    }

    # Try to unload the modules.  Failure is allowed because some other
    # process could be using them.
    system(shell_string($gHelper{'modprobe'})
           . ' -r parport_pc >/dev/null 2>&1');
    system(shell_string($gHelper{'modprobe'}) . ' -r parport >/dev/null 2>&1');
  }

  # The parport numbering scheme in 2.2.X is confusing:
  # Because devices can be daisy-chained on a port, the first port
  # (/proc/parport/0) is /dev/parport0, but the second one (/proc/parport/1)
  # is /dev/parport16 (not /dev/parport1), and so on...

  # This message is wrong.  I have found no evidence for this.
  # On all the linux machines that I've looked at /dev/parport1 is the 2nd port
  # That's my story and I'm sticking to it  - DavidE

  for ($i = 0; $i < 4; $i++) {
    configure_dev('/dev/parport' . $i, 99, $i, 1);
  }
}

# Configuration of the vmmemctl tools device
sub configure_vmmemctl {
  # For the time being, only ESX uses the vmmemctl driver.
  if ($gSystem{'product'} =~ /ESX/) {
    if (vmware_product() eq 'tools-for-freebsd') {
      configure_module_bsd('vmmemctl');
    } else {
      if (configure_module('vmmemctl') eq 'no') {
        query('The memory manager driver (vmmemctl module) is used by '
              . 'VMware host software to efficiently reclaim memory from a '
              . 'virtual machine.' . "\n"
              . 'If the driver is not available, VMware host software may '
              . 'instead need to swap guest memory to disk, which may reduce '
              . 'performance.' . "\n"
              . 'The rest of the software provided by '
              . vmware_product_name()
              . ' is designed to work independently of '
              . 'this feature.' . "\n"
              . 'If you want the memory management feature,'
              . $cModulesBuildEnv
              . "\n", ' Press Enter key to continue ', 0);
        db_add_answer('VMMEMCTL_CONFED', 'no');
      } else {
        db_add_answer('VMMEMCTL_CONFED', 'yes');
      }
    }
  }
}

# Configuration of the vmhgfs tools device
sub configure_vmhgfs {
  # vmhgfs is supported only since 2.4.0
  if ($gSystem{'uts_release'} =~ /^(\d+)\.(\d+)/ &&
      $1 * 1000 + $2 >= 2004) {
    create_dir('/mnt/hgfs', 0x1);
    if (configure_module('vmhgfs') eq 'no') {
      query('The filesystem driver (vmhgfs module) is used only for the '
            . 'shared folder feature. '
            . 'The rest of the software provided by '
            . vmware_product_name()
            . ' is designed to work independently of '
            . 'this feature.' . "\n"
            . 'If you wish to have the shared folders feature,'
            . $cModulesBuildEnv
            . "\n", ' Press Enter key to continue ', 0);
      db_add_answer('VMHGFS_CONFED', 'no');
    } else {
      db_add_answer('VMHGFS_CONFED', 'yes');
    }
  }
}

#
# This function is taken from the old tools installer.
# The first argument is a complete path to a file which will be read and 
# overwritten with the result.
# The second argument will be only read and should be the system file present
# before configuration.
#
sub configure_modules_dot_conf {
  my ($newModulesConf, $systemModulesConf, $ethAliases, $sounddrv, $soundopt) = @_;
  my $inline;
  my $soundfound;
  my %emittedAliases = ();

  if (not file_name_exist($systemModulesConf)) {
    my %patch;
    undef %patch;
    internal_sed('/dev/null', $systemModulesConf, 0, \%patch);
  }

  if (not open(SYSMODCONF, "<$systemModulesConf")) {
    error('Unable to open the file "' . $systemModulesConf . '".' . "\n\n");
  }

  if (not open(NEWMODCONF, ">$newModulesConf")) {
    error('Unable to open the file "' . $newModulesConf . '".' . "\n\n");
  }

  # Look for matches and selectively replace drivers
  $soundfound = 0;
  while (defined($inline = <SYSMODCONF>)) {
    if ($inline =~ /^\s*(\w+)\s+(\w+)/) {
      my ($cmd, $val) = ($1, $2);

      if ($cmd eq 'alias') {
	if ($val eq 'sound') {
	  $inline = sprintf 'alias sound %s' . "\n", $sounddrv;
	  $inline .= $soundopt;
	  $soundfound = 1;
	} elsif ($val eq 'char-major-14') {
	  $inline = sprintf 'alias char-major-14 %s' . "\n", $sounddrv;
          $inline .= $soundopt;
	  $soundfound = 1;
	} elsif (defined($ethAliases->{$val})) {
	  $inline = 'alias ' . $val . ' ' . $ethAliases->{$val} . "\n";
	  $emittedAliases{$val} = 1;
	}
      } elsif ($cmd eq 'options') {
	if ($soundfound and $inline eq $soundopt) {
	  # Silently remove sound options line if we already generated identical one
	  $inline = '';
	} elsif ($val eq $sounddrv) {
	  $inline = '# Commented out by ' . vmware_product_name() . "\n" . '# ' . $inline;
	}
      }
    }
    print NEWMODCONF $inline;
  }

  my @output;

  # Then pick up any drivers we haven't got yet.
  foreach my $key (sort keys %$ethAliases) {
    if (not defined($emittedAliases{$key})) {
      push @output, sprintf("alias %s %s\n", $key, $ethAliases->{$key});
    }
  }
  if ($soundfound == 0) {
    push @output, sprintf("alias char-major-14 %s\n", $sounddrv);
    push @output, $soundopt;
  }
  if (scalar @output) {
    print NEWMODCONF "# Added by " . vmware_product_name() . "\n";
    print NEWMODCONF join('', @output);
  }
  close (SYSMODCONF);
  close (NEWMODCONF);
}

# Enumerate devices we are interested on. Returns array of 3 elements,
# where first element is number of vmxnet adapters, second element
# is number of pcnet32 adapters, and third element is number of es1371
# adapters. We do not attempt to find ISA vlance or sb.
sub get_devices_list {
  my ($vmxnet, $pcnet32, $es1371) = (0, 0, 0);

  if (open LSPCI, 'LANG=C ' . shell_string($gHelper{'lspci'}) . ' -n |') {
    my $line;

    while (defined($line = <LSPCI>)) {
      $line = lc($line);
      if ($line =~ /class [0-9a-f]{4}: ([0-9a-f]{4}:[0-9a-f]{4})/) {
	if ($1 eq '1022:2000') {
	  $pcnet32++;
        } elsif ($1 eq '15ad:0720') {
	  $vmxnet++;
	} elsif ($1 eq '1274:1371') {
	  $es1371++;
	}
      }
    }
    close LSPCI;
  }
  return ($vmxnet, $pcnet32, $es1371);
}

sub is_vmxnet_present {
  my ($vmxnet);

  ($vmxnet) = get_devices_list();
  return $vmxnet ? 'yes' : 'no';
}

# Configuration of the vmxnet tools network device
sub write_module_config {
  my ($vmxnet, $pcnet32, $es1371) = get_devices_list();
  my %ethernet = ();
  my $ethidx = 0;
  my $sounddrv;
  my $soundopt;

  if ($vmxnet) {
    if (configure_module('vmxnet') eq 'no') {
      query('The fast network device driver (vmxnet module) is used only for '
            . 'our fast networking interface. '
            . 'The rest of the software provided by '
            . vmware_product_name()
            . ' is designed to work independently of '
            . 'this feature.' . "\n"
            . 'If you wish to have the fast network driver enabled,'
            . $cModulesBuildEnv
            . "\n", ' Press Enter key to continue ', 0);
      db_add_answer('VMXNET_CONFED', 'no');
      $vmxnet = 0;
    } else {
      my $i;

      db_add_answer('VMXNET_CONFED', 'yes');
      for ($i = 0; $i < $vmxnet; $i++) {
        $ethernet{'eth' . $ethidx} = 'vmxnet';
	$ethidx++;
      }
    }
  }
  if ($pcnet32) {
    my $i;

    for ($i = 0; $i < $pcnet32; $i++) {
      $ethernet{'eth' . $ethidx} = 'pcnet32';
      $ethidx++;
    }
  }
  if ($es1371) {
    $sounddrv = 'es1371';
    # No sound options for es1371
    $soundopt = '';
  } else {
    $sounddrv = 'sb';
    # Assume soundblaster if no es1371 found
    if ($gSystem{'version_integer'} < kernel_version_integer(2, 2, 0)) {
      $soundopt = 'options sb io=0x220 irq=5 dma=1,5' . "\n";
    } else {
      $soundopt = 'options sb io=0x220 irq=5 dma=1 dma16=5 mpu_io=0x330' . "\n";
    }
  }
  # Save the files we have to change.
  my $modules_file = file_name_exist('/etc/conf.modules') ?
                     '/etc/conf.modules' : '/etc/modules.conf';

  backup_file_to_restore($modules_file, 'MODULES_CONF');

  configure_modules_dot_conf($modules_file, $modules_file . $cBackupExtension, 
			     \%ethernet, $sounddrv, $soundopt);
}

sub xserver_bin {
  return '/usr/X11R6/bin';
}

sub xserver4 {
  return xserver_bin() . '/XFree86';
}

sub xserver3 {
  return xserver_bin() . '/XF86_VMware';
}

sub xconfig_file_abs_path {
  my $xconfig_path = shift;
  my $xconfig_file_name = shift;
  return $xconfig_path . '/' . $xconfig_file_name;
}

#
# path_compare(dir, path1, path2)
#
# Compare the two paths, and return true if they are identical
# Evaluate the paths with respect to the passed in directory
#
sub path_compare {
  my ($dir, $path1, $path2) = @_;

  # Prepend directory for relative paths
  $path1 =~ s|^([^/])|$dir/$1|;
  $path2 =~ s|^([^/])|$dir/$1|;

  # Squash out ..'s in paths
  while ($path1 =~ /\/.*\/\.\.\//) {
    $path1 =~ s|/[^/]*/\.\./|/|;
  }

  while ($path2 =~ /\/.*\/\.\.\//) {
    $path2 =~ s|/[^/]*/\.\./|/|;
  }

  # Squash out .'s in paths
  while ($path1 =~ /\/\.\//) {
    $path1 =~ s|/\./|/|;
  }

  while ($path2 =~ /\/\.\//) {
    $path2 =~ s|/\./|/|;
  }

  # Squash out //'s in paths
  while ($path1 =~ /\/\//) {
    $path1 =~ s|//|/|;
  }

  while ($path2 =~ /\/\//) {
    $path2 =~ s|//|/|;
  }

  if ($path1 eq $path2) {
    return 'yes';
  } else {
    return 'no';
  }
}

# check_link 
# Checks that a given link is pointing to the given file.
sub check_link {
  my $file = shift;
  my $link = shift;
  my $linkDest;
  my $dirname;
  $linkDest = readlink($link);
  if (!defined $linkDest) {
    return 'no';
  }
  $dirname = internal_dirname($link);
  return path_compare($dirname, $linkDest, $file);
}

# Install one symbolic link
sub install_symlink {
  my $to = shift;
  my $name = shift;

  uninstall_file($name);
  if (file_check_exist($name)) {
    return;
  }
  # The file could be a symlink to another location.  Remove it
  unlink($name);
  if (not symlink($to, $name)) {
    error('Unable to create symbolic link "' . $name . '" pointing to file "'
          . $to . '".' . "\n\n");
  }
  db_add_file($name, 0);
}

my $gLinkCount = 0;
sub symlink_if_needed {
  my $file = shift;
  my $link = shift;
  if (file_name_exist($file)) {
    if (-l $link && check_link($file, $link) eq 'yes') {
      return;
    }
    $gLinkCount = $gLinkCount + 1;
    backup_file_to_restore($link, 'LINK_' . $gLinkCount);
    install_symlink($file, $link);
  }
}

sub set_uid_X_server {
  my $x_server_file = shift;
  if (!-u $x_server_file) {
    safe_chmod(04711, $x_server_file);
  }
}

sub split_X_version {

  my $xversionAll = shift;
  my $major;
  my $minor;
  my $sub;

  if ($xversionAll =~ /(\d+)\.(\d+)\.?(\d*)/) {
    $major = $1;
    $minor = $2;
    $sub = $3 eq '' ? 0 : $3;
  } else {
    $major = 0;
    $minor = 0;
    $sub = 0;
  }
  return ($major, $minor, $sub);
}

sub fix_X_link {
  my $x_version = shift;
  my $x_server_link;
  my $x_server_link_bin = xserver_bin() . '/X';
  my $x_wrapper_file_name = 'Xwrapper';
  my $x_wrapper_file = xserver_bin() . '/' . $x_wrapper_file_name;
  my $x_server_file = $x_version == 3 ? xserver3(): xserver4();
  my $x_server_file_name = internal_basename($x_server_file);

  # Case 1:
  # In this case, the Xwrapper is used if /etc/X11/X exists (could be broken)
  # _and_ /usr/X11R6/bin/X points to Xwrapper.
  # In this case, the Xwrapper will execute setuid anything /etc/X11/X
  # is pointing to. So /etc/X11/X has to be pointing to the correct X
  # server, this is XFree86 if XFree 4 is used, our driver if XFree 3 is ueed.
  # WARNING: In this case, someone could very easily create a link /etc/X11/X
  # pointing to the Xwrapper, which, of course creates and infinite loop.
  # On SuSE, this mechanism is completely broken because Xwrapper tries to run
  # /usr/X11R6/bin/X !
  # In general, The wrapper is stupid.
  $x_server_link = '/etc/X11/X';
  if (-l $x_server_link &&
      check_link($x_wrapper_file, $x_server_link_bin) eq 'yes') {
    symlink_if_needed($x_server_file, $x_server_link);
    set_uid_X_server($x_server_file);
    return;
  }

  # Case 2:
  # This case is often encountered on a SuSE system.
  # Where /var/X11R6/bin/X is a little like /etc/X11/X but the Xwrapper is
  # never used on a SuSE system, of course, there could be special cases.
  # We might be tempted to zap the use of this var place
  # but startx checks for X link and refuses to start if not present in var.
  # Of course, it doesn't check where it points to :-)
  $x_server_link = '/var/X11R6/bin/X';
  if (-d internal_dirname($x_server_link)) {
    symlink_if_needed($x_server_file, $x_server_link);
    symlink_if_needed($x_server_link, $x_server_link_bin);
    set_uid_X_server($x_server_file);
    return;
  }

  # Case 3:
  # All the remaining cases, where the /usr/X11R6/bin/X bin link should be 
  # pointing to a setuid root X server.
  $x_server_link = '/usr/X11R6/bin/X';
  symlink_if_needed($x_server_file, $x_server_link_bin);
  set_uid_X_server($x_server_file);
}

sub xfree_4 {
  my $xconfig_path = '/etc/X11';
  my $xconfig_file_name = 'XF86Config-4';
  my $xversion = 4;
  my $xversionAll = '';
  my $X4DriverFile = '/usr/X11R6/lib/modules/drivers/vmware_drv.o';
  my $xserver_link = '';
  my $major;
  my $minor;
  my $sub;

  $xversionAll = direct_command(shell_string(xserver4()) . ' -version 2>&1') =~
    /XFree86 Version (\d+\.\d+\.?\d*)/ ? $1: '0.0.0';
  
  # The assumption here is that anything from X.org is 4.4.0. We have to do this 
  # right now because 'X -version' on X.org's server doesn't have a reliable version
  # string. Maybe it will once it settles down.
  if ($xversionAll eq "0.0.0") {
      $xversionAll = direct_command(shell_string(xserver4()) . ' -version 2>&1') =~
	  /X.org Foundation/ ? '4.4.0' : '0.0.0';
  }

  # This search order is issued from the XF86Config man page.
  if (defined $ENV{'XF86CONFIG'} && file_name_exist($xconfig_path . '/' .
      $ENV{'XF86CONFIG'})) {
    $xconfig_file_name = $ENV{'XF86CONFIG'};
  } elsif (defined $ENV{'XF86CONFIG'} &&
           file_name_exist('/usr/X11R6/etc/X11/' . $ENV{'XF86CONFIG'})) {
    $xconfig_path = '/usr/X11R6/etc/X11';
    $xconfig_file_name = $ENV{'XF86CONFIG'};
  } elsif (file_name_exist($xconfig_path . '/XF86Config-4')) {
    $xconfig_file_name = 'XF86Config-4';
  } elsif (file_name_exist($xconfig_path . '/XF86Config')) {
    # In this case, we are in the situation of having a mix between
    # XFree 3 and XFree 4, which is usually the case on RH 7.x and
    # Mandrake 7.x systems. As far as the syntax is concerned, XF86Config 
    # is the 3.x version and XF86Config-4 is the 4.x version. 
    # fix_X_conf patches some of the fields of the old config file into the new
    # one. There are issues if 3.x syntax fields are patched in a 4.x config
    # file. By providing a non existing file fix_X_conf will generate a correct
    # one or if the XF86Config file has the XFree 4 syntax, we can use it.
    # See bug 23196.
    # --Jeremy Bar
    if (direct_command(shell_string($gHelper{'grep'}) . ' '
                       . shell_string('.*') . ' ' . $xconfig_path
                       . '/XF86Config') =~ /Section\s+\"ServerLayout\"/i) {
      $xconfig_file_name = 'XF86Config';
    } else {
      $xconfig_file_name = 'XF86Config-4';
    }
  } elsif (file_name_exist('/etc/XF86Config')) {
    $xconfig_path = '/etc';
    $xconfig_file_name = 'XF86Config';
  } elsif (file_name_exist('/usr/X11R6/etc/X11/XF86Config-4')) {
    $xconfig_path = '/usr/X11R6/etc/X11';
    $xconfig_file_name = 'XF86Config-4';
  } elsif (file_name_exist('/usr/X11R6/etc/X11/XF86Config')) {
    $xconfig_path = '/usr/X11R6/etc/X11';
    $xconfig_file_name = 'XF86Config';
  }

  print wrap("\n\n" . 'Detected XFree86 version ' . $xversionAll . '.'
             . "\n\n", 0);

  # If there is an existing driver, replace it by ours.
  backup_file_to_restore($X4DriverFile, 'OLD_X4_DRV');

  ($major, $minor, $sub) = split_X_version($xversionAll);
  if ($major == $xversion) {
    if ($major == 4 && $minor == 2) {
      # For XFree 4.2.x, we need to replace xaa and shadowfb
      my $xaaDrv = '/usr/X11R6/lib/modules/libxaa.a';
      my $shadowFbDrv = '/usr/X11R6/lib/modules/libshadowfb.a';
      backup_file_to_restore($xaaDrv, 'OLD_X4_XAA_DRV');
      backup_file_to_restore($shadowFbDrv, 'OLD_X4_SHADOW_FB_DRV');
      unlink $xaaDrv;
      unlink $shadowFbDrv;
      if (file_name_exist($X4DriverFile)) {
        unlink $X4DriverFile;
      }
      my %p;
      undef %p;
      install_file(db_get_answer('LIBDIR')
                   . '/configurator/XFree86-4/4.2.x/libxaa.a',
                   $xaaDrv, \%p, 1);
      install_file(db_get_answer('LIBDIR')
                   . '/configurator/XFree86-4/4.2.x/libshadowfb.a',
                   $shadowFbDrv, \%p, 1);
      install_file(db_get_answer('LIBDIR')
                   . '/configurator/XFree86-4/4.2.x/vmware_drv.o',
                   $X4DriverFile, \%p, 1);
    } elsif ($minor > 2 && (not file_name_exist($X4DriverFile))) {
      # In this case, all the XAA and ShadowFB changes are present
      # in the XFree Code and we only need to install the latest
      # driver.
      my %p;
      undef %p;
      install_file(db_get_answer('LIBDIR')
                   . '/configurator/XFree86-4/4.3.x/vmware_drv.o',
                   $X4DriverFile, \%p, 1);
    } elsif ($minor < 2) {
      # The default, install the X free 4 driver which works with
      # the first versions of X.
      my %p;
      undef %p;
      if (file_name_exist($X4DriverFile)) {
        unlink $X4DriverFile;
      }
      install_file(db_get_answer('LIBDIR')
                   . '/configurator/XFree86-4/4.x/vmware_drv.o',
                   $X4DriverFile, \%p, 1);
    }
    # Absolute pointing device.
    if ($major == 4 && $minor >= 2) {
      my %p;
      undef %p;
      install_file(db_get_answer('LIBDIR')
                   . '/configurator/XFree86-4/4.2.x/vmmouse_drv.o',
                   $cX4MouseDriverFile, \%p, 1);
    }
    fix_X_link('4');
  } else {
    error ('Problem extracting verion of XFree 4' . "\n\n");
  }
  return ($xversion, xconfig_file_abs_path($xconfig_path, $xconfig_file_name),
          $xversionAll);
}

sub xfree_3 {
  my $xconfig_path = '/etc';
  my $xconfig_file_name = 'XF86Config';
  my $xversion = 3;
  my $xversionAll = 0;
  my $xserver3default = xserver_bin() . '/XF86_VGA16';
  my $xserver_link = '';

  $xversionAll = file_name_exist($xserver3default) ? 
              direct_command(shell_string($xserver3default) .
                             ' -version 2>&1') =~
                             /XFree86 Version (\d+\.\d+\.?\d*)/ ? $1: '3.0'
                             : '3.0';

  if (file_name_exist('/etc/XF86Config')) {
    $xconfig_path = '/etc';
    $xconfig_file_name = 'XF86Config';
  } elsif (file_name_exist('/usr/X11R6/lib/X11/XF86Config') &&
           (not -l '/usr/X11R6/lib/X11/XF86Config')) {
    $xconfig_path = '/usr/X11R6/lib/X11';
    $xconfig_file_name = 'XF86Config';
  } else {
    $xconfig_path = '/etc';
    $xconfig_file_name = 'XF86Config';
  }
  print wrap("\n\n" . 'Detected XFree86 version ' . $xversionAll . '.'
             . "\n\n", 0);

  if (file_name_exist(xserver3())) {
    backup_file(xserver3());
    unlink xserver3();
  }

  if (vmware_product() eq 'tools-for-freebsd' &&
      $gSystem{'uts_release'} =~ /^(\d+)\.(\d+)/ &&
      $1 >= 4 && $2 >= 5) {
    my %p;
    undef %p;
    install_file(db_get_answer('LIBDIR')
                 . '/configurator/XFree86-3/XF86_VMware_4.5',
                 xserver3(), \%p, 1);
  } else {
    my %p;
    undef %p;
    install_file(db_get_answer('LIBDIR')
                 . '/configurator/XFree86-3/XF86_VMware',
                 xserver3(), \%p, 1);
  }

  fix_X_link('3');
  return ($xversion, xconfig_file_abs_path($xconfig_path, $xconfig_file_name),
          $xversionAll);
}

sub fix_mouse_file {
  my $mouse_file = '/etc/sysconfig/mouse';
  #
  # If gpm supports imps2, use that as the gpm mouse driver
  # for both X & gpm. If gpm doesn't support imps2, or isn't set
  # in this mode, the mouse will be erratic when exiting X if
  # X was set to use imps2
  # 
  my $enableXImps2 = 'no';
  my $GPMBinary = internal_which('gpm');
  if (file_name_exist($GPMBinary) && file_name_exist($mouse_file)) {
    my $enableGpmImps2;

    $enableGpmImps2 =
      (system(shell_string($GPMBinary) . ' -t help | '
              . $gHelper{'grep'} . ' -q imps2')/256) == 0 ? 'yes': 'no';
    $enableXImps2 = $enableGpmImps2;
    
    if ($enableGpmImps2 eq 'yes' ) {
      backup_file_to_restore($mouse_file, 'MOUSE_CONF');
      unlink $mouse_file;
      my %p;
      undef %p;
      $p{'^MOUSETYPE=.*$'} = 'MOUSETYPE=imps2';
      $p{'^XMOUSETYPE=.*$'} = 'XMOUSETYPE=IMPS/2';
      internal_sed($mouse_file . $cBackupExtension,
                   $mouse_file, 0, \%p);
      if (!$gOption{'skipstopstart'}) {
        system(shell_string(db_get_answer('INITSCRIPTSDIR') . '/gpm')
               . ' restart');
      }
    }
  }
  return $enableXImps2;
}

# Create a list of available resolutions for the VMware virtual monitor
sub get_suitable_resolutions {
  my $xf86config = shift;
  my @list;
  my $in;
  my $identifier;

  open(XF86CONFIG, '<' . $xf86config) or 
   error('Unable to open the XFree86 configuration file "'
         . $xf86config . '" in read-mode.' . "\n\n");

  $in = 0;
  while (<XF86CONFIG>) {
    if (/^[ \t]*Section[ \t]*"Monitor"[ \t]*$/) {
      $in = 1;
      $identifier = '';
      @list = ();
    } elsif ($in) {
      if (/^[ \t]*Identifier[ \t]*"(\S+)"[ \t]*$/) {
        $identifier = $1;
      } elsif (/^[ \t]*ModeLine[ \t]*(\S+)[ \t]*(\S+)[ \t]*(\S+)[ \t]*(\S+)[ \t]*(\S+)[ \t]*(\S+)[ \t]*(\S+)[ \t]*(\S+)[ \t]*(\S+)[ \t]*(\S+)[ \t]*$/) {
        push(@list, ($1, $3, $7));
      } elsif (/^[ \t]*EndSection[ \t]*$/) {
        if ($identifier eq 'vmware') {
          last;
        }
        $in = 0;
      }
    }
  }

  close(XF86CONFIG);

  return @list;
}

# Determine the name of the maximum available resolution that can fit in the
# VMware virtual monitor
sub get_best_resolution {
  my $xf86config = shift;
  my $width = shift;
  my $height = shift;
  my @avail_modes;
  my $best_name;
  my $best_res;

  @avail_modes = get_suitable_resolutions($xf86config);

  $best_name = '';
  $best_res = -1;
  while ($#avail_modes > -1) {
    my $mode_name = shift(@avail_modes);
    my $mode_width = shift(@avail_modes);
    my $mode_height = shift(@avail_modes);

    if (($mode_width < $width)
        && ($mode_height < $height)
        && ($mode_width * $mode_height > $best_res)) {
      $best_res = $mode_width * $mode_height;
      $best_name = $mode_name;
    }
  }
  return $best_name;
}

# Sort available resolutions for the VMware virtual monitor in increasing order
sub sort_resolutions {
  my $xf86config = shift;
  my @avail_modes;
  my %resolutions;
  my $res;
  my $names;

  @avail_modes = get_suitable_resolutions($xf86config);

  undef %resolutions;
  while ($#avail_modes > -1) {
    my $mode_name = shift(@avail_modes);
    my $mode_width = shift(@avail_modes);
    my $mode_height = shift(@avail_modes);

    $resolutions{$mode_width * $mode_height} .= $mode_name . ' ';
  }
  
  $names = '';
  foreach $res (sort { $a <=> $b } keys %resolutions) {
    $names .= $resolutions{$res};
  }
  if (not ($names eq '')) {
    chomp($names);
  }
  return $names;
}

#
# Try to determine the current screen size
#
sub get_screen_mode {
  my $xversion = shift;
  my $best_resolution = '';
  my $chosen_resolution = '';
  my $suggested_choice = 3;
  my $i = 1;
  my $n;
  my $mode;
  my $choice;
  my @mode_list;
  my $width;
  my $height;
  my $cXPreviousResolution = 'X_PREVIOUS_RES';
  my $cXConfigFile = db_get_answer('LIBDIR') . '/configurator/XFree86-'
                     . $xversion . '/XF86Config'
                     . ($xversion eq '4' ? '-4': '');

  #
  # Set mode according to what was previously chosen in case of an upgrade
  # or ask the user a valid range of resolutions.
  #
  if (defined(db_get_answer_if_exists($cXPreviousResolution))) {
    if (get_answer("\n\n" .
                   'Do you want to change your guest X resolution? (yes/no)',
                   'yesno', 'no') eq 'no') {
      return db_get_answer($cXPreviousResolution);
    }
  }

  ($width, $height) = split(' ', $gSystem{'resolution'});

  $best_resolution =
    get_best_resolution($cXConfigFile, $width, $height);

  @mode_list = split(' ', sort_resolutions($cXConfigFile));

  $n = scalar @mode_list;

  print wrap("\n" . 'Please choose '
             . 'one of the following display sizes (1 - ' . $n . '):' . "\n\n",
             0);
  foreach $mode (@mode_list) {
    my $header;
    if ($best_resolution eq $mode) {
      $suggested_choice = $i;
      $header = '<';
    } else {
      $header = ' ';
    }
    print wrap('[' . $i . ']' . $header . ' ' . $mode . "\n", 0);
    $i = $i + 1;
  }

  $gMaxNumber = $n;
  $gAnswerSize{'number'} = length($gMaxNumber);
  $choice = get_persistent_answer('Please enter a number between 1 and ' . $n
                                  . ':' . "\n\n", 'XRESNUMBER', 'number',
                                  $suggested_choice);

  $chosen_resolution = $mode_list[$choice - 1];
  db_add_answer($cXPreviousResolution, $chosen_resolution);
  return $chosen_resolution;
}

#
# This function is taken from the old tools installer.
# The first argument is a complete path to a file which will be read and 
# overwritten with the result.
# The second argument will be only read and should be the system file present
# before configuration.
# The third argument is the version of XFree86
# The fourth is a boolean informing weather the Imwheel mouse is used
# in gpm or not.
#
sub fix_X_conf {
  my ($newXF86Config, $existingXF86Config, $xversion, $enableXImps2,
  $xversionAll) = @_;

  my $filessection = 0;
  my $kbdsection = 0;
  my $kbdsectionX4 = 0;
  my $isKbdsectionX4 = 0;
  my $transcribe = 0;
  my $inputdevicesection = 0;
  my $inSection = 0;
  my @currentSection;
  my $sectionLine;
  my $keybRegex = 'driver\s+\"keyboard\"';
  my $kbdIdentifier = 'Keyboard';

  my ($line, $copy);
  my $XFree4_scanpci = xserver_bin() . '/scanpci';
  my @providedXConfigFile;
  my $major;
  my $minor;
  my $sub;

  ($major, $minor, $sub) = split_X_version($xversionAll);

  if (not file_name_exist($existingXF86Config)) {
    my %patch;
    undef %patch;
    internal_sed('/dev/null', $existingXF86Config, 0, \%patch);
  }

  #
  # Check to see if the vmware svga driver is non-unified b/c we have to 
  # specifiy the BusId in the XF86Config-4 file in that case
  #
  my $writeBusIDLine = 0;
  if ($xversion eq '4' &&
      file_name_exist($XFree4_scanpci) &&
      (system(shell_string($XFree4_scanpci) . ' | '
              . shell_string($gHelper{'grep'}) . ' -q 0x0710')/256) == 0 ) {
     $writeBusIDLine = 1;
     # print wrap ('Found the device 0x0710' . "\n\n", 0);
  }

  # Capture current contents before overwriting
  if (not open(PROVIDEDXCONF, "<$newXF86Config")) {
    error('Unable to open the file "' . $newXF86Config . '".' . "\n\n");
  }
  @providedXConfigFile = readline(*PROVIDEDXCONF);
  close(PROVIDEDXCONF);

  if (not open(EXISTINGXF86CONFIG, "<$existingXF86Config")) {
    error('Unable to open the file "' . $existingXF86Config . '".' . "\n\n");
  }

  if (not open(NEWXF86CONFIG, ">$newXF86Config")) {
    error('Unable to open the file "' . $newXF86Config . '".' . "\n\n");
  }

  while (defined($line = <EXISTINGXF86CONFIG>)) {
    if ($line =~ /^\s*#/) {
      if ($transcribe == 0) {
        print NEWXF86CONFIG $line;
      }
    } else {
      if ($line =~ /^\s*EndSection/i) {
        $inSection = 2;
      if ($transcribe == 1) {
          $transcribe = 2;
        }
      }
      if ($line =~ /^\s*Section\s*"([a-zA-Z]+)"/i) {
        my $sectionName = lc($1);
        $inSection = 1;
        if ($sectionName eq 'files') {
          $filessection = 1;
          $transcribe = 1;
        } elsif ($sectionName eq 'keyboard') {
          $kbdsection = 1;
          $transcribe = 1;
        } elsif ($sectionName eq 'inputdevice') {
          $inputdevicesection = 1;
        }
      }
    }
      
    if ($inSection >= 1) {
      push @currentSection, $line;
      if ($inputdevicesection == 1 && $line =~ /$keybRegex/i) {
        $kbdsectionX4 = 1;
        $isKbdsectionX4 = 1;
      }
      if ($inSection == 2) {
        if ($isKbdsectionX4 == 1) {
          foreach $sectionLine (@currentSection) {
            if ($sectionLine =~ /^\s*Identifier\s+\"(.+)\"/i) {
              $kbdIdentifier = $1;
            }
            print NEWXF86CONFIG $sectionLine;
          }
        }
        $inputdevicesection = 0;
        $inSection = 0;
        $isKbdsectionX4 = 0;
        @currentSection = ();
      }
    }

    if ($transcribe == 1) {
      print NEWXF86CONFIG $line;
    } elsif ($transcribe == 2) {
      $transcribe = 3;
      print NEWXF86CONFIG $line;
    }
  }

  # Then append our sections that weren't superceded
  $isKbdsectionX4 = 0;
  $transcribe = 0;
  foreach $line (@providedXConfigFile) {
    # Replace %BUSID_LINE%
    if ($writeBusIDLine) {
      $line =~ s/%BUSID_LINE%/BusID \t\"PCI:0:15:0\"/g;
    } else {
      $line =~ s/%BUSID_LINE%//g;
    }

    # Replace %MOUSE_PROTOCOL%
    if (vmware_product() eq 'tools-for-freebsd') {
      if (direct_command(shell_string($gHelper{'grep'}) . ' '
                         . shell_string('moused_enable') . ' '
                         . shell_string('/etc/rc.conf')) =~ /yes/i) {
        $line =~ s/%MOUSE_DEV%/sysmouse/;
        $line =~ s/%MOUSE_PROTOCOL%/SysMouse/;
      } else {
        $line =~ s/%MOUSE_DEV%/psm0/;
        $line =~ s/%MOUSE_PROTOCOL%/ps\/2/;
      }
    } elsif ($enableXImps2 eq 'yes') {
      $line =~ s/%MOUSE_PROTOCOL%/IMPS\/2/g;
    } else {
      $line =~ s/%MOUSE_PROTOCOL%/ps\/2/g;
    }
    if ($major == 4 && $minor >= 2 &&
        file_name_exist($cX4MouseDriverFile)) {
      $line =~ s/%MOUSE_DRIVER%/vmmouse/g;
    } else {
      $line =~ s/%MOUSE_DRIVER%/mouse/g;
    }
    $line =~ s/%Keyboard1%/$kbdIdentifier/g;
    if (not ($line =~ /^\s*#/)) {
      if ($line =~ /^\s*EndSection/i && $transcribe == 1) {
        $transcribe = 2;
      }
      if ($line =~ /^\s*Section/i) {
        if ($line =~ /Files/i && $filessection == 1) {
          $transcribe = 1;
        } elsif ($line =~ /Keyboard/i && $kbdsection == 1) {
          $transcribe = 1;
        } elsif ($line =~ /InputDevice/i && $kbdsectionX4 == 1) {
          $inputdevicesection = 1;
          $transcribe = 1;
        }
      }
    }

    if ($inputdevicesection == 1) {
      push @currentSection, $line;
      if ($line =~ /$keybRegex/i) {
        $isKbdsectionX4 = 1;
      }
      if ($transcribe == 2) {
        if ($isKbdsectionX4 == 0) {
          foreach $sectionLine (@currentSection) {
            print NEWXF86CONFIG $sectionLine;
          }
        }
        $isKbdsectionX4 = 0;
        $inputdevicesection = 0;
        @currentSection = ();
      }
    }

    if (($transcribe != 1) and ($transcribe != 2)) {
      print NEWXF86CONFIG $line;
    }

    if ($transcribe == 2) {
      $transcribe = 3;
    }
  }
  close (EXISTINGXF86CONFIG);
  close (NEWXF86CONFIG);
}

sub configure_X {
  my $xversion = '';
  my $xconfig_file = '';
  my $enableXImps2 = '';
  my $screen_mode = '';
  my $xversionAll = '';

  if (file_name_exist(xserver4())) {
    ($xversion, $xconfig_file, $xversionAll) = xfree_4();
  } elsif (file_name_exist(xserver_bin() . '/xterm')) {
    ($xversion, $xconfig_file, $xversionAll) = xfree_3();
  } else {
     print wrap ('No XFree86 install found.' . "\n\n", 0);
     return;
  }

  $enableXImps2 = fix_mouse_file();
  $screen_mode = get_screen_mode($xversion);

  backup_file_to_restore($xconfig_file, 'XCONFIG_FILE');

  my %p;
  undef %p;
  $p{'%SCREEN_MODE%'} = $screen_mode;
  internal_sed(db_get_answer('LIBDIR') . '/configurator/XFree86-'
               . $xversion . '/XF86Config' . ($xversion eq '4' ? '-4': ''),
               $xconfig_file, 0, \%p);

  fix_X_conf($xconfig_file, $xconfig_file . $cBackupExtension,
             $xversion, $enableXImps2, $xversionAll);
}

# Configuration related to the vmkernel
sub configure_vmkernel {
  my $mod_dir;
  my $candidate;
  my $name;
  my $ver;
  my %patch;
  my $i;
  my $j;
  my $k;
  my $dev;
  my $answer;

  configure_dev('/dev/vmkmem', 10, 165, 1);
  configure_dev('/dev/vmkcnx', 10, 166, 1);

  for ($i = 0; $i < 128; $i++) {
    configure_dev('/dev/vsd' . $i, 88, $i, 0);
  }

  # Install vmnix module in /lib/modules
  $mod_dir = db_get_answer('LIBDIR') . '/modules';
  $ver = $cVmnixVersion;
  $name = "vmnixmod.o";
  undef %patch;
  create_dir('/lib/modules/' . $ver . '/misc', 0x1);
  install_file($mod_dir . '/binary/' . $ver . '/objects/' . $name,
               '/lib/modules/' . $ver . '/misc/' . $name, \%patch, 0x1);
  $name = "vmxnet_console.o";
  undef %patch;
  install_file($mod_dir . '/binary/' . $ver . '/objects/' . $name,
               '/lib/modules/' . $ver . '/misc/' . $name, \%patch, 0x1);

  $answer = get_persistent_answer('Do you want to automatically start up '
                                  . vmware_product_name() . ' now and on each '
                                  . 'bootup?', 'STARTUP_SERVER', 'yesno',
                                  'yes');
}

# Configuration of bridged networking
sub configure_bridged_net {
  my $vHubNr = shift;
  my $vHostIf = shift;
  my $answer;

  if ($vHubNr < $gMinVmnet || $vHubNr > $gMaxVmnet) {
    print wrap('Number of virtual networks exceeded.  Not creating virtual '
               . 'network.' . "\n\n", 0);
    return;
  }

  # If this wasn't a bridged network before, wipe out the old configuration
  # info as it may confuse us later.
  if (!is_bridged_network($vHubNr)) {
    remove_net($vHubNr, $vHostIf);
  }

  print wrap('Configuring a bridged network for vmnet' . $vHubNr . '.'
             . "\n\n", 0);

  if (count_all_networks() == 0 && $#gAllEthIf == -1) {
    # No interface.  We provide a valid default so that everything works.
    make_bridged_net($vHubNr, $vHostIf, "eth0");
    return;
  }

  if ($#gAvailEthIf == 0) {
    # Only one interface.  Use it.  This gives no choice even when the editor
    # is being used.
    make_bridged_net($vHubNr, $vHostIf,  $gAvailEthIf[0]);
    return;
  }

  if ($#gAvailEthIf == -1) {
    # We have other interfaces, but they have all been allocated.
    if (get_answer('All your ethernet interfaces are already bridged.  Are '
                   . 'you sure you want to configure a bridged ethernet '
                   . 'interface for vmnet' . $vHubNr . '? (yes/no)',
                   'yesno', 'no') eq 'no') {
      print wrap('Not changing network settings for vmnet' . $vHubNr . '.'
                 . "\n\n", 0);
      return;
    }
    $answer = get_persistent_answer('Your computer has the following ethernet '
                                    . 'devices: ' . join(', ', @gAllEthIf)
                                    . '. Which one do you want to bridge to '
                                    . 'vmnet' . $vHubNr . '?',
                                    'VNET_' . $vHubNr . '_INTERFACE',
                                    'anyethif', 'eth0');
    make_bridged_net($vHubNr, $vHostIf, $answer);
    return;
  }

  my $queryString = 'Your computer has multiple ethernet network interfaces '
                    . 'available: ' . join(', ', @gAvailEthIf) . '. Which one '
                    . 'do you want to bridge to vmnet' . $vHubNr . '?';
  $answer = get_persistent_answer($queryString,
                                  'VNET_' . $vHubNr . '_INTERFACE',
                                  'availethif', 'eth0');
  make_bridged_net($vHubNr, $vHostIf, $answer);
}

# Creates a bridged network.
sub make_bridged_net {
  my $vHubNr = shift;
  my $vHostIf = shift;
  my $ethIf = shift;

  db_add_answer('VNET_' . $vHubNr . '_INTERFACE', $ethIf);
  configure_dev('/dev/' . $vHostIf, 119, $vHubNr, 1);

  # Reload the list of available ethernet adapters
  load_ethif_info();
}

# Probe for an unused private subnet
# Return value is (status, subnet, netmask).
#  status is 1 on success (subnet and netmask are set),
#  status is 0 on failure.
sub subnet_probe {
  my $vHubNr = shift;
  my $vHostIf = shift;
  # Ref to an array of used subnets
  my $usedSubnets = shift;
  my $i;
  my @subnets;
  my $tries;
  my $maxTries = 100;
  my $pings;
  my $maxPings = 10;
  # XXX We only consider class C subnets for the moment
  my $netmask = '255.255.255.0';
  my %used_subnets;

  # Generate the table of private class C subnets
  @subnets = ();
  for ($i = 0; $i < 255; $i++) {
    $subnets[2 * $i    ] = '192.168.' . $i . '.0';
    $subnets[2 * $i + 1] = '172.16.'  . $i . '.0';
  }

  # Generate a list of used subnets and clear out the ones that have already
  # been used
  foreach $i (@$usedSubnets) {
    $used_subnets{$i} = 1;
  }
  for ($i = 0; $i < $#subnets + 1; $i++) {
    if ($used_subnets{$subnets[$i]}) {
      $subnets[$i] = '';
    }
  }

  print wrap('Probing for an unused private subnet (this can take some '
             . 'time)...' . "\n\n", 0);
  $tries = 0;
  $pings = 0;
  srand(time);
  # Beware, 'last' doesn't seem to work in 'do'-'while' loops
  for (;;) {
    my $r;
    my $subnet;
    my $status;

    $tries++;

    $r = int(rand($#subnets + 1));
    if ($subnets[$r] eq '') {
      # Already tried
      if ($tries == $maxTries) {
        print STDERR wrap('We were unable to locate an unused Class C subnet '
                          . 'in the range of private network numbers.  For '
                          . 'each subnet that we tried we received a response '
                          . 'to our ICMP ping packets from a ' . $machine
                          . ' at the network address intended for assignment '
                          . 'to this machine.  Because no private subnet '
                          . 'appears to be unused you will need to explicitly '
                          . 'specify a network number by hand.' . "\n\n", 0);
        return (0, undef, undef);
      }
      next;
    }
    $subnet = $subnets[$r];
    $subnets[$r] = '';

    # Our convention is that the host OS IP address is <subnet>.1
    $status = system(shell_string(db_get_answer('BINDIR') . '/vmware-ping')
                     . ' -q '
                     . shell_string(int_to_quaddot(quaddot_to_int($subnet)
                                                   + 1))) >> 8;

    if ($status == 3) {
      print STDERR wrap('We were unable to locate an unused Class C subnet in '
                        . 'the range of private network numbers.  You will '
                        . 'need to explicitly specify a network number by '
                        . 'hand.' . "\n\n", 0);
      return (0, undef, undef);
    }

    if ($status == 2) {
      print STDERR wrap('Either your ' . $machine . ' is not connected to an '
                        . 'IP network, or its network configuration does not '
                        . 'specify a default IP route.  Consequently, the '
                        . 'subnet ' . $subnet . '/' . $netmask . ' appears to '
                        . 'be unused.' . "\n\n", 0);
      return (1, $subnet, $netmask);
    }

    if ($status == 1) {
      print wrap('The subnet ' . $subnet . '/' . $netmask . ' appears to be '
                 . 'unused.' . "\n\n", 0);
      return (1, $subnet, $netmask);
    }

    $pings++;
    if (($pings == $maxPings) || ($tries == $maxTries)) {
      print STDERR wrap('We were unable to locate an unused Class C subnet in '
                        . 'the range of private network numbers.  For each '
                        . 'subnet that we tried we received a response to our '
                        . 'ICMP ping packets from a ' . $machine . ' at the '
                        . 'network address intended for assignment to this '
                        . 'machine.  Because no private subnet appears to be '
                        . 'unused you will need to explicitly specify a '
                        . 'network number by hand.' . "\n\n", 0);
      return (0, undef, undef);
    }
  }
}

# Converts an quad-dotted IPv4 address into a integer
sub quaddot_to_int {
  my $quaddot = shift;
  my @quaddot_a;
  my $int;
  my $i;

  @quaddot_a = split(/\./, $quaddot);
  $int = 0;
  for ($i = 0; $i < 4; $i++) {
    $int <<= 8;
    $int |= $quaddot_a[$i];
  }

  return $int;
}

# Converts an integer into a quad-dotted IPv4 address
sub int_to_quaddot {
  my $int = shift;
  my @quaddot_a;
  my $i;

  for ($i = 3; $i >= 0; $i--) {
    $quaddot_a[$i] = $int & 0xFF;
    $int >>= 8;
  }

  return join('.', @quaddot_a);
}

# Compute the subnet address associated to a couple IP/netmask
sub compute_subnet {
  my $ip = shift;
  my $netmask = shift;

  return int_to_quaddot(quaddot_to_int($ip) & quaddot_to_int($netmask));
}

# Compute the broadcast address associated to a couple IP/netmask
sub compute_broadcast {
  my $ip = shift;
  my $netmask = shift;

  return   int_to_quaddot(quaddot_to_int($ip)
         | (0xFFFFFFFF - quaddot_to_int($netmask)));
}

# Makes the patch hash that is used to replace the options in the dhcpd config
# file.
# These DHCP options are needed for the hostonly network.
sub make_dhcpd_patch {
  my $vHubNr = shift;
  my $vHostIf = shift;
  my %patch;

  undef %patch;
  $patch{'%vmnet%'} = $vHostIf;
  $patch{'%hostaddr%'} = db_get_answer('VNET_' . $vHubNr
                                       . '_HOSTONLY_HOSTADDR');
  $patch{'%netmask%'} = db_get_answer('VNET_' . $vHubNr . '_HOSTONLY_NETMASK');
  $patch{'%network%'} = compute_subnet($patch{'%hostaddr%'},
                                       $patch{'%netmask%'});
  $patch{'%broadcast%'} = compute_broadcast($patch{'%hostaddr%'},
                                            $patch{'%netmask%'});
  # Median address in this subnet
  $patch{'%range_low%'} = int_to_quaddot(
    (quaddot_to_int($patch{'%network%'})
     + quaddot_to_int($patch{'%broadcast%'}) + 1) / 2);
  # Last normal address in this subnet
  $patch{'%range_high%'} = int_to_quaddot(
    quaddot_to_int($patch{'%broadcast%'}) - 1);
  $patch{'%router_option%'} = "";
  return %patch;
}

# Write VMware's DHCPd configuration files
sub write_dhcpd_config {
  my $vHubNr = shift;
  my $vHostIf = shift;
  # Function that makes the patch needed for the DHCP config file
  my $make_patch_func = shift;
  my $dhcpd_dir;
  my %patch;

  %patch = &$make_patch_func($vHubNr, $vHostIf);

  # Create the dhcpd config directory (one per virtual interface)
  $dhcpd_dir = $gRegistryDir . '/' . $vHostIf . '/dhcpd';
  create_dir($dhcpd_dir, 0x1);

  install_file(db_get_answer('LIBDIR') . '/configurator/vmnet-dhcpd.conf',
               $dhcpd_dir . '/dhcpd.conf', \%patch, 0x1);

  # Create empty files that will be created by the daemon
  # They will be modified by the daemon, don't timestamp them
  undef %patch;
  install_file('/dev/null', $dhcpd_dir . '/dhcpd.leases', \%patch, 0);
  safe_chmod(0644, $dhcpd_dir . '/dhcpd.leases');
  undef %patch;
  install_file('/dev/null', $dhcpd_dir . '/dhcpd.leases~', \%patch, 0);
  safe_chmod(0644, $dhcpd_dir . '/dhcpd.leases~');
}

# Check the normal dhcp configuration and give advises
sub dhcpd_consultant {
  my $vHubNr = shift;
  my $vHostIf = shift;
  my $conf;
  my $network;
  my $netmask;

  if (-r '/etc/dhcpd.conf') {
    $conf = '/etc/dhcpd.conf';
  } else {
    return;
  }

  $netmask = db_get_answer('VNET_' . $vHubNr . '_HOSTONLY_NETMASK');
  $network = compute_subnet(db_get_answer('VNET_' . $vHubNr
                                          . '_HOSTONLY_HOSTADDR'), $netmask);

  # The host has a normal dhcpd setup
  if (direct_command(
    shell_string($gHelper{'grep'}) . ' '
    . shell_string('^[ ' . "\t" . ']*subnet[ ' . "\t" . ']*' . $network) . ' '
    . shell_string($conf)) eq '') {
    query('This system appears to have a DHCP server configured for normal '
          . 'use.  Beware that you should teach it how not to interfere with '
          . vmware_product_name() . '\'s DHCP server.  There are two ways to '
          . 'do this:' . "\n\n" . '1) Modify the file ' . $conf . ' to add '
          . 'something like:' . "\n\n" . 'subnet ' . $network . ' netmask '
          . $netmask . ' {' . "\n" . '    # Note: No range is given, '
          . 'vmnet-dhcpd will deal with this subnet.' . "\n" . '}' . "\n\n"
          . '2) Start your DHCP server with an explicit list of network '
          . 'interfaces to deal with (leaving out ' . $vHostIf . '). e.g.:'
          . "\n\n" . 'dhcpd eth0' . "\n\n" . 'Consult the dhcpd(8) and '
          . 'dhcpd.conf(5) manual pages for details.' . "\n\n"
          . 'Hit enter to continue.', '', 0);
  }
}

# Write the VMware samba host-wide configuration file
sub write_smb_config {
  my $vHubNr = shift;
  my $vHostIf = shift;
  my $smb_dir;
  my %patch;
  my $smb_file;
  my @smb_files = ('var/locks/STATUS..LCK',
                   'var/locks/browse.dat');

  if (!is_samba_running($vHubNr)) {
    return;
  }

  # Create the smb config directories (one per virtual interface)
  $smb_dir = $gRegistryDir . '/' . $vHostIf . '/smb';
  create_dir($smb_dir . '/private', 0x1);
  create_dir($smb_dir . '/var/locks', 0x1);

  undef %patch;
  $patch{'%vmnet%'} = $vHostIf;
  $patch{'%hostaddr%'} = db_get_answer('VNET_' . $vHubNr
                                       . '_HOSTONLY_HOSTADDR');
  $patch{'%netmask%'} = db_get_answer('VNET_' . $vHubNr . '_HOSTONLY_NETMASK');
  $patch{'%network%'} = compute_subnet($patch{'%hostaddr%'},
                                       $patch{'%netmask%'});
  $patch{'%vardir%'} = $smb_dir . '/var';
  $patch{'%privatedir%'} = $smb_dir . '/private';
  $patch{'%libdir%'} = db_get_answer('LIBDIR') . '/smb';
  install_file(db_get_answer('LIBDIR') . '/configurator/vmnet-smb.conf',
               $smb_dir . '/smb.conf', \%patch, 0x1);

  # Create empty files that will be created by the daemon
  # They will be modified by the daemon, don't timestamp them
  foreach $smb_file (@smb_files) {
    undef %patch;
    install_file('/dev/null', $smb_dir . '/' . $smb_file, \%patch, 0);
    safe_chmod(0644, $smb_dir . '/' . $smb_file);
  }

  my $samba_sid = $gDBAnswer{'VNET_' . $vHubNr . '_SAMBA_MACHINESID'};
  my $samba_passwd = $gDBAnswer{'VNET_' . $vHubNr . '_SAMBA_SMBPASSWD'};

  if (   defined($samba_sid) && (-e $samba_sid)
      && defined($samba_passwd) && (-e $samba_passwd)) {
    # The previous installer saved a valid SMB state.  Restore it.
    undef %patch;
    install_file($samba_sid, $smb_dir . '/private/MACHINE.SID', \%patch, 0);
    db_remove_answer('VNET_' . $vHubNr . '_SAMBA_MACHINESID');
    undef %patch;
    install_file($samba_passwd, $smb_dir . '/private/smbpasswd', \%patch, 0);
    db_remove_answer('VNET_' . $vHubNr . '_SAMBA_SMBPASSWD');
  }

  if (not (   (-e $smb_dir . '/private/MACHINE.SID')
           && (-e $smb_dir . '/private/smbpasswd'))) {
    # There is no valid SMB state.  Create a new valid one.
    undef %patch;
    install_file('/dev/null', $smb_dir . '/private/MACHINE.SID', \%patch, 0);
    undef %patch;
    install_file('/dev/null', $smb_dir . '/private/smbpasswd', \%patch, 0);
  }

  # Set the permissions of the SMB state
  safe_chmod(0644, $smb_dir . '/private/MACHINE.SID');
  safe_chmod(0600, $smb_dir . '/private/smbpasswd');
}

# Generate an interfaces specification for a samba configuration file
sub samba_make_interfaces {
  my $if;
  my $result;
  my $sep;

  # We assume that ifconfig without any command option only display interfaces
  # that are up.
  open(IFCONFIG, shell_string($gHelper{'ifconfig'}) . ' |');
  # XXX I did my best, but this is probably still locale-dependant --hpreg
  $result = '';
  $sep = '';
  while (<IFCONFIG>) {
    if (/^[a-zA-Z]/) {
      my @fields;

      @fields = split(/[ ]+/);
      $if = $fields[0];
    } elsif (/[iI]net/) {
      if (/^[ ]+.*:(\S+)[ ]+.*:(\S+)[ ]+.*:(\S+)/) {
        if (not ($if eq 'lo')) {
          $result .= $sep . $1 . '/' . $3;
          $sep = ' ';
        }
      }
    }
  }

  return $result;
}

# Check the samba configuration and give advises
sub samba_consultant {
  my $vHubNr = shift;
  my $vHostIf = shift;
  my $conf;
  my $prefix;
  my $netmask;
  my $hostaddr;
  my $samba_uid;
  my $samba_ifaddr;

  if (-r '/etc/smb.conf') {
    $conf = '/etc/smb.conf';
  } elsif (-r '/etc/samba/smb.conf') {
    $conf = '/etc/samba/smb.conf';
  } else {
    return;
  }

  $hostaddr = db_get_answer('VNET_' . $vHubNr . '_HOSTONLY_HOSTADDR');
  $netmask = db_get_answer('VNET_' . $vHubNr . '_HOSTONLY_NETMASK');
  # XXX This should be computed based on the netmask instead of assuming a
  # class C in case the user has submitted these values
  ($prefix = $hostaddr) =~ s/\.[0-9]+$//;

  # The host has a samba setup
  # XXX $prefix should be grep-escaped (it contains dots...)
  $samba_ifaddr = direct_command(
    shell_string($gHelper{'grep'}) . ' '
    . shell_string('^[ ' . "\t" . ']*interfaces[ ' . "\t" . ']*=.*' . $prefix)
    . ' ' . shell_string($conf));

  if (count_samba_networks() > 0) {
    query('This system appears to have a CIFS/SMB server (Samba) configured '
          . 'for normal use.  If this server is intended to run, you need to '
          . 'make sure that it will not conflict with the Samba server setup '
          . 'on the private network (the one that we use to share the ' . $os
          . '\'s filesystem).  Please check your ' . $conf . ' file so that:'
          . "\n\n" . '.  The "interfaces" line does not contain "' . $hostaddr
          . '/' . $netmask . '"' . "\n" . '.  There is a "socket address" '
          . 'line that contains only your real host IP address' . "\n\n"
          . 'Hit enter to continue.', '', 0);
  } else {
    if ($samba_ifaddr eq '') {
      query('This system appears to have a CIFS/SMB server (Samba) configured '
            . 'for normal use.  Note that if you want to offer service to '
            . 'virtual machines running on the host-only network, you must '
            . 'modify your ' . $conf . ' file to list the networks Samba '
            . 'should deal with.  You can do this by adding a line looking '
            . 'like this one:' . "\n\n" . 'interfaces = '
            . samba_make_interfaces() . ' ' . $hostaddr . '/' . $netmask
            . "\n\n" . 'You may also need to update any related security '
            . 'controls you might have setup such as the "hosts allow" '
            . 'specification.' . "\n\n" . 'Consult the smb.conf(5) manual '
            . 'page for more details.' . "\n\n"
            . 'Hit enter to continue.', '', 0);
    }
  }
}

# Configuration of hostonly networking
sub configure_hostonly_net {
  my $vHubNr = shift;
  my $vHostIf = shift;
  my $run_dhcpd = shift;
  my $run_samba = shift;
  my $hostaddr;
  my $subnet;
  my $netmask;
  my $status;

  if ($vHubNr < $gMinVmnet || $vHubNr > $gMaxVmnet) {
    print wrap('Number of virtual networks exceeded.  Not creating virtual '
               . 'network.' . "\n\n", 0);
    return;
  }

  # If this wasn't a hostonly network before, wipe out the old configuration
  # info as it may confuse us later.
  if (!is_hostonly_network($vHubNr)) {
    remove_net($vHubNr, $vHostIf);
  }

  print wrap('Configuring a host-only network for vmnet' . $vHubNr . '.'
             . "\n\n", 0);

  my $keep_settings;

  $keep_settings = 'no';
  $hostaddr = $gDBAnswer{'VNET_' . $vHubNr . '_HOSTONLY_HOSTADDR'};
  $netmask = $gDBAnswer{'VNET_' . $vHubNr . '_HOSTONLY_NETMASK'};

  if (defined($hostaddr) && defined($netmask)) {
    $subnet = compute_subnet($hostaddr, $netmask);
    $keep_settings = get_answer('The host-only network is currently '
                                . 'configured to use the private subnet '
                                . $subnet . '/' . $netmask . '.  Do you want '
                                . 'to keep these settings?', 'yesno', 'yes');
  }

  if ($keep_settings eq 'no') {
    # Get the new settings
    for (;;) {
      my $answer;

      $answer = get_answer('Do