# COPYRIGHT_NOTICE_START
# Licensed Materials - Property of IBM
# "Restricted Materials of IBM" -- 5746-SM2
# (C) Copyright IBM Corp. 2007, 2008 All Rights Reserved.
# US Government Users Restricted Rights - Use, duplication or disclosure
# restricted by GSA ADP Schedule Contract with IBM Corp.
# COPYRIGHT_NOTICE_END

package Maiken::UtilFunctions;


# email regex allows anything but spaces prior to the @
# the domain must start with a word character but can then also contain - and .
# followed by a . and a 2 or more word character tld.
sub EMAIL_REGEXP { '(\S+@\w[\w\.-]+\.\w{2,})' } # Brackets allow optional version with ?

=head1 NAME

  Maiken::UtilFunctions - utility functions available to Maiken

=head1 DESCRIPTION

The functions defined here are "mixed in" to Maiken and all its
subclasses for your convenience.

If you write a function that could benefit all classes, please add it
here.

=cut

use strict;
use warnings;

use Cwd ();
use Data::Dumper ();
use Digest::MD5;
use Encode ();
use File::Basename ();
use File::Find ();
use File::Path ();
use File::Temp ();
use POSIX ();

use Maiken::L10N ();

sub ACCEPTED_LICENSE_DIR { 'license' }
sub LICENSE_FILE { 'license' }

# Filesystems that mustn't be used for user-specified paths
sub BANNED_FILESYSTEMS { qw{/dev /proc /sys /selinux} }

# Variables that need to be loaded into hashes or arrays from the
# config file
sub SPECIAL_CONFIG_FILE_VARS {
  { }
}

=head1 METHODS

=over 4

=item B<slurp>

  my $contents = $self->slurp('/etc/motd');

Read a file and return it as a string or an array.

The optional second parameter is the encoding of the file to be read,
eg. 'ISO-8859-1'. Defaults to 'utf8'.

Croaks if file can't be read.

=cut

sub slurp {
  my ($self, $file, $encoding) = @_;
  $encoding ||= 'utf8';
  $self->croak("No such file [_1]", $file) if not -r $file;
  local $/ = wantarray ? $/ : undef;
  open(my $fh, $file) or $self->croak("Cannot open '[_1]' for reading: [_2]",
				      $file, $!);
  binmode $fh, ":$encoding";
  return <$fh>;
}

=item B<write_file>

  $self->write_file('/etc/motd', ['foo', 'bar', 'baz']);

Write the given file with the given arrayref of lines (or a single
scalar containing the whole file).

If the lines don't end with \n it will be added.

If no second parameter is provided, an empty file will be created.

The third parameter is the encoding to use. ':utf8' will be assumed.

The fourth parameter is a list of options; mode and warnOnly are currently accepted.

Croaks on error, unless $options{warnOnly} is true in which case a warning
is emitted without exiting..

=cut

sub write_file {
  my ($self, $filename, $lines, $encoding, %options) = @_;
  $encoding ||= ':utf8';
  $options{mode} ||= '>';
  my $file = '';
  if (ref $lines) {
    chomp @$lines; # remove any newlines
    $file .= "$_\n" for @$lines; # and add them again!
  }
  else {
    $file = $lines if defined $lines;
  }

  my $fh;
  if ( !open($fh, $options{mode}, $filename) )
  {
    if ($options{warnOnly}) {
      $self->log_only_to_file("Cannot open [_1] for write: [_2]", $filename, $!);
      return;
    }
    else {
      $self->croak("Cannot open [_1] for write: [_2]", $filename, $!);
    }
  }
  # Default binmode for :unix
  # Using the :unix encoding was preventing the file handle from being
  # closed successfully
  if ($encoding eq ':unix') {
    binmode $fh;
  }
  else {
    binmode $fh, $encoding;
  }
  print $fh $file;
  binmode $fh; # Unset binmode - for some reason Perl sometimes
               # doesn't close files if we leave this step out.
  if( !close $fh ) {
    if($options{warnOnly}) {
      $self->log_only_to_file("Can't finish writing file [_1]: [_2]", $filename, $!);
    }
    else {
      $self->croak("Can't finish writing file [_1]: [_2]", $filename, $!);
    }
  }
}

=item B<read_directory>

  Returns an array containing all the files and dirs in a directory.
  Croaks if the directory doesn't exist.
  Removes '.', '..' and 'lost+found'.

=cut

sub read_directory {
  my ($self, $dir) = @_;
  unless (opendir D, $dir) {
    $self->croak("Cannot open the directory [_1]", $dir);
    return 0;
  }

  my @f = grep { $_ ne '.' and $_ ne '..' and $_ ne 'lost+found' } readdir D;
  closedir D;
  return @f;
}

=item B<copy_preserve>

  copies a file whilst preserving it's original
  ownerships and permissions

=cut

sub copy_preserve {
  my ($self, $old_path, $new_path) = @_;
  my @old_stat_info = stat($old_path) or
    $self->croak("Cannot stat [_1]: [_2]", $old_path, $!);

  my $old_mode = $old_stat_info[2] & 07777;
  my $old_uid  = $old_stat_info[4];
  my $old_gid  = $old_stat_info[5];

  File::Copy::copy($old_path, $new_path) or
    $self->croak("Cannot copy [_1] to [_2]", $old_path, $new_path);

  chmod($old_mode, $new_path) or
    $self->croak("Cannot chmod [_1]: [_2]", $new_path, $!);

  chown($old_uid, $old_gid, $new_path) or
    $self->croak("Cannot chown [_1]: [_2]", $new_path, $!);
}

=item B<get_permissions>

  my $permissions = $self->get_permissions('/export/');
  die "permission of /export is not 777" unless $permissions == 0777;

  Returns the permissions of a file/directory in the same format
  as you'd set them with chmod.

=cut

sub get_permissions {
  my ($self, $file) = @_;
  return (stat $file)[2] & 07777;
}

=item B<run_command>

Give it arguments as you would to system().

If called in void context it behaves like system().

The "one-arg shell" magic behaviour of system is unsupported. 
If you want to use a shell you must specify it explicitly.

If called in non-void context it returns stdout.

Add the final parameter '2>&1' in non-void context to get stderr
returned too.

Also sets $?>>8 in $self->{exit}.

=cut

sub run_command {
  my ($self, @argv) = @_;

  $self->log_only_to_file(POSIX::strftime('%H:%M:%S', localtime)." [@argv]\n",
			 undef, $self->{encoding});
  if (defined wantarray) {
    local $/ = undef;
    open my $fh, '-|' or do {
      # Redirect STDERR if last parameter is '2>&1'
      if ($argv[-1] eq '2>&1') {
	pop @argv; # drop the parameter
	open STDERR, '>&STDOUT' or $self->croak("Can't dup stdout: [_1]", $1);
      }
      exec {$argv[0]} @argv or exit 255; # only if it fails
    };

    # Using an encoding binmode here would be much more efficient. But
    # if the source data isn't actually in the correct encoding then
    # we're in trouble because Perl will print out a warning that just
    # cannot be suppressed. So instead we load the raw data into a
    # scalar and then convert it.
    binmode $fh;

    my $raw = <$fh>;
    my $out = do {
      no warnings qw(utf8);
      Encode::decode($self->{encoding}, $raw);
    };

    close $fh;
    $self->{exit} = $?>>8;
    return $out;
  }
  else {
    # This is just like system() except it doesn't ignore SIGINT/SIGQUIT
    my $pid = fork or exec {$argv[0]} @argv or exit 255;
    waitpid $pid, 0;
    $self->{exit} = $?>>8;
  }
}


=item B<send_email>

  $installer->send_email(to_address => 'someone@somewhere.com',
                         subject    => 'Subject',
                         body       => 'Body');

Send an email to $address with the given subject and body.

If sending fails, returns false.

Arguments: to_address (compulsory), subject, body

=cut

