client/tools/boottool

#!/usr/bin/perl
=head1 NAME

Linux::Bootloader - Base class interacting with Linux bootloaders

=head1 SYNOPSIS

	
	my $bootloader = new Linux::Bootloader();
        my $config_file='/boot/grub/menu.lst';
	
	$bootloader->read($config_file);
	$bootloader->print_info('all');
	$bootloader->add(%hash);
	$bootloader->update(%hash);
	$bootloader->remove(2);
	$bootloader->get_default();
	$bootloader->set_default(2);
	%hash = $bootloader->read_entry(0);
	$bootloader->write($config_file);

  
=head1 DESCRIPTION

This module provides base functions for working with bootloader configuration files.

=head1 FUNCTIONS

=head2 new()

	Creates a new Linux::Bootloader object.

=head2 read()

	Reads configuration file into an array.
	Takes: string.
	Returns: undef on error.

=head2 write()

	Writes configuration file.
	Takes: string.
	Returns: undef on error.

=head2 print_info()

	Prints information from config.
	Takes: string.
	Returns: undef on error.

=head2 _info()

	Parse config into array of hashes.
	Takes: nothing.
	Returns: array of hashes.

=head2 get_default()

	Determine current default kernel.
	Takes: nothing.
	Returns: integer, undef on error.

=head2 set_default()

	Set new default kernel.
	Takes: integer.
	Returns: undef on error.

=head2 add()

	Add new kernel to config.
	Takes: hash.
	Returns: undef on error.

=head2 update()

	Update args of an existing kernel entry.
	Takes: hash.
	Returns: undef on error.

=head2 remove()

	Remove kernel from config.
	Takes: string.
	Returns: undef on error.

=head2 read_entry()

        Read an existing entry into a hash suitable to add or update from.
	Takes: integer or title
	Returns: undef or hash

=head2 debug($level)

        Sets or gets the current debug level, 0-5.
        Returns:  Debug level

=head2 _check_config()

        Conducts a basic check for kernel validity
        Returns:  true if checks out okay,
                  false if not okay,
                  undef on error

=head2 _lookup()

        Converts title into position.
	Takes: string.
        Returns:  integer,
                  undef on error

=cut


package Linux::Bootloader;

use strict;
use warnings;

use vars qw( $VERSION );


sub new {
    my $this = shift;
    my $class = ref($this) || $this;
    if ( defined $class and $class  eq 'Linux::Bootloader' ){
        my $detected_bootloader = Linux::Bootloader::Detect::detect_bootloader();
        unless (defined $detected_bootloader) { return undef; }
        $class = "Linux::Bootloader::" . "\u$detected_bootloader";
        eval" require $class; ";
    } 
    my $self = bless ({}, $class);
    $self->{config_file} = shift;
    unless (defined $self->{'config_file'}){
        $self->_set_config_file(); 
    }

    $self->{config}	= [];
    $self->{debug}	= 0;
    $self->{'entry'}    = {};

    return $self;
}


### Generic Functions ###

# Read config file into array

sub read {
  my $self=shift;
  my $config_file=shift || $self->{config_file};
  print ("Reading $config_file.\n") if $self->debug()>1;

  open(CONFIG, "$config_file")
    || warn ("ERROR:  Can't open $config_file.\n") && return undef;
  @{$self->{config}}=<CONFIG>;
  close(CONFIG);

  print ("Current config:\n @{$self->{config}}") if $self->debug()>4;
  print ("Closed $config_file.\n") if $self->debug()>2;
  return 1;
}


# Write new config

sub write {
  my $self=shift;
  my $config_file=shift || $self->{config_file};
  my @config=@{$self->{config}};

  return undef unless $self->_check_config();

  print ("Writing $config_file.\n") if $self->debug()>1;
  print join("",@config) if $self->debug() > 4;

  if (-w $config_file) {
    system("cp","$config_file","$config_file.bak.boottool");
    if ($? != 0) {
      warn "ERROR:  Cannot backup $config_file.\n"; 
      return undef;
    } else {
      print "Backed up config to $config_file.bak.boottool.\n";
    }

    open(CONFIG, ">$config_file")
      || warn ("ERROR:  Can't open config file.\n") && return undef;
    print CONFIG join("",@config);
    close(CONFIG);
    return 0;
  } else {
    print join("",@config) if $self->debug() > 2;
    warn "WARNING:  You do not have write access to $config_file.\n";
    return 1;
  }
}


# Parse config into array of hashes

