#!/usr/bin/perl -w

=head1 NAME

xen-duplicate-image - Duplicate an existing Xen instance.

=head1 SYNOPSIS

  xen-duplicate-image [options]

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

  General options:
   --boot     Boot the cloned image after creating it.
   --dir      Specify where the output images should go.
   --volume   Specify the LVM volume where images are to go.
   --ide      Use IDE names for virtual devices (hda not sda)

  Networking options:
   --dhcp     Setup the image to get its networking details via DHCP
   --gateway  Setup the gateway for the image.
   --ip       Setup the IP address for the image.
   --netmask  Setup the netmask the host should use.

  Mandatory options:

   --hostname Set the images hostname.
   --from     The image name we should copy

=cut



=head1 OPTIONS

=over 8

=item B<--boot>
Boot the new instance immediately after creating it.

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

=item B<--dir>
Specify where the output images should go.

=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<--ide>
Use IDE style device names for the virtual devices.

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

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

=item B<--netmask>
Setup the netmask the host should use.

=item B<--from>
Specify the virtual instance that we should copy.

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

=item B<--volume>
Specify the LVM volume where images are to go

=back

=cut


=head1 EXAMPLES

  The following will copy the existing image vm01, and
 save it as vm02, updating the networking details of the new
 image so that DHCP is enabled for network configuraion.

     xen-duplicate-image --dir=/home/xen \
        --from=vm01  --hostname=vm02.my.flat --dhcp

=cut


=head1 DESCRIPTION

  xen-duplicate-image is a simple script which allows you to create new
 Xen instances of Debian Sarge.  The new image will be an identical
 copy of an existing image.

=cut


=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 the configuratione file /etc/xen-tools/xen-tools.conf
 for options.

  The files may contain comments, which begin with the hash '#' character
 and are otherwise of the format 'key = value.  A more detailed description
 may be found in the manpage for the script 'xen-create-image'.

=cut


=head1 AUTHOR


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

 $Id: xen-duplicate-image,v 1.35 2006-06-09 09:27:33 steve Exp $

=cut


=head1 CONTRIBUTORS

  Contributors to this code:

=over 8

=item  Radu Spineanu

=back



=head1 LICENSE

Copyright (c) 2005-2006 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 Pod::Usage;



#
#  Configuration options, initially read from the configuration files
# but may be overridden by the command line.
#
#  Command line flags *always* take precedence over the configuration file.
#
my %CONFIG;

#
# Release number.
#
my $RELEASE = '1.6';


#
#  Defaults
#
$CONFIG{'xm'} 		= '/usr/sbin/xm';


#
#  Read the global configuration file if it exists.
#
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 "\n";
print "Source      :  $CONFIG{'from'}\n";
print "Destination :  $CONFIG{'hostname'}\n";

if ( $CONFIG{'dhcp'} )
{
    print "DHCP\n";
}
else
{
   $CONFIG{'ip'}        && print "IP       : $CONFIG{'ip'}\n";
   $CONFIG{'gateway'}   && print "Gateway  : $CONFIG{'gateway'}\n";
   $CONFIG{'netmask'}   && print "Gateway  : $CONFIG{'netmask'}\n";
}
print "---\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_in = $CONFIG{'dir'} .'/domains/'. $CONFIG{'from'} . "/disk.img" ;
my $image_out= $CONFIG{'dir'}.'/domains/'. $CONFIG{'hostname'} . "/disk.img" ;

my $swap_in  = $CONFIG{'dir'} .'/domains/' .$CONFIG{'from'} . "/swap.img" ;
my $swap_out = $CONFIG{'dir'} .'/domains/' .$CONFIG{'hostname'} . "/swap.img" ;


#
#  Copy the swap file, and disk images.
#
print "Copying swapfile ...\n";
File::Copy::cp( $swap_in,  $swap_out );
print "done\n";

print "Copying disk image ...\n";
File::Copy::cp( $image_in, $image_out );
print "done\n";

#
#  Now mount the image, in a secure temporary location.
#