sub send_email {
  my ($self, %args) = @_;
  if (not $args{to_address}) {
    $self->croak("send_email(): no email address");
    return 0;
  }
  if ($args{to_address} =~ /"/) {
    $self->croak("The email address '[_1]' cannot be accepted as " .
		 "it contains a double quote (\")", $args{to_address});
    return 0;
  }

  # If the body contains carriage-return characters or nulls, remove
  # them.
  $args{body} =~ tr/\r\0//d;

  # We use the 'mail' program to send emails
  # First we need to check if the mail program is available
  if ( not (-x '/bin/mail' or -x '/usr/bin/mail') ) {
    $self->log("Could not detect the mail application");
    return 0;
  }
	
  # The -r option (from address) is not present on all /usr/bin/mail versions.
  my @cmd = qw(mail);
  push @cmd, $args{to_address};
  if ($args{subject}) {
    push @cmd, '-s', $args{subject};
  }

  # Note: Ideally we'd like to add a header saying the email is in
  # utf8. However, most versions of mail don't allow people to add
  # their own headers.
  open my $mail, "|-", or exec(@cmd) or return 0;
  binmode $mail, ':utf8';
  print $mail $args{body};

  close $mail or return 0;
  return 0 if $?;
  return 1;
}

=item B<register_interactively>

Asks the user a few questions, and then sends an email.

Arguments (passed as hash):
  initial_text_for_first_time - text to appear at the top

Croaks if the user says not to send the email.

=cut

sub register_interactively {
  my ($self, %args) = @_;

  #
  # Check we have what we have
  #
  foreach (qw/email organisation record_file questions subject_line_method
	      email_body_method compulsory/) {
    exists $args{$_} or
      $self->croak("register_interactively: [_1] not provided", $_);
  }

  #
  # Title what we're going (as otherwise two registration
  # processes can run into each other)
  #
  $self->log;
  $self->log("Registration with [_1]", $args{organisation});

  #
  # If the user has already registered, then offer the
  # chance to re-register.
  #
  if (-e $args{record_file}) {
    $self->log("Existing registration with [_1] has been found in [_2].",
	       $args{organisation}, $args{record_file});
    if (!$self->ask(q => "Would you like to re-register?", type => 'bool')) {
      return 1;
    }
    # Could delete $args{record_file} here, but there's no point - it will
    # be written over later, and keeping it ensures it remains if the
    # user quits the program before finishing.
  }
  else {
    # Is this registration compulsory? If it's not, offer the user a chance
    # to register
    
    if (!$args{compulsory}) {
      if (!$self->ask(q => "Would you like to register?", type => 'bool')) {
        return 1;
      }
    }

    $self->log($args{initial_text_for_first_time})
      if $args{initial_text_for_first_time};
  }

  my $text;
  do {
    foreach (@{$args{questions}}) {
      my ($field, $text, $regexp, $regexp_explanation, $default_field) = @$_;

      do {
	$self->{config}{$field} =
	  $self->ask('q' => $text, type => 'string',
		     default => $default_field ?
		     $self->{config}{$default_field} : undef);
	if ($regexp) {
	  if ($self->{config}{$field} !~ /^$regexp$/) {
	    $self->log;
	    $self->log("Sorry, that entry is invalid.");
	    $self->log($regexp_explanation) if $regexp_explanation;
	    delete $self->{config}{$field};
	  }
	}
      } until (exists $self->{config}{$field});
    }

    my $email_body_method = $args{email_body_method};
    $text = $self->$email_body_method;

    $text .= "\nInstaller Version: " . $self->version() ."\n";
    if($self->{config}{versions_available})
    {
      # config->chosen_rpm_file would be preferable but isn't available
      # at the point the email is sent.
      $text .= "Product Versions Available: " . 
                  join(", ", sort keys %{$self->{config}{versions_available}}) . "\n";
    }

    $self->log;
    $self->log("The following is about to be sent to [_1]:",
	       $args{organisation});
    $self->log_no_trans($text);
    $self->log;
  } while (!$self->ask
	   (q => 'Is the above information correct?', type => 'bool'));

  $self->ask
    ('q' => ["Send the above information to [_1]?\n(If you answer" .
	     " 'no' here, the installation will be aborted.)",
	     $args{organisation}],
     type => 'bool', default => 1) or
       $self->croak("Aborting installation.");

  #
  # Write the file
  #
  $self->write_file($args{record_file}, $text);

  #
  # Get the subject line string
  #
  my $subject_line_method = $args{subject_line_method};
  my $subject_line = $self->$subject_line_method;

  #
  # Send the email
  #
  if (do {local $ENV{LANG} = local $ENV{LC_ALL} = 'en_US.UTF-8';
	  $self->send_email(to_address   => $args{email},
			    subject      => $subject_line,
			    body         => $text)}) {
    $self->log("Email sent successfully.");
    $self->add_transaction("Registered with [_1]", $args{organisation});

    #
    # Record the successful registration so that we can display a
    # message at the end of the install.
    #
    $self->{successful_registrations}{$args{organisation}} = 1;
    return 1;
  }

  $self->log("Failed to send email to [_1]. Please mail the contents of [_2] to this address.", $args{email}, $args{record_file});
  return 0;
}

=item B<register_noninteractively>

Exactly the same as register_interactively, except it doesn't ask any
questions.

The fields for the email_body_method should be set in $self->{config}
before calling this.

If the record_file is found, the method will return without performing
the registration. If this is not the desired behaviour, provide a true
parameter called 'force'.

=cut

sub register_noninteractively {
  my ($self, %args) = @_;

  # Check all the args are present
  foreach (qw/email organisation record_file subject_line_method
	      email_body_method/) {
    exists $args{$_} or
      $self->croak("register_noninteractively: [_1] not provided", $_);
  }

  # Skip registration if file already exists and we're not forcing
  if (-e $args{record_file} and not $args{force}) {
    $self->log_only_to_file("Skipping registration with $args{organisation} - file has been found.\n");
    return;
  }

  $self->log("Registration with [_1]", $args{organisation});

  # Get the email body
  my $email_body_method = $args{email_body_method};
  my $text = $self->$email_body_method;

  # Write the file
  $self->write_file($args{record_file}, $text);

  # Get the subject line string
  my $subject_line_method = $args{subject_line_method};
  my $subject_line = $self->$subject_line_method;

  # Send the email
  if (do {local $ENV{LANG} = local $ENV{LC_ALL} = 'en_US.UTF-8';
	  $self->send_email(to_address   => $args{email},
			    subject      => $subject_line,
			    body         => $text)}) {
    $self->log("Email sent successfully.");
    $self->add_transaction("Registered with [_1]", $args{organisation});

    #
    # Record the successful registration so that we can display a
    # message at the end of the install.
    #
    $self->{successful_registrations}{$args{organisation}} = 1;
    return 1;
  }

  $self->log("Failed to send email to [_1]. Please mail the contents of [_2] to this address.", $args{email}, $args{record_file});
  return 0;
}

=item B<license_agreement_interactively>

  $installer->license_agreement_interactively('utf16', 'LA', 'LI');

Present the user with a license agreement that they must agree to.

The first argument is the encoding of the license files and the
remaining arguments are the filenames to expect with an '_en' (or
other language code) suffix. They will be concatenated together.

Files are to be stored in resources/licenses/PRODUCT.

If English is not the current locale, and a translation for the
current locale is available, offer the user that instead of the
English.

Returns true if the user accepts the license, false if he doesn't.

=cut

sub license_agreement_interactively {
  my ($self, $encoding, @files) = @_;
  my $accepted_dir = "$self->{config}{config_dir}/".
    $self->ACCEPTED_LICENSE_DIR;
  if (-e "$accepted_dir/".$self->LICENSE_FILE) {
    $self->log("License file found");
    return 1;
  }
  $self->log(qq{
You must agree to the following license to install [_1].\n
If you do not accept the license terms, the installation will abort.

Page through the license with SPACE.
}, $self->PRODUCT_NAME_FRIENDLY);
	$self->log("If you want to quit before you reach the end of the license, press q.");
  $self->log;

  # Get the localized text
  my $localized_text = '';
  foreach my $language ($self->language) {
    next unless $language and $language !~ /^en/;
    $localized_text = $self->get_license_text($language, $encoding, @files)
      and last;
  }

  # Get the English text
  my $english_text = $self->get_license_text('en', $encoding, @files);

  unless ($localized_text) {
    $self->ask(q => "Press ENTER to view the license.", type => 'string');
  }
  my $license_text = $english_text;
  my $done = 0;
  while (not $done) {
    # Give the user a choice
    if ($localized_text) {
      if ($self->ask(q => "Would you prefer to view the license in English?",
		     type => 'bool', default => 0)) {
	$license_text = $english_text;
      }
      else {
	$license_text = $localized_text;
      }
    }
    $self->page($license_text);
    $done = not $self->ask(q => "Do you want to view the license again?",
			   type => 'bool', default => 0);
  }
  while (1) {
    if ($self->ask(q => "Do you accept the license terms?", type => 'bool',
  		   default => 0)) {
      #
      # If an old style licence file exists, move it out of the way
      #
      if (-e $accepted_dir and !-d $accepted_dir) {
	rename($accepted_dir, "$accepted_dir.old") or
	  $self->croak("Unable to move old license file");
      }
      #
      # Create the directory if it does not already exists
      #
      (-d $accepted_dir) or File::Path::mkpath($accepted_dir) or
	    $self->croak("Could not make the directory [_1]",
			 $accepted_dir);

      $self->write_file("$accepted_dir/".$self->LICENSE_FILE, $license_text);
      $self->log;
      $self->log("License text saved in [_1]. You may print this file for your records.", "$accepted_dir/".$self->LICENSE_FILE);

      # Also write out the 'notices' file if it exists.
      my $notices = $self->ROOT."/resources/licenses/$self->{product}/notices";
      if (-r $notices) {
	my $notices_text = $self->_read_encoded($encoding, $notices);
	$self->write_file("$accepted_dir/notices", $notices_text);
      }

      $self->add_transaction("Accepted license agreement");
      $self->{config}{accepted_license_terms} = 1;
      return 1;
    }
    else {
      $self->log("Declining the license agreement will quit the installation process.");
      if ($self->ask(q => "Are you sure you want to decline the license agreement?", type => 'bool',
                   default => 0)) {
        $self->log;
        $self->log("License terms not accepted. Aborting install.");
        $self->add_transaction("Rejected license agreement");
        return 0;
      }
    }
  }
}

=item B<get_license_text>

  $self->get_license_text($language, $encoding, @files);

Get a string containing the localized license text in Perl's IR.

Returns undef if there is no license in the specified language.

=cut

sub get_license_text {
  my ($self, $language, $encoding, @files) = @_;
  my $LICENSE_DIR = $self->ROOT.'/resources/licenses/'.$self->{product};
  if ((grep {-r "$LICENSE_DIR/${_}_$language"} @files) == @files) {
    return $self->_read_encoded($encoding,
				map {"$LICENSE_DIR/${_}_$language"} @files);
  }
  else {
    return;
  }
}

# Auxiliary method for the above
sub _read_encoded {
  my ($self, $encoding, @files) = @_;
  local $/ = undef;
  my $text = '';
  foreach my $filename (@files) {
    open(my $fh, "<:encoding($encoding)", $filename) or
      $self->croak("Couldn't read license file [_1]", $filename);
    $text .= <$fh>;
    close $fh;
  }
  return $text;
}

=item B<language>

Returns the current language, eg. 'en_US' or 'fr_FR'.

In array context, also returns the more generalized language name as
the second element of the array, if appropriate.

May return an empty list if the language couldn't be detected.

=cut

sub language {
  my ($self) = @_;
  my ($langtag) = $self->_get_lh->language_tag;
  $langtag =~ s/-/_/g; # - should be _
  $langtag =~ s/_([a-z]+)$/_\U$1/; # final string of letters should be upcase
  my @lang = ($langtag);
  if ($langtag =~ /_/) {
    my ($lang_gen) = $langtag =~ /^([a-z]+)/i;
    push @lang, $lang_gen;
  }
  return wantarray ? @lang : $lang[0];
}

=item B<page>

  $installer->page('Some long string');

Shell out to a pager with the given string.

Uses more or cat, more is preferred.

=cut

sub page {
  my ($self, $string) = @_;
  my @commands = qw/more cat/;

  my $pager;
  C: foreach my $c (@commands) {
    # Absolute path?
    if ($c =~ m|/| and -x $c) { $pager = $c; last; }
    # Look in well-known dirs
    foreach my $dir (qw|/bin /usr/bin /usr/local/bin|) {
      if (-x "$dir/$c") {
	$pager = $c;
	last C;
      }
    }
  }

  # Store the text in a temporary file - less seems to like files more
  # than being piped stuff where utf8 is concerned.
  my $file = File::Temp->new(
			     TEMPLATE => $self->PRODUCT_NAME.'_pager_XXXXXX',
			     DIR      => File::Spec->tmpdir,
			     UNLINK   => 1,
			    );
  binmode $file, ":encoding($self->{encoding})";
  print $file $string;
  close $file;

  # Now open the pager
  $self->run_command($pager, $file->filename);
  $self->log;
}

=item B<mount_iso>

  $installer->mount_iso($iso_path, $mountpoint);

Mount the given ISO file at the given mountpoint. The mountpoint must
exist.

Returns true on success.

On failure, returns either 0 or undef. If undef is returned it means
something is wrong with mount and it is not worth mounting any further
ISOs.

=cut

sub mount_iso {
  my ($self, $iso_path, $mountpoint) = @_;
  if (not -d $mountpoint) {
    $self->croak("Cannot mount onto [_1] because the directory does not exist",
		 $mountpoint);
  }
  my $output = $self->run_command('mount', '-oloop,ro', '-tiso9660',
				  $iso_path, $mountpoint, '2>&1');
  $self->log_only_to_file($output);
  if ($self->{exit}) {
    if ($output =~ /could not find any (free )?loop device/i) {
      $self->log("WARNING: No loop devices available for mounting ISO files");
      return;
    }
    $self->log("Could not mount [_1] as an ISO file", $iso_path);
    return 0;
  }

  # Remember we mounted it.
  $self->{mounted_filesystems}{$mountpoint} = 1;
  return 1;
}

=item B<umount>

  $installer->umount($mountpoint);

Unmount the given mountpoint and croak if it fails.

=cut

sub umount {
  my ($self, $mountpoint) = @_;
  $self->run_command('umount', $mountpoint);
  if ($self->{exit}) {
    $self->croak("Failed to unmount [_1]", $mountpoint);
  }
  # Delete it from mounted_filesystems
  if (exists $self->{mounted_filesystems}) {
    delete $self->{mounted_filesystems}{$mountpoint};
  }
}

=item B<umount_all>

  $installer->umount_all;