sub _info {
  my $self=shift;

  return undef unless $self->_check_config();
  my @config=@{$self->{config}};

  # remove garbarge - comments, blank lines
  @config=grep(!/^#|^\n/, @config);

  my %matches = ( default => '^\s*default[\s+\=]+(\S+)',
                  timeout => '^\s*timeout[\s+\=]+(\S+)',
                  title   => '^\s*label[\s+\=]+(\S+)',
                  root    => '^\s*root[\s+\=]+(\S+)',
                  args    => '^\s*append[\s+\=]+(.*)',
                  initrd  => '^\s*initrd[\s+\=]+(\S+)',
                );

  my @sections;
  my $index=0;
  foreach (@config) {
    if ($_ =~ /^\s*(image|other)[\s+\=]+(\S+)/i) {
      $index++;
      $sections[$index]{'kernel'} = $2;
    }
    foreach my $key (keys %matches) {
      if ($_ =~ /$matches{$key}/i) {
        $sections[$index]{$key} = $1;
	$sections[$index]{$key} =~ s/\"|\'//g if ($key eq 'args');
      }
    }
  }

  # sometimes config doesn't have a default, so goes to first
  if (!(defined $sections[0]{'default'})) {
    $sections[0]{'default'} = '0';

  # if default is label name, we need position
  } else {
    foreach my $index (1..$#sections) {
      if ($sections[$index]{'title'} eq $sections[0]{'default'}) {
        $sections[0]{'default'} = $index-1;
        last;
      }
    }
  }

  # if still no valid default, set to first
  if ( $sections[0]{'default'} !~ m/^\d+$/ ) {
    $sections[0]{'default'} = 0;
  }

  # return array of hashes
  return @sections;
}


# Determine current default kernel

sub get_default {
  my $self = shift;

  print ("Getting default.\n") if $self->debug()>1;
  return undef unless $self->_check_config();

  my @sections = $self->_info();
  my $default = $sections[0]{'default'};
  if ($default =~ /^\d+$/) {
      return 0+$default;
  }

}

# Find the template entry.
sub get_template {
  my ($self) = @_;

  print ("Getting template.\n") if $self->debug()>1;
  return undef unless $self->_check_config();

  my @sections = $self->_info();
  my $default = $sections[0]{'default'} + 1;

  if (defined $sections[$default]{'kernel'}) {
    return $default - 1;
  }
  for ($default = 1; $default <= $#sections; $default++) {
    if (defined $sections[$default]->{'kernel'}) {
      return $default - 1;
    }
  }
  return undef;
}


# Set new default kernel

sub set_default {
  my $self=shift;
  my $newdefault=shift;

  print ("Setting default.\n") if $self->debug()>1;

  return undef unless defined $newdefault;
  return undef unless $self->_check_config();

  my @config=@{$self->{config}};
  my @sections=$self->_info();

  # if not a number, do title lookup
  if ($newdefault !~ /^\d+$/) {
    $newdefault = $self->_lookup($newdefault);
  }

  my $kcount = $#sections-1;
  if ((!defined $newdefault) || ($newdefault < 0) || ($newdefault > $kcount)) {
    warn "ERROR:  Enter a default between 0 and $kcount.\n";
    return undef;
  }

  # convert position to title
  $newdefault = $sections[++$newdefault]{title};
 
  foreach my $index (0..$#config) {
    if ($config[$index] =~ /^\s*default/i) { 
      $config[$index] = "default=$newdefault	# set by $0\n"; 
      last;
    }
  }
  @{$self->{config}} = @config;
}


# Add new kernel to config

sub add {
  my $self=shift;
  my %param=@_;

  print ("Adding kernel.\n") if $self->debug()>1;

  if (!defined $param{'add-kernel'} && defined $param{'kernel'}) {
    $param{'add-kernel'} = $param{'kernel'};
  } elsif (!defined $param{'add-kernel'} || !defined $param{'title'}) {
    warn "ERROR:  kernel path (--add-kernel), title (--title) required.\n";
    return undef;
  } elsif (!(-f "$param{'add-kernel'}")) {
    warn "ERROR:  kernel $param{'add-kernel'} not found!\n";
    return undef;
  } elsif (defined $param{'initrd'} && !(-f "$param{'initrd'}")) {
    warn "ERROR:  initrd $param{'initrd'} not found!\n";
    return undef;
  }

  return undef unless $self->_check_config();

  # remove title spaces and truncate if more than 15 chars
  $param{title} =~ s/\s+//g;
  $param{title} = substr($param{title}, 0, 15) if length($param{title}) > 15;

  my @sections=$self->_info();

  # check if title already exists
  if (defined $self->_lookup($param{title})) {
    warn ("WARNING:  Title already exists.\n");
    if (defined $param{force}) {
      $self->remove($param{title});
    } else {
      return undef;
    }
  }

  my @config = @{$self->{config}};
  @sections=$self->_info();
 
  # Use default kernel to fill in missing info
  my $default=$self->get_template();
  $default++;

  foreach my $p ('args', 'root') {
    if (! defined $param{$p}) {
      $param{$p} = $sections[$default]{$p};
    }
  }

  # use default entry to determine if path (/boot) should be removed
  my $bootpath = $sections[$default]{'kernel'};
  $bootpath =~ s@[^/]*$@@;

  $param{'add-kernel'} =~ s@^/boot/@$bootpath@;
  $param{'initrd'} =~ s@^/boot/@$bootpath@ unless !defined $param{'initrd'};

  my @newkernel;
  push (@newkernel, "image=$param{'add-kernel'}\n", "\tlabel=$param{title}\n");
  push (@newkernel, "\tappend=\"$param{args}\"\n") if defined $param{args};
  push (@newkernel, "\tinitrd=$param{initrd}\n") if defined $param{initrd};
  push (@newkernel, "\troot=$param{root}\n") if defined $param{root};
  ##push (@newkernel, "\tread-only\n\n");

  if (!defined $param{position} || $param{position} !~ /end|\d+/) {
    $param{position}=0;
  }

  my @newconfig;
  if ($param{position}=~/end/ || $param{position} >= $#sections) { 
    $param{position}=$#sections;
    push (@newconfig,@config);
    if ($newconfig[$#newconfig] =~ /\S/) {
      push (@newconfig, "\n");
    }
    push (@newconfig,@newkernel);
  } else {
    my $index=0;
    foreach (@config) {
      if ($_ =~ /^\s*(image|other)/i) { 
        if ($index==$param{position}) {
          push (@newconfig, @newkernel);
        }
        $index++;
      }
      push (@newconfig, $_);
    }
  }

  @{$self->{config}} = @newconfig;

  if (defined $param{'make-default'}) { 
    $self->set_default($param{position});
  } 
}


# Update kernel args

sub update {
  my $self=shift;
  my %params=@_;

  print ("Updating kernel.\n") if $self->debug()>1;

  if (!defined $params{'update-kernel'} || (!defined $params{'args'} && !defined $params{'remove-args'})) {
    warn "ERROR:  kernel position or title (--update-kernel) and args (--args or --remove-args) required.\n";
    return undef;
  }

  return undef unless $self->_check_config();

  my @config = @{$self->{config}};
  my @sections=$self->_info();

  # if not a number, do title lookup
  if ($params{'update-kernel'} !~ /^\d+$/) {
    $params{'update-kernel'} = $self->_lookup($params{'update-kernel'});
  }

  my $kcount = $#sections-1;
  if ($params{'update-kernel'} !~ /^\d+$/ || $params{'update-kernel'} < 0 || $params{'update-kernel'} > $kcount) {
    warn "ERROR:  Enter a default between 0 and $kcount.\n";
    return undef;
  }

  my $index=-1;
  foreach (@config) {
    if ($_ =~ /^\s*(image|other)/i) {
      $index++;
    }
    if ($index==$params{'update-kernel'}) {
      if ($_ =~ /(^\s*append[\s\=]+)(.*)\n/i) {
        my $append = $1;
        my $args = $2;
        $args =~ s/\"|\'//g;
	$args = $self->_build_args($args, $params{'remove-args'}, $params{'args'});
        if ($_ eq "$append\"$args\"\n") {
          warn "WARNING:  No change made to args.\n";
          return undef;
        } else {
          $_ = "$append\"$args\"\n";
        }
        next;
      }
    }
  }
  @{$self->{config}} = @config;
}


# Remove kernel from config

sub remove {
  my $self=shift;
  my $position=shift;
  my @newconfig;

  return undef unless defined $position;
  return undef unless $self->_check_config();

  my @config=@{$self->{config}};
  my @sections=$self->_info();

  if ($position=~/^end$/i) {
    $position=$#sections-1;
  } elsif ($position=~/^start$/i) {
    $position=0;
  }

  print ("Removing kernel $position.\n") if $self->debug()>1;

  # remove based on title
  if ($position !~ /^\d+$/) {
    my $removed=0;
    for (my $index=$#sections; $index > 0; $index--) {
      if (defined $sections[$index]{title} && $position eq $sections[$index]{title}) {
        $removed++ if $self->remove($index-1);
      }
    }
    if (! $removed) {
      warn "ERROR:  No kernel with specified title.\n";
      return undef;
    }

  # remove based on position
  } elsif ($position =~ /^\d+$/) {

    if ($position < 0 || $position > $#sections) {
      warn "ERROR:  Enter a position between 0 and $#sections.\n";
      return undef;
    }

    my $index=-1;
    foreach (@config) {
      if ($_ =~ /^\s*(image|other|title)/i) {
        $index++
      }
      # add everything to newconfig, except removed kernel (keep comments)
      if ($index != $position || $_ =~ /^#/) {
        push (@newconfig, $_)
      }
    }
    @{$self->{config}} = @newconfig;


    # if we removed the default, set new default to first
    $self->set_default(0) if $position == $sections[0]{'default'};

    print "Removed kernel $position.\n";
    return 1;

  } else {
    warn "WARNING:  problem removing entered position.\n";
    return undef;
  }

}


# Print info from config

sub print_info {
  my $self=shift;
  my $info=shift;

  return undef unless defined $info; 
  return undef unless $self->_check_config();

  print ("Printing config info.\n") if $self->debug()>1;

  my @config=@{$self->{config}};
  my @sections=$self->_info();

  my ($start,$end);
  if ($info =~ /default/i) {
    $start=$end=$self->get_default()
  } elsif ($info =~ /all/i) {
    $start=0; $end=$#sections-1
  } elsif ($info =~ /^\d+/) {
    $start=$end=$info
  } else {
    my $index = $self->_lookup($info);
    if (!defined $index) {
      warn "ERROR:  input should be: #, default, all, or a valid title.\n";
      return undef;
    }
    $start=$end=$index;
  }

  if ($start < 0 || $end > $#sections-1) {
    warn "ERROR:  No kernels with that index.\n";
    return undef;
  }

  for my $index ($start..$end) {
    print "\nindex\t: $index\n";
    $index++;
    foreach ( sort keys(%{$sections[$index]}) ) {
      print "$_\t: $sections[$index]{$_}\n";
    }
  }
}


# Set/get debug level

sub debug {
  my $self=shift;
  if (@_) {
      $self->{debug} = shift;
  }
  return $self->{debug} || 0;
}

# Get a bootloader entry as a hash to edit or update.
sub read_entry {
  my $self=shift;
  my $entry=shift;

  if ($entry !~ /^\d+$/) {
    $entry = $self->_lookup($entry);
  }
  my @sections=$self->_info();

  my $index = $entry + 1;
  if ((defined $sections[$index]{'title'})) {
    $self->{'entry'}->{'index'} = $index;
    foreach my $key ( keys %{$sections[$index]} ){
      $self->{'entry'}->{'data'}->{ $key } = $sections[$index]{$key};
    }
    return $self->{'entry'}->{'data'};
  } else {
    return undef;
  }
}

# Basic check for valid config

sub _check_config {
  my $self=shift;

  print ("Verifying config.\n") if $self->debug()>3;

  if ($#{$self->{config}} < 5) {
    warn "ERROR:  you must read a valid config file first.\n";
    return undef;
  }
  return 1;
}


# lookup position using title

sub _lookup {
  my $self=shift;
  my $title=shift;
  
  unless ( defined $title ){ return undef; }

  my @sections=$self->_info();

  for my $index (1..$#sections) {
    my $tmp = $sections[$index]{title};
    if (defined $tmp and $title eq $tmp) {
      return $index-1;
    }
  }
  return undef;
}

sub _build_args {
  my ($self, $args, $toremove, $toadd) = @_;

  if (defined $toremove) {
    my $base;
    foreach my $remove (split(' ', $toremove)) {
      $base = $remove; $base =~ s/\=.*//;
      $args =~ s/(^|\s+)$base(\=\S+|\s+|$)/$1/ig;
    }
  }

  if (defined $toadd) {
    my $base;
    foreach my $add (split(' ', $toadd)) {
      $base = $add; $base =~ s/\=.*//;
      if (!($args =~ s/(^|\s+)$base(\=\S+)?(\s+|$)/$1$add$3/ig)) {
        $args .= " $add";
      }
    }
  }

  $args =~ s/\s+/ /g;
  return $args;
}


=head1 AUTHOR

Jason N., Open Source Development Labs, Engineering Department <eng@osdl.org>

=head1 COPYRIGHT

Copyright (C) 2006 Open Source Development Labs
All Rights Reserved.

This script is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=head1 SEE ALSO

L<boottool>, L<Linux::Bootloader::Grub>, L<Linux::Bootloader::Lilo>, 
L<Linux::Bootloader::Elilo>, L<Linux::Bootloader::Yaboot>

=cut


1;
package Linux::Bootloader::Detect;

=head1 NAME

Linux::Bootloader::Detect - detects the bootloader and architecture of the system.

=head1 SYNOPSIS

Attempts to determine the bootloader by checking for configuration files
for grub, lilo, elilo and yaboot then searching the master boot record
for GRUB, LILO, ELILO and YABOOT.

Determines the architecture by running uname -m.

=head1 DESCRIPTION

To attempt to discover the bootloader being used by the system
detect_bootloader first calls detect_bootloader_from_conf attempts to locate
/boot/grub/menu.lst, /etc/lilo.conf, /boot/efi/elilo.conf and
/etc/yaboot.conf and returns the corresponding bootloader name. If
either undef of multiple are returned because no configuration files or
multiple configuration files were found detect_bootloader calls
detect_bootloader_from_mbr which generates a list of all devices accessable from
the /dev directory reading in the first 512 bytes from each hd and sd
device using head then redirects the output to grep to determine if
"GRUB", "LILO", "ELILO" or "YABOOT" is present returning the
corresponding value if exactly one mbr on the system contained a
bootloader or multiple if more than one was found and undef if none were
found. detect_bootloader returns either grub, lilo, elilo, yaboot or
undef.

To attempt to discover the architecture of the system
detect_architecture makes a uname -m system call returning x86, ppc,
ia64 or undef.

=head1 FUNCTIONS

=cut

use strict;
use warnings;

use vars qw( $VERSION );

=head3 detect_architecture([style])

Input:
Output: string

This function determines the architecture by calling uname -m.  By
default it will report back exactly what uname -m reports, but if you
specify a "style", detect_architecture will do some mappings.  Possible
styles include:

 Style    Example return values (not an exhaustive list...)
 [none]   i386, i686, sparc, sun4u, ppc64, s390x, x86_64, parisc64
 linux    i386, i386, sparc, sparc, ppc64, s390,  x86_64, parisc
 gentoo    x86,  x86, sparc, sparc, ppc64,         amd64, hppa

Returns undef on error.

=cut

sub detect_architecture {
    my $arch_style = shift || 'uname';

    my $arch;
    if ($arch_style eq 'linux') {
        $arch = `uname -m | sed -e s/i.86/i386/ -e s/sun4u/sparc64/ -e s/arm.*/arm/ -e s/sa110/arm/ -e s/s390x/s390/ -e s/parisc64/parisc/`;
        chomp $arch;
    } elsif ($arch_style eq 'gentoo') {
        $arch = `uname -m | sed -e s/i.86/x86/ -e s/sun4u/sparc/ -e s/arm.*/arm/ -e s/sa110/arm/ -e s/x86_64/amd64/ -e s/sparc.*/sparc/ -e s/parisc.*/hppa/`;
        chomp $arch;
    } else {
        $arch = `uname -m`;
        chomp $arch;
    }
    return $arch;
}

=head3 detect_os_vendor()

Input:
Output: string

This function determines the OS vendor (linux distribution breed).

Return values: "Red Hat", "Fedora", "SUSE", "Ubuntu", "Debian", or
"Unknown" if none of the predefined patterns could be found on the
issue file.

=cut

sub detect_os_vendor {
    my $vendor = "";
    my $issue_file = '/etc/issue';
    if ( not system("egrep 'Red Hat' $issue_file") ){
       $vendor = 'Red Hat';
    } elsif ( not system("egrep 'Fedora' $issue_file") ){
       $vendor = 'Fedora';
    } elsif ( not system("egrep 'SUSE' $issue_file") ){
       $vendor = 'SUSE';
    } elsif ( not system("egrep 'Ubuntu' $issue_file") ){
       $vendor = 'Ubuntu';
    } elsif ( not system("egrep 'Debian' $issue_file") ){
       $vendor = 'Debian';
    } else {
       $vendor = 'Unknown';
    }
    return $vendor;
}

=head3 detect_bootloader(['device1', 'device2', ...])

Input:  devices to detect against (optional)
Output: string

This function attempts to determine the bootloader being used on the
system by first checking for conf files and then falling back to check
the master boot record.

Possible return values:     

    grub        grub was determined to be the bootloader in use
    lilo        lilo was determined to be is the bootloader in use
    elilo       elilo was determined to be the bootloader in use
    yaboot      yaboot was determined to be the bootloader in use
    undef       it was impossible to determine which bootloader was being used
                due either to configuration files for multiple bootloaders or
                bootloader on multiple hard disks

=cut

sub detect_bootloader {
    return detect_bootloader_from_conf(@_) 
        || detect_bootloader_from_mbr(@_);
}

=head2 detect_bootloader_from_conf()

Detects bootloaders by the presence of config files.  This is not as
reliable of a mechanism as looking in the MBR, but tends to be
significantly faster.  

If called in list context, it will return a list of the bootloaders that
it found.

If called in scalar context and only a single bootloader config file is
present it will return the name of that bootloader.  Otherwise, if
multiple (or no) bootloaders are detected, it will return undef.

=cut

sub detect_bootloader_from_conf {
    my @boot_loader = ();

    my %boot_list = ( grub   => '/boot/grub/menu.lst', 
                      lilo   => '/etc/lilo.conf', 
                      elilo  => '/etc/elilo.conf', 
                      yaboot => '/etc/yaboot.conf',
                      zipl   => '/etc/zipl.conf',
                      );

    foreach my $key ( sort keys %boot_list ) {
        if ( -f $boot_list{$key} ) {
            push ( @boot_loader, $key ); 
        }
    }

    if (wantarray()) {
        return @boot_loader;
    } elsif (@boot_loader == 1) {
        return pop( @boot_loader );
    } elsif (@boot_loader == 2) {
	if ($boot_loader[0] eq 'lilo' && $boot_loader[1] eq 'yaboot') {
		return 'lilo';
	}
    }

    if (scalar(@boot_loader) > 1) {
        warn "Warning: Multiple bootloader configs; not certain which is in use.\n";
	warn "         " . join(' ', @boot_loader) . "\n";
    }
    return undef;
}

=head2 detect_bootloader_from_mbr([@devices])

Detects the bootloader by scanning the master boot record (MBR) of the
specified devices (or all devices if not indicated).  

The device arguments must be relative to the /dev/ directory.  I.e.,
('hda', 'sdb', 'cdroms/cdrom0', etc.)

=cut

sub detect_bootloader_from_mbr {
    my @filelist = @_;
    my @boot_loader = ();

    my %map = (
        "GRUB"   => 'grub',
        "LILO"   => 'lilo',
        "EFI"    => 'elilo',
        "yaboot" => 'yaboot',
    );

    if ( ! @filelist && opendir( DIRH, "/sys/block" ) ) {
        @filelist = grep { /^[sh]d.$/ } readdir(DIRH);
        closedir(DIRH);
    }

    foreach my $dev ( @filelist ) {
        if ( -b "/dev/$dev" ) {
            my $strings = `dd if=/dev/$dev bs=512 count=1 2>/dev/null`;
            if ($?) {
                warn "Error:  Could not read MBR on /dev/$dev (are you root?)\n";
            } else {
                $strings = `echo $strings | strings`;
                foreach my $loader (keys %map) {
                    if ($strings =~ /$loader/ms) {
                        push @boot_loader, $map{$loader};
                    }
                }
            }
        }
    }

    if (wantarray()) {
        # Show them all
        return @boot_loader;
    } elsif (@boot_loader == 1) {
        # Found exactly one
        return pop @boot_loader;
    } elsif (@boot_loader == 2) {
        # This is the Lilo/Grub exception
        # Grub on MBR with previous Lilo install
        # Are they lilo and grub in that order?
        if ($boot_loader[0] eq 'lilo' and $boot_loader[1] eq 'grub'){
            warn "Warning:  Grub appears to be used currently, but Lilo was in past.\n";
            return $boot_loader[1];
        }
    } else {
        warn "Warning: Multiple MBR's present; not certain which is in use.\n";
	warn "         " . join(' ', @boot_loader) . "\n";
        return undef;
    }

    # Either none or too many to choose from
    return undef;
}

1;

=head1 AUTHOR

Open Source Development Labs, Engineering Department <eng@osdl.org>

=head1 COPYRIGHT

Copyright (C) 2006 Open Source Development Labs
All Rights Reserved.

This script is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=head1 SEE ALSO

L<Linux::Bootloader>

=cut

package Linux::Bootloader::Elilo;

=head1 NAME

Linux::Bootloader::Elilo - Parse and modify ELILO configuration files.

=head1 SYNOPSIS

	
	my $bootloader = Linux::Bootloader::Elilo->new();
	my $config_file='/etc/elilo.conf';

	$bootloader->read($config_file)

	# add a kernel	
	$bootloader->add(%hash)

	# remove a kernel
	$bootloader->remove(2)

	# set new default
	$bootloader->set_default(1)

	$bootloader->write($config_file)


=head1 DESCRIPTION

This module provides functions for working with ELILO configuration files.

	Adding a kernel:
	- add kernel at start, end, or any index position.
	- kernel path and title are required.
	- root, kernel args, initrd are optional.
	- any options not specified are copied from default.
	- remove any conflicting kernels if force is specified.
	
	Removing a kernel:
	- remove by index position
	- or by title/label


=head1 FUNCTIONS

Also see L<Linux::Bootloader> for functions available from the base class.

=head2 new()

	Creates a new Linux::Bootloader::Elilo object.

=head2 install()

        Attempts to install bootloader.
        Takes: nothing.
        Returns: undef on error.

=cut


use strict;
use warnings;

@Linux::Bootloader::Elilo::ISA = qw(Linux::Bootloader);
use base 'Linux::Bootloader';


use vars qw( $VERSION );


sub _set_config_file {
    my $self=shift;
    $self->{'config_file'}='/etc/elilo.conf';
}


### ELILO functions ###


# Run command to install bootloader

sub install {
  my $self=shift;

  my $elilo = '';
  $elilo = '/sbin/elilo' if (-f '/sbin/elilo');
  $elilo = '/usr/sbin/elilo' if (-f '/usr/sbin/elilo');
  if ($elilo ne '') {
      system($elilo);
      if ($? != 0) { 
	warn ("ERROR:  Failed to run elilo.\n") && return undef; 
      }
  }
  return 1;
}

# Set kernel to be booted once

sub boot_once {
    my $self=shift;
    my $label = shift;

    return undef unless defined $label;

    $self->read( '/etc/elilo.conf' );
    my @config=@{$self->{config}};

    if ( ! grep( /^checkalt/i, @config ) ) {
        warn("ERROR:  Failed to set boot-once.\n");
        warn("Please add 'checkalt' to global config.\n");
        return undef;
    }

    my @sections = $self->_info();
    my $position = $self->_lookup($label);
    $position++;
    my $efiroot = `grep ^EFIROOT /usr/sbin/elilo | cut -d '=' -f 2`;
    chomp($efiroot);

    my $kernel = $efiroot . $sections[$position]{kernel};
    my $root = $sections[$position]{root};
    my $args = $sections[$position]{args};

    #system( "/usr/sbin/eliloalt", "-d" );
    if ( system( "/usr/sbin/eliloalt", "-s", "$kernel root=$root $args" ) ) {
        warn("ERROR:  Failed to set boot-once.\n");
        warn("1) Check that EFI var support is compiled into kernel.\n");
        warn("2) Verify eliloalt works.  You may need to patch it to support sysfs EFI vars.\n");
        return undef;
    }
    return 1;
}


1;


=head1 AUTHOR

Open Source Development Labs, Engineering Department <eng@osdl.org>

=head1 COPYRIGHT

Copyright (C) 2006 Open Source Development Labs
All Rights Reserved.

This script is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=head1 SEE ALSO

L<Linux::Bootloader>

=cut


package Linux::Bootloader::Grub;

=head1 NAME

Linux::Bootloader::Grub - Parse and modify GRUB configuration files.

=head1 SYNOPSIS


        my $config_file='/boot/grub/menu.lst';
	$bootloader = Linux::Bootloader::Grub->new($config_file);

        $bootloader->read();

	# add a kernel	
	$bootloader->add(%hash)

	# remove a kernel
	$bootloader->remove(2)

	# print config info
	$bootloader->print_info('all')

	# set new default
	$bootloader->set_default(1)

        $bootloader->write();


=head1 DESCRIPTION

This module provides functions for working with GRUB configuration files.

	Adding a kernel:
	- add kernel at start, end, or any index position.
	- kernel path and title are required.
	- root, kernel args, initrd, savedefault, module are optional.
	- any options not specified are copied from default.
	- remove any conflicting kernels first if force is specified.
	
	Removing a kernel:
	- remove by index position
	- or by title/label


=head1 FUNCTIONS

Also see L<Linux::Bootloader> for functions available from the base class.

=head2 new()

	Creates a new Linux::Bootloader::Grub object.

=head2 _info()

	Parse config into array of hashes.
	Takes: nothing.
	Returns: array of hashes containing config file options and boot entries,
                 undef on error.

=head2 set_default()

	Set new default kernel.
	Takes: integer or string, boot menu position or title.
	Returns: undef on error.

=head2 add()

	Add new kernel to config.
	Takes: hash containing kernel path, title, etc.
	Returns: undef on error.

=head2 update()

        Update args of an existing kernel entry.
        Takes: hash containing args and entry to update.
        Returns: undef on error.

=head2 install()

        Prints message on how to re-install grub.
        Takes: nothing.
        Returns: nothing.

=head2 update_main_options()

	This updates or adds a general line anywhere before the first 'title' line.
	it is called with the 'update' and 'option' options, when no 'update-kernel'
	is specified.

=head2 boot_once()

	This is a special case of using 'fallback'.   This function makes the current 
	default the fallback kernel and sets the passed argument to be the default 
	kernel which saves to the fallback kernel after booting.  The file 
	'/boot/grub/default' is created if it does not exist.

	This only works with grub versions 0.97 or better.

=head2 _get_bootloader_version()

        Prints detected grub version.
        Takes: nothing.
        Returns: nothing.

=cut

use strict;
use warnings;

@Linux::Bootloader::Grub::ISA = qw(Linux::Bootloader);
use base 'Linux::Bootloader';


use vars qw( $VERSION );


sub _set_config_file {
    my $self=shift;
    $self->{'config_file'}='/boot/grub/menu.lst';
}


### GRUB functions ###

# Parse config into array of hashes

sub _info {
  my $self=shift;

  return undef unless $self->_check_config();

  my @config=@{$self->{config}};
  @config=grep(!/^#|^\n/, @config);

  my %matches = ( default => '^\s*default\s*\=*\s*(\S+)',
		  timeout => '^\s*timeout\s*\=*\s*(\S+)',
		  fallback => '^\s*fallback\s*\=*\s*(\S+)',
		  kernel => '^\s*kernel\s+(\S+)',
		  root 	=> '^\s*kernel\s+.*\s+.*root=(\S+)',
		  args 	=> '^\s*kernel\s+\S+\s+(.*)\n',
		  boot 	=> '^\s*root\s+(.*)',
		  initrd => '^\s*initrd\s+(.*)',
		  savedefault => '^\s*savedefault\s+(.*)',
		  module      => '^\s*module\s+(.+)',
		);

  my @sections;
  my $index=0;
  foreach (@config) {
      if ($_ =~ /^\s*title\s+(.*)/i) {
        $index++;
        $sections[$index]{title} = $1;
      }
      foreach my $key (keys %matches) {
        if ($_ =~ /$matches{$key}/i) {
          $key .= '2' if exists $sections[$index]{$key};
          $sections[$index]{$key} = $1;
          if ($key eq 'args') {
	    $sections[$index]{$key} =~ s/root=\S+\s*//i;
	    delete $sections[$index]{$key} if ($sections[$index]{$key} !~ /\S/);
          }
        }
      }
  }

  # sometimes config doesn't have a default, so goes to first
  if (!(defined $sections[0]{'default'})) { 
    $sections[0]{'default'} = '0'; 

  # if default is 'saved', read from grub default file
  } elsif ($sections[0]{'default'} =~ m/^saved$/i) {
    open(DEFAULT_FILE, '/boot/grub/default')
      || warn ("ERROR:  cannot read grub default file.\n") && return undef;
    my @default_config = <DEFAULT_FILE>;
    close(DEFAULT_FILE);
    $default_config[0] =~ /^(\d+)/;
    $sections[0]{'default'} = $1;
  }

  # return array of hashes
  return @sections;
}


# Set new default kernel

sub set_default {
  my $self=shift;
  my $newdefault=shift;

  return undef unless defined $newdefault;
  return undef unless $self->_check_config();

  my @config=@{$self->{config}};
  my @sections=$self->_info();

  # if not a number, do title lookup
  if ($newdefault !~ /^\d+$/ && $newdefault !~ m/^saved$/) {
    $newdefault = $self->_lookup($newdefault);
    return undef unless (defined $newdefault);
  }

  my $kcount = $#sections-1;
  if ($newdefault !~ m/saved/) {
    if (($newdefault < 0) || ($newdefault > $kcount)) {
      warn "ERROR:  Enter a default between 0 and $kcount.\n";
      return undef;
    }
  }

  foreach my $index (0..$#config) {

    if ($config[$index] =~ /(^\s*default\s*\=*\s*)\d+/i) { 
      $config[$index] = "$1$newdefault\n";
      last;
    } elsif ($config[$index] =~ /^\s*default\s*\=*\s*saved/i) {
      my @default_config;
      my $default_config_file='/boot/grub/default';

      open(DEFAULT_FILE, $default_config_file) 
        || warn ("ERROR:  cannot open default file.\n") && return undef;
      @default_config = <DEFAULT_FILE>;
      close(DEFAULT_FILE);

      if ($newdefault eq 'saved') {
          warn "WARNING:  Setting new default to '0'\n";
          $newdefault = 0;
      }

      $default_config[0] = "$newdefault\n";

      open(DEFAULT_FILE, ">$default_config_file") 
        || warn ("ERROR:  cannot open default file.\n") && return undef;
      print DEFAULT_FILE join("",@default_config);
      close(DEFAULT_FILE);
      last;
    }
  }
  @{$self->{config}} = @config;
}


# Add new kernel to config

sub add {
  my $self=shift;
  my %param=@_;

  print ("Adding kernel.\n") if $self->debug()>1;

  if (!defined $param{'add-kernel'} || !defined $param{'title'}) { 
    warn "ERROR:  kernel path (--add-kernel), title (--title) required.\n";
    return undef; 
  } elsif (!(-f "$param{'add-kernel'}")) { 
    warn "ERROR:  kernel $param{'add-kernel'} not found!\n";
    return undef; 
  } elsif (defined $param{'initrd'} && !(-f "$param{'initrd'}")) { 
    warn "ERROR:  initrd $param{'initrd'} not found!\n";
    return undef; 
  }

  return undef unless $self->_check_config();

  my @sections=$self->_info();

  # check if title already exists
  if (defined $self->_lookup($param{title})) {
    warn ("WARNING:  Title already exists.\n");
    if (defined $param{force}) {
      $self->remove($param{title});
    } else {
      return undef;
    }
  }

  my @config = @{$self->{config}};
  @sections=$self->_info();

  # Use default kernel to fill in missing info
  my $default=$self->get_template();
  $default++;

  foreach my $p ('args', 'root', 'boot', 'savedefault') {
    if (! defined $param{$p}) {
      $param{$p} = $sections[$default]{$p};
    }
  }

  # use default entry to determine if path (/boot) should be removed
  my $bootpath = $sections[$default]{'kernel'};
  $bootpath =~ s@[^/]*$@@;

  $param{'add-kernel'} =~ s@^/boot/@$bootpath@;
  $param{'initrd'} =~ s@^/boot/@$bootpath@ unless !defined $param{'initrd'};

  my @newkernel;
  push(@newkernel, "title\t$param{title}\n") if defined $param{title};
  push(@newkernel, "\troot $param{boot}\n") if defined $param{boot};

  my $line;
  if ( defined $param{xen} ) {
      $line = "\tkernel $sections[$default]{kernel}";
      $line .= " $sections[$default]{root}" if defined $sections[$default]{root};
      $line .= " $sections[$default]{args}" if defined $sections[$default]{args};
      push( @newkernel, "$line\n" );
      push( @newkernel, "\tinitrd $sections[$default]{'initrd'}\n" ) if defined $sections[$default]{'initrd'};
      $line = "\tmodule $param{'add-kernel'}" if defined $param{'add-kernel'};
      $line .= " root=$param{root}"    if defined $param{root};
      $line .= " $param{args}"         if defined $param{args};
      push( @newkernel, "$line\n" );
      push( @newkernel, "\tmodule $param{initrd}\n" ) if defined $param{initrd};
  } else {
      $line = "\tkernel $param{'add-kernel'}" if defined $param{'add-kernel'};
      $line .= " root=$param{root}"    if defined $param{root};
      $line .= " $param{args}"         if defined $param{args};
      push( @newkernel, "$line\n" );
      push( @newkernel, "\tinitrd $param{initrd}\n" ) if defined $param{initrd};
  }

  push(@newkernel, "\tsavedefault $param{savedefault}\n") if defined $param{savedefault};

  foreach my $module (@{$param{'module'}}) {
     push(@newkernel, "\tmodule " . $module . "\n");
  }

  push(@newkernel, "\n");

  if (!defined $param{position} || $param{position} !~ /end|\d+/) { 
    $param{position}=0 
  }

  my @newconfig;
  if ($param{position}=~/end/ || $param{position} >= $#sections) { 
    $param{position}=$#sections;
    push (@newconfig,@config);
    if ($newconfig[$#newconfig] =~ /\S/) { 
      push (@newconfig, "\n"); 
    }
    push (@newconfig,@newkernel);
  } else {
    my $index=0;
    foreach (@config) {
      if ($_ =~ /^\s*title/i) { 
        if ($index==$param{position}) { 
          push (@newconfig, @newkernel); 
        }
        $index++;
      }
      push (@newconfig, $_);
    }
  }

  @{$self->{config}} = @newconfig;

  if (defined $param{'make-default'} || defined $param{'boot-once'}) { 
    $self->set_default($param{position});
  }
  print "Added: $param{'title'}.\n";
}


# Update kernel args

sub update {
  my $self=shift;
  my %params=@_;

  print ("Updating kernel.\n") if $self->debug()>1;

  if (defined $params{'option'} && !defined $params{'update-kernel'}) {
    return $self->update_main_options(%params);
  } elsif (!defined $params{'update-kernel'} || (!defined $params{'args'} && !defined $params{'remove-args'} && !defined $params{'option'})) { 
    warn "ERROR:  kernel position or title (--update-kernel) and args (--args or --remove-args) required.\n";
    return undef; 
  }

  return undef unless $self->_check_config();

#  my @config = @{$self->{config}};
  my @sections=$self->_info();

  # if not a number, do title lookup
  if (defined $params{'update-kernel'} and $params{'update-kernel'} !~ /^\d+$/) {
    $params{'update-kernel'} = $self->_lookup($params{'update-kernel'});
  }

  my $kcount = $#sections-1;
  if ($params{'update-kernel'} !~ /^\d+$/ || $params{'update-kernel'} < 0 || $params{'update-kernel'} > $kcount) {
    warn "ERROR:  Enter a default between 0 and $kcount.\n";
    return undef;
  }

  my $kregex = '(^\s*kernel\s+\S+)(.*)';
  $kregex = '(^\s*module\s+\S+vmlinuz\S+)(.*)' if defined $params{'xen'};

  my $index=-1;
  my $config_line = -1;
  my $line = '';
  foreach $line (@{$self->{config}}) {
    $config_line = $config_line + 1;
    if ($line =~ /^\s*title/i) {
      $index++;
    }
    if ($index==$params{'update-kernel'}) {
      if (defined $params{'args'} or defined $params{'remove-args'}){
        if ( $line =~ /$kregex/i ) {
          my $kernel = $1;
          my $args = $self->_build_args($2, $params{'remove-args'}, $params{'args'});
          if ($line eq $kernel . $args . "\n") {
            warn "WARNING:  No change made to args.\n";
            return undef;
          } else {
            $line = $kernel . $args . "\n";
          }
          next;
        }
      } elsif (defined $params{'option'}){
        foreach my $val ( keys %params){
          if ($line =~ m/^\s*$val.*/i) {
            splice @{$self->{config}},$config_line,1,"$val $params{$val}\n";
            delete $params{$val};
            $config_line += 1;
          }
        }
      }
    } elsif ($index > $params{'update-kernel'}){
      last;
    }
  }
  # Add any leftover parameters
  delete $params{'update-kernel'};
  if (defined $params{'option'}){
    delete $params{'option'};
    $config_line -= 1;
    foreach my $val ( keys %params){
      splice @{$self->{config}},$config_line,0,"$val $params{$val}\n";
      $config_line += 1;
    }
  }
}


# Run command to install bootloader

sub install {
  my $self=shift;
  my $device;

  warn "Re-installing grub is currently unsupported.\n";
  warn "If you really need to re-install grub, use 'grub-install <device>'.\n";
  return undef;

  #system("grub-install $device");
  #if ($? != 0) {
  #  warn ("ERROR:  Failed to run grub-install.\n") && return undef;
  #}
  #return 1;
}


sub update_main_options{
  my $self=shift;
  my %params=@_;
  delete $params{'option'};
  foreach my $val (keys %params){
    my $x=0;
    foreach my $line ( @{$self->{config}} ) {
      # Replace 
      if ($line =~ m/^\s*$val/) {
	splice (@{$self->{config}},$x,1,"$val $params{$val}\n");
        last;
      }
      # Add
      if ($line =~ /^\s*title/i) {
        #  This is a new option, add it before here
        print "Your option is not in current configuration.  Adding.\n";
	splice @{$self->{config}},$x,0,"$val $params{$val}\n";
        last;
      }
      $x+=1;
    }
  }
}


sub boot_once {
  my $self=shift;
  my $entry_to_boot_once = shift;
  my $detected_os_vendor = Linux::Bootloader::Detect::detect_os_vendor();

  unless ( $entry_to_boot_once ) { print "No kernel\n"; return undef;}
  $self->read();
  my $default=$self->get_default();

  if ( $self->_get_bootloader_version() < 0.97 ){
     warn "This function works for grub version 0.97 and up.  No action taken.  \nUpgrade, then re-try.\n";
     return undef;
  }

  if ( $detected_os_vendor eq "Red Hat" or $detected_os_vendor eq "Fedora" ) {
    # if not a number, do title lookup
    if ( $entry_to_boot_once !~ /^\d+$/ ) {
      $entry_to_boot_once = $self->_lookup($entry_to_boot_once);
      return undef unless ( defined $entry_to_boot_once );
    }

    return `echo "savedefault --default=$entry_to_boot_once" --once | grub --batch`;
  } else {
  if ( $default == $self->_lookup($entry_to_boot_once)){
     warn "The default and once-boot kernels are the same.  No action taken.  \nSet default to something else, then re-try.\n";
     return undef;
  }

  $self->set_default('saved');
  if ( ! -f '/boot/grub/default' ){
     open FH, '>/boot/grub/default'; 
     my $file_contents="default
#
#
#
#
#
#
#
#
#
#
# WARNING: If you want to edit this file directly, do not remove any line
# from this file, including this warning. Using `grub-set-default\' is
# strongly recommended.
";
    print FH $file_contents;
    close FH;
  }
  $self->set_default( "$entry_to_boot_once" );
  $self->update( 'option'=>'','fallback' => $default );
  $self->update( 'update-kernel'=>"$entry_to_boot_once",'option'=>'','savedefault' => 'fallback' );
  $self->update( 'update-kernel'=>"$default",'option'=>'', 'savedefault' => '' );
  $self->write();
  }
}

sub _get_bootloader_version {
  my $self = shift;
  return `grub --version | sed 's/grub (GNU GRUB //' | sed 's/)//'`;
}


1;


=head1 AUTHOR

Open Source Development Labs, Engineering Department <eng@osdl.org>

=head1 COPYRIGHT

Copyright (C) 2006 Open Source Development Labs
All Rights Reserved.

This script is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=head1 SEE ALSO

L<Linux::Bootloader>

=cut

package Linux::Bootloader::Lilo;

=head1 NAME

Linux::Bootloader::Lilo - Parse and modify LILO configuration files.

=head1 SYNOPSIS

	
	my $bootloader = Linux::Bootloader::Lilo->new();
	my $config_file='/etc/lilo.conf';

	$bootloader->read($config_file)

	# add a kernel	
	$bootloader->add(%hash)

	# remove a kernel
	$bootloader->remove(2)

	# set new default
	$bootloader->set_default(1)

	$bootloader->write($config_file)


=head1 DESCRIPTION

This module provides functions for working with LILO configuration files.

	Adding a kernel:
	- add kernel at start, end, or any index position.
	- kernel path and title are required.
	- root, kernel args, initrd are optional.
	- any options not specified are copied from default.
	- remove any conflicting kernels if force is specified.
	
	Removing a kernel:
	- remove by index position
	- or by title/label


=head1 FUNCTIONS

Also see L<Linux::Bootloader> for functions available from the base class.

=head2 new()

	Creates a new Linux::Bootloader::Lilo object.

=head2 install()

        Attempts to install bootloader.
        Takes: nothing.
        Returns: undef on error.

=head2 boot-once()

        Attempts to set a kernel as default for one boot only.
        Takes: string.
        Returns: undef on error.

=cut


use strict;
use warnings;

@Linux::Bootloader::Lilo::ISA = qw(Linux::Bootloader);
use base 'Linux::Bootloader';


use vars qw( $VERSION );


sub _set_config_file {
    my $self=shift;
    $self->{'config_file'}='/etc/lilo.conf';
}



### LILO functions ###


# Run command to install bootloader

sub install {
  my $self=shift;

  system("/sbin/lilo");
  if ($? != 0) { 
    warn ("ERROR:  Failed to run lilo.\n") && return undef; 
  }
  return 1;
}


# Set kernel to be booted once

sub boot_once {
  my $self=shift;
  my $label=shift;

  return undef unless defined $label;
  
  if (system("/sbin/lilo","-R","$label")) {
    warn ("ERROR:  Failed to set boot-once.\n") && return undef; 
  }
  return 1;
}


1;


=head1 AUTHOR

Open Source Development Labs, Engineering Department <eng@osdl.org>

=head1 COPYRIGHT

Copyright (C) 2006 Open Source Development Labs
All Rights Reserved.

This script is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=head1 SEE ALSO

L<Linux::Bootloader>

=cut

package Linux::Bootloader::Yaboot;

=head1 NAME

Linux::Bootloader::Yaboot - Parse and modify YABOOT configuration files.

=head1 SYNOPSIS

	
	my $bootloader = Linux::Bootloader::Yaboot->new();
	my $config_file='/etc/yaboot.conf';

	$bootloader->read($config_file)

	# add a kernel	
	$bootloader->add(%hash)

	# remove a kernel
	$bootloader->remove(2)

	# set new default
	$bootloader->set_default(1)

	$bootloader->write($config_file)


=head1 DESCRIPTION

This module provides functions for working with YABOOT configuration files.

	Adding a kernel:
	- add kernel at start, end, or any index position.
	- kernel path and title are required.
	- root, kernel args, initrd are optional.
	- any options not specified are copied from default.
	- remove any conflicting kernels if force is specified.
	
	Removing a kernel:
	- remove by index position
	- or by title/label


=head1 FUNCTIONS

Also see L<Linux::Bootloader> for functions available from the base class.

=head2 new()

	Creates a new Linux::Bootloader::Yaboot object.

=head2 install()

        Attempts to install bootloader.
        Takes: nothing.
        Returns: undef on error.

=cut


use strict;
use warnings;

@Linux::Bootloader::Yaboot::ISA = qw(Linux::Bootloader);
use base 'Linux::Bootloader';


use vars qw( $VERSION );


sub _set_config_file {
    my $self=shift;
    $self->{'config_file'}='/etc/yaboot.conf';
}

### YABOOT functions ###


# Run command to install bootloader

sub install {
	my $self=shift;
	my $cmd="";
	# ybin currently returns an error even when it succeeds, but by
	# dumb luck ybin -v does the right thing
	if (-f "/usr/sbin/ybin") {
		$cmd="/usr/sbin/ybin -v > /dev/null";
	} elsif (-f "/sbin/ybin") {
		$cmd="/sbin/ybin -v > /dev/null";
	} else {
		print("Not installing bootloader.\n");
	}

	system($cmd);
	if ( $? != 0 ) {
		warn("ERROR:  Failed to run ybin.\n") && return undef;
	}
	return 1;
}


1;


=head1 AUTHOR

IBM, Linux Technology Centre, Andy Whitcroft <apw@uk.ibm.com>

=head1 COPYRIGHT

Copyright (C) 2006 IBM Corperation
All Rights Reserved.

This script is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=head1 SEE ALSO

L<Linux::Bootloader>

=cut

package Linux::Bootloader::Zipl;

=head1 NAME

Linux::Bootloader::Zipl - Parse and modify ZIPL configuration files.

=cut

use strict;
use warnings;

@Linux::Bootloader::Zipl::ISA = qw(Linux::Bootloader);
use base 'Linux::Bootloader';


use vars qw( $VERSION );


sub _set_config_file {
    my $self=shift;
    $self->{'config_file'}='/etc/zipl.conf';
}


### ZIPL functions ###

# Parse config into array of hashes
sub _info {
  my $self=shift;

  return undef unless $self->_check_config();

  my @config=@{$self->{config}};
  @config=grep(!/^#|^\s*$/, @config);

  my %matches = (
		  target => '^\s*target\s*=\s*(.*)',
		  kernel => '^\s*image\s*=\s*(\S+)',
		  initrd => '^\s*ramdisk\s*=\s*(.*)',
		  args => '^\s*parameters\s*=\s*"?\s*(.*[^"])"?',
		);

  my %sect_title;
  my $menu_name;
  my $title;
  my @sections;
  foreach (@config) {
    chomp($_);

    # Note the menu and switch mode.
    if ($_ =~ /^:(menu\S*)/) {
      $menu_name = $1;

    # An entry starts [name]
    } elsif ($_ =~ /^\s*\[(\S+)\]/i) {
      $title = $1;
      $sect_title{$title}{title} = $title;
    }

    # Decode the entry fields
    if (!defined $menu_name) {
      foreach my $key (keys %matches) {
	if ($_ =~ /$matches{$key}/i) {
	  $key .= '2' if exists $sect_title{$title}{$key};
	  $sect_title{$title}{$key} = $1;
	}
      }

    # This is the menu, pull it in
    } else {
        # If this is an entry specified copy entry in to the result.
	if ($_ =~ /^\s+(\d+)\s*=\s*(\S*)/) {
	  $sections[$1] = $sect_title{$2};

	# record all the other attributes here, pick out the default
	# if we see it.
	} else {
	  if ($_ =~ /^\s+(\S+)\s*=\s*(.*\S)\s*/) {
	    $sections[0]{$1} = $2;
	  }
	}
     }
  }
  $sections[0]{'menu'} = $menu_name;
  if (defined $sections[0]{'default'}) {
    $sections[0]{'default'}--;
  }

  # sometimes config doesn't have a default, so goes to first
  if (!(defined $sections[0]{'default'})) {
    $sections[0]{'default'} = '0';

  # if default is label name, we need position
  } elsif ($sections[0]{'default'} !~ m/^\d+$/) {
    foreach my $index (1..$#sections) {
      if ($sections[$index]{'title'} eq $sections[0]{'default'}) {
        $sections[0]{'default'} = $index-1;
        last;
      }
    }
    $sections[0]{'default'} = 0 if (!defined $sections[0]{'default'});
  }

  # return array of hashes
  return @sections;
}

# Set new default kernel

sub set_default {
  my $self=shift;
  my $newdefault=shift;

  return undef unless defined $newdefault;
  return undef unless $self->_check_config();

  my @config=@{$self->{config}};
  my @sections=$self->_info();

  # if not a number, do title lookup
  if ($newdefault !~ /^\d+$/) {
    $newdefault = $self->_lookup($newdefault);
    return undef unless (defined $newdefault);
  }

  my $kcount = $#sections-1;
  if (($newdefault < 0) || ($newdefault > $kcount)) {
    warn "ERROR: Enter a default between 0 and $kcount.\n";
    return undef;
  }

  # Look up the actual title of this section.
  my $title = $sections[$newdefault + 1]{'title'};

  # Look through the config file for the specifier,
  # note there are two, one the name and one the number
  # go figure.  Note that ZIPL numbering is 1..N.
  foreach my $index (0..$#config) {
    if ($config[$index] =~ /(^\s*default\s*\=*\s*)\d+\s*$/i) {
      $config[$index] = $1 . ($newdefault + 1) . "\n";

    } elsif ($config[$index] =~ /(^\s*default\s*\=*\s*)/i) {
      $config[$index] = "$1$title\n";
    }
  }
  @{$self->{config}} = @config;
}


# Add new kernel to config
sub add {
  my $self=shift;
  my %param=@_;

  print ("Adding kernel.\n") if $self->debug()>1;

  if (!defined $param{'add-kernel'} || !defined $param{'title'}) {
    warn "ERROR:  kernel path (--add-kernel), title (--title) required.\n";
    return undef;
  } elsif (!(-f "$param{'add-kernel'}")) {
    warn "ERROR:  kernel $param{'add-kernel'} not found!\n";
    return undef;
  } elsif (defined $param{'initrd'} && !(-f "$param{'initrd'}")) {
    warn "ERROR:  initrd $param{'initrd'} not found!\n";
    return undef;
  }

  return undef unless $self->_check_config();

  my @sections=$self->_info();

  # check if title already exists
  if (defined $self->_lookup($param{title})) {
    warn ("WARNING:  Title already exists.\n");
    if (defined $param{force}) {
      $self->remove($param{title});
    } else {
      return undef;
    }
  }

  my @config = @{$self->{config}};
  @sections=$self->_info();

  # Use default kernel to fill in missing info
  my $default=$self->get_template();
  $default++;

  foreach my $p ('args', 'target') {
    if (! defined $param{$p}) {
      $param{$p} = $sections[$default]{$p};
    }
  }

  # use default entry to determine if path (/boot) should be removed
  my $bootpath = $sections[$default]{'kernel'};
  $bootpath =~ s@[^/]*$@@;

  $param{'add-kernel'} =~ s@^/boot/@$bootpath@;
  $param{'initrd'} =~ s@^/boot/@$bootpath@ unless !defined $param{'initrd'};

  my $line;
  my @newkernel;
  push(@newkernel, "[$param{'title'}]\n");
  push(@newkernel, "\ttarget=$param{'target'}\n") if (defined $param{'target'});
  push(@newkernel, "\timage=$param{'add-kernel'}\n");
  push(@newkernel, "\tramdisk=$param{'initrd'}\n") if (defined $param{'initrd'});
  $line = '';
  $line .= "root=$param{root} " if (defined $param{'root'});
  $line .= "$param{args} " if (defined $param{'args'});
  chop($line);
  push(@newkernel, "\tparameters=\"$line\"\n");

  push(@newkernel, "\n");

  if (!defined $param{position} || $param{position} !~ /end|\d+/) {
    $param{position} = 0;
  }

  my @newconfig;
  my $index=0;
  my $menu=0;
  my @list;
  foreach (@config) {
    if ($_ !~ /^\s*\[defaultboot]/i && $_ =~ /^\s*\[(\S+)]/i) {
      if ($param{'position'} ne 'end' && $index == $param{position}) {
	push(@newconfig, @newkernel);
        push(@list, $param{'title'});
      }
      $index++;
      push(@list, $1);

    } elsif (/^:menu\S*/) {
      if ($param{'position'} eq 'end' || $index < $param{'position'}) {
	push(@newconfig, @newkernel);
        push(@list, $param{'title'});
	$param{position} = $index;
      }
      # Rebuild the menu entries.
      push(@newconfig, $_);
      for (my $n = 0; $n <= $#list; $n++) {
        push(@newconfig, "\t" . ($n+1) . "=$list[$n]\n");
      }
      $menu = 1;
      next;
    }
    if ($menu) {
      if (/^\s+\d+=/) {
	next;
      } else {
	$menu = 0;
      }
    }
    push(@newconfig, $_);
  }

  @{$self->{config}} = @newconfig;

  if (defined $param{'make-default'} || defined $param{'boot-once'}) {
    $self->set_default($param{position});
  }
  print "Added: $param{'title'}.\n";
}


# Remove a kernel from config
sub remove {
  my $self=shift;
  my $position=shift;

  return undef unless defined $position;
  return undef unless $self->_check_config();

  my @config=@{$self->{config}};
  my @sections=$self->_info();
  my $default = $self->get_default();

  if ($position=~/^end$/i) {
    $position=$#sections-1;
  } elsif ($position=~/^start$/i) {
    $position=0;
  }

  print ("Removing kernel $position.\n") if $self->debug()>1;

  # if not a number, do title lookup
  if ($position !~ /^\d+$/) {
    $position = $self->_lookup($position);
  }
  if ($position !~ /^\d+$/) {
    warn "ERROR: $position: should be # or title\n";
    return undef;
  }

  my $title = $sections[$position + 1]{'title'};

  my $keep = 1;
  my @newconfig;
  my @list;
  my $index = 0;
  my $menu;
  foreach (@config) {
    if ($_ !~ /^\s*\[defaultboot]/i && $_ =~ /^\s*\[(\S+)]/i) {
      if ($index == $position) {
        $keep = 0;
      } else {
        push(@list, $1);
	$keep = 1;
      }
      $index++;

    } elsif (/^:menu\S*/) {
      # Rebuild the menu entries.
      push(@newconfig, $_);
      for (my $n = 0; $n <= $#list; $n++) {
        push(@newconfig, "\t" . ($n+1) . "=$list[$n]\n");
      }
      $menu = 1;
      $keep = 1;
      next;
    }
    if ($menu) {
      if (/^\s+\d+=/) {
	next;
      } else {
	$menu = 0;
      }
    }
    push(@newconfig, $_) if ($keep);
  }

  @{$self->{config}} = @newconfig;

  # Update the default.
  my $new = $default;
  if ($default == $position) {
    $new = 0;
  } elsif ($default > $position) {
    $new = $default - 1;
  }
  if ($default != $new) {
    $self->set_default($new);
  }

  print "Removed: $title\n";
}


# Update kernel args
sub update {
  my $self=shift;
  my %params=@_;

  print ("Updating kernel.\n") if $self->debug()>1;

  if (defined $params{'option'} && !defined $params{'update-kernel'}) {
    return $self->update_main_options(%params);
  } elsif (!defined $params{'update-kernel'} || (!defined $params{'args'} && !defined $params{'remove-args'} && !defined $params{'option'})) {
    warn "ERROR:  kernel position or title (--update-kernel) and args (--args or --remove-args) required.\n";
    return undef;
  }

  return undef unless $self->_check_config();

#  my @config = @{$self->{config}};
  my @sections=$self->_info();

  # if not a number, do title lookup
  if (defined $params{'update-kernel'} and $params{'update-kernel'} !~ /^\d+$/) {
    $params{'update-kernel'} = $self->_lookup($params{'update-kernel'});
  }

  my $kcount = $#sections-1;
  if ($params{'update-kernel'} !~ /^\d+$/ || $params{'update-kernel'} < 0 || $params{'update-kernel'} > $kcount) {
    warn "ERROR: Enter a default between 0 and $kcount.\n";
    return undef;
  }

  # Convert to a title to find the relevant section.
  my $title = $sections[$params{'update-kernel'} + 1]{'title'};

  my $seen = '';
  my $config_line = -1;
  my $line = '';
  foreach $line (@{$self->{config}}) {
    $config_line = $config_line + 1;
    if ($line =~ /^\s*\[(\S+)]/i) {
      $seen = $1;
    }
    if ($title eq $seen) {
      if (defined $params{'args'} or defined $params{'remove-args'}){
        if ($line =~ /^\s*parameters="(.*[^"])"/i) {
	  my $oargs = $1;
	  my $args = $self->_build_args($oargs, $params{'remove-args'}, $params{'args'});
          if ($args eq $oargs) {
            warn "WARNING:  No change made to args.\n";
            return undef;
          }
	  # Note that updating line updates the _real_ lines in @config.
	  $line = "\tparameters=\"$args\"\n";
          next;
        }
      } elsif (defined $params{'option'}){
        foreach my $val ( keys %params){
          if ($line =~ m/^\s*$val.*/i) {
            splice @{$self->{config}},$config_line,1,"$val $params{$val}\n";
            delete $params{$val};
            $config_line += 1;
          }
        }
      }
    }
  }
  # Add any leftover parameters
  delete $params{'update-kernel'};
  if (defined $params{'option'}){
    delete $params{'option'};
    $config_line -= 1;
    foreach my $val ( keys %params){
      splice @{$self->{config}},$config_line,0,"\t$val $params{$val}\n";
      $config_line += 1;
    }
  }
}


# Run command to install bootloader
sub install {
  my $self=shift;
  my $device;

  my @sections=$self->_info();

  warn "ZIPL: needs to run zipl -m $sections[0]{'menu'}\n";
  system("/sbin/zipl -m $sections[0]{'menu'}");
  if ($? != 0) {
    warn ("ERROR:  Failed to run grub-install.\n") && return undef;
  }
  return 1;
}


sub update_main_options{
  # XXX: the main options are probabally those on the menu object.
  die "ERROR: unable to update main options\n";
}


sub boot_once {
  warn "ZIPL does not support boot-once\n";
  return undef;
}

1;

=head1 AUTHOR

Open Source Development Labs, Engineering Department <eng@osdl.org>

=head1 COPYRIGHT

Copyright (C) 2006 Open Source Development Labs
All Rights Reserved.

This script is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=head1 SEE ALSO

L<Linux::Bootloader>

=cut

#!/usr/bin/perl -I ../lib

use lib '../lib';
use Getopt::Long;
use Pod::Usage;


my %params;

GetOptions(
           \%params,
           "bootloader-probe",      # Prints the bootloader in use on the system
           "arch-probe:s",          # Prints the arch of the system
           "bootloader=s",
           "config_file=s",
           "add-kernel=s",
           "remove-kernel=s",
           "update-kernel=s",
           "title=s",
           "args=s",
           "remove-args=s",
           "initrd=s",
           "root=s",
           "savedefault=s",
           "position=s",
           "info=s",
           "debug=i",
           "set-default=s",
           "make-default",
           "force",
           "boot-once",
           "install",
	   "module=s@", 
           "default",
           "help",
           "man",
           "version|V",
           "xen",
           ) or pod2usage(-verbose => 1, -exitstatus => 0);

pod2usage(-verbose => 2, -exitstatus => 0) if ($params{man});
pod2usage(-verbose => 1, -exitstatus => 0) if ($params{help});
pod2usage(-verbose => 0, -exitstatus => 0) if ! %params;

if ($params{version}) {
    print "$0 version 1.1\n";
}

### Bootloader / Arch Detection ###

my $detected_bootloader;
my $detected_architecture;

if (defined $params{'bootloader-probe'}) {
  our $opt_bootloader      = 0;
  $detected_bootloader = Linux::Bootloader::Detect::detect_bootloader()
    || warn "Could not detect bootloader\n";
  print "$detected_bootloader\n";
  exit 0;
} elsif (defined $params{'arch-probe'}) {
  our $opt_arch    = 0;
  $detected_architecture = Linux::Bootloader::Detect::detect_architecture( $params{'arch-probe'} )
    || warn "Could not detect architecture\n";
  print "$detected_architecture\n";
  exit 0;
} elsif (defined $params{bootloader}) {
  $detected_bootloader = $params{bootloader};
} else {
  #$detected_bootloader = 'grub';
  $detected_bootloader = Linux::Bootloader::Detect::detect_bootloader()
    || warn "Could not detect bootloader\n";
}


### Load Module ###

my $bootloader;
if ($detected_bootloader =~ m/^(grub|elilo|lilo|yaboot|zipl)$/) {
  my $class = "Linux::Bootloader::" . "\u$detected_bootloader";
  eval "require $class";
  $bootloader = eval "new $class(\$params{config_file});";

} else { 
  die "ERROR: Bootloader $detected_bootloader not recognized!\n";
}


### Check Config ###

if (! -r $bootloader->{config_file}) { die "Can't read config file.\n"; }

if (defined $params{'debug'}) {
  $bootloader->debug($params{'debug'});
}

if (defined $params{'install'}) {
  $bootloader->read();
  $bootloader->install() unless $detected_bootloader eq 'grub' 
                             or $detected_bootloader eq 'pxe' ;
} elsif (defined $params{'add-kernel'}) {
  $bootloader->read();
  $bootloader->add(%params);
  $bootloader->write();
  $bootloader->install() unless $detected_bootloader eq 'grub';

} elsif (defined $params{'remove-kernel'}) {
  $bootloader->read();
  $bootloader->remove($params{'remove-kernel'});
  $bootloader->write();
  $bootloader->install() unless $detected_bootloader eq 'grub';

} elsif (defined $params{'update-kernel'}) {
  $bootloader->read();
  $bootloader->update(%params);
  $bootloader->write();
  $bootloader->install() unless $detected_bootloader eq 'grub';

} elsif (defined $params{info}) {
  $bootloader->read();
  $bootloader->print_info($params{info});

} elsif (defined $params{'set-default'}) {
  $bootloader->read();
  $bootloader->set_default($params{'set-default'});
  $bootloader->write();
  $bootloader->install() unless $detected_bootloader eq 'grub';

} elsif (defined $params{'default'}) {
  $bootloader->read();
  print $bootloader->get_default() . "\n";

} elsif (defined $params{'boot-once'} && defined $params{'title'}) {
  if ($detected_bootloader =~ /^lilo|^elilo|^grub/) {
    $bootloader->boot_once($params{title});
  } else {
    warn "WARNING: $detected_bootloader does not have boot-once support.\n";
    warn "Setting as default instead.\n";
    $bootloader->read();
    $bootloader->set_default($params{'title'});
    $bootloader->write();
  } 
}

 
__END__


=head1 NAME

boottool - tool for modifying bootloader configuration

=head1 SYNOPSIS

boottool [--bootloader-probe] [--arch-probe]
         [--add-kernel=<kernel_path>] [--title=<kernel_title>] [--position=<#|start|end>]
         [--root=<root_path>] [--args=<kernel_args>] [--initrd=<initrd_path>]
         [--make-default] [--force] [--boot-once] [--install]
         [--bootloader=<grub|lilo|elilo|yaboot|zipl>] [--config-file=</path/to/config>]
         [--remove-kernel=<#|title|start|end>] [--module=<module>]
         [--update-kernel=<#|title>] [--remove-args=<args>]
         [--info=<all|default|#>] [--default]
         [--help] [--debug=<0..5>] [--set-default=<#>]

=head1 DESCRIPTION

Boottool allows scripted modification of bootloader configuration files.
Grub, Lilo, Elilo, and Yaboot are currently supported.
When adding a kernel, any options not specified are copied from default.

=head1 OPTIONS

=head2 GENERAL OPTIONS

These can be used with any of the commands to override defaults or
autodetection.  They are not typically needed.

=over 8

=item B<--bootloader>=I<string>

Manually specify the bootloader to use.  By default, boottool will
automatically try to detect the bootloader being used.

=item B<--config_file>=I<string>

Specifies the path and name of the bootloader config file, overriding
autodetection of this file.

=back

=head2 INFORMATIONAL OPERATIONS

These operations return information about the system, without making
alterations to any files.

=over 8

=item B<--bootloader-probe>

Prints the bootloader in use on the system and exits.

=item B<--arch-probe>

Prints the arch of the system and exits.

=item B<--info>=I<string>

Display information about the bootloader entry at the given position number.
Also accepts 'all' or 'default'.

=item B<--default>

Prints the current default kernel for the bootloader.

=back

=head2 KERNEL OPERATIONS

These operations result in modifications to system configuration files.
Only one of these operations may be called.  See KERNEL MODIFICATION
PARAMETERS (below) for specifying what the operations should do.

=over 8

=item B<--add-kernel>=I<string>

Adds a new kernel with the given path.

=item B<--update-kernel>=I<string>

Updates an existing kernel with the given position number or title.
Used with --args or --remove-args.

=item B<--module>=I<string>

This option adds modules to the new kernel. It only works with Grub Bootloader.
For more module options just add another --module parameter

=item B<--remove-kernel>=I<string>

Removes the bootloader entry with the given position or title.
Also accepts 'start' or 'end'.

=item B<--set-default>=I<integer>

Updates the bootloader to set the default boot entry to given given
position or title.

=item B<--boot-once>

Causes the bootloader to boot the kernel specified by --title just one
time, then fall back to the default.  This option doesn't work
identically on all architectures.

=back

=head2 KERNEL MODIFICATION PARAMETERS

These parameters can be used with the kernel operations listed above, to 
specify how the operations should work.

=over 8

=item B<--title>=I<string>

The title or label to use for the bootloader entry.

=item B<--args>=I<string>

Arguments to be passed to the kernel at boot.

=item B<--remove-args>=I<string>

Arguments to be removed from an existing entry.
Used with --update-kernel.

=item B<--initrd>=I<string>

The initrd image path to use in the bootloader entry.

=item B<--root>=I<string>

The device where the root partition is located.

=item B<--savedefault>=I<string>

The number to use in the savedefault section

=item B<--position>=I<string>

Insert bootloader entry at the given position number, counting from 0.
Also accepts 'start' or 'end'.  This is only useful when using the
--add-kernel operation.

=item B<--make-default>

Specifies that the bootloader entry being added should be set to the
default.

=item B<--install>

Causes bootloader to update and re-install the bootloader file.

=back


=head2 OTHER OPTIONS

=over 8

=item B<-V, --version>

Prints the version and exits.

=item B<-h, --help>

Prints a brief help message with option summary.

=item B<--man>

Prints a manual page (detailed help).  Same as `perdoc tgen`

=item B<-D, --debug N>

Prints debug messages.  This expects a numerical argument corresponding
to the debug message verbosity.

=back

=head1 PREREQUISITES

C<Linux::Bootloader>

C<Getopt::Long>

C<Pod::Usage>

=head1 COREQUISITES

boottool works with any bootloader supported by Linux::Bootloader,
including the following:

C<Lilo>

C<Grub>

C<Yaboot>

C<Elilo>

Obviously, at least one bootloader must be installed for this to be of
any use.  ;-)

=head1 BUGS

Send bug reports to L<http://sourceforge.net/projects/crucible/>

=head1 VERSION

1.0

=head1 SEE ALSO

L<crucible>, L<WWW::PkgFind>, L<Test::Parser>, L<Linux::Distribution>

=head1 AUTHOR

Jason N.

L<http://www.osdl.org/|http://www.osdl.org/>

=head1 COPYRIGHT

Copyright (C) 2006 Open Source Development Labs
All Rights Reserved.

This script is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=head1 REVISION

Revision: $Revision: 1.10 $

=cut