my $dir = tempdir( CLEANUP => 1 );
my $mount_cmd = "mount -t auto -o loop $image_out $dir";
`$mount_cmd`;


# Test that the mount worked

my $mount = `/bin/mount`;

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

#
#  Setup the output directories for the configuration files here - note
# that this should already exist.
#
`mkdir -p $dir/etc/apt`;
`mkdir -p $dir/etc/network`;


#
#  Setup the /etc/network/interfaces file upon the guest image
#
setupNetworking( $dir );


#
#  Now unmount the image.
#
`umount $dir`;


#
# Finally setup Xen to allow us to create the image.
#
if ( -x "/etc/xen-tools/hook.d/95-create-cfg" )
{
    print "Setting up Xen configuration file .. ";

    #
    #  Setup environment for child hook
    #
    foreach my $key ( keys %CONFIG )
    {
	if ( defined( $CONFIG{$key} ) )
	{
	    $ENV{$key} = $CONFIG{$key};
	}
    }
    $ENV{'imagevbd'} = "file:" . $image_out;
    $ENV{'swapvbd'}  = "file:" . $swap_out;

    `/etc/xen-tools/hook.d/95-create-cfg`;
}
else
{
    print "Failed to setup Xen configuration file .. ";
}
print "Done\n";



#
#  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'.
#
#
if ( $CONFIG{'boot'} )
{
    my $pid = fork();
    if ( $pid )
    {
	exit;
    }
    else
    {
	system( "$CONFIG{'xm'} create $CONFIG{'hostname'}.cfg >/dev/null 2>/dev/null" );
    }
}


#
#  End of the 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'},
	       "from=s",     \$CONFIG{'from'},
	       "ip=s",       \$CONFIG{'ip'},
	       "gateway=s",  \$CONFIG{'gateway'},
	       "netmask=s",  \$CONFIG{'netmask'},
	       "dir=s",      \$CONFIG{'dir'},
	       "volume=s",   \$CONFIG{'volume'},
	       "kernel=s",   \$CONFIG{'kernel'},
	       "dhcp",       \$CONFIG{'dhcp'},
               "ide",        \$CONFIG{'ide'},
	       "help",       \$HELP,
	       "manual",     \$MANUAL,
	       "version",    \$VERSION
	      );

    pod2usage(1) if $HELP;
    pod2usage(-verbose => 2 ) if $MANUAL;


    if ( $VERSION )
    {
	my $REVISION      = '$Revision: 1.35 $';

	if ( $REVISION =~ /1.([0-9.]+) / )
	{
	    $REVISION = $1;
	}

	print "xen-duplicate-image release $RELEASE - CVS: $REVISION\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{'from'} ) )
    {
        print<<EOF

  You should set a source with '--from=bar'.

  This option is required.
EOF
      ;
        exit;

    }


    #
    #  Make sure we have either a volume, or a root.
    #
    if ( $CONFIG{'volume'} && $CONFIG{'dir'} )
    {
	print "Please only use a volume or a directory name - not both\n";
	exit;
    }


    #
    # Volumes are not supported yet :(
    #
    if ( $CONFIG{'volume'} )
    {
	print "LVM Volumes are not supported yet\n";
	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 we have every binary we need
    #
    if ( ! -x $CONFIG{'xm'} )
    {
        print "Could not find " .$CONFIG{'xm'}. ".\n";
        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 the source image we're copying exists.
    #
    my $source = $CONFIG{'dir'} . "/domains/" . $CONFIG{'from'} . "/disk.img";
    if ( ! -e $source )
    {
	print "The source image you've specified doesn't exist";
	exit;
    }


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

    #
    #  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 we're using DHCP then the other networking options should
    # be unsent.
    #
    if ( $CONFIG{'dhcp'} )
    {
	$CONFIG{'gateway'}   = '';
	$CONFIG{'netmask'}   = '';
	$CONFIG{'ip'}	     = '';
    }
}



=head2 setupNetworking

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

=cut

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

    `echo '$CONFIG{'hostname'}' > $prefix/etc/hostname`;

    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 );
}