parse.tcl.in

#!/usr/local/bin/otclsh

#
# EMULAB-COPYRIGHT
# Copyright (c) 2000-2003 University of Utah and the Flux Group.
# All rights reserved.
#

######################################################################
# parse.tcl.in
#
# This is the testbed parser.  It takes a project id, an experiment
# id and a NS file.  It will parse the NS file and update the DB.
# It also displays warnings for unsupported functionality.
#
# See README for extensive discussion of the structure and 
# implementation.
#
# -q will supress all the unsupported messages.
# -n will cause the parser to output error/warning messages and exit
#    without updating the database.
######################################################################

package require sql

# Initial Procedures

###
# lpop <listname>
# This takes the *name* of a list variable and pops the first element
# off of it, returning that element.
###
proc lpop {lv} {
    upvar $lv l
    set ret [lindex $l 0]
    set l [lrange $l 1 end]
    return $ret
}

###
# var_import <varspec>
# This procedure takes a fully qualified variable name (::x::y::z..) and
# creates a variable z which is the same as the variable specified.  This
# fills the lack of variable importing support in 'namespace import'.
#
# Example:
#  proc a {} {
#    var_import ::GLOBALS::verbose
#    if {$verbose == 1} {puts "verbose is on."}
#  }
# is functionally identical to:
#  proc a {} {
#    if {${::GLOBALS::verbose} == 1} {puts "verbose is on."}
#  }
###
proc var_import {varspec} {
    uplevel "upvar $varspec [namespace tail $varspec]"
}

###
# perror <msg>
# Print an error message and mark as failed run.
###
proc perror {msg} {
    var_import ::GLOBALS::errors 
    var_import ::GLOBALS::simulated

    # If this was a true error in specifying
    # the simulation, it would have been
    # caught when run with NSE
    if { $simulated == 1 } {
	return 0
    }

    global argv0
    puts stderr "*** $argv0: "
    puts stderr "    $msg"
    set errors 1
}

###
# punsup {msg}
# Print an unsupported message.
###
proc punsup {msg} {
    var_import ::GLOBALS::verbose
    var_import ::GLOBALS::WARN_FILE
    var_import ::GLOBALS::simulated

    # If this was a true error in specifying
    # the simulation, it would have been
    # caught when run with NSE
    if {$simulated == 0 && $verbose == 1} {
	puts stderr "*** WARNING: Unsupported NS Statement!"
	puts stderr "    $msg"
	puts $WARN_FILE "*** WARNING: Unsupported NS Statement!"
	puts $WARN_FILE "    $msg"
    }
}	

#
# We ignore unsupported tcl commands if it is inside
# make-simulated else error is flagged i.e. we call 
# perror which does the right thing
#
proc unknown {args} {
    perror "Unknown: $args"
}

# Parse Arguments

# We setup a few globals that we need for argument parsing.
namespace eval GLOBALS {
variable verbose 1
variable impotent 0
variable anonymous 0
variable vtype_list {}
}

while {$argv != {}} {
    set arg [lindex $argv 0]
    if {$arg == "-n"} {
	lpop argv
	set GLOBALS::impotent 1
    } elseif {$arg == "-q"} {
	lpop argv
	set GLOBALS::verbose 0
    } elseif {$arg == "-a"} {
	lpop argv
	set GLOBALS::anonymous 1
    } else {
	break
    }
}

if {${GLOBALS::anonymous} && ! ${GLOBALS::impotent}} {
    puts stderr "-a can only be used with -n."
    exit 1
}

if {${GLOBALS::anonymous} && ([llength $argv] != 1)} {
    puts stderr "Syntax: $argv0 \[-q\] -n -a ns_file"
    exit 1
} elseif {(! ${GLOBALS::anonymous}) && ([llength $argv] != 3)} {
    puts stderr "Syntax: $argv0 \[-q\] \[-n \[-a\]\] pid eid ns_file"
    exit 1
}

