Commit 8b418535 authored by Christopher Alfeld's avatar Christopher Alfeld

parse.tcl has a few minor fixes and copies in the tb_compat.tcl file now.

postparse now uses tbcmds
sim.tcl is updated to close (and flush) the tbcmds output stream if it
exists.
tb_compat.tcl is the TB version that should be included by newstyle ns scripts.
tb_compat_nop.tcl is the NS version that should be renamed to tb_compat.tcl
and included by scripts when they are run under ns.  I.e. scripts
	source tb_compat.tcl
as the first line and then use either the TB or the NS (nop) version depending
on what they are doing.
parent 7e7f5a14
......@@ -9,7 +9,8 @@ SUBDIR = tbsetup/ns2ir
include $(OBJDIR)/Makeconf
LIB_STUFF = event.tcl stubs.tcl link.tcl \
tcl-object.tcl node.tcl sim.tcl lan.tcl
tcl-object.tcl node.tcl sim.tcl lan.tcl \
tb_compat.tcl
LIBEXEC_STUFF = parse.tcl postparse
#
......
......@@ -11,6 +11,7 @@ set irfile [lindex $argv 2]
set tbroot @prefix@
set libdir @prefix@/lib/ns2ir
set tbcompat "$libdir/tb_compat.tcl"
source $libdir/tcl-object.tcl
source $libdir/node.tcl
source $libdir/link.tcl
......@@ -84,5 +85,7 @@ source $libdir/sim.tcl
source $libdir/stubs.tcl
set prefix $id
source $nsfile
# Copy in tb_compat.tcl
file copy -force $tbcompat [file dirname $nsfile]
source $nsfile
......@@ -16,11 +16,11 @@ push(@INC, $IRLIB);
require libir;
if ($#ARGV != 1) {
print STDERR "Syntax: $0 ns_file ir_file\n";
print STDERR "Syntax: $0 tbcmds_file ir_file\n";
exit(1);
}
($nsfile,$irfile) = @ARGV;
($tbcmdfile,$irfile) = @ARGV;
use DBI;
......@@ -84,36 +84,40 @@ while (@row = $sth->fetchrow_array) {
}
$sth->finish;
open(NSFILE,$nsfile) || do {
open(TBCMD,$tbcmdfile) || do {
print STDERR "Could not open $nsfile\n";
exit(1);
};
# hwtype is indexed by node and contains the type
# linkloss is indexed by src:dst and contains the loss rate
while (<NSFILE>) {
/^\#TB/ || next;
while (<TBCMD>) {
chop;
@line = split;
if ($line[1] eq "set-hardware") {
if ($#line != 3) {
if ($line[0] eq "tb-set-hardware") {
if ($#line != 2) {
print "!\n";
push(@ERRORS,"Syntax: set-hardware node type");
push(@ERRORS,"Syntax: tb-set-hardware node type");
next;
}
if (! defined($nodes{$line[2]})) {
push(@ERRORS,"$line[2] is not a valid node.");
if (! defined($nodes{$line[1]})) {
push(@ERRORS,"$line[1] is not a valid node.");
next;
}
if (! defined($hwtypes{$line[3]})) {
push(@ERRORS,"$line[3] is not a valid hw type.");
if (! defined($hwtypes{$line[2]})) {
push(@ERRORS,"$line[2] is not a valid hw type.");
next;
}
# hwtype(node) = type
$hwtype{$line[2]} = $line[3];
} elsif ($line[1] eq "set-link-loss") {
if ($#line != 4) {
push(@ERRORS,"Syntax: set-link-loss src dst loss_rate");
$hwtype{$line[1]} = $line[2];
} elsif ($line[0] eq "tb-set-link-loss") {
if ($#line != 3) {
push(@ERRORS,"Syntax: tb-set-link-loss src dst loss_rate");
next;
}
if ((! defined($nodes{$line[1]})) &&
(! defined($lans{$line[1]}))) {
push(@ERRORS,"$line[1] is not a valid node.");
next;
}
if ((! defined($nodes{$line[2]})) &&
......@@ -121,44 +125,39 @@ while (<NSFILE>) {
push(@ERRORS,"$line[2] is not a valid node.");
next;
}
if ((! defined($nodes{$line[3]})) &&
(! defined($lans{$line[3]}))) {
push(@ERRORS,"$line[3] is not a valid node.");
next;
}
if (! defined($links{"$line[2]:$line[3]"})) {
push(@ERRORS,"No link between $line[2] and $line[3]");
if (! defined($links{"$line[1]:$line[2]"})) {
push(@ERRORS,"No link between $line[1] and $line[2]");
next;
}
if ( ((! ($line[4] =~ /^[0-9]+(\.[0-9]+)?$/)) &&
(! ($line[4] =~ /^\.[0-9]+$/))) ||
($line[4] < 0) || ($line[4] > 1)) {
push(@ERRORS,"$line[4] not between 0.0 and 1.0");
if ( ((! ($line[3] =~ /^[0-9]+(\.[0-9]+)?$/)) &&
(! ($line[3] =~ /^\.[0-9]+$/))) ||
($line[3] < 0) || ($line[3] > 1)) {
push(@ERRORS,"$line[3] not between 0.0 and 1.0");
next;
}
# linkloss(src:dst) = loss
$linkloss{"$line[2]:$line[3]"} = $line[4];
} elsif ($line[1] eq "set-lan-loss") {
if ($#line != 3) {
push(@ERRORS,"Syntax: set-lan-loss lan loss_rate");
$linkloss{"$line[1]:$line[2]"} = $line[4];
} elsif ($line[1] eq "tb-set-lan-loss") {
if ($#line != 2) {
push(@ERRORS,"Syntax: tb-set-lan-loss lan loss_rate");
} else {
if (! defined($lans{$line[2]})) {
push(@ERRORS,"$line[2] is not a valid lan.");
if (! defined($lans{$line[1]})) {
push(@ERRORS,"$line[1] is not a valid lan.");
next;
}
if ( ((! ($line[3] =~ /^[0-9]+(\.[0-9]+)?$/)) &&
(! ($line[3] =~ /^\.[0-9]+$/))) ||
($line[3] < 0) || ($line[3] > 1)) {
push(@ERRORS, "$line[3] not between 0.0 and 1.0");
if ( ((! ($line[2] =~ /^[0-9]+(\.[0-9]+)?$/)) &&
(! ($line[2] =~ /^\.[0-9]+$/))) ||
($line[2] < 0) || ($line[2] > 1)) {
push(@ERRORS, "$line[2] not between 0.0 and 1.0");
next;
}
# lanloss(lan) = loss
$lanloss{$line[2]} = $line[3];
$lanloss{$line[1]} = $line[2];
}
}
}
close(NSFILE);
close(TBCMD);
if ($#ERRORS != -1) {
foreach (@ERRORS) {
......
......@@ -35,7 +35,7 @@
# SUCH DAMAGE.
#
# @(#) $Header: /home/cvs_mirrors/cvs-public.flux.utah.edu/CVS/testbed/tbsetup/ns2ir/Attic/sim.tcl,v 1.4 2000-12-26 23:54:15 calfeld Exp $
# @(#) $Header: /home/cvs_mirrors/cvs-public.flux.utah.edu/CVS/testbed/tbsetup/ns2ir/Attic/sim.tcl,v 1.5 2001-02-14 16:34:53 calfeld Exp $
#
......@@ -180,6 +180,7 @@ Simulator instproc run {} {
global eventlist
global lanlist
global irfile
global TBCMD
set IRfile [open $irfile w]
......@@ -205,6 +206,11 @@ Simulator instproc run {} {
puts $IRfile "END events"
close $IRfile
# Close the TBCMDs file if necessary
if {[info exists TBCMD]} {
close $TBCMD
}
}
Simulator instproc halt {} {
......
# This is the tb_compact.tcl that deals with all the TB specific commands.
# It should be loaded at the beginning of any ns script using the TB commands.
# Open up the tbcmds file
if {[catch "open tbcmds w" TBCMD]} {
puts stderr "Fatal Error: Could not open tbcmds file for writing."
exit 1
}
proc tb-set-ip {node ip} {
global TBCMD nodeid_map
puts $TBCMD "tb-set-ip $nodeid_map($node) $ip"
}
proc tb-set-ip-interface {src dst ip} {
global TBCMD nodeid_map
puts $TBCMD "tb-set-ip-interface $nodeid_map($src) $nodeid_map($dst) $ip"
}
proc tb-set-hardware {node type args} {
global TBCMD nodeid_map
puts $TBCMD "tb-set-hardware $nodeid_map($node) $type $args"
}
proc tb-set-node-os {node os} {
global TBCMD nodeid_map
puts $TBCMD "tb-set-node-os $nodeid_map($node) $os"
}
proc tb-create-os {label path partition} {
global TBCMD nodeid_map
puts $TBCMD "tb-create-os $label $path $partition"
}
proc tb-set-link-loss {src dst rate} {
global TBCMD nodeid_map
puts $TBCMD "tb-set-link-loss $nodeid_map($src) $nodeid_map($dst) $rate"
}
proc tb-set-lan-loss {lan rate} {
global TBCMD nodeid_map
puts $TBCMD "tb-set-lan-loss $nodeid_map($lan) $rate"
}
proc tb-set-dnard-os {shelf number os} {
global TBCMD nodeid_map
puts $TBCMD "tb-set-dnard-os $nodeid_map($shelf) $number $os"
}
# The following commands are not clearly defined and probably will be
# changed or removed
proc tb-set-dnard-ip {shelf number ip} {}
proc tb-set-node-deltas {node deltas} {}
proc tb-set-dnard-deltas {shelf number deltas} {}
# Show that we have loaded
set TB_COMPACT 1
# This is a nop tb_compact.tcl file that should be used when running scripts
# under ns.
proc tb-set-ip {node ip} {}
proc tb-set-ip-interface {src dst ip} {}
proc tb-set-hardware {node type args} {}
proc tb-set-node-os {node os} {}
proc tb-create-os {label path partition} {}
proc tb-set-link-loss {src dst rate} {}
proc tb-set-lan-loss {lan rate} {}
# The following commands are not clearly defined and probably will be
# changed or removed
proc tb-set-dnard-ip {shelf number ip} {}
proc tb-set-dnard-os {shelf number os} {}
proc tb-set-node-deltas {node deltas} {}
proc tb-set-dnard-deltas {shelf number deltas} {}
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