http://runtime.bordeaux.inria.fr/oaumage/oa/Teaching/ARSA_06/Umlnet/umlnet.pl
#!/usr/bin/perl -w
##################
# Strict Perl checking
use strict;
# Import usleep
use Time::HiRes qw( usleep );
# Settings
my $do_debug = 0;
my $do_log = 1;
my $do_trace = 1;
my $do_exec = 1;
my $do_use_konsole = 1;
# Libs
unshift @INC, "/lib/umlnet";
unshift @INC, "/usr/lib/umlnet";
unshift @INC, "/usr/local/lib/umlnet";
# Obtain user name
my $user_name;
if (exists $ENV{'USER'} and defined $ENV{'USER'}) {
$user_name = ${ENV{'USER'}};
}
# Obtain the home dir
my $home_dir;
# -I~/.umlnet
#
if (exists $ENV{'HOME'} and defined $ENV{'HOME'} and -d "$ENV{'HOME'}") {
$home_dir = ${ENV{'HOME'}};
unshift @INC, "${home_dir}/.umlnet";
}
# Import the umlnet library shared with UML nodes
my $umlnet_lib_module = 'Umlnet_Lib.pm';
require $umlnet_lib_module;
my $umlnet_lib_path = $INC{$umlnet_lib_module};
# UML tools control points
my $uml_switch = '/usr/bin/uml_switch';
my $uml_switch_ctl = '/var/run/uml-utilities/uml_switch.ctl';
my $uml_socket_dir = '/tmp';
# Script usage information
sub usage {
print "usage: net.pl <net.cfg>\n";
exit 1;
}
usage if $#ARGV < 0;
usage if $#ARGV > 1;
# Get configuration filename from command line and try to open it
my $cfg_filename = shift @ARGV;
open (my $cfg_fd, "< $cfg_filename") or die "open $cfg_filename: $!\n";
# Parse the configuration file into a hash, and close it
my $cfg_href = Umlnet_Lib::parse_config($cfg_fd);
close $cfg_fd;
#
# Check if the config file has the required sections and fields, and cache the important values
# 'main' section
if (!exists ${$cfg_href}{"main"}) {
die "no 'main' section found\n";
}
my $main_section = ${$cfg_href}{"main"};
# 'kernel' field (path to kernel file)
if (!exists ${$main_section}{"kernel"}) {
die "no 'kernel' property found in main section\n";
}
my $kernel = ${$main_section}{"kernel"};
# 'img' field (path to disk image)
if (!exists ${$main_section}{"img"}) {
die "no 'img' property found in main section\n";
}
my $img = ${$main_section}{"img"};
# 'networks' field (list of networks)
if (!exists ${$main_section}{"networks"}) {
die "no 'networks' property found in main section\n";
}
#
# session variables
# network names
my @network_ids = split (',', ${$main_section}{"networks"});
# host names
my @host_ids;
# hosts entries
my %hosts_h;
# switch processes
my %switch_ps;
# host processes
my %host_ps;
# Konsole processes
my %konsole_ps;
#
# Process the network entries, and launch the corresponding switches
foreach my $net_id (@network_ids) {
$do_log and print "network: $net_id\n";
# current network section
if (!exists ${$cfg_href}{$net_id}) {
die "no $net_id section found\n";
}
my $section = ${$cfg_href}{$net_id};
# switch entry
# - standalone: a new uml_switch process will be launched for this network
# - default: the network will use the default system-wide uml_switch (possible connected
# to the Internet
if (!exists ${$section}{"switch"}) {
die "no 'switch' property found in $net_id section\n";
}
my $switch = ${$section}{"switch"};
# 'hosts' entry (list of hosts in this network)
if (!exists ${$section}{"hosts"}) {
die "no 'hosts' property found in $net_id section\n";
}
my @net_host_ids = split (',',${$section}{"hosts"});
# Process the host entries for this network
foreach my $host_id (@net_host_ids) {
# Check if the host has not already been encountered on another host
if (exists $hosts_h{$host_id}) {
my $net_a = ${$hosts_h{$host_id}}{"network_ids"};
push @{$net_a}, $net_id;
$do_log and print "host $host_id also found on net $net_id\n";
next;
}
# Check if the host section exists
if (!exists ${$cfg_href}{$host_id}) {
die "no $host_id section found\n";
}
# Mark the host as already encountered
$hosts_h{$host_id} = ${$cfg_href}{$host_id};
my $net_a = [ $net_id ];
${$hosts_h{$host_id}}{"network_ids"} = $net_a;
push @host_ids, $host_id;
$do_log and print "new host $host_id found on net $net_id\n";
}
# Launch the switches
if ($switch eq "default") {
# nothing to do
} elsif ($switch eq "standalone") {
my $cmdline;
my @args;
# Build and store the pathname of the UNIX socket connected to the switch
my $uml_socket = "${uml_socket_dir}/${user_name}${net_id}";
${$section}{"switch_socket"} = $uml_socket;
# Select whether the uml_switch should emulate a hub or a regular switch
my $type;
if (exists ${$section}{"type"}) {
$type = ${$section}{"type"};
}
# Build the command line for launching the switch process
push @args, "$uml_switch";
if (defined $type) {
if ($type eq 'hub') {
push @args, '-hub'
} else {
die "parse error: switch type\n" unless ($type eq 'switch');
}
}
push @args, '-unix';
push @args, "${uml_socket}";
# push @args, "-daemon";
$do_trace and print "Launching a standalone switch for network ${net_id}\n";
$cmdline = join(' ', @args);
$do_log and print "$cmdline\n";
# Fork the process and exec the uml_switch
my $child_pid = fork;
if (!defined $child_pid) {
print STDERR "WARNING: fork failed: $!\n";
next;
}
if ($child_pid) {
# Father
$do_log and print "father: switch child: ${child_pid}\n";
$switch_ps{$child_pid} = $net_id;
} else {
# Child
$do_log and print "switch child\n";
if ($do_exec) {
usleep(100);
exec { $args[0] } @args or die "couldn't exec $args[0]: $!";
}
exit 0;
}
} else {
die "invalid switch type: $switch\n";
}
}
$do_log and print "\n";
# Launch the host processes
foreach my $host_id (@host_ids) {
my $section = $hosts_h{$host_id}; # cache a ref to the current host section
my $host_network_ids = ${$section}{"network_ids"}; # Networks
my $cow = "$img.$host_id"; # copy-on-write diff img
my @args;
my $cmdline;
my $gdb;
my $gdb_filename = "/tmp/gdb_cfg";
# Check if a gdb session should be attached to this host
if (exists ${$section}{"gdb"}) {
$gdb = ${$section}{"gdb"};
}
# Start building the command line
push @args, $kernel; # Kernel file
push @args, "host_id=${host_id}"; # host identification
# user name
if (defined $user_name) {
push @args, "user_name=${user_name}";
}
# home directory
if (defined $home_dir) {
push @args, "home_dir=${home_dir}";
}
# Fork/exec a Konsole process if we use KDE konsoles
my $kpid;
if ($do_use_konsole) {
$kpid = fork();
if (!defined $kpid) {
print STDERR "WARNING: fork failed: $!\n";
next;
}
if ($kpid) {
# Father
$do_log and print "father: konsole child: ${kpid}\n";
$konsole_ps{$kpid} = $kpid;
} else {
# Child
exec "konsole --noclose --type umlnet --script" or die "couldn't exec konsole: $!";
}
}
push @args, 'con0=xterm'; # terminal type of console 0
# push @args, 'con0=fd:0,fd:1';
push @args, 'con=xterm'; # terminal type of other consoles
# If we use KDE konsoles, we modify the 'xterm' terminal launching command to call
# our helper instead
#
# Note: there must not be any whitespace between -H${host_id} and -T
if ($do_use_konsole) {
push @args, "xterm=umlnet_konsole_helper.pl,-H${host_id}-T";
}
# Plug the image and copy-on-write private diff onto UML virtual disk device ubd0
push @args, "ubd0=${cow},${img}";
# Plug the umlnet library onto UML virtual disk ubd6 (read-only)
push @args, "ubd6r=${umlnet_lib_path}";
# Plug the user supplied configuration file onto UML virtual disk ubd7 (read-only)
push @args, "ubd7r=${cfg_filename}";
# Set the session name
push @args, 'session=umlnet';
# Process the host configuration for the various networks it belongs to
foreach my $net_id (@$host_network_ids) {
# Check if the corresponding network section exists
if (!exists ${$section}{$net_id}) {
die "no $net_id property found in $host_id section\n";
}
# Get the network config line for this host
my $host_net = ${$section}{$net_id};
# Extract the various fields of the network config line
#
# eth_num: network interface name
# eth_addr: hardware address of the interface (or suffix of the HW addr)
# ip: either 'dhcp' or the IPv4 address (or suffix of the IP addr)
# gw (optionnal): IPv4 address (or suffix) of the gateway
#
# suffixes may be specified instead of full addresses if (and only if) a
# corresponding prefix is specified in the network section
my ($eth_num, $eth_addr, $ip,) = split (',', $host_net);
# Cache the network section
my $net_section = ${$cfg_href}{$net_id};
# Get the switch type
my $switch = ${$net_section}{'switch'};
# If a HW addr prefix is in use for the network, merge the HW net prefix
# and the HW host suffix
if (exists ${$net_section}{'hw_addr_prefix'}) {
my $net_eth = ${$net_section}{'hw_addr_prefix'};
$eth_addr = Umlnet_Lib::eth_net($eth_addr, $net_eth);
}
# Connect the network interface to the uml_switch
if ($switch eq 'default') {
push @args, "${eth_num}=daemon,${eth_addr},unix,${uml_switch_ctl}";
} elsif ($switch eq "standalone") {
my $uml_socket = ${$net_section}{"switch_socket"};
push @args, "${eth_num}=daemon,${eth_addr},unix,${uml_socket}";
}
}
# Clean-up any former private copy-on-write diff file
$cmdline = "rm -fv ${cow}";
$do_log and print "$cmdline\n";
system($cmdline) == 0
or die "system $cmdline failed: $?";
# Fork and exec the host process
$do_trace and print "Launching host ${host_id}\n";
$cmdline = join(' ', @args);
$do_log and print "$cmdline\n";
my $child_pid = fork;
if (!defined $child_pid) {
print STDERR "WARNING: fork failed: $!\n";
next;
}
if ($child_pid) {
# Father
$do_log and print "father: host child: ${child_pid}\n";
$host_ps{$child_pid} = $host_id;
} else {
# Child
$do_log and print "host child\n";
if ($do_use_konsole) {
# If we use Konsole, we leave some time for dcop to connect to the Konsole process
my $retries = 5;
$ENV{'KPID'} = $kpid;
while ($retries) {
$retries --;
system "dcop konsole-${kpid} session-1 renameSession umlnet";
if ($? == -1) {
print "renameSession failed to execute: $!\n";
}
elsif ($? & 127) {
printf "renameSession child died with signal %d, %s coredump\n",
($? & 127), ($? & 128) ? 'with' : 'without';
}
else {
my $v = $? >> 8;
if ($v) {
printf "renameSession child exited with value %d\n", $v;
} else {
last;
}
}
sleep(1);
print "retrying dcop call\n";
}
}
# NPTL incompatibility workaround
$ENV{'LD_ASSUME_KERNEL'} = '2.4.1';
if ($do_exec) {
usleep(100);
# Actually exec the command, either inside a GDB/Emacs session, or simply alone
if (defined $gdb and $gdb) {
# GDB case
my @gdb_args;
# Build a config file for gdb
open (my $gdb_fd, "> ${gdb_filename}")
or die "open $gdb_filename: $!\n";
# Disable handling of SIGSEGV signals which are used by UML
print $gdb_fd "handle SIGSEGV pass nostop noprint\n"
or die "print to $gdb_filename: $!\n";
# Disable handling of SIGUSR1 signals which are used by UML
print $gdb_fd "handle SIGUSR1 pass nostop noprint\n"
or die "print to $gdb_filename: $!\n";
# Write the kernel command line args with proper double-quoting
my $_kernel = shift @args;
print $gdb_fd "set args \""
or die "print to $gdb_filename: $!\n";
print $gdb_fd (join '" "', @args)
or die "print to $gdb_filename: $!\n";
print $gdb_fd "\""
or die "print to $gdb_filename: $!\n";
# Close the gdb config gile
close $gdb_fd
or die "close $gdb_filename: $!\n";
# Build the actual command line
#push @gdb_args, 'xterm';
#push @gdb_args, '-e';
#push @gdb_args, 'echo';
#push @gdb_args, '--';
push @gdb_args, 'emacs';
push @gdb_args, '--execute';
# Note: we launch gdb inside emacs through a Emacs-Lisp command-line call
my $wd = `pwd`;
push @gdb_args, "(gdb \"gdb $_kernel -cd $wd -x $gdb_filename\")";
#push @gdb_args, "'(";
#push @gdb_args, 'gdb';
#push @gdb_args, '"';
#push @gdb_args, "$_kernel";
#push @gdb_args, '-x';
#push @gdb_args, "$gdb_filename";
#push @gdb_args, '"';
#push @gdb_args, ")'";
print ((join ' ', @gdb_args), "\n");
exec { $gdb_args[0] } @gdb_args or die "couldn't exec $gdb_args[0]: $!";
} else {
exec { $args[0] } @args or die "couldn't exec $args[0]: $!";
}
}
exit 0;
}
}
# Wait for the host child processes to complete
while (%host_ps) {
# at least one active child process
my $pid = wait;
if ($pid == -1) {
# all our childs have disappeared
%host_ps = ();
%switch_ps = ();
}
if (exists $host_ps{$pid}) {
# the deceased child was a host child
my $host_id = $host_ps{$pid};
$do_trace and print "host $host_id completed\n";
$do_log and print "deleting host process $pid\n";
delete $host_ps{$pid};
} elsif (exists $switch_ps{$pid}) {
# the deceased child was a switch child
my $net_id = $switch_ps{$pid};
$do_trace and print "standalone switch for network $net_id completed\n";
$do_log and print "deleting switch process $pid\n";
delete $switch_ps{$pid};
} elsif (exists $konsole_ps{$pid}) {
delete $konsole_ps{$pid};
} else {
print STDERR "WARNING: unknown deceased child: pid = $pid\n";
}
}
# Terminates remaining switch processes if any
while (%switch_ps) {
my @pid_list = keys %switch_ps;
my $pid = shift @pid_list;
my $net_id;
kill 15, $pid or die "kill 15, $pid\n";
kill 9, $pid or die "kill 9, $pid\n";
while ( (my $_pid = wait) != $pid ) {
if (exists $switch_ps{$_pid}) {
$net_id = $switch_ps{$_pid};
$do_trace and print "standalone switch for network $net_id completed\n";
$do_log and print "deleting early deceased switch process $_pid\n";
delete $switch_ps{$_pid};
} else {
print STDERR "WARNING: unknown deceased child: pid = $pid\n";
}
}
$net_id = $switch_ps{$pid};
$do_trace and print "standalone switch for network $net_id completed\n";
$do_log and print "deleting killed switch process $pid\n";
delete $switch_ps{$pid};
}
# Terminates remaining konsole processes if any
#if ($do_use_konsole) {
# foreach my $kpid (keys %konsole_ps) {
# system "dcop konsole-${kpid} MainApplication-Interface quit";
# delete $konsole_ps{$kpid};
# }
#}
