Commit bf8dd3d2 authored by Christopher Alfeld's avatar Christopher Alfeld
Browse files

Ported postparse.tcl to PERL and updated GNUmakefile

parent 48c336f4
......@@ -7,7 +7,7 @@ include ../../GNUmakerules
#
# These get installed with .tcl extensions.
#
SCRIPTS = event.tcl parse.tcl stubs.tcl link.tcl postparse.tcl \
SCRIPTS = event.tcl parse.tcl stubs.tcl link.tcl postparse \
tcl-object.tcl node.tcl sim.tcl
all:
......
#!/usr/bin/perl -w
# This handles some of the TB commands.
# TB commands handled:
# set-hardware
# set-link-loss
push(@INC,"./ir");
#/usr/testbed/lib/tbsetup/ir");
require libir;
if ($#ARGV != 1) {
die "Syntax: $0 ns_file ir_file";
}
($nsfile,$irfile) = @ARGV;
&ir_read($irfile);
# Read in nodes from ir file.
@nodes = split("\n",&ir_get("/topology/nodes"));
open(NSFILE,$nsfile) || die "Could not open $nsfile\n";
# hwtype is indexed by node and contains the type
# linkloss is indexed by src:dst and contains the loss rate
while (<NSFILE>) {
/^\#TB/ || next;
chop;
@line = split;
if ($line[1] eq "set-hardware") {
# hwtype(node) = type
$hwtype{$line[2]} = $line[3];
} elsif ($line[1] eq "set-link-loss") {
# linkloss(src:dst) = loss
$linkloss{"$line[2]:$line[3]"} = $line[4];
}
}
close(NSFILE);
# Set hardware types
@newnodes = ();
foreach (@nodes) {
($name,$type,@links) = split;
if (defined($hwtype{$name})) {
$type = $hwtype{$name};
}
push(@newnodes,"$name $type " . join(" ",@links));
}
&ir_set("/topology/nodes",join("\n",@newnodes) . "\n");
# Set link loss
@links = split("\n",&ir_get("/topology/links"));
@newlinks = ();
foreach (@links) {
@info = split;
$src = $info[1];
$dst = $info[3];
if (defined($linkloss{$src . ":" . $dst})) {
push(@newlinks,"$_ " . $linkloss{$src . ":" . $dst});
} else {
push(@newlinks,"$_ 0.0");
}
}
&ir_set("/topology/links",join("\n",@newlinks) . "\n");
&ir_write($irfile);
#!/usr/local/bin/tclsh
### Bootstrapping code. The whole purpose of this is to find the
# directory containing the script.
set file [info script]
while {![catch "file readlink $file" newfile]} {
set file $newfile
}
set scriptdir [file dirname $file]
if {$scriptdir == "."} {set scriptdir [pwd]}
###
source $scriptdir/../ir/libir.tcl
namespace import TB_LIBIR::ir
if {$argc != 2} {
puts "usage: $argv0 ns_file ir_file"
exit 1
}
set nsfile [lindex $argv 0]
set irfile [lindex $argv 1]
ir read $irfile
set nodes [ir get /topology/nodes]
if {[catch "open $nsfile r" nsFP]} {
puts stderr "ERROR opening $nsfile ($nsFP)."
exit 1
}
while {[gets $nsFP line] >= 0} {
if {[regexp {^#TB} $line] == 1} {
set cmd [lindex $line 1]
if {$cmd == "set-hardware"} {
set node [lindex $line 2]
set type [lindex $line 3]
# XXX currently only shark-shelf supported
set hwtype($node) $type
} elseif {$cmd == "set-link-loss"} {
set src [lindex $line 2]
set dst [lindex $line 3]
set loss [lindex $line 4]
set linkloss($src:$dst) $loss
}
}
}
close $nsFP
set newnodes {}
foreach node $nodes {
set name [lindex $node 0]
set type [lindex $node 1]
set links [lrange $node 2 end]
if {[info exists hwtype($name)]} {
set type $hwtype($name)
}
lappend newnodes [concat $name $type $links]
}
ir set /topology/nodes $newnodes
set links [ir get /topology/links]
set newlinks {}
foreach link $links {
set src [lindex $link 1]
set dst [lindex $link 3]
if {[info exists linkloss($src:$dst)]} {
lappend newlinks [concat $link $linkloss($src:$dst)]
} else {
lappend newlinks [concat $link 0.0]
}
}
ir set /topology/links $newlinks
ir write $irfile
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment