nstbparse.in 3.54 KB
Newer Older
1
#! @prefix@/libexec/nsverify/nstb
Leigh Stoller's avatar
Leigh Stoller committed
2 3
#
# Copyright (c) 2000-2006 University of Utah and the Flux Group.
4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
# 
# {{{EMULAB-LICENSE
# 
# This file is part of the Emulab network testbed software.
# 
# This file is free software: you can redistribute it and/or modify it
# under the terms of the GNU Affero General Public License as published by
# the Free Software Foundation, either version 3 of the License, or (at
# your option) any later version.
# 
# This file is distributed in the hope that it will be useful, but WITHOUT
# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
# FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Affero General Public
# License for more details.
# 
# You should have received a copy of the GNU Affero General Public License
# along with this file.  If not, see <http://www.gnu.org/licenses/>.
# 
# }}}
Leigh Stoller's avatar
Leigh Stoller committed
23
#
24 25 26 27 28 29 30

# rename set in order to capture the variable names used in the ns file.
variable last_host {}
variable last_lan {}
variable last_link {}
variable last_sim {}
variable last_fw {}
31
variable last_fw_node {}
32 33 34 35 36 37 38
#  arrays mapping tcl hostnames to variable names
variable hosts
variable lans
variable links
# optional items
variable rtproto "none"
variable simname
39
variable DATASTORE "@PROJROOT_DIR@"
40 41 42 43 44 45 46

rename puts real_puts
proc puts {args} {
}

rename set real_set
proc set {args} {
47
    global last_host last_lan last_link last_sim last_fw last_fw_node
48 49 50 51 52 53 54 55 56
    global hosts lans links simname

    if {[llength $args] == 1} {
	return [uplevel real_set \{[lindex $args 0]\}]
    }

    real_set var [lindex $args 0]
    real_set rval [lindex $args 1]
    
Timothy Stack's avatar
Timothy Stack committed
57 58 59 60 61 62 63 64 65 66 67 68 69 70 71
    # Run the set to make sure variables declared as global get registered
    # as global (does not happen until first set).
    real_set ret [uplevel real_set \{$var\} \{$rval\}]

    # Rename happens only when assigning to a global variable. Because of
    # array syntax, must strip parens and indices to get the base variable
    # name (has no effect if not an array access).
    real_set l [split $var \(]
    real_set base_var [lindex $l 0]

    # Now check to see if its a global. No renaming if not a global.
    if {[uplevel info globals $base_var] == {}} {
        return $ret
    }

72 73 74 75 76
    # Here we change ARRAY(INDEX) to ARRAY-INDEX
    regsub -all {[\(]} $var {-} out
    regsub -all {[\)]} $out {} val

    if {$rval == {}} {
77 78 79 80 81 82 83 84 85 86
    } else {
	real_set do_rename 1

	if {$rval == $last_host} {
	    array set hosts [list $last_host $val]
	} elseif {$rval == $last_lan} {
	    array set lans [list $last_lan $val]
	} elseif {$rval == $last_link} {
	    array set links [list $last_link $val]
	} elseif {$rval == $last_sim} {
Timothy Stack's avatar
Timothy Stack committed
87
	    real_set simname $var
88
	} elseif {$rval == $last_fw} {
89
	    array set hosts [list $last_fw_node $val]
90 91 92 93 94 95 96 97 98 99 100 101 102 103
	} else {
	    real_set do_rename 0
	}

	if {$do_rename != 0} {
	    # Create a procedure with the variable name that forwards any calls
	    # to the real object.  This is should emulate the behavior of the
	    # testbed parser without requiring us to add "rename" methods to
	    # the NS objects.
	    real_set np "proc $val {args} {\n"
	    append np "  eval return $rval \$args\n"
	    append np "}\n"
	    eval $np
	}
104 105 106 107 108 109 110 111 112
    }

    real_set last_host {}
    real_set last_lan {}
    real_set last_link {}
    real_set last_sim {}
    real_set last_fw {}

    # There are a bunch of cases where we just pass through to real set.
Timothy Stack's avatar
Timothy Stack committed
113
    return [uplevel real_set \{$var\} \{$rval\}]
114 115 116 117 118 119 120 121 122 123 124
}

variable pid [lindex $argv 0]
variable gid [lindex $argv 1]
variable eid [lindex $argv 2]
variable nsfile [lindex $argv 3]

variable tbroot @prefix@
variable libdir @prefix@/lib/ns2ir

source [lindex $argv 3]