# Now we can set up the rest of our global variables.
namespace eval GLOBALS {
    # Remaining arguments
    if {$anonymous} {
	variable pid "PID"
	variable eid "EID"
	variable nsfile [lindex $argv 0]
    } else {
	variable pid [lindex $argv 0]
	variable eid [lindex $argv 1]
	variable nsfile [lindex $argv 2]
    }
    
    # This is used to name class instances by the variables they
    # are stored in.  It contains the initial id of the most
    # recently created class.  See README
    variable last_class {}

    # Some settings taken from configure.
    variable tbroot @prefix@
    variable libdir @prefix@/lib/ns2ir
    variable disablense {@DISABLE_NSE@}

    # This is the location of the tb_compat.tcl file.  It is copied
    # into the same directory is the ns file so that the initial
    # 'source tb_compat.tcl' statement succeeds.
    variable tbcompat "$libdir/tb_compat.tcl"

    # This is used in running the script through nse for syntax errors
    variable nstbcompat "$libdir/nstb_compat.tcl"

    # Is 1 if any errors have occured so far.
    variable errors 0
    
    # Is 1 after a 'Simulator run' command.
    variable ran 0

    # This is a counter used by the 'new' procedure to create null
    # classes.
    variable new_counter 0

    # This will hold the handle for the database connection
    variable DB {}

    # These are going to be default values within the NS file.
    variable default_ip_routing_type "none"

    # For remote nodes. Use latest widearea data.
    variable uselatestwadata 0

    # For remote nodes. Use tunnels
    variable usewatunnels 1

    # Use link delays instead of delay nodes.
    variable uselinkdelays 0

    # Force link delays (where a delay would not otherwise be inserted)
    variable forcelinkdelays 0

    # For remote nodes. The solver weights.
    variable wa_delay_solverweight 1
    variable wa_bw_solverweight	   7
    variable wa_plr_solverweight   500

    # This is the file handler for the warnings file
    variable WARN_FILE [open "$eid.warnings" w]

    # This distinguishes whether the script that
    # is being parsed should go into a NSE simulation or not
    variable simulated 0

    # Hidden variable to relax some restrictions for debugging.
    variable enforce_user_restrictions 1
}

# Connect to the DB
set GLOBALS::DB [sql conn]
sql selectdb ${GLOBALS::DB} @TBDBNAME@

namespace eval GLOBALS {
    # A mapping of event objects.
    variable objtypes

    sql query $DB \
	    "select idx,type from event_objecttypes"
    
    while {[set row [sql fetchrow $DB]] != ""} {
	set idx [lindex $row 0]
	set type [lindex $row 1]
	set objtypes($type) $idx
    }
    sql endquery $DB
}

# Load all our classes
source ${GLOBALS::libdir}/nsobject.tcl
source ${GLOBALS::libdir}/sim.tcl
source ${GLOBALS::libdir}/lanlink.tcl
source ${GLOBALS::libdir}/node.tcl
source ${GLOBALS::libdir}/null.tcl
source ${GLOBALS::libdir}/traffic.tcl
source ${GLOBALS::libdir}/vtype.tcl
source ${GLOBALS::libdir}/program.tcl

##################################################
# Redifing Assignment
#
# Here we rewrite the set command.  The global variable 'last_class'
# holds the name instance created just before set.  If last_class is set
# and the value of the set call is last_class then the value should be
# changed to the variable and the class renamed to the variable.  I.e.
# we are making it so that NS objects are named by the variable they
# are stored in.
#
# We only do this if the level above is the global level.  I.e. if
# class are created in subroutines they keep their internal names
# no matter what.
#
# We munge array references from ARRAY(INDEX) to ARRAY-INDEX.
#
# Whenever we rename a class we call the rename method.  This method
# should update all references that it may have set up to itself.
#
# See README
##################################################
rename set real_set
proc set {args} {
    var_import GLOBALS::last_class

    # There are a bunch of cases where we just pass through to real set.
    if {[llength $args] == 1} {
	return [uplevel real_set \{[lindex $args 0]\}]
    } elseif {($last_class == {})} {
	return [uplevel real_set \{[lindex $args 0]\} \{[lindex $args 1]\}]
    }

    real_set var [lindex $args 0]
    real_set val [lindex $args 1]

    # 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\} \{$val\}]

    # 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
    }
    
    # At this point this is an assignment immediately after class creation.
    if {$val == $last_class} {
	# Here we change ARRAY(INDEX) to ARRAY-INDEX
	regsub -all {[\(]} $var {-} out
	regsub -all {[\)]} $out {} val

	# Sanity check
	if {! [catch "uplevel info args $val"]} {
	    error "Already have an object named $val."
	}
	# And now we rename the class.  After the class has been
	# renamed we call it its rename method.
	uplevel rename $last_class $val
	uplevel $val rename $last_class $val
    }
    
    # Reset last_class in all cases.
    real_set last_class {}
    
    # And finally we pass through to the actual assignment operator.
    return [uplevel real_set \{$var\} \{$val\}]
}

