#!/usr/bin/perl -w

=head1 NAME

xen-create-image - Create a new virtual Debian installation for Xen.

=head1 SYNOPSIS

  xen-create-image [options]

  Help Options:
   --debug    Show useful debugging information.
   --help     Show this scripts help information.
   --manual   Read this scripts manual.
   --version  Show the version number and exit.

  Size / General options:
   --boot        Boot the new instance after creating it.
   --debootstrap Pass anything named here onto debootstrap.
   --dir         Specify where the output images should go.
   --dist        Specify the distribution you wish to install: Sarge/Etch/Sid.
   --fs          Specify the filesystem type to use.
   --kernel      Set the path to the kernel to use for dom U
   --memory      Setup the amount of memory allocated to the instance.
   --mirror      Setup the mirror to use when installing Sarge.
   --size        Set the size of the primary disk image.
   --swap        Set the size of the swap partition.   


  Networking options:
   --dhcp      Setup the image to get an IP address via DHCP
   --gateway   Setup the iamge's network gateway.
   --ip	       Setup the ip 
   --netmask   Setup the netmask

  Mandatory options:

   --hostname  Set the images hostname.

=cut



=head1 OPTIONS

=over 8

=item B<--boot>
Start the new virtual instance as soon as the installation has finished.

=item B<--debug>
Show the commands this script executes as an aid to debugging.

=item B<--debootstrap>
Anything specified after this will be passed onto the debootstrap command executed.

=item B<--dhcp>
Specify that the virtual image should use DHCP to obtain its networking information.  Conflicts with B<--ip>.

=item B<--dir>
Specify the root directory beneath which the image should be saved.  Subdirectories will be created for each virtual image.

=item B<--dist>
Specify the distribution to install, defaults to 'sarge'.

=item B<--fs>
Specify the filesystem the image should be given.  Valid options are 'ext3',
'xfs', or 'reiserfs'.

=item B<--gateway>
Specify the gateway address for the virtual image, only useful if DHCP is not used.

=item B<--help>
Show the brief help information.

=item B<--hostname>
Set the hostname of the new instance.

=item B<--ip>
Set the IP address for the virtual image.  Conflicts with B<--dhcp>

=item B<--kernel>
Set the path to the kernel to use for the image.

=item B<--manual>
Read the manual, with examples.

=item B<--memory>
Specify the amount of memory the virtual image should be allocated.  Defaults
to 96Mb.

=item B<--mirror>
Specify the mirror to use to the installation of Sarge, defaults to http://ftp.us.debian.org/debian

=item B<--netmask>
Set the netmask the virtual image should use.

=item B<--size>  
Specify the size of the primary drive to give the virtual image.  The size may be suffixed with either Mb, or Gb.

=item B<--swap>
Specify the size of the virtual swap partition to create.  The size may be
suffixed with either Mb, or Gb.

=item B<--version>
Show the version number and exit.

=back

=cut


=head1 EXAMPLES

  The following will create a 2Gb disk image, along with a 128Mb 
 swap file with Debian Sarge setup and running via DHCP.

     xen-create-image --size=2Gb --swap=128Mb --dhcp \
          --dir=/home/xen --hostname=vm01.my.flat

  This next example sets up a host which has the name 'vm02' and
 IP address 192.168.1.200, with the gateway address of 192.168.1.1

     xen-create-image --size=2Gb --swap=128Mb \
          --ip=192.168.1.200 --netmask=255.255.255.0
          --gateway=192.168.1.1 \
          --dir=/home/xen --hostname=vm02

  To save time these command line options may be specified in the
 configuration file discussed later.

  The directory specified for the output will be used to store the files
 which are produced.  To avoid clutter each host will have its images 
 stored beneath the specified directory, named after the hostname.

  For example the images created above will be stored as:

   $dir/domains/vm01.my.flat/
   $dir/domains/vm01.my.flat/disk.img
   $dir/domains/vm01.my.flat/swap.img

   $dir/domains/vm02.my.flat/
   $dir/domains/vm02.my.flat/disk.img
   $dir/domains/vm02.my.flat/swap.img

  The '/domains/' subdirectory will be created if necessary.

=cut


=head1 DESCRIPTION


  xen-create-image is a simple script which allows you to create new
 Xen instances of Debian Sarge.  The new image will be comprised of
 two seperate files:

   1.  One disk image which will be treated as the primary disk drive.
   2.  One swap image.

  The image will have OpenSSH installed upon it, and an appropriate
 /etc/inittab file created, along with copies of the hosts password
 and shadow files.


