diff -aruN xen-tools-export/Build.PL xen-tools-merge/Build.PL --- xen-tools-export/Build.PL 1970-01-01 00:00:00.000000000 +0000 +++ xen-tools-merge/Build.PL 2007-09-03 18:31:16.000000000 +0000 @@ -0,0 +1,19 @@ +use strict; +use warnings; +use Module::Build; + +my $builder = Module::Build->new( + module_name => 'Xen::Tools', + license => 'perl', + dist_author => 'Steve Kemp ', + dist_version_from => 'lib/Xen/Tools.pm', + build_requires => { + 'Test::More' => 0, + 'Moose' => '0.17', + }, + add_to_cleanup => [ 'Xen-Tools-*' ], +# This breaks Steve's build system +# create_makefile_pl => 'traditional', +); + +$builder->create_build_script(); diff -aruN xen-tools-export/MANIFEST xen-tools-merge/MANIFEST --- xen-tools-export/MANIFEST 1970-01-01 00:00:00.000000000 +0000 +++ xen-tools-merge/MANIFEST 2007-09-03 19:18:19.000000000 +0000 @@ -0,0 +1,181 @@ +META.yml # Will be created by "make dist" +.cvsignore +.release +AUTHORS +BUGS +Build.PL +LICENSE +MANIFEST +README +SUPPORT +TODO +bin/xen-create-image +bin/xen-create-nfs +bin/xen-delete-image +bin/xen-list-images +bin/xen-update-image +bin/xt-create-xen-config +bin/xt-customize-image +bin/xt-install-image +debian/.cvsignore +debian/README.Debian +debian/changelog +debian/compat +debian/control +debian/copyright +debian/dirs +debian/docs +debian/examples/setup-kernel-initrd +debian/examples/update-modules +debian/postinst +debian/preinst +debian/rules +debian/watch +etc/xen-tools.conf +etc/xm-nfs.tmpl +etc/xm.tmpl +hooks/README +hooks/centos-4/10-disable-tls +hooks/centos-4/20-setup-yum +hooks/centos-4/30-disable-gettys +hooks/centos-4/35-setup-users +hooks/centos-4/40-setup-networking +hooks/centos-4/50-setup-hostname +hooks/centos-4/55-create-dev +hooks/centos-4/60-copy-host-files +hooks/centos-4/65-copy-user-files +hooks/centos-4/70-install-ssh +hooks/centos-4/80-install-modules +hooks/centos-4/90-make-fstab +hooks/centos-4/99-clean-image +hooks/centos-5/10-disable-tls +hooks/centos-5/20-setup-yum +hooks/centos-5/30-disable-gettys +hooks/centos-5/35-setup-users +hooks/centos-5/40-setup-networking +hooks/centos-5/50-setup-hostname +hooks/centos-5/55-create-dev +hooks/centos-5/60-copy-host-files +hooks/centos-5/65-copy-user-files +hooks/centos-5/70-install-ssh +hooks/centos-5/80-install-modules +hooks/centos-5/90-make-fstab +hooks/centos-5/99-clean-image +hooks/common.sh +hooks/dapper/01-disable-daemons +hooks/dapper/05-shadowconfig-on +hooks/dapper/10-disable-tls +hooks/dapper/15-disable-hwclock +hooks/dapper/20-setup-apt +hooks/dapper/25-generate-locale +hooks/dapper/30-disable-gettys +hooks/dapper/35-setup-users +hooks/dapper/40-setup-networking +hooks/dapper/50-setup-hostname +hooks/dapper/55-create-dev +hooks/dapper/60-copy-host-files +hooks/dapper/65-copy-user-files +hooks/dapper/70-install-ssh +hooks/dapper/80-install-modules +hooks/dapper/90-make-fstab +hooks/dapper/99-clean-image +hooks/dapper/99-enable-daemons +hooks/debian/01-disable-daemons +hooks/debian/05-shadowconfig-on +hooks/debian/15-disable-hwclock +hooks/debian/20-setup-apt +hooks/debian/30-disable-gettys +hooks/debian/35-setup-users +hooks/debian/40-setup-networking +hooks/debian/50-setup-hostname +hooks/debian/55-create-dev +hooks/debian/60-copy-host-files +hooks/debian/65-copy-user-files +hooks/debian/70-install-ssh +hooks/debian/80-install-modules +hooks/debian/90-make-fstab +hooks/debian/95-configure-locales +hooks/debian/99-clean-image +hooks/debian/99-enable-daemons +hooks/edgy/01-disable-daemons +hooks/edgy/05-shadowconfig-on +hooks/edgy/15-disable-hwclock +hooks/edgy/20-setup-apt +hooks/edgy/25-generate-locale +hooks/edgy/30-disable-gettys +hooks/edgy/35-setup-users +hooks/edgy/40-setup-networking +hooks/edgy/50-setup-hostname +hooks/edgy/60-copy-host-files +hooks/edgy/65-copy-user-files +hooks/edgy/70-install-ssh +hooks/edgy/80-install-modules +hooks/edgy/90-make-fstab +hooks/edgy/99-clean-image +hooks/edgy/99-enable-daemons +hooks/fedora-core-6/10-disable-tls +hooks/fedora-core-6/20-setup-yum +hooks/fedora-core-6/30-disable-gettys +hooks/fedora-core-6/35-setup-users +hooks/fedora-core-6/40-setup-networking +hooks/fedora-core-6/50-setup-hostname +hooks/fedora-core-6/55-create-dev +hooks/fedora-core-6/60-copy-host-files +hooks/fedora-core-6/65-copy-user-files +hooks/fedora-core-6/70-install-ssh +hooks/fedora-core-6/80-install-modules +hooks/fedora-core-6/90-make-fstab +hooks/fedora-core-6/99-clean-image +hooks/gentoo/10-disable-tls +hooks/gentoo/20-enable-su +hooks/gentoo/30-disable-gettys +hooks/gentoo/35-setup-users +hooks/gentoo/40-setup-networking +hooks/gentoo/50-setup-hostname +hooks/gentoo/55-create-dev +hooks/gentoo/60-copy-host-files +hooks/gentoo/65-copy-user-files +hooks/gentoo/70-install-ssh +hooks/gentoo/80-install-modules +hooks/gentoo/90-make-fstab +lib/Xen/Tools.pm +lib/Xen/Tools/Log.pm +man/.cvsignore +misc/README +misc/xen-tools +misc/xen-tools.spec +misc/xm +partitions/sample-server +roles/builder +roles/cfengine +roles/gdm +roles/minimal +roles/passwd +roles/udev +roles/xdm +t/00-load.t +t/Makefile +t/argument-check.t +t/getopt.t +t/hook-daemons.t +t/hook-hostname.t +t/hook-inittab.t +t/hook-tls.t +t/hooks.t +t/modules.sh +t/modules.t +t/no-tabs.t +t/perl-syntax.t +t/plugin-checks.t +t/pod-check.t +t/pod-coverage.t +t/pod.t +t/portable-shell.t +t/programs.t +t/shell-syntax.t +t/test-trailing-whitespace.t +t/xen-delete-image.t +t/xen-lists-images.t +t/xen-tools-log.t +t/xen-tools.t +t/xt-create-xen-config.t diff -aruN xen-tools-export/META.yml xen-tools-merge/META.yml --- xen-tools-export/META.yml 1970-01-01 00:00:00.000000000 +0000 +++ xen-tools-merge/META.yml 2007-09-03 18:59:39.000000000 +0000 @@ -0,0 +1,23 @@ +--- +name: Xen-Tools +version: 0.01 +author: + - 'Steve Kemp ' +abstract: Build Xen domains with Perl +license: perl +resources: + license: http://dev.perl.org/licenses/ +build_requires: + Moose: 0.17 + Test::More: 0 +provides: + Xen::Tools: + file: lib/Xen/Tools.pm + version: 0.01 + Xen::Tools::Log: + file: lib/Xen/Tools/Log.pm + version: 0.01 +generated_by: Module::Build version 0.2808 +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.2.html + version: 1.2 diff -aruN xen-tools-export/bin/xen-create-image xen-tools-merge/bin/xen-create-image --- xen-tools-export/bin/xen-create-image 2007-08-11 18:24:08.000000000 +0000 +++ xen-tools-merge/bin/xen-create-image 2007-09-03 19:17:49.000000000 +0000 @@ -621,6 +621,7 @@ use Getopt::Long; use Pod::Usage; +use Xen::Tools; # # Configuration values read initially from the global configuration @@ -684,6 +685,7 @@ # parseCommandLineArguments(); +my $xt = Xen::Tools->new( hostname => $CONFIG{hostname} ); # # If we received an additional configuration file then read it. @@ -705,8 +707,9 @@ } else { - logprint( "The specified configuration file does not exist: '$path'\n" ); - logprint( "Aborting\n\n" ); + $xt->log( "The specified configuration file does not exist: '$path'\n", + "Aborting\n\n" + ); exit; } } @@ -807,8 +810,9 @@ else { # Can't happen we didn't get an installation type. - logprint( "Error: No recognised installation type.\n" ); - logprint( "Please specify a directory, lvm, or evms volume to use.\n"); + $xt->log( "Error: No recognised installation type.\n", + "Please specify a directory, lvm, or evms volume to use.\n" + ); $FAIL = 1; exit; } @@ -847,7 +851,7 @@ # if ( ! -x $MOUNT_POINT . "/bin/ls" ) { - logprint( "System installation failed. Aborting\n"); + $xt->log( "System installation failed. Aborting\n"); $FAIL = 1; exit; } @@ -886,7 +890,7 @@ # # Report success. # -logprint( "All done\n"); +$xt->log( "All done\n"); # @@ -915,7 +919,7 @@ if ( ( -d "/etc/xen/auto" ) && ( ! -e "/etc/xen/auto/$CONFIG{'hostname'}.cfg" ) ) { - logprint( "Creating auto-start symlink\n" ); + $xt->log( "Creating auto-start symlink\n" ); my $link = "ln -s /etc/xen/$CONFIG{'hostname'}.cfg /etc/xen/auto/"; runCommand( $link ); @@ -937,7 +941,7 @@ # Child. system( "$CONFIG{'xm'} create $CONFIG{'hostname'}.cfg >/dev/null 2>/dev/null" ); - logprint( "Started new Xen guest: $CONFIG{'hostname'}\n" ); + $xt->log( "Started new Xen guest: $CONFIG{'hostname'}\n" ); } } @@ -969,8 +973,9 @@ { if ( ! defined( findBinary( $bin ) ) ) { - logprint("The script '$bin' was not found.\n"); - logprint( "Aborting\n\n" ); + $xt->log("The script '$bin' was not found.\n", + "Aborting\n\n" + ); exit; } } @@ -1338,10 +1343,13 @@ # # NOTE: We set the local variable here, not the global. # - "copy-cmd=s", \$CONFIG{'copy-cmd'}, # NOP - IGNORED. + # Next 3 fields: NOP - IGNORED. + "copy-cmd=s", \$CONFIG{'copy-cmd'}, + "debootstrap-cmd=s", \$CONFIG{'debootstrap-cmd'}, + "tar-cmd=s", \$CONFIG{'tar-cmd'}, + "install-method=s", \$CONFIG{'install-method'}, "install-source=s", \$CONFIG{'install-source'}, - "tar-cmd=s", \$CONFIG{'tar-cmd'}, # NOP - IGNORED. # Misc. options "accounts", \$CONFIG{'accounts'}, @@ -1383,7 +1391,7 @@ $REVISION = $1; } - logprint( "xen-create-image release $RELEASE - CVS: $REVISION\n" ); + $xt->log( "xen-create-image release $RELEASE - CVS: $REVISION\n" ); exit; } @@ -1449,7 +1457,7 @@ E_O_ROOT - logprint( $err ); + $xt->log( $err ); exit; } } @@ -1476,7 +1484,7 @@ # if ( ! defined( $CONFIG{'dist'} ) ) { - logprint( "The '--dist' argument is mandatory\n" ); + $xt->log( "The '--dist' argument is mandatory\n" ); exit 1; } @@ -1485,7 +1493,7 @@ # if ( ! defined( $CONFIG{'hostname'} ) ) { - logprint( "The '--hostname' argument is mandatory.\n" ); + $xt->log( "The '--hostname' argument is mandatory.\n" ); exit 1; } @@ -1520,7 +1528,7 @@ Aborting. E_OR - logprint( $err ); + $xt->log( $err ); exit 1; } @@ -1533,7 +1541,7 @@ if ( ( $CONFIG{'image'} ne "sparse" ) && ( $CONFIG{'image'} ne "full" ) ) { - logprint( "Image type must be 'sparse' or 'full'\n" ); + $xt->log( "Image type must be 'sparse' or 'full'\n" ); exit; } } @@ -1612,7 +1620,7 @@ { # failed to find either by fully qualified path, # or inside /etc/xen-tools. - logprint( "The specified template file, $CONFIG{'template'}, does not exist.\n" ); + $xt->log( "The specified template file, $CONFIG{'template'}, does not exist.\n" ); exit 1; } } @@ -1625,7 +1633,7 @@ { if ( ! -d $CONFIG{'roledir'} ) { - logprint( "The specified role directory '$CONFIG{'roledir'}' does not exist\n" ); + $xt->log( "The specified role directory '$CONFIG{'roledir'}' does not exist\n" ); exit 1; } } @@ -1638,7 +1646,7 @@ { if ( ! -d $CONFIG{'partitionsdir'} ) { - logprint( "The specified partitions directory '$CONFIG{'partitionsdir'}' does not exist\n" ); + $xt->log( "The specified partitions directory '$CONFIG{'partitionsdir'}' does not exist\n" ); exit 1; } } @@ -1657,7 +1665,7 @@ if ( ! -e $CONFIG{'partitions'} ) { - logprint( "The specified partitions file, $CONFIG{'partitions'}, does not exist.\n" ); + $xt->log( "The specified partitions file, $CONFIG{'partitions'}, does not exist.\n" ); exit 1; } @@ -1666,19 +1674,19 @@ if ( $CONFIG{'swap-dev'} && $CONFIG{'noswap'} ) { - logprint( "Please choose either swap-dev or noswap, not both!\n" ); + $xt->log( "Please choose either swap-dev or noswap, not both!\n" ); exit 1; } if ( $CONFIG{'swap-dev'} && $CONFIG{'partitions'} ) { - logprint( "Please choose either swap-dev or partitions, not both!\n" ); + $xt->log( "Please choose either swap-dev or partitions, not both!\n" ); exit 1; } if ( $CONFIG{'image-dev'} && $CONFIG{'partitions'} ) { - logprint( "Please choose either image-dev or partitions, not both!\n" ); + $xt->log( "Please choose either image-dev or partitions, not both!\n" ); exit 1; } @@ -1698,7 +1706,7 @@ } else { - logprint( "Please choose either DHCP or static usage, not both!\n" ); + $xt->log( "Please choose either DHCP or static usage, not both!\n" ); exit 1; } } @@ -1708,9 +1716,9 @@ # if ( ( !$CONFIG{'dhcp'} ) && ( !$CONFIG{'ip'} ) ) { - logprint( "Please choose one of:\n" ); - logprint( " --dhcp\n" ); - logprint( " --ip xx.xx.xx.xx\n" ); + $xt->log( "Please choose one of:\n" ); + $xt->log( " --dhcp\n" ); + $xt->log( " --ip xx.xx.xx.xx\n" ); exit 1; } @@ -1720,10 +1728,10 @@ # if ( $CONFIG{'ip'} ) { - logprint( "WARNING: No gateway address specified!\n" ) + $xt->log( "WARNING: No gateway address specified!\n" ) unless( defined( $CONFIG{'gateway'} ) ); - logprint( "WARNING: No netmaks address specified!\n" ) + $xt->log( "WARNING: No netmaks address specified!\n" ) unless( defined( $CONFIG{'netmask'} ) ); } @@ -1840,8 +1848,8 @@ { if ( ! defined( findBinary( $file ) ) ) { - logprint( "The following binary is required to run this tool\n" ); - logprint( "\t$file\n"); + $xt->log( "The following binary is required to run this tool\n" ); + $xt->log( "\t$file\n"); exit 1; } } @@ -1854,9 +1862,9 @@ # loopback image if ( ! defined( findBinary( "dd" ) ) ) { - logprint( "The following binary is required to run this tool\n" ); - logprint( "\tdd\n"); - logprint( "(This only required for loopback images, which you've selected)\n" ); + $xt->log( "The following binary is required to run this tool\n" ); + $xt->log( "\tdd\n"); + $xt->log( "(This only required for loopback images, which you've selected)\n" ); exit 1; } } @@ -1871,9 +1879,9 @@ { if ( ! defined( findBinary( $file ) ) ) { - logprint( "The following binary is required to run this tool\n"); - logprint( "\t$file\n" ); - logprint( "(This is only required for EVMS volumes, which you've selected)\n" ); + $xt->log( "The following binary is required to run this tool\n"); + $xt->log( "\t$file\n" ); + $xt->log( "(This is only required for EVMS volumes, which you've selected)\n" ); exit; } } @@ -1887,9 +1895,9 @@ { if ( !defined( findBinary( $file ) ) ) { - logprint( "The following binary is required to run this tool\n"); - logprint( "\t$file\n" ); - logprint( "(This is only required for LVM volumes, which you've selected)\n" ); + $xt->log( "The following binary is required to run this tool\n"); + $xt->log( "\t$file\n" ); + $xt->log( "(This is only required for LVM volumes, which you've selected)\n" ); exit; } } @@ -1953,14 +1961,14 @@ { if ( ! ( $name =~ /^[a-zA-Z0-9-]+$/ ) ) { - logprint( "The partition name $name contains invalid characters.\n" ); - logprint( "Only alphanumeric characters and the hyphen are allowed\n" ); + $xt->log( "The partition name $name contains invalid characters.\n" ); + $xt->log( "Only alphanumeric characters and the hyphen are allowed\n" ); exit 1; } if ( ! ( $details->{'size'} =~ /^[0-9.]+[GgMmKk]b?$/ ) ) { - logprint( "The size $details->{'size'} of partition $name contains is not recognized.\n" ); + $xt->log( "The size $details->{'size'} of partition $name contains is not recognized.\n" ); exit 1; } @@ -1976,19 +1984,19 @@ { if ( ! $CONFIG{ 'make_fs_' . $details->{'type'} } ) { - logprint( "The type $details->{'type'} of partition $name is not recognized.\n" ); + $xt->log( "The type $details->{'type'} of partition $name is not recognized.\n" ); exit 1; } if ( ! ( $details->{'mountpoint'} =~ /^\/[^: \t\r\n]*$/ ) ) { - logprint( "The mount point $details->{'mountpoint'} of partition $name is invalid.\n" ); + $xt->log( "The mount point $details->{'mountpoint'} of partition $name is invalid.\n" ); exit 1; } if ( ! ( $details->{'options'} =~ /^[^: \t\r\n]*$/ ) ) { - logprint( "The mount options $details->{'options'} of partition $name are invalid.\n" ); + $xt->log( "The mount options $details->{'options'} of partition $name are invalid.\n" ); exit 1; } @@ -2016,7 +2024,7 @@ if ( ! $foundroot ) { - logprint( "The root partition was not specified.\n" ); + $xt->log( "The root partition was not specified.\n" ); exit 1; } @@ -2128,58 +2136,58 @@ # # Show the user what to expect. # - logprint( "\nGeneral Information\n" ); - logprint( "--------------------\n" ); - logprint( "Hostname : $CONFIG{'hostname'}\n" ); - logprint( "Distribution : $CONFIG{'dist'}\n" ); + $xt->log( "\nGeneral Information\n" ); + $xt->log( "--------------------\n" ); + $xt->log( "Hostname : $CONFIG{'hostname'}\n" ); + $xt->log( "Distribution : $CONFIG{'dist'}\n" ); if ( defined $CONFIG{'image-dev'} ) { - logprint( "Root Device : $CONFIG{'image-dev'}\n" ); + $xt->log( "Root Device : $CONFIG{'image-dev'}\n" ); } if ( defined $CONFIG{'swap-dev'} ) { - logprint( "Swap Device : $CONFIG{'swap-dev'}\n" ); + $xt->log( "Swap Device : $CONFIG{'swap-dev'}\n" ); } my $info; my $partcount = 0; - logprint( "Partitions : " ); + $xt->log( "Partitions : " ); foreach my $partition ( @PARTITIONS ) { $info = sprintf('%-15s %-5s (%s)', ($partition->{'type'} ne 'swap') ? $partition->{'mountpoint'} : 'swap', $partition->{'size'}, $partition->{'type'}); if ($partcount++) { - logprint( " $info\n" ); + $xt->log( " $info\n" ); } else { - logprint( "$info\n" ); + $xt->log( "$info\n" ); } } - logprint( "Image type : $CONFIG{'image'}\n" ); - logprint( "Memory size : $CONFIG{'memory'}\n" ); + $xt->log( "Image type : $CONFIG{'image'}\n" ); + $xt->log( "Memory size : $CONFIG{'memory'}\n" ); if ( defined( $CONFIG{'kernel'} ) && length( $CONFIG{'kernel'} ) ) { - logprint( "Kernel path : $CONFIG{'kernel'}\n" ); + $xt->log( "Kernel path : $CONFIG{'kernel'}\n" ); } if ( defined( $CONFIG{'modules'} ) && length( $CONFIG{'modules'} ) ) { - logprint( "Module path : $CONFIG{'modules'}\n" ); + $xt->log( "Module path : $CONFIG{'modules'}\n" ); } if ( defined( $CONFIG{'initrd'} ) && length( $CONFIG{'initrd'} ) ) { - logprint( "Initrd path : $CONFIG{'initrd'}\n" ); + $xt->log( "Initrd path : $CONFIG{'initrd'}\n" ); } - logprint( "\nNetworking Information\n" ); - logprint( "----------------------\n" ); + $xt->log( "\nNetworking Information\n" ); + $xt->log( "----------------------\n" ); # # Show each IP address added. @@ -2245,28 +2253,28 @@ if ( $i =~ /^([0-9]+)\.([0-9]+)\.([0-9]+)\.([0-9]+)$/ ) { # NOP - $CONFIG{'verbose'} && logprint( "IP address is complete: $i\n" ); + $CONFIG{'verbose'} && $xt->log( "IP address is complete: $i\n" ); } elsif ( $i =~ /^([0-9]+)\.([0-9]+)\.([0-9]+)\.$/ ) { $CONFIG{'verbose'} && - logprint( "Automatically determining the last octet for: $i\n" ); + $xt->log( "Automatically determining the last octet for: $i\n" ); $i = findNextIP( $i ); - $CONFIG{'verbose'} && logprint( "Found $i\n" ); + $CONFIG{'verbose'} && $xt->log( "Found $i\n" ); } # # Show the IP address. # - logprint( "IP Address $count : $i" ); + $xt->log( "IP Address $count : $i" ); # Option MAC address. if ( defined( $m ) ) { - logprint( " [MAC: $m]" ); + $xt->log( " [MAC: $m]" ); } - logprint( "\n" ); + $xt->log( "\n" ); $count += 1; } @@ -2280,18 +2288,18 @@ { if ( defined( $CONFIG{'mac'} ) ) { - logprint( "IP Address : DHCP [MAC: $CONFIG{'mac'}]\n" ); + $xt->log( "IP Address : DHCP [MAC: $CONFIG{'mac'}]\n" ); } else { - logprint( "IP Address : DHCP\n" ); + $xt->log( "IP Address : DHCP\n" ); } } - $CONFIG{'netmask'} && logprint( "Netmask : $CONFIG{'netmask'}\n" ); - $CONFIG{'broadcast'} && logprint( "Broadcast : $CONFIG{'broadcast'}\n" ); - $CONFIG{'gateway'} && logprint( "Gateway : $CONFIG{'gateway'}\n" ); - $CONFIG{'p2p'} && logprint( "Point to Point : $CONFIG{'p2p'}\n" ); + $CONFIG{'netmask'} && $xt->log( "Netmask : $CONFIG{'netmask'}\n" ); + $CONFIG{'broadcast'} && $xt->log( "Broadcast : $CONFIG{'broadcast'}\n" ); + $CONFIG{'gateway'} && $xt->log( "Gateway : $CONFIG{'gateway'}\n" ); + $CONFIG{'p2p'} && $xt->log( "Point to Point : $CONFIG{'p2p'}\n" ); print "\n"; } @@ -2316,11 +2324,11 @@ if ( $modules !~ m/loop/ ) { - logprint( "WARNING\n" ); - logprint( "-------\n" ); - logprint( "Loopback module not loaded and you're using loopback images\n" ); - logprint( "Run the following to load the module:\n\n" ); - logprint( "modprobe loop loop_max=255\n\n" ); + $xt->log( "WARNING\n" ); + $xt->log( "-------\n" ); + $xt->log( "Loopback module not loaded and you're using loopback images\n" ); + $xt->log( "Run the following to load the module:\n\n" ); + $xt->log( "modprobe loop loop_max=255\n\n" ); } } } @@ -2373,9 +2381,9 @@ if ( -e $disk ) { - logprint( "The partition image already exists. Aborting.\n" ); - logprint( "Specify '--force' to overwrite, or remove the following file\n" ); - logprint( $disk . "\n" ); + $xt->log( "The partition image already exists. Aborting.\n" ); + $xt->log( "Specify '--force' to overwrite, or remove the following file\n" ); + $xt->log( $disk . "\n" ); exit; } } @@ -2413,26 +2421,26 @@ # # Use dd to create the partition image. # - logprint( "\nCreating partition image: $disk\n" ); + $xt->log( "\nCreating partition image: $disk\n" ); my $image_cmd; if ( $CONFIG{'image'} eq "sparse" ) { - $CONFIG{'verbose'} && logprint( "Creating sparse image\n" ); + $CONFIG{'verbose'} && $xt->log( "Creating sparse image\n" ); $image_cmd = "dd if=/dev/zero of=$disk bs=$size count=0 seek=1024"; } else { - $CONFIG{'verbose'} && logprint( "Creating full-sized image\n" ); + $CONFIG{'verbose'} && $xt->log( "Creating full-sized image\n" ); $image_cmd = "dd if=/dev/zero of=$disk bs=$size count=1024"; } runCommand( $image_cmd ); - logprint( "Done\n" ); + $xt->log( "Done\n" ); if ( ! -e $disk ) { - logprint( "The partition image creation failed to create $disk.\n" ); - logprint( "aborting\n" ); + $xt->log( "The partition image creation failed to create $disk.\n" ); + $xt->log( "aborting\n" ); exit; } @@ -2477,8 +2485,8 @@ if (! -e $swap_img ) { - logprint( "The physical device or logical volume for swap-dev $swap_img doesn't exist. Aborting.\n" ); - logprint( "NOTE: Please provide full path to your physical device or logical volume.\n" ); + $xt->log( "The physical device or logical volume for swap-dev $swap_img doesn't exist. Aborting.\n" ); + $xt->log( "NOTE: Please provide full path to your physical device or logical volume.\n" ); exit; } @@ -2500,7 +2508,7 @@ } else { - logprint( "No image-dev parameter given. Aborting.\n" ); + $xt->log( "No image-dev parameter given. Aborting.\n" ); exit; } @@ -2535,13 +2543,13 @@ # Delete if forcing if ( $CONFIG{'force'} ) { - logprint( "Removing $lvm_disk - since we're forcing the install\n" ); + $xt->log( "Removing $lvm_disk - since we're forcing the install\n" ); runCommand( "lvremove --force $lvm_disk" ); } else { - logprint( "The LVM disk image already exists. Aborting.\n" ); - logprint( "Specify '--force' to delete and recreate\n" ); + $xt->log( "The LVM disk image already exists. Aborting.\n" ); + $xt->log( "Specify '--force' to delete and recreate\n" ); exit; } } @@ -2573,8 +2581,8 @@ # if ( ! -e $lvm_disk ) { - logprint( "The LVM partition image creation failed to create $lvm_disk.\n" ); - logprint( "aborting\n" ); + $xt->log( "The LVM partition image creation failed to create $lvm_disk.\n" ); + $xt->log( "aborting\n" ); exit; } @@ -2622,13 +2630,13 @@ # Delete if forcing if ( $CONFIG{'force'} ) { - logprint( "Removing $evms_volume_disk - since we're forcing the install\n" ); + $xt->log( "Removing $evms_volume_disk - since we're forcing the install\n" ); runCommand( "echo Delete : $evms_volume_disk | evms" ); } else { - logprint( "The EVMS volume $evms_volume_disk already exists. Aborting.\n" ); - logprint( "Specify '--force' to delete and recreate\n" ); + $xt->log( "The EVMS volume $evms_volume_disk already exists. Aborting.\n" ); + $xt->log( "Specify '--force' to delete and recreate\n" ); exit; } } @@ -2645,13 +2653,13 @@ # Delete if forcing if ( $CONFIG{'force'} ) { - logprint( "Removing $evms_object_disk - since we're forcing the install\n" ); + $xt->log( "Removing $evms_object_disk - since we're forcing the install\n" ); runCommand( "echo Delete : $evms_object_disk | evms" ); } else { - logprint( "The EVMS object $evms_object_disk already exists. Aborting.\n" ); - logprint( "Specify '--force' to delete and recreate\n" ); + $xt->log( "The EVMS object $evms_object_disk already exists. Aborting.\n" ); + $xt->log( "Specify '--force' to delete and recreate\n" ); exit; } } @@ -2750,25 +2758,25 @@ if ( ! defined( findBinary( $binary ) ) ) { - logprint( "The binary '$binary' required to create the filesystem $fs is missing\n" ); + $xt->log( "The binary '$binary' required to create the filesystem $fs is missing\n" ); exit; } } else { - logprint( "The filesystem creation hash is bogus for filesystem : $fs\n" ); + $xt->log( "The filesystem creation hash is bogus for filesystem : $fs\n" ); exit; } # # OK we have the command and the filesystem. Create it. # - logprint( "\nCreating $fs filesystem on $image\n" ); + $xt->log( "\nCreating $fs filesystem on $image\n" ); $command .= $image; runCommand( $command ); - logprint( "Done\n" ); + $xt->log( "Done\n" ); } @@ -2785,10 +2793,10 @@ { my ( $path ) = ( @_ ); - logprint( "\nCreating swap on $path\n" ); + $xt->log( "\nCreating swap on $path\n" ); runCommand( "mkswap $path" ); - logprint( "Done\n" ); + $xt->log( "Done\n" ); } @@ -2918,15 +2926,15 @@ # # Show the user what they are installing # - logprint( "Installation method: $CONFIG{'install-method'}\n" ); - logprint( "(Source: $CONFIG{'install-source'})\n" ) if defined( $CONFIG{'install-source'} ); + $xt->log( "Installation method: $CONFIG{'install-method'}\n" ); + $xt->log( "(Source: $CONFIG{'install-source'})\n" ) if defined( $CONFIG{'install-source'} ); # # Run the command. # runCommand( $cmd ); - logprint( "Done\n" ); + $xt->log( "Done\n" ); } @@ -3020,11 +3028,11 @@ # if ( $CONFIG{'verbose'} ) { - logprint( "Customization Script Environment:\n" ); - logprint( "---------------------------------\n" ); + $xt->log( "Customization Script Environment:\n" ); + $xt->log( "---------------------------------\n" ); foreach my $key ( sort keys %ENV ) { - logprint( "\t'" . $key . "' = '" . $ENV{$key} . "'\n" ); + $xt->log( "\t'" . $key . "' = '" . $ENV{$key} . "'\n" ); } } @@ -3037,9 +3045,9 @@ { $customize .= " --verbose"; } - logprint( "\nRunning hooks\n" ); + $xt->log( "\nRunning hooks\n" ); runCommand( $customize ); - logprint( "Done\n" ); + $xt->log( "Done\n" ); # # Unmount /proc in the guest install. @@ -3114,7 +3122,7 @@ if ( !defined( $role ) ) { - logprint( "\nNo role script specified. Skipping\n" ); + $xt->log( "\nNo role script specified. Skipping\n" ); return; } @@ -3125,14 +3133,14 @@ if ( -x $file ) { - logprint( "\nRole: $role\n" ); - logprint( "\tFile: $file\n" ); - logprint( "\tArgs: $args\n" ) if ( length( $args ) ); + $xt->log( "\nRole: $role\n" ); + $xt->log( "\tFile: $file\n" ); + $xt->log( "\tArgs: $args\n" ) if ( length( $args ) ); } else { - logprint( "\nRole script not executable : $file for role '$role'\n" ); - logprint( "Ignoring\n" ); + $xt->log( "\nRole script not executable : $file for role '$role'\n" ); + $xt->log( "Ignoring\n" ); return; } @@ -3150,7 +3158,7 @@ # runCommand( $file . " " . $MOUNT_POINT . $args ); - logprint( "Role script completed.\n" ); + $xt->log( "Role script completed.\n" ); } @@ -3180,9 +3188,9 @@ { unless( $CONFIG{'force'} ) { - logprint( "The Xen configuration file $file exists\n" ); - logprint( "Specify --force to force overwriting it.\n" ); - logprint( "Aborting\n" ); + $xt->log( "The Xen configuration file $file exists\n" ); + $xt->log( "Specify --force to force overwriting it.\n" ); + $xt->log( "Aborting\n" ); $FAIL = 1; exit; } @@ -3208,9 +3216,9 @@ $command .= " --admins=$CONFIG{'admins'}"; } - logprint( "\nCreating Xen configuration file\n" ); + $xt->log( "\nCreating Xen configuration file\n" ); runCommand( $command ); - logprint( "Done\n" ); + $xt->log( "Done\n" ); } @@ -3225,7 +3233,7 @@ sub setupRootPassword { - logprint( "Setting up root password\n" ); + $xt->log( "Setting up root password\n" ); if ( -x $MOUNT_POINT . "/usr/bin/passwd" ) { @@ -3233,7 +3241,7 @@ } else { - logprint( "'passwd' command not found in the new install.\n" ); + $xt->log( "'passwd' command not found in the new install.\n" ); } } @@ -3339,8 +3347,8 @@ if ( $? != 0 ) { - logprint( "Running command '$cmd' failed.\n" ); - logprint( "Aborting\n" ); + $xt->log( "Running command '$cmd' failed.\n" ); + $xt->log( "Aborting\n" ); $FAIL = 1; exit; } @@ -3449,7 +3457,7 @@ # # Run the command # - $CONFIG{'verbose'} && logprint( "Removing failed install: $CONFIG{'hostname'}\n" ); + $CONFIG{'verbose'} && $xt->log( "Removing failed install: $CONFIG{'hostname'}\n" ); system( "xen-delete-image --hostname=$CONFIG{'hostname'}" ); } diff -aruN xen-tools-export/lib/Xen/Tools/Log.pm xen-tools-merge/lib/Xen/Tools/Log.pm --- xen-tools-export/lib/Xen/Tools/Log.pm 1970-01-01 00:00:00.000000000 +0000 +++ xen-tools-merge/lib/Xen/Tools/Log.pm 2007-08-30 16:49:04.000000000 +0000 @@ -0,0 +1,206 @@ +package Xen::Tools::Log; + +use warnings; +use strict; +use Moose; +use File::Spec; + +=head1 NAME + +Xen::Tools::Log - Log Xen::Tools events + +=head1 VERSION + +Version 0.01 + +=cut + +our $VERSION = '0.01'; + + +=head1 SYNOPSIS + +Mostly internal to Xen::Tools. Use this to create a logging mechanism. + + my $xtl = Xen::Tools::Log->new( hostname => 'firewall' ); + + $xtl->print("Yay for logging."); + +=head1 FUNCTIONS + +=head2 new + + Create the log object + +=cut + +=head2 print + + Print the given string both to our screen, and to the logfile. + +=cut + +sub print { + my $self = shift; + + $self->print_screen( @_ ); + $self->print_log( @_ ); +} + +=head2 print_screen + + Print the given string to our screen + +=cut + +sub print_screen { + my $self = shift; + + print @_; +} + +=head2 print_log + + Print the given string to the logfile. + +=cut + +sub print_log { + my $self = shift; + + my $fh = $self->log_fh(); + print $fh ( @_ ); +} + +=head2 hostname + + Attribute storing the hostname this log describes + +=cut + +has 'hostname' => ( is => 'rw', isa => 'Str', required => 1 ); + +=head2 logpath + + Attribute storing the directory in which the log file resides + +=cut + +has 'logpath' => ( is => 'rw', + isa => 'Str', + default => '/var/log/xen-tools' + ); + +=head2 log_fh + + FileHandle attribute storing the filehandle of the log + +=cut + +has 'log_fh' => ( is => 'ro', + isa => 'FileHandle', + lazy => 1, + default => \&_init_fh, + ); + +=head2 clean_up + + Boolean attribute indicating whether the log will be cleaned up when the + logger is closed + +=cut + +has 'clean_up' => ( is => 'ro', + isa => 'Bool', + default => 0, + ); + +before 'DESTROY' => sub { + my $self = shift; + + # Deconstructor +}; + +=head2 meta + + This is a method which provides access to the current class's meta- + class. Inherited from Moose. + +=cut + +=begin doc + +_init_fh + + This private method initializes the logging filehandle + +=end doc + +=cut + +sub _init_fh { + my $self = shift; + + my $logFile = + File::Spec->catfile( $self->logpath(), $self->hostname() . '.log' ); + + open( $self->{log_fh}, q{>>}, $logFile ); +}; + +=head1 AUTHOR + +C.J. Adams-Collier, C<< >> + +=head1 BUGS + +Please report any bugs or feature requests to C, or through +the web interface at L. I will be notified, and then you'll +automatically be notified of progress on your bug as I make changes. + + + + +=head1 SUPPORT + +You can find documentation for this module with the perldoc command. + + perldoc Xen::Tools + + +You can also look for information at: + +=over 4 + +=item * RT: CPAN's request tracker + +L + +=item * AnnoCPAN: Annotated CPAN documentation + +L + +=item * CPAN Ratings + +L + +=item * Search CPAN + +L + +=back + + +=head1 ACKNOWLEDGEMENTS + + +=head1 COPYRIGHT & LICENSE + +Copyright 2007 C.J. Adams-Collier, all rights reserved. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + + +=cut + +1; # End of Xen::Tools::Log diff -aruN xen-tools-export/lib/Xen/Tools.pm xen-tools-merge/lib/Xen/Tools.pm --- xen-tools-export/lib/Xen/Tools.pm 1970-01-01 00:00:00.000000000 +0000 +++ xen-tools-merge/lib/Xen/Tools.pm 2007-08-30 17:25:05.000000000 +0000 @@ -0,0 +1,336 @@ +package Xen::Tools; + +use warnings; +use strict; +use Moose; + +use Xen::Tools::Log; + +=head1 NAME + +Xen::Tools - Build Xen domains with Perl + +=head1 VERSION + +Version 0.01 + +=cut + +our $VERSION = '0.01'; + +=head1 SYNOPSIS + + my $xt = Xen::Tools->new(); + +=head1 FUNCTIONS + +=head2 new + + Instantiate the object. + +=cut + +override 'new' => sub { + my $class = shift; + + # Initialize the base class + my $self = $class->super(@_); + + $self->{_xtl} = Xen::Tools::Log->new( hostname => $self->hostname, + logpath => $self->logpath, + ); + + $self->_checkSystem(); + + return $self; +}; + +=head2 meta + + This is a method which provides access to the current class's meta- + class. Inherited from Moose. + +=cut + +=head2 log + + This method sends a log message to the current object's logging + mechanism + +=cut + +sub log { + my $self = shift; + + $self->{_xtl}->print(@_); +} + +=head2 hostname + + Attribute which indicates the domain's hostname + +=cut + +has 'hostname' => ( is => 'ro', isa => 'Str', required => 1 ); + +=head2 logpath + + Attribute which indicates the log directory. Defaults to /var/log/xen-tools + +=cut + +has 'logpath' => ( is => 'ro', + isa => 'Str', + default => '/var/log/xen-tools' + ); + +=begin doc + +_findBinary + + Find the location of the specified binary on the curent user's PATH. + + Return undef if the named binary isn't found. + +=end doc + +=cut + +sub _findBinary { + my $self = shift; + my( $bin ) = (@_); + + # strip any path which might be present. + $bin = $2 if ( $bin =~ /(.*)[\/\\](.*)/ ); + + foreach my $entry ( split( /:/, $ENV{'PATH'} ) ) + { + # guess of location. + my $guess = $entry . "/" . $bin; + + # return it if it exists and is executable + return $guess if ( -e $guess && -x $guess ); + } + + return; +} + +=begin doc + +_checkSystem + + Test that this system is fully setup for the new xen-create-image + script. + + This means that the the companion scripts xt-* are present on the + host and executable. + +=end doc + +=cut + +sub _checkSystem { + my $self = shift; + my @required = qw ( / xt-customize-image + xt-install-image + xt-create-xen-config / ); + + foreach my $bin ( @required ) + { + if ( ! defined( $self->_findBinary( $bin ) ) ) + { + $self->log("The script '$bin' was not found.\n", + "Aborting\n\n" + ); + exit; + } + } + + # + # Make sure that we have Text::Template installed - this + # will be used by `xt-create-xen-config` and if that fails then + # running is pointless. + # + my $test = "use Text::Template"; + eval( $test ); + if ( ( $@ ) && ( ! $self->{_force} ) ) + { + print <{_admins} ) + { + my $shell = undef; + $shell = "/usr/bin/xen-login-shell" if ( -x "/usr/bin/xen-login-shell" ); + $shell = "/usr/local/bin/xen-login-shell" if ( -x "/usr/bin/local/xen-login-shell" ); + + if ( !defined( $shell ) ) + { + print <_testXenConfig(); +} + +=begin doc + + Test that the current Xen host has a valid network configuration, + this is designed to help newcomers to Xen. + +=end doc + +=cut + +sub _testXenConfig { + my $self = shift; + # wierdness. + return if ( ! -d "/etc/xen" ); + + # + # Temporary hash. + # + my %cfg; + + # + # Read the configuration file. + # + open( my $config_fh, q{<}, '/etc/xen/xend-config.sxp' ) + or die "Failed to read /etc/xen/xend-config.sxp: $!"; + while( <$config_fh> ) + { + next if ( ! $_ || !length( $_ ) ); + + # vif + if ( $_ =~ /^\(vif-script ([^)]+)/ ) + { + $cfg{'vif-script'} = $1; + } + + # network + if ( $_ =~ /^\(network-script ([^)]+)/ ) + { + $cfg{'network-script'} = $1; + } + } + close( $config_fh ); + + if ( !defined( $cfg{'network-script'} ) || + !defined( $cfg{'vif-script'} ) ) + { + print < >> + +=head1 BUGS + +Please report any bugs or feature requests to C, or through +the web interface at L. I will be notified, and then you'll +automatically be notified of progress on your bug as I make changes. + + + + +=head1 SUPPORT + +You can find documentation for this module with the perldoc command. + + perldoc Xen::Tools + + +You can also look for information at: + +=over 4 + +=item * RT: CPAN's request tracker + +L + +=item * AnnoCPAN: Annotated CPAN documentation + +L + +=item * CPAN Ratings + +L + +=item * Search CPAN + +L + +=back + + +=head1 ACKNOWLEDGEMENTS + + +=head1 COPYRIGHT & LICENSE + +Copyright 2007 C.J. Adams-Collier, all rights reserved. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + + +=cut + +1; # End of Xen::Tools diff -aruN xen-tools-export/t/00-load.t xen-tools-merge/t/00-load.t --- xen-tools-export/t/00-load.t 1970-01-01 00:00:00.000000000 +0000 +++ xen-tools-merge/t/00-load.t 2007-09-01 18:04:52.000000000 +0000 @@ -0,0 +1,10 @@ +#!perl -T + +use Test::More tests => 2; + +BEGIN { + use_ok( 'Xen::Tools' ); + use_ok( 'Xen::Tools::Log' ); +} + +diag( "Testing Xen::Tools $Xen::Tools::VERSION, Perl $], $^X" ); diff -aruN xen-tools-export/t/getopt.t xen-tools-merge/t/getopt.t --- xen-tools-export/t/getopt.t 2007-03-19 22:14:43.000000000 +0000 +++ xen-tools-merge/t/getopt.t 2007-09-03 19:09:48.000000000 +0000 @@ -20,6 +20,9 @@ # foreach my $file ( sort( glob "./bin/*-*" ) ) { + # Skip emacs and CVS backups + next if $file =~ /~$/; + testFile( $file ); } diff -aruN xen-tools-export/t/pod-coverage.t xen-tools-merge/t/pod-coverage.t --- xen-tools-export/t/pod-coverage.t 1970-01-01 00:00:00.000000000 +0000 +++ xen-tools-merge/t/pod-coverage.t 2007-09-01 17:49:00.000000000 +0000 @@ -0,0 +1,18 @@ +use strict; +use warnings; +use Test::More; + +# Ensure a recent version of Test::Pod::Coverage +my $min_tpc = 1.08; +eval "use Test::Pod::Coverage $min_tpc"; +plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage" + if $@; + +# Test::Pod::Coverage doesn't require a minimum Pod::Coverage version, +# but older versions don't recognize some common documentation styles +my $min_pc = 0.17; +eval "use Pod::Coverage $min_pc"; +plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage" + if $@; + +all_pod_coverage_ok(); diff -aruN xen-tools-export/t/pod.t xen-tools-merge/t/pod.t --- xen-tools-export/t/pod.t 2006-06-09 15:12:33.000000000 +0000 +++ xen-tools-merge/t/pod.t 2007-09-01 17:53:29.000000000 +0000 @@ -1,17 +1,19 @@ -#!/usr/bin/perl -w +#!perl -T # # Test that the POD we use in our modules is valid. # - use strict; +use warnings; use Test::More; -eval "use Test::Pod 1.00"; -plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; + +# Ensure a recent version of Test::Pod +my $min_tp = 1.08; +eval "use Test::Pod $min_tp"; +plan skip_all => "Test::Pod $min_tp required for testing POD" if $@; # # Run the test(s). # -my @poddirs = qw( bin ); -all_pod_files_ok( all_pod_files( @poddirs ) ); +all_pod_files_ok(); diff -aruN xen-tools-export/t/xen-tools-log.t xen-tools-merge/t/xen-tools-log.t --- xen-tools-export/t/xen-tools-log.t 1970-01-01 00:00:00.000000000 +0000 +++ xen-tools-merge/t/xen-tools-log.t 2007-09-01 17:49:20.000000000 +0000 @@ -0,0 +1,17 @@ +#!perl -T + +use strict; +use warnings; +use Test::More tests => 1; +use File::Temp; + +use Xen::Tools::Log; + +my $dir = File::Temp::tempdir( CLEANUP => 1 ); + +my $xtl = Xen::Tools::Log->new( hostname => 'xen-tools-log-test', + logpath => $dir, + ); + +ok( $xtl->isa('Xen::Tools::Log') ); + diff -aruN xen-tools-export/t/xen-tools.t xen-tools-merge/t/xen-tools.t --- xen-tools-export/t/xen-tools.t 1970-01-01 00:00:00.000000000 +0000 +++ xen-tools-merge/t/xen-tools.t 2007-09-01 17:49:16.000000000 +0000 @@ -0,0 +1,11 @@ +#!perl -T + +use strict; +use warnings; +use Test::More tests => 1; + +use Xen::Tools; + +my $xt = Xen::Tools->new( hostname => 'xen-tools-test' ); + +ok( $xt->isa('Xen::Tools') ); diff -aruN xen-tools-export/tests/00-load.t xen-tools-merge/tests/00-load.t --- xen-tools-export/tests/00-load.t 1970-01-01 00:00:00.000000000 +0000 +++ xen-tools-merge/tests/00-load.t 2007-09-01 18:04:52.000000000 +0000 @@ -0,0 +1,10 @@ +#!perl -T + +use Test::More tests => 2; + +BEGIN { + use_ok( 'Xen::Tools' ); + use_ok( 'Xen::Tools::Log' ); +} + +diag( "Testing Xen::Tools $Xen::Tools::VERSION, Perl $], $^X" ); diff -aruN xen-tools-export/tests/Makefile xen-tools-merge/tests/Makefile --- xen-tools-export/tests/Makefile 1970-01-01 00:00:00.000000000 +0000 +++ xen-tools-merge/tests/Makefile 2006-06-24 20:22:41.000000000 +0000 @@ -0,0 +1,17 @@ + +all: + @cd ..; prove --shuffle tests/ + +verbose: + @cd ..; prove --shuffle --verbose tests/ + + +modules: .PHONY + ./modules.sh > modules.t + +.PHONY: + true + +clean: + + rm *~ diff -aruN xen-tools-export/tests/argument-check.t xen-tools-merge/tests/argument-check.t --- xen-tools-export/tests/argument-check.t 1970-01-01 00:00:00.000000000 +0000 +++ xen-tools-merge/tests/argument-check.t 2007-08-08 22:43:18.000000000 +0000 @@ -0,0 +1,141 @@ +#!/usr/bin/perl -w +# +# Test that the arguments in etc/xen-tools.conf match those used in +# xen-create-image. +# +# Steve +# -- +# $Id: argument-check.t,v 1.8 2007-08-08 22:43:18 steve Exp $ +# + +use strict; +use Test::More qw( no_plan ); + +# +# Open and parse the xen-tools.conf configuration file. +# +my %OPTIONS; +%OPTIONS = parseConfigFile( "etc/xen-tools.conf" ); + +# +# Test we got something back. +# +ok( %OPTIONS, "Options successfully parsed" ); + + +# +# Now open and read the file "xen-create-image" +# +my @lines = readFile( "bin/xen-create-image" ); +ok ( @lines, "We read the 'xen-create-image' script" ); + + +# +# For each option we found we want to make sure it is +# contained in the script, via the documentation. +# +foreach my $key ( sort keys %OPTIONS ) +{ + my $found = 0; + + foreach my $line ( @lines ) + { + if ( $line =~ /--$key/ ) + { + $found = 1; + } + } + + next if ( $key =~ /mirror_/i ); + next if ( $key =~ /_options/i ); + + is( $found, 1 , " Found documentation for '$key'" ); +} + + + + +=head2 parseConfigFile + + Parse the 'key=value' configuration file passed to us, and + return a hash of the reults. + +=cut + +sub parseConfigFile +{ + my ($file) = ( @_ ); + + # + # Options we read + # + my %CONFIG; + + open( FILE, "<", $file ) or die "Cannot read file '$file' - $!"; + + my $line = ""; + + while (defined($line = ) ) + { + chomp $line; + if ($line =~ s/\\$//) + { + $line .= ; + redo unless eof(FILE); + } + + # Skip blank lines + next if ( length( $line ) < 1 ); + + # skip false positive + next if ( $line =~ /Otherwise/ ); + + # Find variable settings + if ( $line =~ /([^=]+)=([^\n]+)/ ) + { + my $key = $1; + my $val = $2; + + if ( $key =~ /([ \t#]*)(.*)/ ) + { + $key = $2; + } + + + # Strip leading and trailing whitespace. + $key =~ s/^\s+//; + $key =~ s/\s+$//; + $val =~ s/^\s+//; + $val =~ s/\s+$//; + + next if ( $key =~ /--/ ); + + # Store value. + $CONFIG{ $key } = $val; + } + } + + close( FILE ); + + return( %CONFIG ); +} + + + + +=head2 readFile + + Read a named file and return an array of its contents. + +=cut + +sub readFile +{ + my ($file) = ( @_ ); + + open( FILE, "<", $file ) or die "Cannot read file '$file' - $!"; + my @LINES = ; + close( FILE ); + + return( @LINES ); +} diff -aruN xen-tools-export/tests/getopt.t xen-tools-merge/tests/getopt.t --- xen-tools-export/tests/getopt.t 1970-01-01 00:00:00.000000000 +0000 +++ xen-tools-merge/tests/getopt.t 2007-09-03 19:09:48.000000000 +0000 @@ -0,0 +1,146 @@ +#!/usr/bin/perl -w +# +# Test that every perl script accepts and processes each of the options +# documented in its POD. +# +# Cute test :) +# +# Steve +# -- +# $Id: getopt.t,v 1.4 2007-03-19 22:14:43 steve Exp $ + + +use strict; +use File::Find; +use Test::More qw( no_plan ); + + +# +# Test each file +# +foreach my $file ( sort( glob "./bin/*-*" ) ) +{ + # Skip emacs and CVS backups + next if $file =~ /~$/; + + testFile( $file ); +} + + +# +# Check that the given file implements all the option processing it +# is supposed to. +# +# +sub testFile +{ + my ($file ) = (@_); + is( -e $file, 1, "File exists: $file" ); + is( -x $file, 1, "File is executable" ); + + # + # Run the file with "--help" and capture the output. + # + my $output = `$file --help`; + + # + # Parse out the options we accept + # + my @documented = (); + + foreach my $line ( split( /\n/, $output ) ) + { + if ( $line =~ /[ \t]*--([a-z-_]+)/ ) + { + push @documented, $1; + } + } + + # + # Test we discovered some documented options. + # + ok( $#documented > 1, "We found some options documented." ); + + + + # + # Now read the input file so that we can see if these advertised + # options are actually used. + # + open( IN, "<", $file ) or die "Failed to open file for reading $file - $!"; + my @LINES = ; + close( IN ); + + # + # Options accepted + # + my %accepted; + + # + # Do minimal parsing to find the options we process with + # Getopt::Long; + # + my $complete = join( "\n", @LINES ); + if ( $complete =~ /GetOptions\(([^\)]+)\)/mi ) + { + # + # Multi-line text which should have all the options we've + # invoked GetOptions with. + # + my $opt = $1; + + # + # Process each one. + # + foreach my $o ( split( /\n/, $opt ) ) + { +#print "O: $o "; + # + # Strip trailing comments. + # + if ( $o =~ /([^#]+)#/ ) + { + $o = $1; + } +#print " - strip comments : $o "; + + # + # Remove "" from around it. + # + if ( $o =~ /"([^"]+)"/ ) + { + $o = $1; + } +#print " - remove quotes : $o "; + # + # Discard anything after "=", or " " + # + if ( $o =~ /(.*)[ \t=]+(.*)/ ) + { + $o = $1; + } +#print " - remove = : $o "; + # + # Now avoid blank lines. + # + next if ( $o =~ /^[ \t]*$/ ); + + + # + # Phew. Now we're done. + # + # This option '$o' is something we call GetOptions with. + # + $accepted{$o} = 1; + } + } + + # + # Now we want to make sure that each documented option is + # present in the list of options we pass to getopt. + # + foreach my $argument ( @documented ) + { + is( $accepted{$argument}, 1, "Option '--$argument' accepted: $file" ); + } +} diff -aruN xen-tools-export/tests/hook-daemons.t xen-tools-merge/tests/hook-daemons.t --- xen-tools-export/tests/hook-daemons.t 1970-01-01 00:00:00.000000000 +0000 +++ xen-tools-merge/tests/hook-daemons.t 2007-06-12 14:05:38.000000000 +0000 @@ -0,0 +1,106 @@ +#!/usr/bin/perl -w +# +# Test that our policy-rc.d file is created and removed as we expect in our hooks. +# +# Steve +# -- +# $Id: hook-daemons.t,v 1.1 2007-06-12 14:05:38 steve Exp $ +# + + +use strict; +use Test::More qw( no_plan ); +use File::Temp; + + + + +# +# Rather than having a hardwired list of distributions to test +# against we look for subdirectories beneath hooks/ and test each +# one. +# +foreach my $dir ( glob( "hooks/*" ) ) +{ + next if ( $dir =~ /CVS/i ); + next if ( ! -d $dir ); + + if ( $dir =~ /hooks\/(.*)/ ) + { + my $dist = $1; + + maybeCallHook( $dist ); + } +} + + + +# +# If the given distribution has the following two files test them: +# +# 01-disable-daemons +# 99-enable-daemons +# +sub maybeCallHook +{ + my( $dist ) = (@_); + + # + # Do the two files exist? + # + foreach my $file ( qw/ 01-disable-daemons 99-enable-daemons / ) + { + return if ( ! -e "./hooks/$dist/$file" ); + } + + # + # Call the test on the given distribution + # + testHook( $dist ); +} + + + +# +# Test that the two hooks work. +# +sub testHook +{ + my ( $dist ) = ( @_ ); + + # + # Output + # + ok( $dist, "Testing: $dist" ); + + # + # Create a temporary directory. + # + my $dir = File::Temp::tempdir( CLEANUP => 1 ); + + # + # Test we got a directory and there is no /usr/sbin there. + # + ok( -d $dir, "Temporary directory created OK" ); + ok( ! -d $dir . "/usr/sbin", "There is no /usr/sbin directory there. yet" );; + + + # + # Call the first hook + # + `./hooks/$dist/01-disable-daemons $dir`; + + # + # Now /usr/sbin should exist. + # + ok( -d $dir . "/usr/sbin", "The /usr/sbin directory was created" ); + ok( -x $dir . "/usr/sbin/policy-rc.d", "The policy-rc.d file was created" ); + + # + # Now call the second hook + # + `./hooks/$dist/99-enable-daemons $dir`; + + ok( ! -x $dir . "/usr/sbin/policy-rc.d", "The policy-rc.d file was correctly removed" ); +} + diff -aruN xen-tools-export/tests/hook-hostname.t xen-tools-merge/tests/hook-hostname.t --- xen-tools-export/tests/hook-hostname.t 1970-01-01 00:00:00.000000000 +0000 +++ xen-tools-merge/tests/hook-hostname.t 2006-12-26 22:27:25.000000000 +0000 @@ -0,0 +1,107 @@ +#!/usr/bin/perl -w +# +# Test that we get an /etc/hosts etc file created when DHCP is used. +# +# Steve +# -- +# $Id: hook-hostname.t,v 1.1 2006-12-26 22:27:25 steve Exp $ +# + + +use strict; +use Test::More qw( no_plan ); +use File::Temp; + + + + +# +# Rather than having a hardwired list of distributions to test +# against we look for subdirectories beneath hooks/ and test each +# one. +# +foreach my $dir ( glob( "hooks/*" ) ) +{ + next if ( $dir =~ /CVS/i ); + next if ( ! -d $dir ); + + if ( $dir =~ /hooks\/(.*)/ ) + { + my $dist = $1; + + testHostCreation( $dist ) unless ( $dist =~ /fedora/i ); + } +} + + + + +# +# Test that the creation succeeds. +# +sub testHostCreation +{ + my ( $dist ) = ( @_ ); + + # + # Setup the environment. + # + $ENV{'hostname'} = "steve"; + $ENV{'dhcp'} = 1; + + # + # Create a temporary directory. + # + my $dir = File::Temp::tempdir( CLEANUP => 1 ); + mkdir( $dir . "/etc", 0777 ); + + # + # Gentoo + # + if ( $dist =~ /gentoo/i ) + { + mkdir( $dir . "/etc/conf.d", 0777 ); + } + + ok( -d $dir, "Temporary directory created OK" ); + ok( -d $dir . "/etc/conf.d" , "Temporary directory created OK" ) if ( $dist =~ /gentoo/i ); + + # + # Make sure there are no files. + # + ok( -d $dir . "/etc/", "Temporary directory created OK" ); + ok( ! -e $dir . "/etc/hosts", " There is no hosts file present" ); + ok( ! -e $dir . "/etc/mailname", " There is no mailname file present" ); + ok( ! -e $dir . "/etc/hostname", " There is no hostname file present" ); + + # + # Make sure we have the distro-specific hook directory, and + # TLS-disabling hook script. + # + ok( -d "hooks/$dist", "There is a hook directory for the distro $dist" ); + + ok( -e "hooks/$dist/50-setup-hostname", "There is a hook for setting up hostname stuff." ); + + # + # Call the hook + # + `hooks/$dist/50-setup-hostname $dir`; + + ok( -e $dir . "/etc/hosts", " There is now a hosts file present" ); + + # + # These files are not used in Gentoo + # + if ( $dist =~ /gentoo/i ) + { + ok( -e $dir . "/etc/conf.d/domainname", " There is now a domainname file present" ); + ok( -e $dir . "/etc/conf.d/hostname", " There is now a hostname file present" ); + + } + else + { + ok( -e $dir . "/etc/mailname", " There is now a mailname file present" ); + ok( -e $dir . "/etc/hostname", " There is now a hostname file present" ); + } +} + diff -aruN xen-tools-export/tests/hook-inittab.t xen-tools-merge/tests/hook-inittab.t --- xen-tools-export/tests/hook-inittab.t 1970-01-01 00:00:00.000000000 +0000 +++ xen-tools-merge/tests/hook-inittab.t 2006-12-03 12:16:45.000000000 +0000 @@ -0,0 +1,108 @@ +#!/usr/bin/perl -w +# +# Test that the /etc/inittab file is modified as we expect. +# +# Steve +# -- +# $Id: hook-inittab.t,v 1.9 2006-12-03 12:16:45 radu Exp $ +# + +use strict; +use Test::More qw( no_plan ); +use File::Temp; +use File::Copy; + + +# +# Sanity check. +# +ok( -e "/etc/inittab", "/etc/inittab exists." ); + + + +# +# Rather than having a hardwired list of distributions to test +# against we look for subdirectories beneath hooks/ and test each +# one. +# +foreach my $dir ( glob( "hooks/*" ) ) +{ + next if ( $dir =~ /CVS/i ); + next if ( ! -d $dir ); + + if ( $dir =~ /hooks\/(.*)/ ) + { + my $dist = $1; + + next if ( $dist =~ /(edgy|dapper|ubuntu)/i ); + + testHook( $dist ); + } +} + + + + +sub testHook +{ + my ( $dist ) = ( @_ ); + + # + # Create a temporary directory, and copy our inittab into it. + # + my $dir = File::Temp::tempdir( CLEANUP => 1 ); + mkdir( $dir . "/etc", 0777 ); + File::Copy::cp( "/etc/inittab", $dir . "/etc" ); + + # + # Make sure that worked. + # + ok( -d $dir, "Temporary directory created OK" ); + ok( -e $dir . "/etc/inittab", "/etc/inittab copied correctly." ); + + ok( -e "hooks/$dist/30-disable-gettys", "$dist inittab fixing hook exists" ); + ok( -x "hooks/$dist/30-disable-gettys", "$dist inittab fixing hook is executable" ); + + # + # Call the hook + # + `hooks/$dist/30-disable-gettys $dir`; + + # + # Now we read the new file, and make sure it looks like we expect. + # + open( INIT, "<", $dir . "/etc/inittab" ) + or die "Failed to open modified inittab."; + my @lines = ; + close( INIT ); + + # + # Test we read some lines. + # + ok( $#lines > 0, "We read the new inittab." ); + + # + # Now test that the lines look like they should. + # + my $count = 0; + foreach my $line ( @lines ) + { + if ( $line =~ /^([1-9])(.*) (.*)$/ ) + { + # + # This should be our only line: + # + # 1:2345:respawn:/sbin/getty 38400 console + # + ok( $1 eq "1", "We found the first getty line." ); + ok( $3 eq "tty1", "Which does uses the correct driver: $3" ); + } + + if ( $line =~ /^(.).*getty/ ) + { + $count += 1 if ( $1 ne "#" ); + } + } + + ok( $count = 1, "Only found one uncommented getty line" ); +} diff -aruN xen-tools-export/tests/hook-tls.t xen-tools-merge/tests/hook-tls.t --- xen-tools-export/tests/hook-tls.t 1970-01-01 00:00:00.000000000 +0000 +++ xen-tools-merge/tests/hook-tls.t 2007-03-19 22:10:54.000000000 +0000 @@ -0,0 +1,87 @@ +#!/usr/bin/perl +# +# Test that the tls-disabling hook works. +# +# Steve +# -- +# $Id: hook-tls.t,v 1.9 2007-03-19 22:10:54 steve Exp $ +# + +use Config qw(config_vars); +use Test::More; +use File::Temp; + + +if ( $Config::Config{archname} =~ /64/ ) +{ + plan skip_all => "This test will fail upon 64 bit systems" ; +} +else +{ + plan no_plan; +} + +# +# Rather than having a hardwired list of distributions to test +# against we look for subdirectories beneath hooks/ and test each +# one. +# +foreach my $dir ( glob( "hooks/*" ) ) +{ + next if ( $dir =~ /CVS/i ); + next if ( ! -d $dir ); + + if ( $dir =~ /hooks\/(.*)/ ) + { + my $dist = $1; + + testTLSDisabling( $dist ) unless ( $dist =~ /(dapper|edgy|ubuntu|debian)/i ); + } +} + + + + +# +# Test that there is a hook for the given distribution, and that +# it successfully disables a faked TLS. +# +sub testTLSDisabling +{ + my ( $dist ) = ( @_ ); + + # + # Create a temporary directory. + # + my $dir = File::Temp::tempdir( CLEANUP => 1 ); + + mkdir( $dir . "/lib", 0777 ); + mkdir( $dir . "/lib/tls", 0777 ); + mkdir( $dir . "/lib/tls/foo", 0777 ); + + ok( -d $dir, "Temporary directory created OK" ); + ok( -d $dir . "/lib/tls", "TLS directory OK" ); + ok( -d $dir . "/lib/tls/foo", "TLS directory is non-empty" ); + + + # + # Make sure we have the distro-specific hook directory, and + # TLS-disabling hook script. + # + ok( -d "hooks/$dist", "There is a hook directory for the distro $dist" ); + + ok( -e "hooks/$dist/10-disable-tls", "TLS Disabling hook exists" ); + ok( -x "hooks/$dist/10-disable-tls", "TLS Disabling hook is executable" ); + + # + # Call the hook + # + `hooks/$dist/10-disable-tls $dir`; + + # + # Make sure the the TLS directory is empty + # + ok( ! -e "$dir/lib/tls/foo", "The fake library from /lib/tls is gone" ); + ok( -e "$dir/lib/tls.disabled/foo", "The fake library ended up in /lib/tls.disabled" ); + ok( -d "$dir/lib/tls", "There is a new /lib/tls directory" ); +} diff -aruN xen-tools-export/tests/hooks.t xen-tools-merge/tests/hooks.t --- xen-tools-export/tests/hooks.t 1970-01-01 00:00:00.000000000 +0000 +++ xen-tools-merge/tests/hooks.t 2006-06-25 20:02:33.000000000 +0000 @@ -0,0 +1,54 @@ +#!/usr/bin/perl -w +# +# Test that all the hook files we install are executable. +# +# Steve +# -- +# $Id: hooks.t,v 1.7 2006-06-25 20:02:33 steve Exp $ +# + +use strict; +use Test::More qw( no_plan ); + + +# +# Rather than having a hardwired list of distributions to test +# against we look for subdirectories beneath hooks/ and test each +# one. +# +foreach my $dir ( glob( "hooks/*" ) ) +{ + next if ( $dir =~ /CVS/i ); + next if ( ! -d $dir ); + + if ( $dir =~ /hooks\/(.*)/ ) + { + my $dist = $1; + testDistroHooks( $dist ); + } +} + + + +sub testDistroHooks +{ + my ( $dist ) = ( @_ ); + + # + # Make sure we have a distro-specific hook directory. + # + ok( -d "hooks/$dist", "There is a hook directory for distro $dist" ); + + # + # Now make sure we just have files, and that they are executable. + # + foreach my $file ( glob( "hooks/$dist/*" ) ) + { + if ( ! -d $file ) + { + ok( -e $file, "$file" ); + ok( -x $file, " File is executable: $file" ); + } + } +} + diff -aruN xen-tools-export/tests/modules.sh xen-tools-merge/tests/modules.sh --- xen-tools-export/tests/modules.sh 1970-01-01 00:00:00.000000000 +0000 +++ xen-tools-merge/tests/modules.sh 2007-06-12 14:04:08.000000000 +0000 @@ -0,0 +1,35 @@ +#!/bin/sh +# +# Automatically attempt to create a test which ensures all the modules +# used in the code are availabe. +# +# Steve +# -- +# http://www.steve.org.uk/ +# +# $Id: modules.sh,v 1.5 2007-06-12 14:04:08 steve Exp $ +# + +cat < \&checkFile, no_chdir => 1 }, '.' ); + + + +# +# Check a file. +# +# +sub checkFile +{ + # The file. + my $file = $File::Find::name; + + # We don't care about directories + return if ( ! -f $file ); + + # Nor about backup files. + return if ( $file =~ /~$/ ); + + # Nor about files which start with ./debian/ + return if ( $file =~ /^\.\/debian\// ); + + # See if it is a shell/perl file. + my $isShell = 0; + my $isPerl = 0; + + # Read the file. + open( INPUT, "<", $file ); + foreach my $line ( ) + { + if ( ( $line =~ /\/bin\/sh/ ) || + ( $line =~ /\/bin\/bash/ ) ) + { + $isShell = 1; + } + if ( $line =~ /\/usr\/bin\/perl/ ) + { + $isPerl = 1; + } + } + close( INPUT ); + + # + # Return if it wasn't a perl file. + # + if ( $isShell || $isPerl ) + { + # + # Count TAB characters + # + my $count = countTabCharacters( $file ); + + is( $count, 0, "Script has no tab characters: $file" ); + } +} + + +=head2 countTabCharacters + +=cut + +sub countTabCharacters +{ + my ( $file ) = (@_); + + my $count = 0; + + open( FILE, "<", $file ) + or die "Cannot open $file - $!"; + foreach my $line ( ) + { + while( $line =~ /(.*)\t(.*)/ ) + { + $count += 1; + $line = $1 . $2; + } + } + close( FILE ); + + return( $count ); +} diff -aruN xen-tools-export/tests/perl-syntax.t xen-tools-merge/tests/perl-syntax.t --- xen-tools-export/tests/perl-syntax.t 1970-01-01 00:00:00.000000000 +0000 +++ xen-tools-merge/tests/perl-syntax.t 2007-03-19 22:16:20.000000000 +0000 @@ -0,0 +1,73 @@ +#!/usr/bin/perl -w +# +# Test that every perl file we have passes the syntax check. +# +# Steve +# -- +# $Id: perl-syntax.t,v 1.4 2007-03-19 22:16:20 steve Exp $ + + +use strict; +use File::Find; +use Test::More qw( no_plan ); + + +# +# Find all the files beneath the current directory, +# and call 'checkFile' with the name. +# +find( { wanted => \&checkFile, no_chdir => 1 }, '.' ); + + + +# +# Check a file. +# +# If this is a perl file then call "perl -c $name", otherwise +# return +# +sub checkFile +{ + # The file. + my $file = $File::Find::name; + + # We don't care about directories + return if ( ! -f $file ); + + # `modules.sh` is a false positive. + return if ( $file =~ /modules.sh$/ ); + + # `tests/hook-tls.t` is too. + return if ( $file =~ /hook-tls.t$/ ); + + # See if it is a perl file. + my $isPerl = 0; + + # Read the file. + open( INPUT, "<", $file ); + foreach my $line ( ) + { + if ( $line =~ /\/usr\/bin\/perl/ ) + { + $isPerl = 1; + } + } + close( INPUT ); + + # + # Return if it wasn't a perl file. + # + return if ( ! $isPerl ); + + # + # Now run 'perl -c $file' to see if we pass the syntax + # check. We add a couple of parameters to make sure we're + # really OK. + # + # use strict "vars"; + # use strict "subs"; + # + my $retval = system( "perl -Mstrict=subs -Mstrict=vars -c $file 2>/dev/null >/dev/null" ); + + is( $retval, 0, "Perl file passes our syntax check: $file" ); +} diff -aruN xen-tools-export/tests/plugin-checks.t xen-tools-merge/tests/plugin-checks.t --- xen-tools-export/tests/plugin-checks.t 1970-01-01 00:00:00.000000000 +0000 +++ xen-tools-merge/tests/plugin-checks.t 2006-06-25 20:02:33.000000000 +0000 @@ -0,0 +1,98 @@ +#!/usr/bin/perl -w +# +# Test that the plugins each refer to environmental variables, +# not the perl config hash. +# +# Steve +# -- +# $Id: plugin-checks.t,v 1.7 2006-06-25 20:02:33 steve Exp $ +# + + +use strict; +use Test::More qw( no_plan ); + + +# +# Rather than having a hardwired list of distributions to test +# against we look for subdirectories beneath hooks/ and test each +# one. +# +foreach my $dir ( glob( "hooks/*" ) ) +{ + next if ( $dir =~ /CVS/i ); + next if ( ! -d $dir ); + + if ( $dir =~ /hooks\/(.*)/ ) + { + my $dist = $1; + testPlugins( $dist ); + } +} + + + +=head2 testPlugins + + Test each plugin associated with the given directory. + +=cut + +sub testPlugins +{ + my ( $dist ) = ( @_ ); + + # + # Make sure there is a hook directory for the named distro + # + ok( -d "hooks/$dist/", "There is a hook directory for the distro $dist" ); + + # + # Make sure the plugins are OK. + # + foreach my $file ( glob( "hooks/$dist/*" ) ) + { + ok( -e $file, "$file" ); + + if ( -f $file ) + { + ok( -x $file, "File is executable" ); + + # + # Make sure the file is OK + # + my $result = testFile( $file ); + is( $result, 0, " File contains no mention of the config hash" ); + + } + } + +} + + + +# +# Test that the named file contains no mention of '$CONFIG{'xx'};' +# +sub testFile +{ + my ( $file ) = ( @_ ); + + open( FILY, "<", $file ) or die "Failed to open $file - $!"; + + foreach my $line ( ) + { + if ( $line =~ /\$CONFIG{[ \t'"]+(.*)[ \t'"]+}/ ) + { + close( FILY ); + return $line; + } + } + close( FILY ); + + # + # Success + # + return 0; +} + diff -aruN xen-tools-export/tests/pod-check.t xen-tools-merge/tests/pod-check.t --- xen-tools-export/tests/pod-check.t 1970-01-01 00:00:00.000000000 +0000 +++ xen-tools-merge/tests/pod-check.t 2006-06-13 13:26:01.000000000 +0000 @@ -0,0 +1,33 @@ +#!/usr/bin/perl -w +# +# Test that the POD we include in our scripts is valid, via the external +# podcheck command. +# +# Steve +# -- +# $Id: pod-check.t,v 1.5 2006-06-13 13:26:01 steve Exp $ +# + +use strict; +use Test::More qw( no_plan ); + +foreach my $file ( glob( "bin/*-*" ) ) +{ + ok( -e $file, "$file" ); + ok( -x $file, " File is executable: $file" ); + ok( ! -d $file, " File is not a directory: $file" ); + + if ( ( -x $file ) && ( ! -d $file ) ) + { + # + # Execute the command giving STDERR to STDOUT where we + # can capture it. + # + my $cmd = "podchecker $file"; + my $output = `$cmd 2>&1`; + chomp( $output ); + + is( $output, "$file pod syntax OK.", " File has correct POD syntax: $file" ); + } +} + diff -aruN xen-tools-export/tests/pod-coverage.t xen-tools-merge/tests/pod-coverage.t --- xen-tools-export/tests/pod-coverage.t 1970-01-01 00:00:00.000000000 +0000 +++ xen-tools-merge/tests/pod-coverage.t 2007-09-01 17:49:00.000000000 +0000 @@ -0,0 +1,18 @@ +use strict; +use warnings; +use Test::More; + +# Ensure a recent version of Test::Pod::Coverage +my $min_tpc = 1.08; +eval "use Test::Pod::Coverage $min_tpc"; +plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage" + if $@; + +# Test::Pod::Coverage doesn't require a minimum Pod::Coverage version, +# but older versions don't recognize some common documentation styles +my $min_pc = 0.17; +eval "use Pod::Coverage $min_pc"; +plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage" + if $@; + +all_pod_coverage_ok(); diff -aruN xen-tools-export/tests/pod.t xen-tools-merge/tests/pod.t --- xen-tools-export/tests/pod.t 1970-01-01 00:00:00.000000000 +0000 +++ xen-tools-merge/tests/pod.t 2007-09-01 17:53:29.000000000 +0000 @@ -0,0 +1,19 @@ +#!perl -T + +# +# Test that the POD we use in our modules is valid. +# + +use strict; +use warnings; +use Test::More; + +# Ensure a recent version of Test::Pod +my $min_tp = 1.08; +eval "use Test::Pod $min_tp"; +plan skip_all => "Test::Pod $min_tp required for testing POD" if $@; + +# +# Run the test(s). +# +all_pod_files_ok(); diff -aruN xen-tools-export/tests/portable-shell.t xen-tools-merge/tests/portable-shell.t --- xen-tools-export/tests/portable-shell.t 1970-01-01 00:00:00.000000000 +0000 +++ xen-tools-merge/tests/portable-shell.t 2006-10-19 17:10:31.000000000 +0000 @@ -0,0 +1,88 @@ +#!/usr/bin/perl -w +# +# Test that we don't use non-portable shell syntax in our hooks. +# +# Specifically we test for: +# +# 1. "[[" & "]]" around tests. +# +# 2. The "function" keyword +# +# Steve +# -- +# $Id: portable-shell.t,v 1.1 2006-10-19 17:10:31 steve Exp $ + + +use strict; +use File::Find; +use Test::More qw( no_plan ); + + +# +# Find all the files beneath the current directory, +# and call 'checkFile' with the name. +# +find( { wanted => \&checkFile, no_chdir => 1 }, '.' ); + + + +# +# Check a file. +# +# If this is a shell script then call "sh -n $name", otherwise +# return +# +sub checkFile +{ + # The file. + my $file = $File::Find::name; + + # We don't care about directories + return if ( ! -f $file ); + + # We're only testing things beneath hooks + return if ( $file !~ /hooks/ ); + + # See if it is a shell script. + my $isShell = 0; + + # Read the file. + open( INPUT, "<", $file ); + foreach my $line ( ) + { + if ( ( $line =~ /\/bin\/sh/ ) || + ( $line =~ /\/bin\/bash/ ) ) + { + $isShell = 1; + } + } + close( INPUT ); + + # + # Return if it wasn't a shell script. + # + return if ( ! $isShell ); + + + # The result + my $result = 0; + + # + # Open the file and read it. + # + open( INPUT, "<", $file ) + or die "Failed to open '$file' - $!"; + + while( my $line = ) + { + # [[ or ]] + $result += 1 if ( $line =~ /\[\[/ ); + $result += 1 if ( $line =~ /\]\]/ ); + + # function + $result += 1 if ( $line =~ /^[ \t]*function/ ); + } + close( INPUT ); + + is( $result, 0, "Shell script passes our portability check: $file" ); +} diff -aruN xen-tools-export/tests/programs.t xen-tools-merge/tests/programs.t --- xen-tools-export/tests/programs.t 1970-01-01 00:00:00.000000000 +0000 +++ xen-tools-merge/tests/programs.t 2006-06-15 11:10:54.000000000 +0000 @@ -0,0 +1,43 @@ +#!/usr/bin/perl -w -I.. +# +# Test that we have several required programs present. +# +# Steve +# -- +# + +use Test::More qw( no_plan ); + + +# +# Files that we want to use. +# +my @required = qw( /usr/sbin/debootstrap /bin/ls /bin/dd /bin/mount /bin/cp /bin/tar ); + +# +# Files that we might wish to use. +# +my @optional = qw( /usr/bin/rpmstrap /usr/sbin/xm /sbin/mkfs.ext3 /sbin/mkfs.xfs/sbin/mkfs.reiserfs ); + + + +# +# Test required programs +# +foreach my $file ( @required ) +{ + ok( -x $file , "Required binary installed: $file" ); +} + +# +# Test optional programs - if they exist then we ensure they are +# executable. If they don't we'll not complain since they are optional. +# +foreach my $file ( @optional ) +{ + if ( -e $file ) + { + ok( -x $file , "Optional binary installed: $file" ); + } +} + diff -aruN xen-tools-export/tests/shell-syntax.t xen-tools-merge/tests/shell-syntax.t --- xen-tools-export/tests/shell-syntax.t 1970-01-01 00:00:00.000000000 +0000 +++ xen-tools-merge/tests/shell-syntax.t 2006-06-14 13:46:25.000000000 +0000 @@ -0,0 +1,64 @@ +#!/usr/bin/perl -w +# +# Test that every shell script we have passes a syntax check. +# +# Steve +# -- +# $Id: shell-syntax.t,v 1.3 2006-06-14 13:46:25 steve Exp $ + + +use strict; +use File::Find; +use Test::More qw( no_plan ); + + +# +# Find all the files beneath the current directory, +# and call 'checkFile' with the name. +# +find( { wanted => \&checkFile, no_chdir => 1 }, '.' ); + + + +# +# Check a file. +# +# If this is a shell script then call "sh -n $name", otherwise +# return +# +sub checkFile +{ + # The file. + my $file = $File::Find::name; + + # We don't care about directories + return if ( ! -f $file ); + + # See if it is a shell script. + my $isShell = 0; + + # Read the file. + open( INPUT, "<", $file ); + foreach my $line ( ) + { + if ( ( $line =~ /\/bin\/sh/ ) || + ( $line =~ /\/bin\/bash/ ) ) + { + $isShell = 1; + } + } + close( INPUT ); + + # + # Return if it wasn't a perl file. + # + return if ( ! $isShell ); + + # + # Now run 'sh -n $file' to see if we pass the syntax + # check + # + my $retval = system( "sh -n $file 2>/dev/null >/dev/null" ); + + is( $retval, 0, "Shell script passes our syntax check: $file" ); +} diff -aruN xen-tools-export/tests/test-trailing-whitespace.t xen-tools-merge/tests/test-trailing-whitespace.t --- xen-tools-export/tests/test-trailing-whitespace.t 1970-01-01 00:00:00.000000000 +0000 +++ xen-tools-merge/tests/test-trailing-whitespace.t 2007-06-16 13:36:41.000000000 +0000 @@ -0,0 +1,61 @@ +#!/usr/bin/perl -w +# +# Test that every script in ./bin/ has no trailing whitespace. +# +# Steve +# -- +# $Id: test-trailing-whitespace.t,v 1.1 2007-06-16 13:36:41 steve Exp $ + + +use strict; +use File::Find; +use Test::More qw( no_plan ); + + +# +# Find our bin/ directory. +# +my $dir = undef; + +$dir = "./bin/" if ( -d "./bin/" ); +$dir = "../bin/" if ( -d "../bin/" ); + +plan skip_all => "No bin directory found" if (!defined( $dir ) ); + + +# +# Process each file. +# +foreach my $file (sort( glob ( $dir . "*" ) ) ) +{ + # skip backups, and directories. + next if ( $file =~ /~$/ ); + next if ( -d $file ); + + ok( -e $file, "Found file : $file" ); + + checkFile( $file ); +} + + +# +# Check a file. +# +# +sub checkFile +{ + my( $file ) = (@_); + + my $trailing = 0; + + # Read the file. + open( INPUT, "<", $file ); + foreach my $line ( ) + { + $trailing = 1 if ( $line =~ /^(.*)[ \t]+$/ ) + } + close( INPUT ); + + is( $trailing, 0, "File has no trailing whitespace" ); +} + diff -aruN xen-tools-export/tests/xen-delete-image.t xen-tools-merge/tests/xen-delete-image.t --- xen-tools-export/tests/xen-delete-image.t 1970-01-01 00:00:00.000000000 +0000 +++ xen-tools-merge/tests/xen-delete-image.t 2006-06-13 13:26:01.000000000 +0000 @@ -0,0 +1,94 @@ +#!/usr/bin/perl -w +# +# Test that the xen-delete-image script will delete an images +# contents correctly. +# +# Steve +# -- +# $Id: xen-delete-image.t,v 1.4 2006-06-13 13:26:01 steve Exp $ +# + + +use strict; +use Test::More qw( no_plan ); +use File::Temp; + + +# +# Create a temporary directory. +# +my $dir = File::Temp::tempdir( CLEANUP => 1 ); +my $domains = $dir . "/domains"; + +# +# Test that we can make the directory. +# +ok ( -d $dir, "The temporary directory was created: $dir" ); + +# +# Create the domains directory. +# +ok ( ! -d $domains, "The temp directory doesn't have a domains directory." ); +mkdir( $domains, 0777 ); +ok ( -d $domains, "The temp directory now has a domains directory." ); + + +# +# Generate a random hostname. +# +my $hostname = join ( '', map {('a'..'z')[rand 26]} 0..17 ); +ok( ! -d $domains . "/" . $hostname, "The virtual hostname doesnt exist." ); + +# +# Make the hostname directory +# +mkdir( $domains . "/" . $hostname, 0777 ); +ok( -d $domains . "/" . $hostname, "The virtual hostname now exists." ); + + +# +# Create a stub disk image +# +open( IMAGE, ">", $domains . "/" . $hostname . "/" . "disk.img" ) + or warn "Failed to open disk image : $!"; +print IMAGE "Test"; +close( IMAGE ); + + +# +# Create a stub swap image +# +open( IMAGE, ">", $domains . "/" . $hostname . "/" . "swap.img" ) + or warn "Failed to open swap image : $!"; +print IMAGE "Test"; +close( IMAGE ); + + +# +# Now we have : +# +# $dir/ +# $dir/domains/ +# $dir/domains/$hostname +# $dir/domains/$hostname/disk.img +# $dir/domains/$hostname/swap.img +# +# So we need to run the deletion script and verify the images +# are removed correctly. +# +`./bin/xen-delete-image --test --dir=$dir $hostname`; + + +# +# If the deletion worked our images are gone. +# +ok( ! -e $domains . "/" . $hostname . "/" . "disk.img", + "Disk image deleted successfully." ); +ok( ! -e $domains . "/" . $hostname . "/" . "swap.img", + "Swap image deleted successfully." ); + +# +# And the hostname directory should have gone too. +# +ok( ! -d $domains . "/" . $hostname, + "The hostname directory was removed" ); diff -aruN xen-tools-export/tests/xen-lists-images.t xen-tools-merge/tests/xen-lists-images.t --- xen-tools-export/tests/xen-lists-images.t 1970-01-01 00:00:00.000000000 +0000 +++ xen-tools-merge/tests/xen-lists-images.t 2007-07-23 19:55:25.000000000 +0000 @@ -0,0 +1,137 @@ +#!/usr/bin/perl -w +# +# Test that the xen-list-images script can process two "fake" +# installations which we construct manually. +# +# +# Steve +# -- +# $Id: xen-lists-images.t,v 1.6 2007-07-23 19:55:25 steve Exp $ +# + + +use strict; +use Test::More qw( no_plan ); +use File::Temp; + + +# +# Test some random instances. +# +testRandomInstance( "foo.my.flat", 0 ); +testRandomInstance( "foo.my.flat", 1 ); + +testRandomInstance( "bar.my.flat", 0 ); +testRandomInstance( "bar.my.flat", 1 ); + +testRandomInstance( "baz.my.flat", 0 ); +testRandomInstance( "baz.my.flat", 1 ); + + + +=head2 testRandomInstance + + Create a fake Xen configuration file and test that the xen-list-images + script can work with it. + +=cut + +sub testRandomInstance +{ + my ( $name, $dhcp ) = ( @_ ); + + # Create a temporary directory. + my $dir = File::Temp::tempdir( CLEANUP => 1 ); + ok ( -d $dir, "The temporary directory was created for test: $name" ); + + + # + # Generate a random amount of memory + # + my $memory = int( rand( 4096 ) ); + + # + # Generate a random IP address. + # + my $ip = ''; + my $count = 0; + while( $count < 4 ) + { + $ip .= int( rand( 256 ) ) . "."; + + $count += 1; + } + + + # + # Write a xen configuration file to the temporary directory. + # + open( TMP, ">", $dir . "/foo.cfg" ); + + if ( $dhcp ) + { + print TMP < 1; +use File::Temp; + +use Xen::Tools::Log; + +my $dir = File::Temp::tempdir( CLEANUP => 1 ); + +my $xtl = Xen::Tools::Log->new( hostname => 'xen-tools-log-test', + logpath => $dir, + ); + +ok( $xtl->isa('Xen::Tools::Log') ); + diff -aruN xen-tools-export/tests/xen-tools.t xen-tools-merge/tests/xen-tools.t --- xen-tools-export/tests/xen-tools.t 1970-01-01 00:00:00.000000000 +0000 +++ xen-tools-merge/tests/xen-tools.t 2007-09-01 17:49:16.000000000 +0000 @@ -0,0 +1,11 @@ +#!perl -T + +use strict; +use warnings; +use Test::More tests => 1; + +use Xen::Tools; + +my $xt = Xen::Tools->new( hostname => 'xen-tools-test' ); + +ok( $xt->isa('Xen::Tools') ); diff -aruN xen-tools-export/tests/xt-create-xen-config.t xen-tools-merge/tests/xt-create-xen-config.t --- xen-tools-export/tests/xt-create-xen-config.t 1970-01-01 00:00:00.000000000 +0000 +++ xen-tools-merge/tests/xt-create-xen-config.t 2007-07-07 23:49:02.000000000 +0000 @@ -0,0 +1,224 @@ +#!/usr/bin/perl -w +# +# Test that calling xt-create-xen-config with the appropriate parameters +# results in output we expect. +# +# Steve +# -- +# $Id: xt-create-xen-config.t,v 1.5 2007-07-07 23:49:02 steve Exp $ +# + + +use strict; +use Test::More qw( no_plan ); +use File::Temp; + + +# +# What we basically do here is setup a collection of environmental +# variables, and then call the script. We then make a couple of simple +# tests against the output file which is written. +# +# + + +# +# Look for mention of DHCP when setting up DHCP, this conflicts with +# a static IP address. +# +testOutputContains( "dhcp", + memory => 128, dhcp => 1, dir => '/tmp' ); +noMentionOf( "ip=", + memory => 128, dhcp => 1, dir => '/tmp' ); + + +# +# Look for an IP address when specifying one, and make sure there +# is no mention of DHCP. +# +testOutputContains( "ip=192.168.1.1", + memory => 128, ip1 => '192.168.1.1', dir => '/tmp' ); +noMentionOf( "dhcp", + memory => 128, ip1 => '192.168.1.1', dir => '/tmp' ); + +# +# SCSI based systems: +# +testOutputContains( "sda1", + memory => 128, ip1 => '192.168.1.1', dir => '/tmp' ); +testOutputContains( "/dev/sda1 ro", + memory => 128, ip1 => '192.168.1.1', dir => '/tmp' ); +noMentionOf( "hda1", + memory => 128, ip1 => '192.168.1.1', dir => '/tmp' ); + + +# +# IDE based systems +# +testOutputContains( "hda1", + memory => 128, ip1 => '192.168.1.1', dir => '/tmp', ide => 1 ); +testOutputContains( "/dev/hda1 ro", + memory => 128, ip1 => '192.168.1.1', dir => '/tmp', ide => 1 ); + + + +# +# Test memory size. +# +testOutputContains( "128", + memory => 128, dhcp => 1, dir => '/tmp' ); +testOutputContains( "211", + memory => 211, dhcp => 1, dir => '/tmp' ); +testOutputContains( "912", + memory => 912, dhcp => 1, lvm => 'skx-vg0' ); + + +# +# Test LVM stuff. +# +testOutputContains( "phy:", + memory => 128, dhcp => 1, lvm => 'skx-vg0' ); +testOutputContains( "skx-vg0", + memory => 128, dhcp => 1, lvm => 'skx-vg0' ); +noMentionOf( "/tmp", + memory => 128, dhcp => 1, lvm => 'skx-vg0' ); +noMentionOf( "domains", + memory => 128, dhcp => 1, lvm => 'skx-vg0' ); + + +# +# Now test the loopback devices. +# +testOutputContains( "/tmp", + memory => 128, dhcp => 1, dir => '/tmp' ); +testOutputContains( "/tmp/domains", + memory => 128, dhcp => 1, dir => '/tmp' ); +testOutputContains( "/tmp/domains/foo.my.flat", + memory => 128, dhcp => 1, dir => '/tmp' ); +noMentionOf( "phy:", + memory => 128, dhcp => 1, dir => '/tmp' ); + + + + + + + + +=head2 runCreateCommand + + Run the xt-create-xen-config command and return the output. + + This involves setting up the environment and running the command, + once complete return the text which has been written to the xen + configuration file. + +=cut + +sub runCreateCommand +{ + my ( %params ) = ( @_ ); + + # + # Force a hostname + # + $params{'hostname'} = 'foo.my.flat'; + $params{'noswap'} = 1; + + # + # Create a temporary directory, and make sure it is present. + # + my $dir = File::Temp::tempdir( CLEANUP => 0 ); + ok ( -d $dir, "The temporary directory was created: $dir" ); + + # + # Save the environment. + # + my %SAFE_ENV = %ENV; + + # + # Update the environment with our parameters. + # + foreach my $p ( keys %params ) + { + $ENV{$p} = $params{$p}; + } + + # + # Run the command + # + system( "./bin/xt-create-xen-config --output=$dir --template=./etc/xm.tmpl" ); + + # + # Reset the environment + # + %ENV = %SAFE_ENV; + + + + # + # Read the Xen configuration file which the xt-creaat... + # command wrote and return it to the caller. + # + open( OUTPUT, "<", $dir . "/foo.my.flat.cfg" ); + my @LINES = ; + close( OUTPUT ); + + return( join( "\n", @LINES ) ); +} + + + +=head2 testOutputContains + + Run the xt-create-xen-config and ensure that the output + contains the text we're looking for. + +=cut + +sub testOutputContains +{ + my ( $text, %params ) = ( @_ ); + + # Get the output of running the command. + my $output = runCreateCommand( %params ); + + # + # Look to see if we got the text. + # + my $found = 0; + if ( $output =~ /\Q$text\E/ ) + { + $found += 1; + } + + ok( $found > 0, "We found the output we wanted: $text" ); +} + + +=head2 noMentionOf + + Make sure that the creation of a given Xen configuration + file contains no mention of the given string. + +=cut + +sub noMentionOf +{ + my ( $text, %params ) = ( @_ ); + + # Get the output of running the command. + my $output = runCreateCommand( %params ); + + # + # Look to see if we got the text. + # + my $found = 0; + if ( $output =~ /\Q$text\E/ ) + { + $found += 1; + } + + ok( $found == 0, "The output didn't contain the excluded text: $text" ); + +}