### Local Variables: ***
### mode:perl ***
### comment-column:0 ***
### comment-start: "### " ***
### comment-end: "***" ***
### End: ***
#
# ****************DO NOT MOVE OR CHANGE LINES ABOVE THIS*********************
#
# The first set of lines runs perl from any shell. The second set of lines
# identifies the rest of the file as PERL for EMACS autoformatting.
# See end of copyright for more information.
#
#
# -------------------------------------------------------------------
# X-BONE
#
# http://www.isi.edu/xbone
# USC Information Sciences Institute (USC/ISI)
# Marina del Rey, California 90292, USA
# Copyright (c) 1998-2005
#
# -------------------------------------------------------------------
#
# Copyright (c) 1998-2005 by the University of Southern California.
# All rights reserved.
#
# Permission to use, copy, modify, and distribute this software and
# its documentation in source and binary forms for non-commercial
# purposes and without fee is hereby granted, provided that the above
# copyright notice appear in all copies and that both the copyright
# notice and this permission notice appear in supporting
# documentation, and that any documentation, advertising materials,
# and other materials related to such distribution and use acknowledge
# that the software was developed by the University of Southern
# California, Information Sciences Institute. The name of the
# University may not be used to endorse or promote products derived
# from this software without specific prior written permission.
#
# THE UNIVERSITY OF SOUTHERN CALIFORNIA MAKES NO REPRESENTATIONS ABOUT
# THE SUITABILITY OF THIS SOFTWARE FOR ANY PURPOSE. THIS SOFTWARE IS
# PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES,
# INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
# MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
# Other copyrights might apply to parts of this software and are so
# noted when applicable.
#
# -------------------------------------------------------------------
#
# Effort partly sponsored by the Defense Advanced Research Projects
# Agency (DARPA) and Air Force Research Laboratory, Air Force Materiel
# Command, USAF, under agreement numbers F30602-98-1-0200 (X-Bone) and
# F30602-01-2-0529 (DynaBone). The views and conclusions contained
# herein are those of the authors and should not be interpreted as
# necessarily representing the official policies or endorsements,
# either expressed or implied, of the Defense Advanced Research
# Projects Agency (DARPA), the Air Force Research Laboratory, or the
# U.S. Government.
#
# This work was partly supported by the NSF STI-XTEND (ANI-0230789)
# and NETFS (ANI-0129689) projects. Any opinions, findings, and
# conclusions or recommendations expressed in this material are those
# of the authors and do not necessarily reflect the views of the
# National Science Foundation.
#
# -------------------------------------------------------------------
# $RCSfile: XB_Dummynet.pm,v $
#
# $Revision: 1.21 $
# $Author: pingali $
# $Date: 2005/03/31 07:03:55 $
# $State: Exp $
# ----------------------------------------------------------------------------
#
# Primary Author: Nop Vanitcha
package XB_Dummynet;
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw();
@EXPORT_OK = qw(up down is_present);
use strict;
use sigtrap;
use XB_Params;
use XB_Route;
use XB_Log;
# Description:
# Add a dummynet pipe.
#
# Arguments:
# $l local address (outer header source)
# $r remote address (outer header destination)
# $n pipe number
# $dir direction
#
# Returns:
# -
#
# Exceptions:
# "XB_Dummynet::add_pipe" on error, nothing to clean up by caller
sub add_pipe ($$$$) {
my $proc = "XB_Dummynet::add_pipe";
XB_Log::log "info", "-> $proc: @_";
# this function is so simple, we don't need our normal exception magic
my ($l, $r, $n, $dir) = @_;
my @cmd = ("ipfw", "-q", "-f", "add", $n, "pipe", $n, "ip",
"from", $l, "to", $r, $dir);
# open SAVEOUT, ">&STDOUT"; open STDOUT, ">/dev/null"; # suppress STDOUT
# open SAVEERR, ">&STDERR"; open STDERR, ">/dev/null"; # suppress STDERR
XB_Log::log "debug6", "[$proc] executing @cmd ";
my $rc = 0xff & system(@cmd);
($rc == 0) or XB_Log::log "err",
"Unable to configure the traffic shaper. @cmd failed: $!" and die $proc;
# open STDERR, ">&SAVEERR"; # reenable STDERR
# open STDOUT, ">&SAVEOUT"; # reenable STDOUT
XB_Log::log "info", "<- $proc";
}
# Description:
# Delete a dummynet pipe.
#
# Arguments:
# $n pipe number (can be used as rule number)
#
# Returns:
# -
#
# Exceptions:
# "XB_Dummynet::delete_pipe" on error, nothing to clean up by caller
sub delete_pipe ($) {
my $proc = "XB_Dummynet::delete_pipe";
XB_Log::log "info", "-> $proc: @_";
# this function is so simple, we don't need our normal exception magic
my @cmd = ("ipfw", "-q", "-f", "delete", shift);
# open SAVEOUT, ">&STDOUT"; open STDOUT, ">/dev/null"; # suppress STDOUT
# open SAVEERR, ">&STDERR"; open STDERR, ">/dev/null"; # suppress STDERR
my $rc = 0xff & system(@cmd);
($rc == 0) or XB_Log::log "err",
"Unable to deconfigure the traffic shaper. @cmd failed: $!" and die $proc;
# open STDERR, ">&SAVEERR"; # reenable STDERR
# open STDOUT, ">&SAVEOUT"; # reenable STDOUT
XB_Log::log "info", "<- $proc";
}
# Description:
# Configure a dummynet pipe.
#
# Arguments:
# $n pipe number
# %args dummynet settings
#
# Returns:
# -
#
# Exceptions:
# "XB_Dummynet::config_pipe" on error, nothing to clean up by caller
sub config_pipe ($$) {
my $proc = "XB_Dummynet::config_pipe";
XB_Log::log "info", "-> $proc: @_";
# this function is so simple, we don't need our normal exception magic
my ($n, $args) = @_;
my @cmd = ("ipfw", "-q", "-f", "pipe", $n, "config");
if (defined $args->{delay}) { push @cmd, "delay", $args->{delay}; }
if (defined $args->{loss_rate}) { push @cmd, "plr", $args->{loss_rate}; }
if (defined $args->{bandwidth}) {
push @cmd, "bw", $args->{bandwidth}.$args->{bandwidth_unit};
}
if (defined $args->{queue}) {
push @cmd, "queue", $args->{queue}.$args->{queue_unit};
}
# open SAVEOUT, ">&STDOUT"; open STDOUT, ">/dev/null"; # suppress STDOUT
# open SAVEERR, ">&STDERR"; open STDERR, ">/dev/null"; # suppress STDERR
XB_Log::log "debug6", "[$proc] executing @cmd ";
my $rc = 0xff & system(@cmd);
($rc == 0) or XB_Log::log "err",
"Unable to configure the traffic shaper. @cmd failed: $!" and die $proc;
# open STDERR, ">&SAVEERR"; # reenable STDERR
# open STDOUT, ">&SAVEOUT"; # reenable STDOUT
XB_Log::log "info", "<- $proc";
}
# Description:
# Delete a dummynet pipe configuration.
#
# Arguments:
# $n pipe number (can be used as rule number)
#
# Returns:
# -
#
# Exceptions:
# "XB_Dummynet::delete_config_pipe" on error, nothing to clean
# up by caller
sub delete_config_pipe ($) {
my $proc = "XB_Dummynet::delete_config_pipe";
XB_Log::log "info", "-> $proc: @_";
# this function is so simple, we don't need our normal exception magic
my @cmd = ("ipfw", "-q", "-f", "pipe", "delete", shift);
# open SAVEOUT, ">&STDOUT"; open STDOUT, ">/dev/null"; # suppress STDOUT
# open SAVEERR, ">&STDERR"; open STDERR, ">/dev/null"; # suppress STDERR
XB_Log::log "debug6", "[$proc] executing @cmd ";
my $rc = 0xff & system(@cmd);
($rc == 0) or XB_Log::log "err",
"Unable to deconfigure the traffic shaper. @cmd failed: $!" and die $proc;
# open STDERR, ">&SAVEERR"; # reenable STDERR
# open STDOUT, ">&SAVEOUT"; # reenable STDOUT
XB_Log::log "info", "<- $proc";
}
# Description:
# Configure dummynet.
#
# Arguments:
# $l local virtual address (inner header source)
# $r remote virtual address (inner header destination)
# %args dummynet settings such as delay, bandwidth, loss probability.
#
# Returns:
# dummynet handle for FreeBSD
#
# Exceptions:
# "XB_Dummynet::up" on error, nothing to clean up by caller
sub up ($$$) {
my $proc = "XB_Dummynet::up";
XB_Log::log "info", "-> $proc: @_";
my ($l, $r, $args) = @_;
my @rules = ();
if ($XB_Params::node_opts{os} =~ /linux/i) {
eval {
my $cmd = "cnistnet -u";
my $rc = 0xff & system ($cmd);
($rc == 0) or XB_Log::log "err", "unable to configure nistnet".
" $cmd failed: $!" and die "nistnet";
# remove any rule from $r to $l
$cmd = "cnistnet -r $r $l";
$rc = 0xff & system ($cmd);
($rc == 0) or XB_Log::log "err", "unable to configure nistnet".
" $cmd failed: $!" and die "nistnet";
my $delay = $args->{delay};
$cmd = "cnistnet -a $r $l add new";
if (defined $args->{delay}) {$cmd = $cmd." --delay $delay";}
if (defined $args->{loss_rate}) {
my $lossrate = $args->{loss_rate}*100;
$cmd = $cmd." --drop $lossrate";
}
if (defined $args->{bandwidth}) {
if ($args->{bandwidth_unit} eq "Mbit/s") {
my $bandwidth = $args->{bandwidth}*1000/8;
$cmd = $cmd. " --bandwidth $bandwidth";
} elsif ($args->{bandwidth_unit} eq "bit/s") {
my $bandwidth = $args->{bandwidth}/8;
$cmd = $cmd." --bandwidth $bandwidth";
}
}
if (defined $args->{queue}) {
$cmd = $cmd. " --drd $args->{queue}, $args->{queue}";
}
XB_Log::log "debug6", "[$proc] executing $cmd ";
$rc = 0xff & system($cmd);
($rc == 0) or XB_Log::log "err", "unable to configure nistnet".
"$cmd failed: $!" and die "nistnet";
};
# exception handling
if ($@) {
unless($@ =~ /^nistnet/) {
# unknown exception caught, log and pass up a defined one
XB_Log::log "warning", "$proc: caught unexpected exception $@";
}
# pass defined exceptions up to caller
die $proc;
}
} else {
# Default (FreeBSD)
eval {
foreach my $x ([$l, $r, "out"], [$r, $l, "in"]) {
my ($a, $b, $dir) = @$x;
# We need to find an unused ipfw rule number for the new
# pipe rule. What we do is put all the used rule numbers
# into a hash, pick a random rule, and then search linearly
# from there upwards until we find an empty one. This only
# works well if the rule number table is sparsely populated
# (but much better than Nop's original scheme).
my %used_rules;
my $pipe = "ipfw -q -f pipe list |";
open PIPE, $pipe
or XB_Log::log "err",
"Unable to obtain traffic shaper information." .
"cannot open $pipe: $!" and die "open";
while(<PIPE>) { if(/^(\d+):/) { $used_rules{$1} = 1; } }
close PIPE
or XB_Log::log "err",
"Unable to obtain traffic shaper information.".
"cannot close $pipe: $!" and die "close";
# since we use pipe numbers as rule numbers, we need to find one
# that's unused in both
$pipe = "ipfw -q -f list |";
open PIPE, $pipe
or XB_Log::log "err",
"Unable to obtain traffic shaper information.".
"cannot open $pipe: $!" and die "open";
while(<PIPE>) { if(/^(\d+)\s/) { $used_rules{$1} = 1; } }
close PIPE
or XB_Log::log "err",
"Unable to configure traffic shaper. cleanup failed.".
"cannot close $pipe: $!" and die "close";
# starting at a random rule 0 <= n < 65535, look for an unused
# one and wrap around if needed
my $n = int rand 65535;
my $n_original = $n;
while(exists $used_rules{$n}) {
# wrap around if we hit the limit
if (++$n >= 65535) { $n = 0; }
# check if the number space is exhausted
if ($n == $n_original) {
XB_Log::log "err",
"Unable to configure the traffic shaper.".
"no available ipfw rule numbers" and die "rule";
}
}
# use rule number n for the pipe
eval {
add_pipe $a, $b, $n, $dir;
};
if ($@){
delete_pipe $n;
XB_Log::log "err", "Unable to configure traffic shaper. ".
"Error while creating a pipe";
die($@);
}
eval {
config_pipe $n, $args;
};
if ($@){
delete_config_pipe $n;
XB_Log::log "err", "Unable to configure traffic shaper. ".
"Error while configuring the pipe";
die($@);
}
# remember the rule number used, so we can create a tag below
push @rules, $n;
}
};
# exception handling
if ($@) {
unless($@ =~ /^(open|close|rule|XB_Dummynet::(add|config)_pipe)/) {
# unknown exception caught, log and pass up a defined one
XB_Log::log "warning", "$proc: caught unexpected exception $@";
}
# pass defined exceptions up to caller
die $proc;
}
}
XB_Log::log "info", "<- $proc";
return join ":", @rules unless $@; # success if no exception
}
# Description:
# Tear down dummynet pipe.
#
# Arguments:
# $tag tag (return value from corresponding XB_Dummynet::up)
#
# Returns:
# -
#
# Exceptions:
# "XB_Dummynet::down" on error, nothing to clean up by caller
sub down ($) {
my $proc = "XB_Dummynet::down";
XB_Log::log "info", "-> $proc";
# set if *any* error occurred - we don't throw exceptions during
# ::down, so we can take down as much as we can
my $failure = 0;
if ($XB_Params::node_opts{os} =~ /linux/i) {
# Linux OS
eval {
XB_Log::log "debug6", "execute cnistnet -d";
my $pipe = "cnistnet -d |";
open PIPE, $pipe
or XB_Log::log "err",
"Unable to obtain nistnet information." .
"cannot open $pipe:$!" and die "open";
while (<PIPE>) {
XB_Log::log "err", "nistnet is not sucessfully installed"
and die "nistnet";
}
close PIPE
or XB_Log::log "err",
"Unable to obtain nistnet information.".
"cannot close $pipe: $!" and die "close";
};
if ($@) {$failure = 1; XB_Log::log "info", "-> $@";}
} else {
# Default FreeBSD
# unwrap rule number from opaque dummynet tag
foreach my $n (split /:/, shift) {
eval { delete_pipe $n };
if ($@ =~ /^XB_Dummynet/) { $failure = 1; XB_Log::log "info", "-> $@";}
eval { delete_config_pipe $n };
if ($@ =~ /^XB_Dummynet/) { $failure = 1; XB_Log::log "info", "-> $@";}
}
}
XB_Log::log "info", "<- $proc";
return unless $failure; # success if no exception
# pass defined exceptions up to caller (no matter which one)
die $proc;
}
# Description:
# Check if Dummynet is available on a host.
# Arguments:
# -
# Returns:
# 1 if Dummynet is available, 0 otherwise.
# Exceptions:
# -
sub is_present () {
XB_Log::log "info", "-> XB_Dummynet::is_present";
my $proc = "XB_Dummynet::is_present";
my $result = 0;
if($XB_Params::node_opts{os} =~ /freebsd|kame/) {
# On FreeBSD, test for Dummynet by trying to read from the
# "net.inet.ip.dummynet.curr_time" sysctl switch. If that
# succeeds, Dummynet is present.
eval { $result = XB_Utils::sysctl_read "net.inet.ip.dummynet.curr_time" };
$result = defined $result;
}
elsif ($XB_Params::node_opts{os} =~ /linux/i) {
eval {
my $pipe = "which cnistnet |";
open PIPE, $pipe
or XB_Log::log "err", "Unable to obtain nistnet information." .
"cannot open $pipe:$!" and die "open";
my $path = <PIPE>;
if(defined $path) {
close PIPE or XB_Log::log "err",
"cannot close $pipe: $!" and die "close";
$result = 1 if ($path ne "");
}
};
if ($@) {
unless ($@ =~ /^(open|close)/) {
# unknown exception caught, log and pass up a defined one
XB_Log::log "warning", "$proc: caught unexpected exception $@";
}
die $proc;
}
}
XB_Log::log "info", "<- XB_Dummynet::is_present";
return $result;
}
1;
syntax highlighted by Code2HTML, v. 0.9.1