=head1 CONFIGURATION

  To reduce the length of the command line each of the options may
 be specified inside a configuration file.

  The script will check a global configuration file for options:

     /etc/xen-tools/xen-tools.conf

  The files may contain comments, which begin with the hash '#' character
 and are otherwise of the format 'key = value.

  A sample configuration file would look like this:


=for example begin

 #
 #  Output directory.  Images are stored beneath this directory, one
 # subdirectory per hostname.
 #
 dir = /home/xen

 #
 #  Disk and Sizing options.
 #
 size       = 2Gb      # Disk image size.
 memory     = 128Mb    # Memory size
 swap       = 128Mb    # Swap size
 filesystem = ext3     # use EXT3 filesystems
 dist       = sarge    # Default distribution to install.

 #
 # Kernel options.
 #
 kernel     = /boot/vmlinuz-2.6.12-xenU

 #
 # Networking options.
 #
 gateway   = 192.168.1.1
 netmask   = 255.255.255.0

=for example end

  This allows a new image to be created with only two command line flags:

      xen-create-image --hostname='vm03.my.flat' --ip=192.168.1.201


=head1 CACHING

  Because the virtual systems are installed with the debootstrap
 tool there can be a lot of network overhead.

  To minimize this the .deb files which are downloaded into the
 new instance are cached upon the host in the directory
 /var/cache/apt/archives. 

  When a new image is created these packages are copied into the new
 image - before the debootstrap process runs.  This will avoid a
 the expensive fetch from the network.

  If you wish to clean the cache run on the host:

  apt-get clean


=head1 CUSTOMIZATION


  If you wish to add new packages to the image automatically you may
 take advantage of the '--debootstrap' option which allows you to 
 pass flags to the debootstrap command.

  For the following command causes three new packages to be added
 to the base image:


      xen-create-image --debootstrap='--include=screen,sudo,less'

  An alternative is to use the hook directory, described below, to
 run a script which will install a package.


=head1 HOOKS

  After the image has been installed using debootstrap there is
 the chance for you to run some scripts before the image is unmounted.

  To do this place executable scripts inside the "hook directory"
 /etc/xen-tools/xen-create-image.d/.

  Each script will be executed in turn and given two parameters,
 the first is the name of the mount point the image is available at,
 and the second is the hostname of the new image.


  A script could copy some the kernel modules to the new system, and
 install a package, for example:

=for example start

 #!/bin/sh

 prefix=$1
 hostname=$2

 # Copy modules
 mkdir -p ${prefix}/lib/modules
 cp -R /lib/modules/2.6.12.6-xen/ ${prefix}/lib/modules

 # Install the package 'module-init-tools'
 DEBIAN_FRONTEND=noninteractive chroot $prefix /usr/bin/apt-get --yes --force-yes install module-init-tools


=for example cut

=cut


=head1 AUTHOR


 Steve
 --
 http://www.steve.org.uk/

 $Id: xen-create-image,v 1.62 2005-12-24 10:34:14 steve Exp $

=cut


=head1 CONTRIBUTORS

  Radu Spineanu

=head1 LICENSE

Copyright (c) 2005 by Steve Kemp.  All rights reserved.

This module is free software;
you can redistribute it and/or modify it under
the same terms as Perl itself.
The LICENSE file contains the full text of the license.

=cut


use strict;
use English;
use File::Copy;
use File::Temp qw/ tempdir /;
use Getopt::Long;
use IPC::Open3;
use Pod::Usage;




#
#  Global configuration options.
#
#  Initially our options are read from the configuration file into this
# hash.  Later they may be overridden by the command line.
#
#  Command line flags *always* take precedence over the configuration files(s).
#
#
my %CONFIG;

#
#  The width of the current terminal, used for line-wrapping.
#
my ( $TERMINAL_WIDTH, $TERMINAL_HEIGHT ) = getTerminalSize();



#
#  These hashes contain information used for the creation of different
# fileystems.
#
my %FILESYSTEM_BINARY;
my %FILESYSTEM_CREATE;
my %FILESYSTEM_MOUNT;

#
#  The program to run to create a filesystem - used in the next hash.
#
$FILESYSTEM_BINARY{'ext3'}     = '/sbin/mkfs.ext3';
$FILESYSTEM_BINARY{'xfs'}      = '/sbin/mkfs.xfs';
$FILESYSTEM_BINARY{'reiserfs'} = '/sbin/mkfs.reiserfs';

#
#  The command to use to create a filesystem.  The disk image
# filename is appended to these commands to generate what is
# ultimately executed.
#
$FILESYSTEM_CREATE{'ext3'}     = $FILESYSTEM_BINARY{'ext3'}. ' -F ';
$FILESYSTEM_CREATE{'xfs'}      = $FILESYSTEM_BINARY{'xfs'}. ' -d name=';
$FILESYSTEM_CREATE{'reiserfs'} = $FILESYSTEM_BINARY{'reiserfs'}. ' -f -q ';