###
# new <class> ...
# NS defines the new command to create class instances.  If the call is
# for an object we know about we create and return an instance.  For 
# any classes we do not know about we create a null class and return it
# as well as display an unsupported message.
#
# new_classes is an array in globals that defines the classes
# new should support.  The index is the class name and the value
# is the argument list.
#
# TODO: Implement support for classes that take arguments.  None yet
# in supported NS subset.
###
namespace eval GLOBALS {
    variable new_classes
    set new_classes(Simulator) {}
}
proc new {class args} {
    var_import GLOBALS::new_counter
    var_import GLOBALS::new_classes
    if {! [info exists new_classes($class)]} {
	punsup "Object: $class"
	set id null[incr new_counter]
	NullClass $id $class
	return $id
    }

    set id $class[incr new_counter]

    # XXX Hack!
    if {[llength $args] > 1} {
	punsup "arguments for $class"
    } elseif {[llength $args] == 1} {
	eval $class $id [lindex $args 0]
    } else {
	eval $class $id 
    }
    return $id
}

# Useful routines.

# parse_bw bspec 
# This takes a bandwidth specifier in the form of <amt><unit> where
# <unit> is any of b, bps, kb, kbps, Mb, Mbps, Gb, or Gbps.  If no
# unit is given then bytes (b) is assumed.  It returns the bandwidth
# in Kbps.
proc parse_bw {bspec} {
    # Default to bytes
    if {[scan $bspec "%f%s" bw unit] == 1} {
	set unit b
    }

    switch -- $unit {
	b {set val [expr int($bw/1000)]} 
	bps {set val [expr int($bw/1000)]} 
	kb {set val [expr int($bw)]}
	kbps {set val [expr int($bw)]}
	Mb {set val [expr int($bw*1000)]}
	Mbps {set val [expr int($bw*1000)]}
	Gb {set val [expr int($bw*1000000)]}
	Gbps {set val [expr int($bw*1000000)]}
	default {
	    perror "Unknown bandwidth unit $unit."
	    set val 100000
	}
    }

    if {$val < 10} {
	perror "Bandwidth of $val Kbs is too low."
	return 0
    }
    return $val
}

# parse_delay dspec
# This takes a delay specifier in the form of <amt><unit> where <unit>
# is any of s, ms, ns.  If no unit is given then seconds (s) is
# assumed.  It returns the delay in ms.
proc parse_delay {dspec} {
    # Default to seconds
    if {[scan $dspec "%f%s" delay unit] == 1} {
	set unit s
    }
    switch $unit {
	s {return [expr int($delay*1000)]}
	ms {return [expr int($delay)]}
	ns {return [expr int($delay/1000)]}
	default {
	    perror "Unknown delay unit $unit."
	    return 0
	}
    }
}

# We now have all our infrastructure in place.  We are ready to load
# the NS file.

if { ${GLOBALS::errors} != 1 } {
    file copy -force ${GLOBALS::tbcompat} .
    source ${GLOBALS::nsfile}

    if {${GLOBALS::ran} == 0} {
	perror "No 'Simulator run' statement found."
    }

}

# Clean up
sql disconnect ${GLOBALS::DB}

close ${GLOBALS::WARN_FILE}

exit ${GLOBALS::errors}