source/selftest/target/Kvm.pm

   1 #!/usr/bin/perl
   2 # Start a KVM machine and run a number of tests against it.
   3 # Copyright (C) 2005-2008 Jelmer Vernooij <jelmer@samba.org>
   4 # Published under the GNU GPL, v3 or later.
   5
   6 package Kvm;
   7
   8 use strict;
   9 use Cwd qw(abs_path);
  10 use FindBin qw($RealBin);
  11 use POSIX;
  12
  13 sub new($$$$) {
  14         my ($classname, $dc_image) = @_;
  15         my $self = {
  16                 dc_image => $dc_image,
  17         };
  18         bless $self;
  19         return $self;
  20 }
  21
  22 sub write_kvm_ifup($$$)
  23 {
  24         my ($self, $path, $ip_prefix) = @_;
  25         open(SCRIPT, ">$path/kvm-ifup");
  26
  27         print SCRIPT <<__EOF__;
  28 #!/bin/sh
  29
  30 PREFIX=$ip_prefix
  31
  32 /sbin/ifconfig \$1 \$PREFIX.1 up
  33
  34 cat <<EOF>$path/udhcpd.conf
  35 interface \$1
  36 start           \$PREFIX.20
  37 end             \$PREFIX.20
  38 max_leases 1
  39 lease_file      $path/udhcpd.leases
  40 pidfile $path/udhcpd.pid
  41 EOF
  42
  43 touch $path/udhcpd.leases
  44
  45 /usr/sbin/udhcpd $path/udhcpd.conf
  46
  47 exit 0
  48 __EOF__
  49         close(SCRIPT);
  50         chmod(0755, "$path/kvm-ifup");
  51
  52         return ("$path/kvm-ifup", "$path/udhcpd.pid", "$ip_prefix.20");
  53 }
  54
  55 sub teardown_env($$)
  56 {
  57         my ($self, $envvars) = @_;
  58
  59         print "Killing kvm instance $envvars->{KVM_PID}\n";
  60
  61         kill 9, $envvars->{KVM_PID};
  62
  63         print "Killing dhcpd instance $envvars->{DHCPD_PID}\n";
  64         kill 9, $envvars->{DHCPD_PID};
  65
  66         return 0;
  67 }
  68
  69 sub getlog_env($$)
  70 {
  71         my ($self, $envvars) = @_;
  72
  73         return "";
  74 }
  75
  76 sub check_env($$)
  77 {
  78         my ($self, $envvars) = @_;
  79
  80         # FIXME: Check whether $self->{pid} is still running
  81
  82         return 1;
  83 }
  84
  85 sub read_pidfile($)
  86 {
  87         my ($path) = @_;
  88
  89         open(PID, $path);
  90         <PID> =~ /([0-9]+)/;
  91         my ($pid) = $1;
  92         close(PID);
  93         return $pid;
  94 }
  95
  96 sub start($$$)
  97 {
  98         my ($self, $path, $image) = @_;
  99
 100         my $pidfile = "$path/kvm.pid";
 101
 102         my $opts = (defined($ENV{KVM_OPTIONS})?$ENV{KVM_OPTIONS}:"-nographic");
 103
 104         my ($ifup_script, $dhcpd_pidfile, $ip_address) = $self->write_kvm_ifup($path, "192.168.9");
 105
 106         system("kvm $opts -daemonize -pidfile $pidfile -snapshot $image -net nic -net tap,script=$ifup_script");
 107
 108         return (read_pidfile($pidfile), read_pidfile($dhcpd_pidfile), $ip_address);
 109 }
 110
 111 sub setup_env($$$)
 112 {
 113         my ($self, $envname, $path) = @_;
 114
 115         if ($envname eq "dc") {
 116                 ($self->{dc_pid}, $self->{dc_dhcpd_pid}, $self->{dc_ip}) = $self->start($path, $self->{dc_image});
 117
 118                 sub choose_var($$) {
 119                         my ($name, $default) = @_;
 120                         return defined($ENV{"KVM_DC_$name"})?$ENV{"KVM_DC_$name"}:$default;
 121                 }
 122
 123                 if ($envname eq "dc") {
 124                         return {
 125                                 KVM_PID => $self->{dc_pid},
 126                                 DHCPD_PID => $self->{dc_dhcpd_pid},
 127                                 USERNAME => choose_var("USERNAME", "Administrator"),
 128                                 PASSWORD => choose_var("PASSWORD", "penguin"),
 129                                 DOMAIN => choose_var("DOMAIN", "SAMBA"),
 130                                 REALM => choose_var("REALM", "SAMBA"),
 131                                 SERVER => choose_var("SERVER", "DC"),
 132                                 SERVER_IP => $self->{dc_ip},
 133                                 NETBIOSNAME => choose_var("NETBIOSNAME", "DC"),
 134                                 NETBIOSALIAS => choose_var("NETBIOSALIAS", "DC"),
 135                         };
 136                 } else {
 137                         return undef;
 138                 }
 139         } else {
 140                 return undef;
 141         }
 142 }
 143
 144 sub stop($)
 145 {
 146         my ($self) = @_;
 147 }
 148
 149 1;