#
#  Flags to pass to "mount" to mount our image.  Kinda redundent and may
# go away - seems to me that just using '-t $CONFIG{'fs'}' is sufficient.
#
$FILESYSTEM_MOUNT{'ext3'}      = '-t ext3';
$FILESYSTEM_MOUNT{'xfs'}       = '-t xfs';
$FILESYSTEM_MOUNT{'reiserfs'}  = '-t reiserfs';



#
#  Setup defaults:
#
#  Memory = 96M, Image = 2000Mb, Swap = 128Mb, and filesystem is ext3.
#
#  These may be overriden by one of the configuration files, or by the
# command line arguments.
#
$CONFIG{'memory'}      = '96Mb';
$CONFIG{'size'}	       = '2000Mb';
$CONFIG{'swap'}	       = '128M';
$CONFIG{'fs'}	       = 'ext3';
$CONFIG{'mirror'}      = 'http://ftp.us.debian.org/debian';
$CONFIG{'dist'}	       = 'sarge';
$CONFIG{'xm'}	       = '/usr/sbin/xm';
$CONFIG{'kernel'}      = '/boot/vmlinuz-2.6.12-xenU';
$CONFIG{'debootstrap'} = '';
$CONFIG{'hook_dir'}    = '/etc/xen-tools/xen-create-image.d/';

#
#  Read configuration file(s) if they exist.
#
if ( -e "/etc/xen-tools/xen-tools.conf" )
{
    readConfigurationFile( "/etc/xen-tools/xen-tools.conf" );
}


#
#  Parse command line arguments, these override the values from the
# configuration file.
#
parseCommandLineArguments();


#
#  Check that the arguments the user has supplied are both 
# valid, and complete.
#
checkArguments();


if ( $EFFECTIVE_USER_ID != 0 )
{
    print <<E_O_ROOT;

  In order to use this script you must be running with root privileges.

  (This is necessary to mount the disk images.)

E_O_ROOT

    exit;
}


print "\nGeneral Infomation\n";
print "--------------------\n";
print "Hostname       :  $CONFIG{'hostname'}\n";
print "Distribution   :  $CONFIG{'dist'}\n";
print "Fileystem Type :  $CONFIG{'fs'}\n";

print "\nSize Information\n";
print "----------------\n";
print "Image size     :  $CONFIG{'size'}\n";
print "Swap size      :  $CONFIG{'swap'}\n";
print "Memory size    :  $CONFIG{'memory'}\n";
print "Kernel Path    :  $CONFIG{'kernel'}\n";

print "\nNetworking Information\n";
print "----------------------\n";

$CONFIG{'ip'}        && print "IP Address     : $CONFIG{'ip'}\n";
$CONFIG{'dhcp'}      && print "IP Address     : DHCP\n";
$CONFIG{'netmask'}   && print "Netmask        : $CONFIG{'netmask'}\n";
$CONFIG{'gateway'}   && print "Gateway        : $CONFIG{'gateway'}\n";
print "\n\n";


#
#  If the output directories don't exist then create them.
#
if ( ! -d $CONFIG{'dir'} . "/domains/" )
{
    mkdir $CONFIG{'dir'} . '/domains', 0777
      || die "Cannot create $CONFIG{'dir'}/domains - $!";
}
if ( ! -d $CONFIG{'dir'} . "/domains/" . $CONFIG{'hostname'} )
{
    mkdir $CONFIG{'dir'}. '/domains/' . $CONFIG{'hostname'}, 0777
      || die "Cannot create $CONFIG{'dir'}/domains/$CONFIG{'hostname'} - $!" ;
}



#
# The two images we'll use, one for the disk image, one for swap.
#
my $image = $CONFIG{'dir'} . '/domains/' . $CONFIG{'hostname'} . "/disk.img" ;
my $swap  = $CONFIG{'dir'} . '/domains/' . $CONFIG{'hostname'} . "/swap.img" ;

#
#  Create swapfile and initialise it.
#
print "\n\nCreating swapfile : $swap\n";

#
# Remove any trailing Mb.
# 
$CONFIG{'swap'} =~ s/Mb*$//i;

#
# Build up the command, and execute it.
#
my $swap_cmd = "/bin/dd if=/dev/zero of=$swap bs=1024k count=$CONFIG{'swap'}";
runCommand( $swap_cmd );
runCommand( "/sbin/mkswap $swap" );
print "Done\n";