Unmount all filesystems that we remembered we mounted (ideally this
shouldn't do anything but you can never be too sure).

=cut

sub umount_all {
  my ($self) = @_;
  if (exists $self->{mounted_filesystems}) {
    $self->umount($_) for keys %{$self->{mounted_filesystems}};
  }
}

=item B<is_on_remote_filesystem>

  if ($installer->is_on_remote_filesystem('/path/to/file')) {
    # STUFF
  }

Returns true if the major device number of the given file is 0 or
0xff, which probably suggests the device is nfs or fuse or something.

=cut

sub is_on_remote_filesystem {
  my ($self, $filename) = @_;
  my ($dev) = stat $filename;
  if (not defined $dev) {
    $self->croak("No such file [_1]", $filename);
  }
  my $major = $dev >> 8;
  return ($major == 0 or $major == 0xff);
}

=item B<directory_has_mounted_filesystems>

  $installer->directory_has_mounted_filesystems('/path/to/dir');

Looks in /proc for mounted filesystems beginning with the specified
path. If it finds any, it returns a string with the names in.

Given the named parameter 'include_self', it will include the
directory itself in its search.

Otherwise, returns false.

Note: Linux-specific

=cut

sub directory_has_mounted_filesystems {
  my ($self, $dir, %params) = @_;
  -d $dir or $self->croak("No such directory [_1].", $dir);
  $dir =~ s|/*$|/|; # make sure we have precisely one slash
  my @found;
  my @mounts = $self->slurp('/proc/mounts');
  foreach (@mounts) {
    (undef, my $mountpoint) = split;
    # convert octal numbers in the mountpoint to their real characters
    $mountpoint =~ s/\\(\d{3})/chr oct($1)/ge;
    if ($params{include_self}) {
      if ($mountpoint =~ /^\Q$dir/ or ("$mountpoint/" eq $dir)) {
	push @found, $mountpoint;
      }
    }
    else {
      if ($dir ne $mountpoint and $mountpoint =~ /^\Q$dir/) {
	push @found, $mountpoint;
      }
    }
  }
  return join(', ', @found);
}

=item B<determine_linux_distribution>

Returns the Linux distribution as a string (eg. SLES9SP3).

If it can't be determined (usually because the appropriate rules
haven't been added), returns a string containing "unknown".

If the $^O is not 'linux' it will simply return $^O.

Currently supports the following distributions:

  RHEL
  SLES

Takes an optional root path so it can be used to determine a subject
world's distribution.

=cut

sub determine_linux_distribution {
  my ($self, $root) = @_;

  # Not linux?
  unless ($root) {
    return $^O unless $^O eq 'linux';
  }

  $root ||= '';

  # Red Hat
  if (-f "$root/etc/redhat-release") {
    my $release = $self->slurp("$root/etc/redhat-release");
    if ($release =~ /Red Hat Enterprise Linux \w+ release (\d+)(?:\.(\d+))?/) {
      my $distro = "RHEL$1";
      if ($2){
        $distro .= "U$2";
      }
      elsif ($release =~ /Update (\d+)/) {
	$distro .= "U$1";
      }
      return $distro;
    }
    return "Red Hat unknown version";
  }

  # SLES
  if (-f "$root/etc/SuSE-release") {
    my $release = $self->slurp("$root/etc/SuSE-release");
    if ($release =~ /SUSE Linux Enterprise Server/i) {
      my $distro = "SLES";
      if ($release =~ /VERSION = (\d+)/) {
	$distro .= $1;
      }
      if ($release =~ /PATCHLEVEL = (\d+)/) {
	$distro .= "SP$1";
      }
      return $distro;
    }
    return "SUSE unknown version";
  }

  return 'unknown';
}

=item B<find_uninstalled_rpms>

Given a list of RPM package names, return the ones that are not installed.

=cut

sub find_uninstalled_rpms {
  my ($self, @packages) = @_;
  my @uninstalled;
  foreach (@packages) {
    $self->run_command(qw/rpm -q --quiet/, $_);
    push @uninstalled, $_ if $self->{exit};
  }
  return @uninstalled;
}

=item B<get_installed_rpm_full_name>

Given an RPM package name returns the full name of the RPM that is
installed or undef if the RPM is not installed.

  eg. POWER-x86 -> POWER-x86-0.3.2-SLES

=cut

sub get_installed_rpm_full_name {
  my ($self, $package_name) = @_;
  my $output = $self->run_command('rpm', '-q', $package_name, '2>&1');
  return if $self->{exit}; # indicates a problem
  chomp $output;
  return $output;
}

=item B<get_uninstalled_rpm_full_name>

Given an RPM file, returns the correct name for the RPM.

 e.g. /path/to/powervm-lx86-latest.rpm ->  powervm-lx86-0.1.0-SLES

=cut

sub get_uninstalled_rpm_full_name {
  my ($self, $package_name) = @_;

  # RPM has an annoying bug that means we have to "double-escape"
  # spaces in the filename.
  $package_name =~ s/ /\\ /g;

  my $output = $self->run_command('rpm', '-qp', $package_name, '2>&1');
  return if $self->{exit}; # indicates a problem
  chomp $output;
  return $output;
}

=item B<install_rpm>

  $installer->install_rpm('/path/to/some.rpm');
  $installer->install_rpm('/path/to/some.rpm', prefix => '/usr/local');

Install the given RPM package. Returns true on success, false on
error.

Output/error is stored in $self->{rpm_output}.

Options are provided as hash parameters. Supports the following:

  upgrade (bool)
  prefix (path)
  test (bool)

=cut

sub install_rpm {
  my ($self, $rpm, %options) = @_;

  my @command = qw/rpm --quiet/;
  if ($options{prefix}) {
    push @command, '--prefix', "$options{prefix}";
  }
  if ($options{test}) {
    push @command, '--test';
  }
  if ($options{upgrade}) {
    push @command, '-U';
  }
  else {
    push @command, '-i';
  }
  push @command, $rpm;
	
  # It's not clear why, but this command can return zero exit status
  # in non-English languages
  local $ENV{LANG} = local $ENV{LC_ALL} = 'en_US.UTF-8';

  $self->{rpm_output} = $self->run_command(@command, '2>&1');
  return not $self->{exit}; # we want true if it's nonzero
}

=item B<uninstall_rpm>

  $installer->uninstall_rpm('PackageName');

Install the given RPM package. Returns true on success, false on
error.

Output is stored in $self->{rpm_output}.

=cut

sub uninstall_rpm {
  my ($self, $package) = @_;
  my @command = qw/rpm --quiet -e/;
  push @command, $package;
  $self->{rpm_output} = $self->run_command(@command, '2>&1');
  return not $self->{exit}; # we want true if it's nonzero
}

=item B<get_running_processes_of_type>

  my @pids = $installer->get_running_processes_of_type('foo');

Returns a list of pids running with the given name.

If the 'pgrep' command is not available, will return an empty list and
generate a warning.

=cut

sub get_running_processes_of_type {
  my ($self, $type) = @_;
  my @cmd = (qw/pgrep -x/, $type);
  my $pids = $self->run_command(@cmd);
  # 1 means "pass but no processes"
  if ($self->{exit} && ($self->{exit} != 1)) {
    $self->log("WARNING: Couldn't determine if [_1] processes are running.",
	       $type);
  }
  my @pids = split "\n", $pids;
  return @pids;
}

=item B<get_living_processes>

  my @not_zombies = $installer->get_living_processes(@pids);

Returns a list of processes not in state 'Z'.

If @pids is defined, returns only the subset of @pids that are living.
If ps fails, assumes all of @pids are still living.

Tested on Linux only.

=cut

sub get_living_processes {
  my ($self, @pids) = @_;
  my @cmd = ('ps', '-o', 'pid,state');
  if (@pids) {
    my $pids_csv = join ',', @pids;
    push @cmd, '-p', $pids_csv;
  } else {
    push @cmd, '-e';
  }
  my $pids = $self->run_command(@cmd);
  if ($self->{exit} && ($self->{exit} != 1)) {
    return @pids;
  }

  my @valid_pids;
  my @all_pids = split "\n", $pids;
  shift @all_pids;
  for my $ps_line (@all_pids) {
    my ($pid, $state) = split " ", $ps_line;
    if ($state !~ /z/i) {
      push @valid_pids, $pid;
    }
  }
  return @valid_pids;
}

=item B<check_disk_space_in>

  my $space = $self->check_disk_space_in('/some/dir');

Returns the number of KB free on the disk containing the specified
directory.

If the directory does not exist, it works up the tree until it finds
one that does.

NOTE: Only works on Linux.

Croaks on error.

=cut

sub check_disk_space_in {
  my ($self, $dir) = @_;
  if (not -d $dir) {
    return $self->check_disk_space_in(File::Basename::dirname($dir));
  }
  my $df = $self->run_command('df', '-P', $dir, '2>&1');
  $self->log_only_to_file($df);
  my @df = split "\n", $df;
  if ($self->{exit} or not $df[1]) {
    $self->croak("Error checking disk space.");
  }
  my @fields = split /\s+/, $df[1];
  return $fields[3];
}

=item B<are_files_on_same_filesystem>

  if ($self->are_files_on_same_filesystem('/path/to/file1', '/other/file2')) {
    #
  }

Returns true if stat() believes the two specified files or directories
are on the same filesystem.

If either file doesn't exist, it will work its way up the tree until
it finds one that does.

=cut

sub are_files_on_same_filesystem {
  my ($self, $file1, $file2) = @_;
  if (not -e $file1) {
    return $self->are_files_on_same_filesystem(File::Basename::dirname($file1),
					       $file2);
  }
  if (not -e $file2) {
    return $self->are_files_on_same_filesystem($file1,
					       File::Basename::dirname($file2));
  }
  my @stat1 = stat $file1;
  my @stat2 = stat $file2;
  return ($stat1[0] == $stat2[0]);
}

=item B<set_default_config_common>

  $installer->set_default_config_common;

Call this method if you want to set the following variables based on:

  1. The config file if it exists
  2. Default values in constants of the installer subclass

These variables are set (can still be overridden by the user in
get_initial_config_interactively):

  config_exists
  anything set in CONFIG_DEFAULTS

If $self->{config}{old_product_installed} is set, it will be used to
work out what the defaults are.

If a filename is provided as the parameter 'filename', it will be used
instead of $self->CONFIG_FILE.

If the parameter 'askif' is true, it will only update the
$self->{config} for variables that pass their 'askif' test.

=cut

sub set_default_config_common {
  my ($self, %options) = @_;
  my $config_defaults = $self->CONFIG_DEFAULTS;

  if (not $options{filename}) {
    $options{filename} = "$self->{config}{config_dir}/".$self->CONFIG_FILE;
    $self->{config}{config_exists} = -f $options{filename};
  }

  # Look in the config file first
  if (-f $options{filename}) { # don't use config_exists because this
                               # might not be called with the default
                               # config filename
    local $_ = $self->slurp($options{filename}, ':unix');
    foreach my $h (@$config_defaults) {

      # NOTE: Don't check for 'askif' because we don't actually know
      # if the conditions are true yet.

      # Check for values not just of var, but also of any
      # formerly-used names in the old_var_names array
      my @vars_to_check = ($h->{var});
      if ($h->{old_var_names}) {
	push @vars_to_check, @{$h->{old_var_names}};
      }
      foreach my $var (@vars_to_check) {
        # Pick out the value and comments; currently we just discard the comments
        my ($value, $comment) = /^\Q$var\E=(.*?)\s*(\#.*?)?$/m;
        if ($value) {
          $self->{config}{$h->{key}} = $value;
          last;
        }
      }
    }
  }

  # Set them if they are not set already
  foreach my $h (@$config_defaults) {
    my $subname = $h->{default};
    $self->{config}{$h->{key}} ||= $self->$subname($self->{config}{old_product_installed});
  }
}

=item B<get_all_config_from_file>

Just like set_default_config_common, except it also looks for
variables named INSTALLER_* - each one of these will be assumed to be
a key in the $self->{config} hash (but normalized to lower case and
without the INSTALLER_ prefix).

set_default_config_common is always called by this with askif set to
true.

If a variable in SPECIAL_CONFIG_FILE_VARS is encountered, it will be
treated as an array or hash accordingly.

Also logs the contents of the file to the logfile.

Dies if the config file (or the global one if not specified) doesn't
exist.

=cut

sub get_all_config_from_file {
  my ($self, $filename) = @_;

  # This needs to be done before we set $filename if it is undef
  $self->set_default_config_common(filename => $filename, askif => 1);

  my $default_filename = "$self->{config}{config_dir}/".$self->CONFIG_FILE;
  $filename ||= $default_filename;

  # Only error if the user has specified a config filename, otherwise
  # assume that empty == OK
  if ($filename ne $default_filename and not -f $filename) {
    $self->croak("No such config file: [_1]", [$filename, 'user']);
  }

  if (-f $filename) {
    my @lines = $self->slurp($filename, ':unix');

    # Log the config file contents
    $self->log_only_to_file("\n");
    $self->log_only_to_file("Loaded config from file $filename\n");
    $self->log_only_to_file(join '', @lines);
    $self->log_only_to_file("\n");

    foreach my $line (@lines) {
      if ($line =~ /^INSTALLER_(\w+)=(.*?)\s*$/) {
	my $key = lc $1;
	my $value = $2;
	if (exists $self->SPECIAL_CONFIG_FILE_VARS->{$key}) {
	  if ($self->SPECIAL_CONFIG_FILE_VARS->{$key} eq '@') {
	    # Array
	    push @{$self->{config}{$key}}, $value;
	  }
	  else {
	    # Hash
	    my ($key2, $value2) = split /=/, $value;
	    $self->{config}{$key}{$key2} = $value2;
	  }
	}
	else {
	  $self->{config}{$key} = $value;
	}
      }
    }
  }

  # Dump the loaded config to the file
  $self->log_only_to_file(Data::Dumper->Dump([$self->{config}], ['config']));
}

=item B<get_config_common_interactively>

Asks the user for the config values in CONFIG_DEFAULTS, defaulting to
whatever they were before this method was called.

=cut

sub get_config_common_interactively {
  my ($self) = @_;
  my $config_defaults = $self->CONFIG_DEFAULTS;

  foreach my $h (@$config_defaults) {
    # If we have an askif method and it returns false, don't proceed to ask.
    if (not exists $h->{askif} or $h->{askif}->($self)) {
      $self->{config}{$h->{key}} =
	$self->ask(q => $h->{question},
		   type => ($h->{path} ? 'path' : 'string'),
		   default => $self->{config}{$h->{key}});
    }
  }
}

=item B<get_config_file_lines_common>

Gets an array of lines for the config file corresponding to the values
of the CONFIG_DEFAULTS in $self->{config}.

=cut

sub get_config_file_lines_common {
  my ($self) = @_;
  my $config_defaults = $self->CONFIG_DEFAULTS;
  my @config;
  foreach my $h (@$config_defaults) {
    my $subname = $h->{default};
    if ($self->{config}{$h->{key}} and
	$self->{config}{$h->{key}} ne
	$self->$subname($self->{config}{old_product_installed})) {
      push @config, "$h->{var}=$self->{config}{$h->{key}}";
    }
  }
  return @config;
}

=item B<get_uncommon_config_lines>

Gets an array of lines from the config file that are not in the
CONFIG_DEFAULTS so they can be written back to the file unharmed.

=cut

sub get_uncommon_config_lines {
  my ($self) = @_;

  # Make the common vars (from CONFIG_DEFAULTS) into a hash.
  my %common_vars;
  @common_vars{map {$_->{var}} @{$self->CONFIG_DEFAULTS}} = ();
  foreach my $val (@{$self->CONFIG_DEFAULTS}) {
    if ($val->{old_var_names}) {
      @common_vars{@{$val->{old_var_names}}} = ();
    }
  }

  # Special extra vars are added here
  $common_vars{LOCALISATION_FILES_DIR} = undef;

  # The lines we want are the ones that don't begin with one of the
  # common vars.
  my @lines;
  if (-f "$self->{config}{config_dir}/".$self->CONFIG_FILE) {
    @lines = grep { not /^(\w+)=/ or not exists $common_vars{$1} }
      $self->slurp("$self->{config}{config_dir}/".$self->CONFIG_FILE, ':unix');
  }

  return @lines;
}

=item B<replicate_passwd_and_friends>

Given a directory, copy the passwd/group/shadow files into that
directory's /etc.

Remove any compat lines (/^\+/).

Ensure the permissions are the same.

=cut

sub replicate_passwd_and_friends {
  my ($self, $path) = @_;
  foreach my $file (qw/passwd group shadow/) {
    my $src  = "/etc/$file";
    next unless -f $src; # 'shadow' in particular may not exist
    my $dest = "$path/etc/$file";
    my @src_lines = $self->slurp($src);
    @src_lines = grep !/^\+/, @src_lines; # remove compat lines
    $self->write_file($dest, \@src_lines);
    my $p = $self->get_permissions($src);
    chmod $p, $dest or
      $self->croak("Could not set permission of [_1]", $dest);
  }
}

=item B<install_self_into>

  $installer->install_self_into('/path/to/installer');

Copies the entire installer directory into the given path, creating it
if it doesn't already exist.

The installer directory is assumed to be the parent directory of this
file, UtilFunctions.pm.

=cut

sub install_self_into {
  my ($self, $dir) = @_;
  # Remove any previous installation
  if (-d $dir) {
    File::Path::rmtree($dir);
  }
  # Create parent directories in case they don't already exist.
  File::Path::mkpath($dir);
  rmdir $dir or # Remove the directory itself
    $self->croak("Unable to remove [_1]", $dir);

  # Determine installer directory
  my $installer_dir = Cwd::abs_path($self->ROOT)
    or $self->croak("Could not determine installer directory.");

  # We could do a recursive copy with File::Find and File::Copy but
  # the number of edge cases is huge. Instead, we'll shell out to the
  # system's cp command.
  $self->run_command('cp', '-r', $installer_dir, $dir);
  if ($self->{exit}) {
    $self->croak("Failed to copy installer directory to [_1]: [_2]", $dir, $!);
  }
}

=item B<check_archive_functionality_available>

  if ($installer->check_archive_functionality_available) {
    # ...
  }

Returns true (star's version number) if star is installed.

Otherwise prints a message and returns false.

=cut

sub check_archive_functionality_available {
  my ($self) = @_;
  if (-x "/usr/bin/star") {
    my $version_info = $self->run_command('/usr/bin/star', '--version');
    my ($version) = $version_info =~ /star ([\d\.a]+)/;
    return $version;
  }
  else {
    $self->log;
    $self->log("This functionality is only available if the 'star' utility is installed.\nPlease locate and install the appropriate RPM file.");
    return 0;
  }
}

=item B<get_metadata_from_archive_file>

  my $metadata = $installer->get_metadata_from_archive_file('/path/to/archive.bin');
  my ($metadata, $fh) = $installer->get_metadata_from_archive_file(...);

Given an archive file generated by Maiken, return the metadata portion
of the file as a hashref.

Dies if the file doesn't exist.

Returns undef if the file is not an archive file.

If called in array context, returns the filehandle, seeked to the
right point, as a second return value. Otherwise, the filehandle is
closed.

=cut

sub get_metadata_from_archive_file {
  my ($self, $filename) = @_;
  local $/ = "\n";
  if (not -f $filename) {
    $self->croak("Archive file [_1] does not exist", $filename);
  }
  open(my $fh, $filename) or
    $self->croak("Cannot open '[_1]' for reading: [_2]", $filename, $!);
  my $firstline = <$fh>;
  if (not $firstline or $firstline ne "-*- Maiken archive -*-\n") {
    return undef;
  }
  my %metadata;
  while (my $line = <$fh>) {
    if ($line eq "__DATA__\n") {
      if (wantarray) {
	return (\%metadata, $fh);
      }
      else {
	close $fh;
	return \%metadata;
      }
    }
    elsif ($line =~ /^(\w+)=(.*)$/) {
      $metadata{$1} = $2;
    }
    elsif ($line !~ /^#/) {
      $self->log_only_to_file("Can't understand the line: $line");
      return undef;
    }
  }
}

=item B<install_archive_file>

  $installer->install_archive_file('/path/to/archive.bin', '/directory');

Installs the specified archive file to the specified directory.

Dies if the archive file doesn't exist or is not an archive file or
the installation fails.

Dies if the directory doesn't exist.

=cut

sub install_archive_file {
  my ($self, $filename, $directory) = @_;
  use bytes;

  if (not -d $directory) {
    $self->croak("No such directory [_1].", $directory);
  }

  # Use this method to check everything's OK and skip over the metadata
  my ($metadata, $fh) = $self->get_metadata_from_archive_file($filename);

  # Errctl file for controlling error messages
  my $errctl = $self->ROOT.
    "/resources/config/$self->{product}/star_errctl_install";

  # Now, open a pipe for extracting the tarball
  my @options = ('-x', '-xattr', '-silent', '-no-statistics',
		 '-errctl', $errctl, '-H=exustar', '-z', '-p', '-U',
		 '-C', $directory);
  $self->log_only_to_file("[star options: @options]\n");
  local $SIG{PIPE} = sub {
    $self->log_only_to_file("Broken pipe installing archive!\n");
    $self->croak("Failed to install archive.");
  };
  open(my $pipe, '|-') or do {
    exec('/usr/bin/star', @options) or exit 255;
  };
  while (read $fh, my $chunk, 1024) {
    print $pipe $chunk;
  }
  close $fh;
  close $pipe or $self->croak("Failed to install archive.");
  if ($?) {
    $self->croak("Failed to install archive.");
  }

  # Update the absolute symlinks
  if ($metadata->{sw_root_path}) {
    $self->update_absolute_symlinks_from_to($metadata->{sw_root_path},
					    $directory, $directory);
  }
}

=item B<update_absolute_symlinks_from_to>

  $installer->update_absolute_symlinks_from_to('/old/path', '/new/path', $dir);

Given two absolute paths and a directory, recursively update any
absolute symlinks that begin with the old path to begin with the new
path.

Croaks on error.

=cut

sub update_absolute_symlinks_from_to {
  my ($self, $old_path, $new_path, $dir) = @_;
  return if $old_path eq $new_path; # nothing to do!
  my $sub = sub {
    return unless -l;
    my $path = readlink;
    if ($path =~ m!^$old_path(/|$)!) {
      $path =~ s/^$old_path/$new_path/;
      unlink or $self->croak("Cannot remove [_1]: [_2]",
			     $File::Find::name, $!);
      symlink $path, $_ or
	$self->croak("Failed to create symlink [_1]", $File::Find::name);
    }
  };
  File::Find::find($sub, $dir);
}

=item B<create_archive_file>

  $installer->create_archive_file('/path/to/archive.bin', '/directory',
                                  $metadata, $exclude_patterns);

Creates the given archive file using the given directory as the tree
to build from and the metadata hashref as data to write to the
metadata section of the file. The fourth optional argument is an
arrayref of patterns to exclude.

Dies if the archive can't be created.

=cut

sub create_archive_file {
  my ($self, $filename, $directory, $metadata, $exclude_patterns) = @_;
  use bytes;

  my @exclude_args;
  if ($exclude_patterns) {
    push @exclude_args, '-V';
    push @exclude_args, "pat=$_" for @$exclude_patterns;
  }

  open(my $fh, '>', $filename) or
    $self->croak("Cannot open [_1] for write: [_2]", $filename, $!);

  # Print the header and metadata
  print $fh "-*- Maiken archive -*-\n";
  foreach my $key (sort keys %$metadata) {
    print $fh "$key=$metadata->{$key}\n";
  }
  print $fh "__DATA__\n";

  # Errctl file for controlling error messages - use the _new if the
  # version is 1.5a67 or greater, because the WARN|ALL syntax is
  # supported for greater reliability. NOTE: 1.5 (ie. 1.5 final) is
  # greater than 1.5a67
  my $errctl = $self->ROOT.
    "/resources/config/$self->{product}/star_errctl_create";
  my $version = $self->check_archive_functionality_available;
  my ($maj, $min, $point) = $version =~ /^(\d+)\.(\d+)(?:\w+(\d+))?$/;
  if ($maj > 1 or ($maj == 1 and $min > 5) or
      ($maj == 1 and $min == 5 and (not $point or $point >= 67))) {
    $errctl .= '_new';
  }

  # Now hand it over to star to generate the file
  my @options = ('-c', '-xattr', '-silent', '-no-statistics',
		 '-errctl', $errctl, '-H=exustar',
		 @exclude_args, '-z', '-p', '-C', $directory, '.');
  $self->log_only_to_file("[star options: @options]\n");
  open(my $pipe, '-|') or do {
    exec('/usr/bin/star', @options) or exit 255;
  };
  while (read $pipe, my $chunk, 1024) {
    print $fh $chunk;
  }
  close $fh or
    $self->croak("Can't finish writing file [_1]: [_2]", $filename, $!);
  close $pipe or $self->croak("Failed to create archive.");
  if ($?) {
    $self->croak("Failed to create archive.");
  }
}

=item B<fix_config_dir>

  $installer->fix_config_dir;

If the config directory is an old one, move it to the correct location.

Fatal error if unsuccessful.

=cut

sub fix_config_dir {
  my ($self) = @_;
  if ($self->{config}{config_dir} ne $self->CONFIG_DIR) {
    rename $self->{config}{config_dir}, $self->CONFIG_DIR
      or $self->croak("Failed to rename config directory to [_1]",
		      $self->CONFIG_DIR);
    $self->{config}{config_dir} = $self->CONFIG_DIR;
  }
}

=item B<log_no_trans>

  $installer->log_no_trans("Foo");

Like log() below but without the translation. Also doesn't add the
newline automatically.

=cut

sub log_no_trans {
  my ($self, $msg) = @_;
  print $msg unless ref $self and $self->{quiet};
  $self->log_only_to_file($msg);
}

=item B<log_only_to_file>

  $installer->log_only_to_file("Foo");

Like log_no_trans() above but will only log to the logfile if it
exists and not to the user.

The second parameter sets an optional binmode on the filehandle
(instead of utf8), which is useful if you want to write out a
bytestream without the auto-conversion.

If $msg is not in Perl's internal representation, please specify the
encoding as the third parameter.

=cut

sub log_only_to_file {
  my ($self, $msg, $binmode, $msg_encoding) = @_;
  if ($msg_encoding) {
    $msg = Encode::decode($msg_encoding, $msg);
  }
  if (ref $self and $self->{logfile}) {
    my $fh = $self->{logfile};
    binmode $fh, $binmode if $binmode;
    print $fh $msg;
    binmode $fh, ':utf8' if $binmode;
  }
}

=item B<log>

  $installer->log("Some message");

This method should always be called instead of print() as it will
redirect the output to the appropriate place and localize it into the
user's language if applicable.

A newline will be added automatically.

If any of the arguments are arrayrefs, the second parameter will be
assumed to be a control string. The following control strings are
supported:

  user: Parameter was entered as user input - it will be decoded back
  to the user's encoding and will not be translated.

If you want to print even in quiet mode, do it like this:

  {
    local $self->{quiet} = 0;
    $self->log("Loud message!");
  }

=cut

sub log {
  my ($self, $msg, @args) = @_;
  # Just a newline if given no args
  if (not $msg) {
    $self->log_no_trans("\n");
    return;
  }

  chomp $msg; # we don't want any newline sending to maketext

  # Watch out for tuples that include a control string.
  my ($args_copy, $args_copy_untranslated) = $self->_sort_control_strings(\@args);

  # Send the translated to stdout
  # Also translate the args themselves
  my $trans = $self->_get_lh->maketext($msg, @$args_copy);
  print "$trans\n" unless ref $self and $self->{quiet};

  # Send only the English to the logfile
  my $english = $self->_get_lh('english')->maketext($msg, @$args_copy_untranslated);
  $self->log_only_to_file("$english\n");
}

=item B<croak>

  $installer->croak("Oh dear");

This is like log() above but terminates the program.

=cut

sub croak {
  my ($self, @msg) = @_;
  $self->log;
  $self->log("Installer exited abnormally, with the following error:");
  {
    if (ref $self) {
      local $self->{quiet} = 0;
      $self->log(@msg);
    }
    else {
      $self->log(@msg);
    }
  }
  $self->log;
  if (ref $self and $self->{logfile} and
      UNIVERSAL::isa($self->{logfile}, 'File::Temp')) {
    $self->log("If you require support, please send the logfile [_1] to [_2].",
	       $self->{logfile}->filename, $self->SUPPORT_NAME);
  }
  $self->umount_all if ref $self; # In case this is being called from the class
  exit 255;
}

=item B<ask>

  $installer->ask(q       => "Do you want instructions?",
                  type    => 'bool',
                  default => 1);

Ask a question. Should only be used in functions that run in
interactive mode. Returns the answer.

  q:       The question (arrayref or string, arrayref is of args to maketext)
  type:    'bool' or 'string' or 'path'
  default: 1/0 for bools, anything for strings (optional, defaults to 0/'')
  skip:    if true will allow paths of 'skip'
  list:    if true will allow paths of 'list'
  slash_allowed: if true will allow paths of '/'
  must_exist: if true for paths then the path must exist (unless 'skip' etc.)

=cut

sub ask {
  my ($self, %args) = @_;

  # 1. Error checking
  unless ($self->{rl}) {
    $self->croak("Not connected to an interactive terminal");
  }
  if (!$args{type} or $args{type} !~ /^(bool|string|path)$/) {
    $self->croak("ask(): Invalid type");
  }
  if (!$args{q}) {
    $self->croak("ask(): No 'q' parameter given");
  }

  # 2. Ask question
  my ($q, @args) = ref $args{q} ? @{$args{q}} : ($args{q});
  my ($args_copy, $args_copy_untranslated) = $self->_sort_control_strings(\@args);
  my $prompt = $self->_get_lh->maketext($q, @$args_copy);
  my $prompt_no_trans = $self->_get_lh('english')->maketext($q, @$args_copy_untranslated);
  if ($args{type} eq 'bool') {
    $prompt .= $args{default} ? ' [Y/n]' : ' [y/N]';
    $prompt_no_trans .= $args{default} ? ' [Y/n]' : ' [y/N]';
  }
  elsif ($args{default}) {
    my $default = $args{default};
    $default = Encode::decode($self->{encoding}, $default)
      if $args{type} eq 'path';
    $prompt .= " [$default]";
    $prompt_no_trans .= " [$default]";
  }
  $prompt .= ' ';
  $prompt_no_trans .= ' ';
  # 3. Get answer
  $self->log_only_to_file($prompt_no_trans);
  # change prompt from Perl's IR to bytestream in correct encoding
  $prompt = Encode::encode($self->{encoding}, $prompt);
  my $answer = $self->{rl}->readline($prompt);
  # change answer from bytestream to Perl's IR, unless it's a path
  unless ($args{type} eq 'path') {
    $answer = Encode::decode($self->{encoding}, $answer);
  }
  if (!defined $answer) {
    # Received EOF? Ask again
    $self->log;
    return $self->ask(%args);
  }
  if ($args{type} eq 'path') {
    $self->log_only_to_file("$answer\n", undef, $self->{encoding});
  }
  else {
    $self->log_only_to_file("$answer\n");
  }

  # 4. Process answer accordingly
  if ($args{type} eq 'bool') {
    if ($answer eq '') {
      return $args{default};
    }
    elsif (lc $answer eq 'n') {
      return 0;
    }
    elsif (lc $answer eq 'y') {
      return 1;
    }
    else {
      $self->log("Please enter 'y' or 'n'.");
      return $self->ask(%args); # ask again
    }
  }
  elsif ($args{type} eq 'path') {
    if ($answer) {
      $answer =~ s/^\s+//;
      $answer =~ s/\s+$//;
      $answer =~ s|\/{2,}|\/|g;     #Eliminate slash duplication
    }
    return $answer if $args{skip} and $answer eq 'skip';
    return $answer if $args{list} and $answer eq 'list';
    return $args{default} if $args{default} and not $answer;
    # The only check we have for an absolute path is that it begins with /
    if ($answer !~ m|^/|) {
      $self->log("Please enter a valid absolute path.");
      return $self->ask(%args); # ask again
    }
    if ($answer =~ /['"`\$]/) {
      $self->log("Please enter a path that does not contain any of the characters '\"`\$");
      return $self->ask(%args); # ask again
    }
    if ($answer eq '/' and not $args{slash_allowed}) {
      $self->log("Please enter a path that is not the root '/' directory.");
      return $self->ask(%args); # ask again
    }
    my $banned_fs_regexp = join('|', $self->BANNED_FILESYSTEMS);
    if ($answer =~ m!^($banned_fs_regexp)(/|$)!) {
      $self->log("Please enter a path that is not under the /dev, /proc, /selinux, /sys filesystems.");
      return $self->ask(%args); # ask again
    }
    if ($args{must_exist} and not -e $answer) {
      $self->log("Please enter a path that exists.");
      return $self->ask(%args); # ask again
    }	
    {
      use bytes; # So unicode character count as the number of bytes,
                 # rather than just 1.

      # Problems with POSIX::PATH_MAX are so frequently identified
      # that we just hardcode 79 (was: 256) now
      my $path_max = 79;
      if (length $answer > $path_max) {
	$self->log("Please enter a path that is less than [_1] bytes long",
		   $path_max);
	return $self->ask(%args);
      }
    }
    $answer =~ s|\/$||;    #Strip the final slash
    return $answer;
  }
  return ($answer || $args{default} || ''); # if expecting a string
}


=item B<percent>

  $installer->percent($numerator, $denominator, %options);

Prints the percentage compelte, and a graphic showing it.

If $self->{rpm_start_time} is set, also prints an estimate of how
long the installation will take.

Prints nothing if $self->{quiet}.

If the options 'ppack' and 'ppack_msg' are provided, it will update
the specified PowerPack's status (see Maiken::RO::PowerPack) with the
current percentage and message.

=cut

sub percent {
  my ($self, $numerator, $denominator, %options) = @_;
  return if $self->{quiet};

  my $percent = ($denominator == 0 ? 0 : ($numerator/$denominator)*100);

  # Only show 100% when we're actually complete:
  $percent = 99 if $percent == 100 and $numerator < $denominator;

  # Show the percentage, then a graphic like [=======> ]
  # \r\e[K means "return to start and erase line"
  printf("\r\e[K%3d%%  [%-21s] ", $percent, (('=' x int($percent/5)) . '>'));

  unless ($percent == 100) {
    my $remaining_string =
      $self->rounded_time_remaining($numerator, $denominator);
    print "  $remaining_string " if $remaining_string;
  }

  if ($options{ppack}) {
    $options{ppack}->progress(percent => int($percent),
			      title => $options{ppack_msg});
  }
}


=item B<rounded_time_remaining>

  $installer->rounded_time_remaining($count, $total_count)

Returns a string suggesting how long it will take
for the remainding items to be installed. Gives a
very rounded guess so as not to be too misleading.

Expects $self->{rpm_start_time} to be set to the time that
the installation started - returns undef if it isn't.

=cut

sub rounded_time_remaining {
  my ($self, $count, $total_count) = @_;
  ($count and $total_count and $self->{rpm_start_time}) or return;

  # Insist on being at least 4% of the way there or have at least
  # 20 things installed before we attempt to guess the time remaining.
  ($count > 20 or $count * 25 > $total_count) or return;

  # So far, how long have we been installing RPMs?
  my $time_so_far = time() - $self->{rpm_start_time};

  my $est_total_time = ($time_so_far / $count) * $total_count;
  my $time_remaining = $est_total_time - $time_so_far;
  my @msg;

  # One minute or less (when rounded)? Say 1 minute, as at this level
  # it's not worth attempting to be more accurate.
  if ($time_remaining < 90) {
    @msg = ('About a minute remaining');
  }

  # More than 4 hours? Say 'several hours'. Otherwise we run the risk
  # of giving wildly large estimates for slow machines.
  elsif ($time_remaining >= 60 * 60 * 4) {
    @msg = ('Several hours remaining');
  }

  # More than an hour (but not more than 4)? Round to the nearest hour.
  elsif ($time_remaining >= 3600) {
    my $hours = int((1800 + $time_remaining) / 3600);
    if ($hours > 1) {
      @msg = ('About [_1] hours remaining', $hours)
    }
    else {
      @msg = ('About an hour remaining');
    }
  }

  else {
    my $minutes;

    # Under 15 minutes? Show to the nearest minute
    if ($time_remaining < 900) {
      $minutes = int((30+$time_remaining) / 60);
    }

    # Over 15 minutes? Round down to the nearest 5 minutes
    # (Round down so as not to get '60 minutes')
    else {
      $minutes = 5 * int($time_remaining / 300);
    }

    @msg = ("About [_1] minutes remaining", $minutes);
  }

  return $self->_get_lh->maketext(@msg);
}


=item B<menu>

  $installer->menu(
    [
     [foo => 'Do some foo'],
     [bar => 'Go to a bar'],
    ],
    "Please select an option:"
  );

Present the user with a menu. The arrayref given should be a list of
pairs. The first element should be the string that is returned by menu
if the user chooses it and the second element should be the string the
user is presented with.

This string may instead by an arrayref to be passed to log().

The second parameter should be the prompt, defaults to
"Please select the type of operation you would like to perform:"

=cut

sub menu {
  my ($self, $menu, $prompt) = @_;
  $prompt ||= "Please select the type of operation you would like to perform:";
  my $answer = 0;
  while (!$answer or $answer =~ /\D/ or $answer < 1 or $answer > @$menu) {
    $self->log;
    for my $idx (0..@$menu-1) {
      my $option = $menu->[$idx][1];
      my ($first, @rest) = (ref $option ? @$option : $option);
      $self->log_no_trans(($idx+1).". ");
      $self->log($first, @rest);
    }
    $self->log;
    $answer = $self->ask(q => $prompt, type => 'string');
  }
  my $response = $menu->[$answer-1][0];
  return $response;
}

=item B<add_transaction>

  $installer->add_transaction("Installed [_1]", $foo);

Like log() but adds it to the transaction log to be shown to the user
when done instead of straight away.

=cut

sub add_transaction {
  my ($self, @args) = @_;
  push @{$self->{transactions}}, \@args;
}

=item B<md5sum_of_file>

  $md5sum = $installer->md5sum_of_file($filename);

Returns the md5sum of a file (as hex)

=cut

sub md5sum_of_file {
  my ($self, $f) = @_;

  my $handle;
  open($handle, $f) or $self->croak("Cannot open '[_1]' for reading: [_2]", $f, $!);
  binmode($handle);

  my $digest ="";
  eval {
    $digest = Digest::MD5->new->addfile($handle)->hexdigest;
  };
  if ($@) {
    $self->log_only_to_file("Error generating MD5 for $f");
  }
	
  return $digest;
}

=item B<_get_lh>

Get a locale handle. If called from an object it will cache the handle
in the object. Otherwise it creates a fresh one and returns it.

If given the optional parameter $english as a true value will always
get an English lh. This is so that we can log in English.

=cut

sub _get_lh {
  my ($pkg_or_self, $english) = @_;
  my $keyword = 'normal';
  my @args;
  if ($english) {
    $keyword = 'english';
    @args = ('en_US.UTF-8');
  }
  if (ref $pkg_or_self) {
    if (!exists $pkg_or_self->{"lh_$keyword"}) {
      $pkg_or_self->{"lh_$keyword"} = Maiken::L10N->get_handle(@args);
      if (!defined $pkg_or_self->{"lh_$keyword"}) {
	Carp::croak("No locale handle (called from class $pkg_or_self)!");
      }

    }
    return $pkg_or_self->{"lh_$keyword"};
  }
  else {
    my $lh = Maiken::L10N->get_handle(@args);
    if (!defined $lh) {
      Carp::croak("No locale handle (called from class $pkg_or_self)!");
    }
    return $lh;
  }
}

=item B<_sort_control_strings>

Given an arrayref of args to log(), returns two arrayrefs of $args_copy
and $args_copy_untranslated with the any control strings (tuples)
processed.

=cut

sub _sort_control_strings {
  my ($self, $args) = @_;
  my (@args_copy, @args_copy_untranslated);
  foreach (@$args) {
    my $control = '';
    if (UNIVERSAL::isa($_, 'ARRAY')) {
      $control = $_->[1];
      $_ = $_->[0];
    }

    if ($control =~ /\buser\b/) {
      # Decode back to user's encoding
      $_ = Encode::decode($self->{encoding}, $_);
    }
    push @args_copy_untranslated, $_;

    # Translate if this isn't user input
    if ($control !~ /\buser\b/) {
      # Translate it
      $_ = $self->_get_lh->maketext($_);
    }
    push @args_copy, $_;
  }

  return (\@args_copy, \@args_copy_untranslated);
}


=back 4

=cut

1;