#
#  Create disk file and initialise it.
#
print "\nCreating disk image: $image\n";
$CONFIG{'size'} =~ s/Mb*$/k/i;
my $image_cmd = "/bin/dd if=/dev/zero of=$image bs=$CONFIG{'size'} count=1 seek=1024";
runCommand( $image_cmd );
print "Done\n";

print "\nCreating $CONFIG{'fs'} filesystem\n";
my $create = $FILESYSTEM_CREATE{lc( $CONFIG{'fs'} ) } . $image ;
runCommand( $create );
print "Done\n";


#
#  Now mount the image, in a secure temporary location.
#
my $dir = tempdir( CLEANUP => 1 );
my $mount_cmd = "mount " . $FILESYSTEM_MOUNT{lc($CONFIG{'fs'})} . " -o loop $image $dir";
runCommand( $mount_cmd );


# Test that the mount worked

my $mount = runCommand( "/bin/mount" );

if ( ! $mount =~ /$image/) 
{
    print "Something went wrong trying to mount the new filesystem\n";
    exit;
}

#
#  Copy any local .deb files into the debootstrap archive as a potential
# speedup.
#
print "\nCopying files from host to image.\n";
runCommand( "mkdir -p $dir/var/cache/apt/archives" );

my @files =  glob( "/var/cache/apt/archives/*.deb" );
my $count = 1;
my $total = $#files+1;
foreach my $file ( @files )
{
    my $t = "\r[$count/$total] : ";
    if ( $file =~ /(.*)\/(.*)/ )
    {
	$t .= $2;
    }

    #
    # Print the status message and do the copy.
    #
    printWideMessage( $t );
    File::Copy::cp( $file, "$dir/var/cache/apt/archives" );

    $count += 1;
}
printWideMessage( "\rDone" );


#
#  Install the base system - with a simple sense of progress.
#
print "\n\nRunning debootstrap to install the system.   This will take a while!\n";
my $debootstrap = "debootstrap $CONFIG{'debootstrap'} $CONFIG{'dist'} $dir $CONFIG{'mirror'}";
runCommandWithProgress( $debootstrap );

#
#  Copy these files as a speed boost for the next run.
#
print "\n\nCaching debootstrap files to the host system\n";
@files =  glob( "$dir/var/cache/apt/archives/*.deb" );
$count = 1;
$total = $#files + 1;
foreach my $file ( @files )
{
    my $t = "\r[$count/$total] : ";
    if ( $file =~ /(.*)\/(.*)/ )
    {
	$t .= $2;
    }
    
    #
    # Print the status message and do the copy
    #
    printWideMessage( $t );
    File::Copy::cp( $file, "/var/cache/apt/archives" );

    $count += 1;
}
printWideMessage( "\rDone" );



#
#  If the debootstrap failed then we'll setup the output directories
# for the configuration files here.
#
runCommand( "mkdir -p $dir/etc/apt" );
runCommand( "mkdir -p $dir/etc/network" );

#
#  OK now we can do the basic setup.
#
print "\n\nSetting up APT sources\n";
open( APT, ">", $dir . "/etc/apt/sources.list" );
print APT<<E_O_APT;
#
#  /etc/apt/sources.list
#


#
# $CONFIG{'dist'}
#
deb     $CONFIG{'mirror'}     $CONFIG{'dist'} main contrib non-free
deb-src $CONFIG{'mirror'}     $CONFIG{'dist'} main contrib non-free

# 
#  Security updates
# 
deb     http://security.debian.org/ stable/updates  main contrib non-free
deb-src http://security.debian.org/ stable/updates  main contrib non-free


E_O_APT
close( APT );

print "Done\n";



#
#  Copy some files from the host system, after setting up the hostname.
#
#
my @hostFiles = ( "/etc/resolv.conf",
		  "/etc/hosts",
		  "/etc/passwd",
		  "/etc/group",
		  "/etc/shadow",
		  "/etc/gshadow" );

print "\n\nCopying essential files from the host to the guest\n";
foreach my $file ( @hostFiles )
{
    printWideMessage( "\r" . $file );
    File::Copy::cp( $file, $dir . "/etc" );
}
printWideMessage( "\rDone" );



#
#  Disable TLS
#
if ( -d $dir . "/lib/tls" ) 
{
    runCommand( "mv $dir/lib/tls $dir/lib/tls.disabled" );
}



#
#  Now setup the fstab
#
print "\n\nSetting up /etc/fstab\n";

#
#  XFS requires different options for the fstab file.  *sigh*.
#
my $options;
if ( $CONFIG{'fs'} eq "xfs" ) 
{
    $options = "defaults";
} 
else
{
    $options = "errors=remount-ro";
}


open( TAB, ">", $dir . "/etc/fstab" );
print TAB<<E_O_TAB;
/dev/sda1     /     $CONFIG{'fs'}     $options     0     1
/dev/sda2     none  swap     sw                    0     0
proc          /proc proc     defaults              0     0
E_O_TAB
close( TAB );

print "Done\n";


#
#  Setup the /etc/network/interfaces file upon the guest image
#
print "\n\nSetting up networking\n";
setupNetworking( $dir );
print "Done\n";


#
#  Install OpenSSH + any other required programs.
#
installImagePackages( $dir );


#
#  Cleanup the new image to make more space available to it.
#
cleanupNewImage( $dir );


#
#  Fixup Inittab file
#
print "\n\nSetting up initial console\n";
fixupInittab( $dir );
print "done\n";



#
#  Allow the sysadmin to create scripts to be executed
# post-install.
#
if ( -d $CONFIG{'hook_dir'} )
{
    print "Running hooks from : $CONFIG{'hook_dir'}\n";
    runHooks( $CONFIG{'hook_dir'}, $dir );
    print "Done\n";
}



#
#  Now unmount the image.
#
runCommand( "umount $dir" );


#
# Finally setup Xen to allow us to create the image.
#
print "\n\nCreating Xen configuration file in /etc/xen .. ";
open( XEN, ">", "/etc/xen/$CONFIG{'hostname'}.cfg" );
print XEN<<E_O_XEN;
kernel = "$CONFIG{'kernel'}"
memory = $CONFIG{'memory'}
name   = "$CONFIG{'hostname'}"
disk   = [ 'file:$image,sda1,w','file:$swap,sda2,w' ]
root   = "/dev/sda1 ro"
E_O_XEN
if ( $CONFIG{'dhcp'} )
{
    print XEN "dhcp=\"dhcp\"\n";
}
else
{
    print XEN "#dhcp=\"dhcp\"\n";
}
close( XEN );
print "Done\n";



#
#  Clear screen before printing success message, unless
# we're running under '--debug'.
#
$TERMINAL_HEIGHT *= 2;
while( $TERMINAL_HEIGHT )
{
    printWideMessage( "\n" ) unless $CONFIG{'debug'};
    $TERMINAL_HEIGHT -= 1;
}


#
#  Give status message
#
if ( $CONFIG{'boot'} )
{

    #
    #  Should we immediately start the new instance?
    #  If so fork() and do it so that we can return to the user, they can
    # attach to the console via the command : 'xm console $name'.
    #
    #
    print "\n\nBooting newly created virtual image: $CONFIG{'hostname'} in the background.\n";
    print "\nTo attach to the console run (as root):\n\n";
    print "\t\txm console $CONFIG{'hostname'}\n\n";
    print "\n";

    my $pid = fork();
    if ( $pid )
    {

	exit;
    }
    else
    {
	#
	#  Start Xen instance in our forked process.  Avoid annoying
	# output.
	#
	#
	system( "$CONFIG{'xm'} create $CONFIG{'hostname'}.cfg >/dev/null 2>/dev/null" );
    }
}
else
{
    print <<EOEND;

New Image Created
-----------------

  To make any manual tweaks to the setup of $CONFIG{'hostname'} please run:

    mkdir /mnt/tmp
    mount -t $CONFIG{'fs'} -o loop $image /mnt/tmp
    chroot /mnt/tmp /bin/bash

    # make your changes

    exit
    umount /mnt/tmp

 Once completed you may start your new instance of Xen with:

    xm create $CONFIG{'hostname'}.cfg -c

EOEND
}


#
#  End of script.
#
exit;



=head2 readConfigurationFile

  Read the configuration file specified.

=cut

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

    open( FILE, "<", $file ) or die "Cannot read file '$file' - $!";

    my $line       = ""; 

    while (defined($line = <FILE>) ) 
    {
        chomp $line;
	if ($line =~ s/\\$//) 
	{
	    $line .= <FILE>;
	    redo unless eof(FILE);
	}
      
	# Skip lines beginning with comments
	next if ( $line =~ /^([ \t]*)\#/ );

	# Skip blank lines
	next if ( length( $line ) < 1 );

	# Strip trailing comments.
	if ( $line =~ /(.*)\#(.*)/ )
	{
	    $line = $1;
	}

	# Find variable settings
	if ( $line =~ /([^=]+)=([^\n]+)/ )
	{
	    my $key = $1;
	    my $val = $2;

	    # Strip leading and trailing whitespace.
	    $key =~ s/^\s+//;
	    $key =~ s/\s+$//;
	    $val =~ s/^\s+//;
	    $val =~ s/\s+$//;
	    
	    # Store value.
	    $CONFIG{ $key } = $val;
	}
    }

    close( FILE );
}




=head2 parseCommandLineArguments

  Parse the arguments specified upon the command line.

=cut

sub parseCommandLineArguments
{
    my $HELP	= 0;
    my $MANUAL	= 0;
    my $VERSION	= 0;

    #  Parse options.
    #
    GetOptions(
	       "hostname=s",   \$CONFIG{'hostname'},
	       "ip=s",         \$CONFIG{'ip'},
	       "gateway=s",    \$CONFIG{'gateway'},
	       "netmask=s",    \$CONFIG{'netmask'},
	       "dir=s",        \$CONFIG{'dir'},
	       "dhcp",         \$CONFIG{'dhcp'},
	       "mirror=s",     \$CONFIG{'mirror'},
	       "size=s",       \$CONFIG{'size'},
	       "swap=s",       \$CONFIG{'swap'},
	       "memory=s",     \$CONFIG{'memory'},
	       "fs=s",         \$CONFIG{'fs'},
	       "boot",         \$CONFIG{'boot'},
	       "dist=s",       \$CONFIG{'dist'},
	       "debootstrap=s",\$CONFIG{'debootstrap'},
	       "debug" ,       \$CONFIG{'debug'},
	       "kernel=s",     \$CONFIG{'kernel'},
	       "help",         \$HELP,
	       "manual",       \$MANUAL,
	       "version",      \$VERSION
	      );
    
    pod2usage(1) if $HELP;
    pod2usage(-verbose => 2 ) if $MANUAL;


    if ( $VERSION )
    {
	my $REVISION      = '$Id: xen-create-image,v 1.62 2005-12-24 10:34:14 steve Exp $';
	$VERSION = join (' ', (split (' ', $REVISION))[2]);
	$VERSION =~ s/,v\b//;
	$VERSION =~ s/(\S+)$/$1/;

	print "xen-create-image release 0.5 - CVS: $VERSION\n";
	exit;
    }
}



=head2 checkArguments

  Check that the arguments the user has specified are complete and
 make sense.

=cut

sub checkArguments
{

    if (!defined( $CONFIG{'hostname'} ) )
    {
	print<<EOF

  You should set a hostname with '--hostname=foo'.

  This option is required.
EOF
      ;
	exit;
    }


    if (!defined( $CONFIG{'dir'} ) )
    {
	print<<EOF

  You should set an output directory with '--dir=/my/path'.

  This option is required.  Subdirectories will be created
 beneath the directory you name.

EOF
	  ;
	exit;
    }



    #
    #  Make sure the directory exists.
    #
    if ( ! -d $CONFIG{'dir'} )
    {
	print "Output directory '$CONFIG{'dir'}' doesn't exist\n";
	exit;
    }

    if ( ! -w $CONFIG{'dir'} )
    {
	print "Output directory '$CONFIG{'dir'}' isn't writable.\n";
	exit;
    }

    #
    #  Make sure we have every binary we need
    #
    if ( ! -x $CONFIG{'xm'} )
    {
	print "Could not find " .$CONFIG{'xm'}. ".\n";
	exit;
    }

    my $binpath = $FILESYSTEM_BINARY{lc( $CONFIG{'fs'} ) };
    if ( ! -x $binpath ) {
  	  print "Unable to find required executable ". $binpath. ".\n";
	  exit;
    }

    # 
    #  Make sure we have a valid size
    #
    if ( !(($CONFIG{'size'} =~ /^\d+[GM]b*$/i) && ($CONFIG{'swap'} =~ /^\d+[GM]b*$/i)) )
    {
        print "Invalid size formats.  Please use something like:\n";
	print " --size=128Mb\n";
	print " --size=2Gb\n";
        exit;
    }


    # Convert Gb -> Mb
    if ( $CONFIG{'size'} =~ /^(\d+)Gb*$/i )
    {
	$CONFIG{'size'} = $1 * 1024 . "M";
    }
    if ( $CONFIG{'swap'} =~ /^(\d+)Gb*$/i )
    {
	$CONFIG{'swap'} = $1 * 1024 . "M";
    }

    # Strip trailing Mb from the memory size.
    if ( $CONFIG{'memory'} =~ /^(\d+)Mb*$/i )
    {
	$CONFIG{'memory'} = $1;
    }


    #    
    #  Check mirror format
    #
    if (!($CONFIG{'mirror'} =~ /^http/i)) 
    {
	print "Please enter a valid mirror.\n";
	exit;
    }

    #
    #  Only one of DHCP / IP is required.
    #
    if ( $CONFIG{'ip'} && $CONFIG{'dhcp'})
    {
	print "You've chosen both DHCP and an IP address.\n";
	print "Only one is supported\n";
	exit;
    }

    if ( $CONFIG{'dhcp'} )
    {
	$CONFIG{'gateway'}   = '';
	$CONFIG{'netmask'}   = '';
	$CONFIG{'ip'}	     = '';
    }

    #
    #  Ensure we know how to create *and* mount the given filesystem.
    #
    if ( !defined( $FILESYSTEM_CREATE{lc( $CONFIG{'fs'} ) } ) ||
	 !defined( $FILESYSTEM_MOUNT{lc( $CONFIG{'fs'} ) } ) )
    {
	print "Unknown filesystem.  Valid choices are:\n";
	foreach my $key (sort keys %FILESYSTEM_MOUNT ) 
	{
	    print "\t" . $key . "\n";
	}
	exit;
    }
}



=head2 setupNetworking

  Setup the /etc/network/interfaces file, and the hostname 
 upon the virtual instance.

=cut

sub setupNetworking
{
    my ( $prefix ) = ( @_ );

    #
    #  Set the hostname.
    #
    open( HOSTNAME, ">", $prefix . "/etc/hostname" );
    print HOSTNAME $CONFIG{'hostname'} . "\n";
    close( HOSTNAME );

    #
    #  Set the networking optins.
    #
    open( IP, ">", $prefix . "/etc/network/interfaces" );
    if ( $CONFIG{'dhcp'} )
    {
	print IP<<E_O_DHCP;
# This file describes the network interfaces available on your system
# and how to activate them. For more information, see interfaces(5).

# The loopback network interface
auto lo
iface lo inet loopback
	    
# The primary network interface
auto eth0
iface eth0 inet dhcp

E_O_DHCP
    }
    else
    {
	print IP<<E_O_STATIC_IP;
# This file describes the network interfaces available on your system
# and how to activate them. For more information, see interfaces(5).

# The loopback network interface
auto lo
iface lo inet loopback
	    
# The primary network interface
auto eth0
iface eth0 inet static
 address $CONFIG{'ip'}
 gateway $CONFIG{'gateway'}
 netmask $CONFIG{'netmask'}

E_O_STATIC_IP
    }

    close( IP );
}



=head2 installImagePackages

  Install some basic packages upon the new image.  This will always
 include OpenSSH.  For specific filesystem images we will install
 different packages:

    xfs filesystem    -> Install xfsprogs
    reiser filesystem -> Install reiserfsprogs

=cut

sub installImagePackages
{
    my ( $prefix ) = ( @_ );

    print "\n\nInstalling OpenSSH into new system\n";
    runCommand( "chroot $prefix /usr/bin/apt-get update" );
    runCommand( "DEBIAN_FRONTEND=noninteractive chroot $prefix /usr/bin/apt-get --yes --force-yes install ssh" );
    runCommand( "chroot $prefix /etc/init.d/ssh stop" );
    print "Done\n";

    #
    #  Extra packages to install.
    #
    my $extra = "";

    if ( $CONFIG{'fs'} eq "xfs" ) 
    {
	$extra = "xfsprogs";
    } 
    elsif ( $CONFIG{'fs'} eq "reiserfs" ) 
    {
	$extra = "reiserfsprogs";
    }
 
    #
    # Install whatever we're supposed to.
    #
    if ( length( $extra ) )
    {
	print "\n\nInstalling package into new system: $extra\n";
    runCommand( "DEBIAN_FRONTEND=noninteractive chroot $prefix /usr/bin/apt-get --yes --force-yes install $extra" );
	print "Done\n";
    }

}




=head2 cleanupNewImage

  Remove the cached files downloaded via apt-get on the new image,
 to make more space available to the fresh image.

=cut

sub cleanupNewImage
{
    my ( $prefix ) = ( @_ );

    print "\n\nCleaning downloaded files on new system\n";
    runCommand( "chroot $prefix /usr/bin/apt-get clean" );
    print "Done\n";

}



=head2 fixupInittab

  Copy the host systems /etc/inittab to the virtual installation 
 making a couple of minor changes:

  1. Setup the first console to be "Linux".
  2. Disable all virtual consoles.

=cut 

sub fixupInittab
{
    my ( $prefix ) = ( @_ );


    my @init;
    open( INITTAB, "<", "/etc/inittab" );
    foreach my $line ( <INITTAB> )
    {
	chomp $line;
	if ( $line =~ /:respawn:/ )
	{
	    if ( $line =~ /^1/ )
	    {
		#
		# Leave line unchanged - but change 'tty1' to 'console'.
		#
		$line = '1:2345:respawn:/sbin/getty 38400 console';

		#
		# Reference:  
		#   http://wiki.xensource.com/xenwiki/DebianSarge
		#
	    }
	    else
	    {
		#
		# Otherwise comment out the line, we don't need multiple
		# terminals since we can only access one.
		#
		$line = "#" . $line;
	    }
	}
	push @init, $line;
    }
    close( INITTAB );
    
    
    open( OUTPUT, ">", "$prefix/etc/inittab" );
    foreach my $line ( @init )
    {
	print OUTPUT $line . "\n";
    }
    close( OUTPUT )
}



=head2 printWideMessage

  Print a message, ensuring the width is as wide as the console.

=cut

sub printWideMessage
{
    my ( $msg ) = ( @_ );

    while( length( $msg ) < $TERMINAL_WIDTH )
    {
	$msg .= " ";
    }
    print $msg;
}



=head2 runCommand

  Run a command, and if debugging is turned on then display it
 to the user along with output.

  Otherwise hide all output.

=cut

sub runCommand
{
    my ( $cmd ) = ( @_ );

    #
    #  Header.
    #
    $CONFIG{'debug'} && print "Executing : $cmd\n";

    #
    #  Hide output unless running with --debug.
    #
    $cmd .= " >/dev/null 2>/dev/null" unless $CONFIG{'debug'};

    #
    #  Run it.
    #
    my $output = `$cmd`;

    #
    # All done.
    #
    $CONFIG{'debug'} && print "Finished : $cmd\n";

    return( $output );
}



=head2 runCommandWithProgress

  Run a command whilst immediately writing the output to the console.

  This is a cheap hack to give a sense of 'progress'.

=cut

sub runCommandWithProgress 
{
    my ( $cmd ) = ( @_ );

    $CONFIG{'debug'} && print "Executing : $cmd\n";

    my $pid = open3(undef, \*READ,0, $cmd );

    #
    #  A failure to run debootstrap is pretty much fatal to us.
    #
    #  Since without it there will be no installed filesystem.
    #
    #  Abort, after unmounting the directory we're using.
    #
    if ( ! $pid )
    {
	print "Error executing command : '$cmd' - $!";
	runCommand( "umount $dir" );
	exit;
    }


    my $output ='';
    while(1)
    {
	#
	# Wait for input.
	#
	select(undef,undef,undef,.01);

	#
	# Read output from the command, max 1k.
	#
	if( sysread \*READ,$output,1024 )
	{
	    #
	    # Remove newlines to avoid weirdness.
	    $output =~ s/\n//g;

	    #
	    #  If there is more output than our terminal width then
	    # truncate it.
	    #
	    if ( length( $output ) > $TERMINAL_WIDTH )
	    {
	       $output = substr( $output, 0, ( $TERMINAL_WIDTH - 5 ) );
	    }

	    #
	    # Pad to exactly terminal width.
	    while( length( $output ) < $TERMINAL_WIDTH ) 
	    { 
		$output .= " " ; 
	    }
	    

	    #
	    # Now rewind cursor to start of line and display
	    # the text.
	    #
	    print STDERR "\r";
	    print STDERR $output;
	}
	else
	{
	    #
	    # command finished.
	    #
	    my $over = "\rFinished";
	    while( length( $over ) < $TERMINAL_WIDTH )
	    {
		$over .= " ";
	    }
	    print STDERR $over . "\n";
	    return;
	}
    }
}



=head2 getTerminalWidth

  Find and return the width of the current terminal.  This makes 
 use of the optional Term::Size module.  If it isn't installed then
 we fall back to using 80.

=cut


sub getTerminalSize
{

    my $testModule  = "use Term::Size;";

    my $width  = 80;
    my $height = 25;

    #
    #  Test loading the Cache module, if it fails then
    # the cache isn't enabled regardless of what the
    # configuration file says.
    #
    eval( $testModule );
    if ( $@ )
    {
    }
    else
    {
	($width, $height ) = Term::Size::chars();
    }

    return( $width, $height );
}



=head2 runHooks

  When the image has been created, but before the temporary image
 is unmounted there is the opportunity for a number of hooks to be
 run.

  Every script inside the directory /etc/xen-tools/xen-create-image.d/
 which is executable will be run in order.

  The scripts will be given a single argument which is the directory
 of the mounted disk image.

=cut

sub runHooks
{
    my ( $HOOK_DIR, $prefix ) = ( @_ );

    #
    # Make sure that our scripts run in sorted order, as
    # the user would expect.
    #
    foreach my $file ( sort( glob( $HOOK_DIR . "*" ) ) )
    {
	#
	# Only run executable files.
	#
	if ( ( -x $file ) && ( -f $file ) )
	{
	    print "Running hook: $file\n";
	    runCommand( $file . " " . $prefix . " " . $CONFIG{'hostname'} );
	    print "Done\n";
	}
    }
}