#!/bin/sh
# the exec restarts using smash which in turn ignores
# the command because of this backslash: \
exec smash-5.2 "$0" "$@"

# smash-head.tcl --
#
#       This header is added to the beginning of all smash-based tools.
#
# Copyright (c) 1993-2002 The Regents of the University of California.
# All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions are met:
#
# A. Redistributions of source code must retain the above copyright notice,
#    this list of conditions and the following disclaimer.
# B. Redistributions in binary form must reproduce the above copyright notice,
#    this list of conditions and the following disclaimer in the documentation
#    and/or other materials provided with the distribution.
# C. Neither the names of the copyright holders nor the names of its
#    contributors may be used to endorse or promote products derived from this
#    software without specific prior written permission.
#
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS''
# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
# ARE DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR
# ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
# SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
# CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
# OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
# OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
#
# @(#) $Header: /usr/mash/src/repository/mash/mash-1/smash-head.tcl,v 1.6 2002/02/03 04:41:07 lim Exp $ (UCB)

proc option args {
	global _db
	if { [lindex $args 0] == "add" } {
		set o [split [lindex $args 1] .]
		set cls [lindex $o 0]
		set resource [lindex $o 1]
		set value [lindex $args 2]
		set pri [lindex $args 3]
		if { $pri == "" } {
			set pri 80
		}
		if [info exists _db($cls,$resource,pri)] {
			set oldpri $_db($cls,$resource,pri)
		} else {
			set oldpri -1
		}
		if { $oldpri > $pri } {
			return
		}
		set _db($cls,$resource,val) $value
		set _db($cls,$resource,pri) $pri
	} elseif { [lindex $args 0] == "get" } {
		set resource [lindex $args 2]
		set cls [lindex $args 3]
		if [info exists _db($cls,$resource,val)] {
			return $_db($cls,$resource,val)
		} else {
			return ""
		}
	} elseif { [lindex $args 0] == "clear" } {
		unset _db
	}
}
Class Log
Log proc name s {
	Log set name_ $s
}
Log proc warn s {
	Log instvar name_
	if [info exists name_] {
		set name $name_
	} else {
		global argv0
		if [info exists argv0] {
			set name [file tail $argv0]
		} else {
			set name mash
		}
	}
	puts stderr "$name_: $s"
}
Log proc fatal s {
	Log warn $s
	exit 1
}
Class Application
Application public init name {
	$self next
	$self instvar name_ class_
	set name_ $name
	$self add_option appname $name
	Log set name_ $name
	set class_ [string toupper [string index $name_ 0]][string \
		range $name_ 1 end]
	catch "tk appname $name"
	Application set instance_ $self
}
Application proc instance {} {
	return [Application set instance_]
}
Application proc name {} {
	return [[Application instance] set name_]
}
Application proc class {} {
	return [[Application instance] set class_]
}
Application proc toplevel w {
	Application instvar visual_ colormap_
	if [info exists visual_] {
		toplevel $w -class [Application class] \
			-visual $visual_ -colormap $colormap_
	} else {
		toplevel $w -class [Application class]
	}
}
global font
set font(helvetica10) {
	normal--*-100-75-75-*-*-*-*
	normal--10-*-*-*-*-*-*-*
	normal--11-*-*-*-*-*-*-*
	normal--*-100-*-*-*-*-*-*
	normal--*-*-*-*-*-*-*-*
}
set font(helvetica12) {
	normal--*-120-75-75-*-*-*-*
	normal--12-*-*-*-*-*-*-*
	normal--14-*-*-*-*-*-*-*
	normal--*-120-*-*-*-*-*-*
	normal--*-*-*-*-*-*-*-*
}
set font(helvetica14) {
	normal--*-140-75-75-*-*-*-*
	normal--14-*-*-*-*-*-*-*
	normal--*-140-*-*-*-*-*-*
	normal--*-*-*-*-*-*-*-*
}
set font(times14) {
	normal--*-140-75-75-*-*-*-*
	normal--14-*-*-*-*-*-*-*
	normal--*-140-*-*-*-*-*-*
	normal--*-*-*-*-*-*-*-*
}
Application instproc search_font { foundry style weight points slant } {
	global font tcl_version tcl_platform
 	if {$tcl_version >= 8} {
 		if {$slant == "r"} {
 			set slant ""
 		} elseif {$slant == "o"} {
 			set slant "italic"
 		}
		if {$weight == "medium"} {
			set weight ""
		}
 		return "$style -$points $weight $slant"
 	}
	foreach f $font($style$points) {
		set fname -$foundry-$style-$weight-$slant-$f
		if [havefont $fname] {
			return $fname
		}
	}
	$self instvar name_
	puts stderr "$name_: can't find $weight $fname font (using fixed)"
	if ![havefont fixed] {
		puts stderr "$name_: can't find fixed font"
		exit 1
	}
	return fixed
}
Application public init_local {} {
	$self instvar name_
	set f ~/.$name_.tcl
	if [file exists $f] {
		uplevel #0 "source $f"
	}
	set script [$self resource startupScript]
	if { $script != "" } {
		uplevel #0 "source $script"
	}
}
Application instproc user_hook {} {
}
Object instproc options {} {
	$self instvar options_
	if ![info exists options_] {
		Object instvar options_
		if ![info exists options_] {
			set options_ [new Configuration]
			global tcl_platform
			if {"$tcl_platform(platform)"=="windows"} {
				$options_ add_default \
					background SystemButtonFace
				$options_ add_default \
					infoHighlightColor SystemHighlightText
			}
		}
	}
	$options_ add_default appname mash
	return $options_
}
Object instproc optionsFrom o {
	$self set options_ $o
}
Class instproc configuration a {
 	$self instvar options_
	if ![info exists options_] {
		set options_ [new Configuration]
	}
	foreach { option value } $a {
		$options_ add_default $option $value
	}
}
Object instproc get_option r {
	set v [[$self options] get_option $r]
	if { $v != "" } {
		return $v
	}
	set cl [$self info class]
	foreach cl "$cl [$cl info heritage]" {
		$cl instvar options_
		if [info exists options_] {
			set v [$options_ get_option $r]
			if { $v != "" } {
				return $v
			}
		}
	}
	return ""
}
Object instproc resource r {
	return [$self get_option $r]
}
Object instproc add_option { r v } {
	return [[$self options] add_option $r $v]
}
Object instproc add_default { r v } {
	return [[$self options] add_default $r $v]
}
Object instproc yesno r {
	set v [$self get_option $r]
	if [string match \[0-9\]* $v] {
		return $v
	}
	if [string match \[tT\]* $v] {
		return 1
	}
	return 0
}
Object instproc debug s {
	if [$self yesno debug] {
		Log warn $s
	}
}
Object instproc warn s {
	Log warn $s
}
Object instproc fatal s {
	Log fatal $s
}
Class Configuration
Configuration public get_option r {
	$self instvar table_ default_
	if [info exists table_($r)] {
		return $table_($r)
	}
	if [info exists default_($r)] {
		return $default_($r)
	}
	return ""
}
Configuration public add_option { r v } {
	$self instvar table_
	set table_($r) $v
}
Configuration public add_default { r v } {
	$self set default_($r) $v
}
Configuration public register_option  { flag option args } {
	$self instvar arg_option_ usage_ arg_option_default_
	set arg_option_($flag) $option
	if { [lindex $args 0] == "-default" } {
		set arg_option_default_($flag) [lindex $args 1]
		set args [lrange $args 2 end]
	}
	set usage_($flag) $args
}
Configuration public register_boolean_option  { flag option args } {
	$self instvar arg_bool_ arg_bool_val_
	set arg_bool_($flag) $option
	if { $args == "" } {
		set args 1
	}
	set arg_bool_val_($flag) $args
}
Configuration public register_list_option {flag option args} {
	$self instvar arg_list_option_
	set arg_list_option_($flag) $option
	set usage_($flag) $args
}
Configuration private is_arg argv {
	if { $argv != "" } {
		return [string match -* [lindex $argv 0]]
	}
	return 0
}
Configuration instproc parse_args argv {
	$self instvar arg_resource_ bool_resource_
	$self instvar arg_option_ arg_bool_ arg_bool_val_ arg_list_option_ \
			arg_option_default_
	if { [info exists arg_resource_] || [info exists bool_resource_] } {
		puts stderr "your application class needs to be fixed"
		exit 1
	}
	while 1 {
		if ![$self is_arg $argv] {
			break
		}
		set arg [lindex $argv 0]
		set argv [lrange $argv 1 end]
		set val [lindex $argv 0]
		if { $arg == "-help" } {
			$self usage
			exit
		}
		if { $arg == "-X" } {
			set L [split $val =]
			if { [llength $L] != 2 } {
				puts stderr "malformed -X argument"
				exit 1
			}
			$self add_option [lindex $L 0] [lindex $L 1]
			set argv [lrange $argv 1 end]
			continue
		}
		set fatal_msg ""
		if [info exists arg_option_($arg)] {
			if { [llength $argv] > 0 && \
					[string index $val 0]!="-" } {
				$self add_option $arg_option_($arg) $val
				set argv [lrange $argv 1 end]
				continue
			}
			set fatal_msg "must be followed by an argument"
		}
		if [info exists arg_bool_($arg)] {
			$self add_option $arg_bool_($arg) $arg_bool_val_($arg)
			continue
		}
		if [info exists arg_list_option_($arg)] {
			if { [llength $argv] > 0 || \
					[string index $val 0]!="-" } {
				set o $arg_list_option_($arg)
				set l [$self get_option $o]
				lappend l $val
				$self add_option $o $l
				set argv [lrange $argv 1 end]
				continue
			}
			set fatal_msg "must be followed by an argument"
		}
		$self usage
		$self fatal "unknown/invalid command option: $arg ($fatal_msg)"
	}
	return $argv
}
Configuration public usage {} {
	set display_args_on_single_line 0
	if { $display_args_on_single_line } {
		puts "usage: [Application name] [join [$self arg_info]]"
	} else {
		puts "usage: [Application name]"
		foreach arg [$self arg_info] {
			puts $arg
		}
	}
}
Configuration private arg_info {} {
	$self instvar arg_option_ arg_bool_ usage_
	foreach arg [array names arg_option_] {
		set r $arg_option_($arg)
		set d [$self get_option $r]
		if { $d != "" || $usage_($arg) != "required"} {
			lappend opt "\[$arg $r ($d)\]"
		} else {
			lappend req "$arg $r"
		}
	}
	foreach arg [array names arg_bool_] {
		set r $arg_bool_($arg)
		set d [$self get_option $r]
		if { $d != "" } {
		        lappend opt "\[$arg ($d)\]"
		} else {
			lappend opt "\[$arg\]"
		}
	}
	if [info exists opt] {
		if [info exists req] {
			return [concat $opt $req]
		} else {
			return $opt
		}
	} else {
		if [info exists req] {
			return $req
		} else {
			return ""
		}
	}
}
Configuration public load_preferences suffixList {
    global env
    if {![info exists env(HOME)]} {
        new ErrorWindow {Your HOME environment variable must be set.}
        exit 1
    }
	set mash [file join $env(HOME) .mash]
	if {[file isdirectory $mash]} {
		$self load_file $mash/prefs
		foreach suffix $suffixList {
			$self load_file $mash/prefs-$suffix
		}
	}
}
Configuration private load_file fname {
	if ![file readable $fname] {
		return
	}
	set f [open $fname r]
	set count 0
	while 1 {
		incr count
		if [eof $f] {
			close $f
			return
		}
		set line [string trim [gets $f]]
		if { $line == {} || [string index $line 0]=="#" } {
			continue
		}
		set colon [string first ":" $line]
		if { $colon==-1 } {
			puts stderr "Invalid line $count in $fname:\
					Must be of the form \"key: value\""
			continue
		}
		set option [string trim [string range $line 0 [expr $colon-1]]]
		set value [string trim [string range $line \
				[expr $colon+1] end]]
		$self add_option $option $value
	}
}
Configuration public open_preferences { suffix {mode w} } {
    global env
    if {![info exists env(HOME)]} {
        new ErrorWindow {Your HOME environment variable must be set.}
        exit 1
    }
	set mash [file join $env(HOME) .mash]
	if {![file exists $mash]} {
		file mkdir $mash
	}
	set f [open $mash/prefs-$suffix $mode 0644]
	return $f
}
Configuration public write_preference { file key value } {
	puts $file "$key: $value"
}
Configuration public close_preferences { file } {
	close $file
}
Class TkWindow -configuration {
	background gray85
}
Class TopLevelWindow -superclass TkWindow
TkWindow public init {path} {
	$self next
	$self instvar path_
	set path_ $path
}
TkWindow public widget_path {} {
	$self instvar path_
	return $path_
}
TkWindow instproc destroy {} {
	$self instvar path_
	if [winfo exists $path_] {
		destroy $path_
	}
	$self next
}
TkWindow instproc highlight { color } {
	$self instvar path_
	if { $path_ != "" } {
		$path_ configure -background $color
		foreach child [winfo children $path_] {
			window_highlight $child $color
		}
	}
}
TkWindow instproc set_background { color } {
	$self instvar path_
	$path_ configure -background $color
}
TopLevelWindow public build_window {} {
	$self instvar path_
	if ![winfo exists $path_] {
		$self build $path_
	}
}
TopLevelWindow instproc toggle {} {
	$self build_window
	$self instvar path_
	set w $path_
	$self instvar __mappedBefore__
	if { [winfo ismapped $w] } {
		wm withdraw $w
		return
	} elseif ![info exists __mappedBefore__] {
		set __mappedBefore__ 1
		wm transient $w .
		update idletasks
		set x [winfo rootx .]
		set y [winfo rooty .]
		incr y [winfo height .]
		incr y -[winfo reqheight $w]
		incr y -20
		incr x [winfo vrootx .]
		incr y [winfo vrooty .]
		if { $y < 0 } { set y 0 }
		if { $x < 0 } {
			set x 0
		} else {
			set right [expr [winfo screenwidth .] - \
					[winfo reqwidth $w]]
			if { $x > $right } {
				set x $right
			}
		}
		wm geometry $w +$x+$y
	}
	wm deiconify $w
}
TopLevelWindow instproc create-window { w title } {
	Application toplevel $w
	set title "[$self get_option iconPrefix] $title"
	wm transient $w .
	wm title $w $title
	wm iconname $w $title
	bind $w <Enter> "focus $w"
	wm withdraw $w
}
Class HelpWindow -superclass TopLevelWindow
HelpWindow instproc create-window { w title items } {
	$self next $w $title
	frame $w.frame -borderwidth 0 -relief flat
	set p $w.frame
	set n 0
	foreach m $items {
		set h $w.h$n
		incr n
		frame $h
		$self helpitem $h $m
		pack $h -expand 1 -fill both
	}
	button $w.frame.ok -text " Dismiss " -borderwidth 2 -relief raised \
		-command "wm withdraw $w" -font [$self get_option medfont]
	pack $w.frame.ok -pady 6 -padx 6 -anchor e
	pack $w.frame -expand 1 -fill both
        wm protocol $w WM_DELETE_WINDOW "wm withdraw $w"
}
HelpWindow instproc helpitem { w text } {
	set f [$self get_option helpFont]
	canvas $w.bullet -width 12 -height 12
	$w.bullet create oval 6 3 12 9 -fill black
	message $w.msg -justify left -anchor w -font $f -width 450 -text $text
	pack $w.bullet -side left -anchor ne -pady 5
	pack $w.msg -side left -expand 1 -fill x -anchor nw
}
Class ErrorWindow -superclass TopLevelWindow
ErrorWindow public init text {
	set w .dialog
	$self next $w
	catch "destroy $w"
	global V
	set applname [Application name]
	if { $applname == "" } {
		set applname "mash shell"
	}
	$self create-window $w "$applname error"
	label $w.label -text "$applname: $text" -font [$self get_option medfont] \
		-borderwidth 2 -relief groove
	button $w.button -text OK -command "$self destroy" \
			-font [$self get_option medfont]
	pack $w.label -expand 1 -fill x -ipadx 4 -ipady 4
	pack $w.button -pady 4
	wm withdraw $w
	update idletasks
	set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
		- [winfo vrootx [winfo parent $w]]]
	set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
		- [winfo vrooty [winfo parent $w]]]
	wm geom $w +$x+$y
	wm deiconify $w
	bind $w <Enter> "focus $w"
	tkwait window .dialog
}
Class CheckButton
CheckButton public init { w args } {
	$self instvar var_ path_
	set path_ $w
	set var_ [TclObject getid]
	eval checkbutton $w -variable $var_ $args
}
CheckButton instproc get_val {} {
	$self instvar var_
	global $var_
	return [set $var_]
}
CheckButton instproc set_val v {
	$self instvar var_
	global $var_
	set $var_ $v
}
CheckButton instproc set-val v { $self set_val $v }
CheckButton instproc get-val {} { $self get_val }
CheckButton instproc unknown args {
	$self instvar path_
	eval $path_ $args
}
Class RadioButtonsObj
RadioButtonsObj public init { w labelsList args } {
    $self instvar var_ path_ numButtons_
    set path_ $w
    set var_ [TclObject getid]
    set c 0
    foreach i $labelsList {
	eval radiobutton $w.rb$c -variable $var_ $args
	$w.rb$c configure -text [list $i]
	$w.rb$c configure -value [list $i]
	pack $w.rb$c -in $w -anchor w
	incr c
    }
    set numButtons_ $c
}
RadioButtonsObj public get_val {} {
    $self instvar var_
    global $var_
    return [set $var_]
}
RadioButtonsObj public set_val {v} {
    $self instvar var_
    global $var_
    set $var_ $v
}
RadioButtonsObj private unknown args {
    $self instvar path_ numButtons_
    for {set i 0} {$i < $numButtons_} {incr i} {
	eval $path_.rb$i $args
    }
}
Class ScaleObj
ScaleObj public init { w args } {
    $self instvar var_ path_
    set path_ $w
    set var_ [TclObject getid]
    eval scale $w -variable $var_ $args
}
ScaleObj public get_val {} {
    $self instvar var_
    global $var_
    return [set $var_]
}
ScaleObj public set_val {v} {
    $self instvar var_
    global $var_
    set $var_ $v
}
ScaleObj private unknown args {
    $self instvar path_
    eval $path_ $args
}
Class EntryObj
EntryObj public init { w args } {
    $self instvar var_ path_
    set path_ $w
    set var_ [TclObject getid]
    eval entry $w -textvariable $var_ $args
}
EntryObj public get_val {} {
    $self instvar var_
    global $var_
    return [set $var_]
}
EntryObj private unknown args {
    $self instvar path_
    eval $path_ $args
}
Class Timer
Class Timer/Periodic -superclass Timer
Class Timer/Adaptive -superclass Timer
Class Timer/Adaptive/ConstBW -superclass Timer/Adaptive
Timer public init {} {
	$self next
	$self randomize 0
	$self set randwt_ 1.0
}
Timer public destroy {} {
	$self cancel
	$self next
}
Timer public randomize { {yesno 1} {randwt {}} } {
	if { $randwt!={} } {
		$self set randwt_ $randwt
	}
	if {$yesno=="yes"} {set yesno 1} elseif {$yesno=="no"} {set yesno 0}
	$self set randomize_ $yesno
}
Timer private sched { t } {
	$self msched $t
}
Timer public msched { t } {
	$self instvar id_ randomize_ randwt_
	if [info exists id_] {
		puts stderr "warning: $self ([$self info class]):\
				overlapping timers"
	}
	if $randomize_ {
		set r [expr [random]/double(0x7fffffff)-0.5]
		set t [expr $t+$t*$r*$randwt_]
	}
	set t [expr int($t+0.5)]
	set id_ [after $t "$self do_timeout"]
}
Timer private do_timeout {} {
	$self instvar id_
	if ![info exists id_] {
		puts stderr "warning: $self ($class) no timer id_"
	} else {
		unset id_
	}
	$self timeout
}
Timer public is_sched { } {
	$self instvar id_
	return [info exists id_]
}
Timer public cancel {} {
	$self instvar id_
	if [info exists id_] {
		after cancel $id_
		unset id_
	}
}
Timer/Periodic public init { {period 5000} } {
	$self next
	$self set period_ $period
}
Timer/Periodic public start { {period {}} } {
	$self instvar period_
	if { $period!={} } { set period_ $period }
	if [$self is_sched] { $self cancel }
	$self msched $period_
}
Timer/Periodic instproc do_timeout {} {
	$self instvar period_
	$self next
	if { [info commands $self]=="" } return
	$self msched $period_
}
Timer/Adaptive public init { {interval 5000} } {
	$self next
	$self set interval_ $interval
}
Timer/Adaptive public start {} {
	$self instvar interval_
	if [$self is_sched] { $self cancel }
	set interval_ [$self adapt $interval_]
	$self msched [expr int($interval_+0.5)]
}
Timer/Adaptive public do_timeout {} {
	$self next
	if { [info commands $self]=="" } return
	$self instvar interval_
	set interval_ [$self adapt $interval_]
	$self msched [expr int($interval_+0.5)]
}
Timer/Adaptive private adapt {interval} {
	return $interval
}
Timer/Adaptive/ConstBW public init { bw {thresh {}} {size_gain {}} } {
	$self instvar size_gain_ avgsize_ nsrcs_ bw_ thresh_ interval_
	if { $size_gain!={} } {
		set size_gain_ $size_gain
	} else {
		set size_gain_ 0.125
	}
	set avgsize_ 28
	set nsrcs_ 0
	set bw_ $bw
	if { $thresh=={} } {
		set thresh_ 500
	} else {
		set thresh_ $thresh
	}
	$self next $thresh_
}
Timer/Adaptive/ConstBW public threshold { {thresh {}} } {
    $self instvar thresh_
    if {$thresh=={}} {
	return $thresh_
    } else {
	set thresh_ $thresh
    }
}
Timer/Adaptive/ConstBW public bandwidth { {bw {}} } {
    $self instvar bw_
    if {$bw=={}} {
	return $bw_
    } else {
	set bw_ $bw
    }
}
Timer/Adaptive/ConstBW public sample_size { size } {
	$self instvar avgsize_ size_gain_
	set avgsize_ [expr $avgsize_ + $size_gain_ * ($size + 28 - $avgsize_)]
}
Timer/Adaptive/ConstBW public update_nsrcs { nsrcs } {
	$self set nsrcs_ $nsrcs
}
Timer/Adaptive/ConstBW public nsrcs { nsrcs } {
	return [$self set nsrcs_]
}
Timer/Adaptive/ConstBW public incr_nsrcs { {incr 1} } {
        $self instvar nsrcs_
        incr nsrcs_ $incr
}
Timer/Adaptive/ConstBW private adapt {interval} {
	$self instvar avgsize_ bw_ nsrcs_ thresh_
	set t [expr 1000 * ($nsrcs_ * $avgsize_ * 8) / $bw_]
	if { $t < $thresh_ } {
		return $thresh_
	} else {
		return $t
	}
}
Object instproc has_method { method } {
	if { [$self info procs $method]!="" } {
		return 1
	}
	return [[$self info class] has_method $method]
}
Class instproc has_method { method } {
	if { [$self info instprocs $method]!="" } {
		return 1
	}
	foreach cl [$self info heritage] {
		if { [$cl info instprocs $method]!="" } {
			return 1
		}
	}
	return 0
}
proc version {} {
	global mash
	return $mash(version)
}
proc local_fqdn {} {
	set host ""
	catch {set host [lookup_host_name [localaddr]]}
	if { [string first . $host] < 0 } {
		return ""
	}
	return $host
}
proc email_heuristic {} {
	set user [user_heuristic]
	set addr [local_fqdn]
	if { $addr == "" } {
		return ""
	}
	return $user@$addr
}
proc user_heuristic {} {
	global env
	if [info exists env(USER)] {
		set user $env(USER)
	} elseif [info exists env(LOGNAME)] {
		set user $env(LOGNAME)
	} else {
		catch {set env(USER) [getusername]}
		if [info exists env(USER)] {
			return $env(USER)
		}
		return "UNKNOWN"
	}
}
proc format_fps f {
	set fps $f
	if { $fps < .1 } {
		set fps "0 f/s"
	} elseif { $fps < 10 } {
		set fps [format "%.1f f/s" $fps]
	} else {
		set fps [format "%2.0f f/s" $fps]
	}
	return $fps
}
proc format_bps b {
	set bps $b
	if { $bps < 1 } {
		set bps "0 bps"
	} elseif { $bps < 1000 } {
		set bps [format "%3.0f bps" $bps]
	} elseif { $bps < 1000000 } {
		set bps [format "%3.1f kb/s" [expr $bps / 1000.]]
	} else {
		set bps [format "%.2f Mb/s" [expr $bps / 1000000.]]
	}
	return $bps
}
proc gettime {sec} {
    clock format $sec
}
proc sdr_gettimeofday {} {
    clock seconds
}
proc gettimenow {} {
    gettime [clock seconds]
}
proc getreadabletime {} {
    return [clock format [clock seconds] -format {%H:%M, %d/%m/%y}]
}
proc unix_to_ntp {unixtime} {
    set oddoffset 2208988800
    if {$unixtime==0} {return 0}
    return [format %u [expr $unixtime + $oddoffset]]
}
proc ntp_to_unix {ntptime} {
    set oddoffset 2208988800
    if {($ntptime==0)||($ntptime==1)} {return $ntptime}
    if {[catch {expr $ntptime - $oddoffset}] !=0} {
	    return 0
    }
    return [format %u [expr $ntptime - $oddoffset]]
}
proc duration_readable {secs {option terse}} {
	set ret ""
	set r [expr round($secs)]
	set h [expr $r / 3600]
	set r [expr $r % 3600]
	set m [expr $r / 60]
	set s [expr $r % 60]
	if {$option == "verbose"} then {
		if {$h} {
			set ret "$ret $h\h"
		}
		if {$m} {
			set ret "$ret $m\m"
		}
		if {$s} {
			set ret "$ret and $s\s"
		}
	} else {
		set ret "$h:$m:$s"
	}
		return $ret
}
proc in_multicast addr {
	return [expr ([lindex [split $addr .] 0] & 0xf0) == 0xe0]
}
proc invalid_addr a {
    set l [split $a .]
    if {[llength $l] != 4} { return 1 }
    foreach i $l {
	if {![is_number $i] || $i<0 || $i>255} { return 1 }
    }
    return 0
}
proc is_number n {
    if [catch {expr $n}] {
	return 0
    }
	return 1
}
proc parray {a {pattern *}} {
    upvar 1 $a array
    if ![array exists array] {
        error "\"$a\" isn't an array"
    }
    set maxl 0
    foreach name [lsort [array names array $pattern]] {
        if {[string length $name] > $maxl} {
            set maxl [string length $name]
        }
    }
    set maxl [expr {$maxl + [string length $a] + 2}]
    foreach name [lsort [array names array $pattern]] {
        set nameString [format %s(%s) $a $name]
        puts stdout [format "%-*s = %s" $maxl $nameString $array($name)]
    }
}
Class AddressBlock -configuration {
	defaultTTL 1
	maxbw -1
}
Class AddressBlock/RTP -superclass AddressBlock
Class AddressBlock/Simple -superclass AddressBlock
AddressBlock instproc init spec {
	$self next
	$self set nchan_ 0
	foreach s [split $spec ,] {
		set err [$self parse $s]
		if { $err != "" } {
			$self fatal $err
		}
	}
}
AddressBlock instproc data-port p {
	return [expr $p &~ 1]
}
AddressBlock instproc fmt {} {
	$self instvar fmt_
	if [info exists fmt_] { return $fmt_ } else { return "" }
}
AddressBlock instproc ctrl-port p {
	return [expr [$self data-port $p] + 1]
}
AddressBlock instproc addr {{k 0}} {
	return [$self set addr_($k)]
}
AddressBlock instproc sport {{k 0}} {
	return [$self set sport_($k)]
}
AddressBlock instproc rport {{k 0}} {
	return [$self set rport_($k)]
}
AddressBlock instproc ttl {{k 0}} {
	$self instvar ttl_
	if [info exists ttl_($k)] { return $ttl_($k) } else { return {} }
}
AddressBlock instproc nchan {} {
	return [$self set nchan_]
}
AddressBlock instproc parse s {
	set dst [split $s /]
	set n [llength $dst]
	if { $n < 2 } {
		return "must specify both address and port in the form addr/port ($s)"
	}
	set addr [lindex $dst 0]
	set ports [split [lindex $dst 1] :]
	set sport [lindex $ports 0]
	if { [llength $ports] == 1 } {
		set rport $sport
	} else {
		set rport [lindex $ports 1]
	}
	set firstchar [string index $addr 0]
	if [string match \[a-zA-Z\] $firstchar] {
		set s [gethostbyname $addr]
		if { $s == "" } {
			return "cannot lookup host name: $addr"
		}
		set addr $s
	}
	foreach port "$sport $rport" {
		if { ![string match \[0-9\]* $port] || $port >= 65536 } {
			$self fatal "illegal port '$port'"
		}
	}
	set ttl [$self get_option defaultTTL]
	set cnt 1
	if { $n >= 3 } {
		set fmt [lindex $dst 2]
		if { $n==3 && [regexp {^[0-9]+$} $fmt] } {
			set ttl $fmt
			set fmt {}
		}
		if { $n >= 4 } {
			set ttl [lindex $dst 3]
			if { $n > 4 } {
				set cnt [lindex $dst 4]
				if { ![string match \[0-9\]* $cnt] ||
				     $cnt >= 20 } {
					return "$dst: bad layered addr count"
					exit 1
				}
				if { $n > 5 } {
					return "$dst: malformed address"
				}
			}
		}
	}
	if { $ttl < 0 || $ttl > 255 } {
		return "$dst: invalid ttl ($ttl)"
	}
	set oct [split $addr .]
	set base [lindex $oct 0].[lindex $oct 1].[lindex $oct 2]
	set off [lindex $oct 3]
	$self instvar addr_ sport_ rport_ ttl_ nchan_
	set i 0
	while { $i < $cnt } {
		set sp [$self data-port $sport]
		set rp [$self data-port $rport]
		set addr_($nchan_) $base.$off
		set sport_($nchan_) $sp
		set rport_($nchan_) $rp
		set ttl_($nchan_) $ttl
		if [in_multicast $addr] {
			incr off
		}
		incr sport 2
		incr rport 2
		incr i
		incr nchan_
	}
	if { [info exists fmt] && $fmt != "" } {
		$self set fmt_ $fmt
	}
	if [info exists confid] {
		$self add_option confid $confid
	}
	if [info exists ttl] {
		$self add_option defaultTTL $ttl
	}
	$self bandwidth_heuristic
}
AddressBlock instproc bandwidth_heuristic {} {
	$self instvar nchan_ addr_ ttl_ maxbw_
	set i 0
	while { $i < $nchan_ } {
		set maxbw [$self get_option maxbw]
		if { $maxbw <= 0 } {
			set ttl $ttl_($i)
			if { $ttl <= 16 || ![in_multicast $addr_($i)] } {
				set maxbw 10000000
			} elseif { $ttl <= 64 } {
				set maxbw 4000000
			} elseif  { $ttl <= 128 } {
				set maxbw 1000000
			} elseif { $ttl <= 192 } {
				set maxbw 128000
			} else {
				set maxbw 56000
			}
		}
		set maxbw_($i) $maxbw
		incr i
	}
}
AddressBlock/Simple instproc data-port p {
	return $p
}
AddressBlock/RTP instproc data-port p {
	return [expr $p &~ 1]
}
set rlm_param(alpha) 4
set rlm_param(alpha) 2
set rlm_param(beta) 0.75
set rlm_param(init-tj) 1.5
set rlm_param(init-tj) 10
set rlm_param(init-tj) 5
set rlm_param(init-td) 5
set rlm_param(init-td-var) 2
set rlm_param(max) 600
set rlm_param(max) 60
set rlm_param(g1) 0.25
set rlm_param(g2) 0.25
Class MMG
MMG instproc init { levels } {
	$self next
	$self instvar debug_ env_ maxlevel_
	set debug_ 0
	set env_ [lindex [split [$self info class] /] 1]
	set maxlevel_ $levels
	global rlm_debug_flag
	if [info exists rlm_debug_flag] {
		set debug_ $rlm_debug_flag
	}
	$self instvar TD TDVAR state_ subscription_
	global rlm_param
	set TD $rlm_param(init-td)
	set TDVAR $rlm_param(init-td-var)
	set state_ /S
	$self instvar layer_ layers_
	set i 1
	while { $i <= $maxlevel_ } {
		set layer_($i) [$self create-layer [expr $i - 1]]
		lappend layers_ $layer_($i)
		incr i
	}
	set subscription_ 0
	$self add-layer
	set state_ /S
	$self set_TJ_timer
}
MMG instproc set-state s {
	$self instvar state_
	set old $state_
	set state_ $s
	$self debug "FSM: $old -> $s"
}
MMG instproc drop-layer {} {
	$self dumpLevel
	$self instvar subscription_ layer_
	set n $subscription_
	if { $n > 0 } {
		$self debug "DRP-LAYER $n"
		$layer_($n) leave-group
		incr n -1
		set subscription_ $n
	}
	$self dumpLevel
}
MMG instproc add-layer {} {
	$self dumpLevel
	$self instvar maxlevel_ subscription_ layer_
	set n $subscription_
	if { $n < $maxlevel_ } {
		$self debug "ADD-LAYER"
		incr n
		set subscription_ $n
		$layer_($n) join-group
	}
	$self dumpLevel
}
MMG instproc current_layer_getting_packets {} {
	$self instvar subscription_ layer_ TD
	set n $subscription_
	if { $n == 0 } {
		return 0
	}
	set l $layer_($subscription_)
	$self debug "npkts [$l npkts]"
	if [$l getting-pkts] {
		return 1
	}
	set delta [expr [$self now] - [$l last-add]]
	if { $delta > $TD } {
		set TD [expr 1.2 * $delta]
	}
	return 0
}
MMG instproc mmg_loss {} {
	$self instvar layers_
	set loss 0
	foreach l $layers_ {
		incr loss [$l nlost]
	}
	return $loss
}
MMG instproc mmg_pkts {} {
	$self instvar layers_
	set npkts 0
	foreach l $layers_ {
		incr npkts [$l npkts]
	}
	return $npkts
}
MMG instproc check-equilibrium {} {
	global rlm_param
	$self instvar subscription_ maxlevel_ layer_
	set n [expr $subscription_ + 1]
	if { $n >= $maxlevel_ || [$layer_($n) timer] >= $rlm_param(max) } {
		set eq 1
	} else {
		set eq 0
	}
	$self debug "EQ $eq"
}
MMG instproc backoff-one { n alpha } {
	$self debug "BACKOFF $n by $alpha"
	$self instvar layer_
	$layer_($n) backoff $alpha
}
MMG instproc backoff n {
	$self debug "BACKOFF $n"
	global rlm_param
	$self instvar maxlevel_ layer_
	set alpha $rlm_param(alpha)
	set L $layer_($n)
	$L backoff $alpha
	incr n
	while { $n <= $maxlevel_ } {
		$layer_($n) peg-backoff $L
		incr n
	}
	$self check-equilibrium
}
MMG instproc highest_level_pending {} {
	$self instvar maxlevel_
	set m ""
	set n 0
	incr n
	while { $n <= $maxlevel_ } {
		if [$self level_pending $n] {
			set m $n
		}
		incr n
	}
	return $m
}
MMG instproc rlm_update_D  D {
	global rlm_param
	$self instvar TD TDVAR
	set v [expr abs($D - $TD)]
	set TD [expr $TD * (1 - $rlm_param(g1)) \
				+ $rlm_param(g1) * $D]
	set TDVAR [expr $TDVAR * (1 - $rlm_param(g2)) \
		       + $rlm_param(g2) * $v]
}
MMG instproc exceed_loss_thresh {} {
	$self instvar h_npkts h_nlost
	set npkts [expr [$self mmg_pkts] - $h_npkts]
	if { $npkts >= 10 } {
		set nloss [expr [$self mmg_loss] - $h_nlost]
		set loss [expr double($nloss) / ($nloss + $npkts)]
		$self debug "H-THRESH $nloss $npkts $loss"
		if { $loss > 0.25 } {
			return 1
		}
	}
	return 0
}
MMG instproc enter_M {} {
	$self set-state /M
	$self set_TD_timer_wait
	$self instvar h_npkts h_nlost
	set h_npkts [$self mmg_pkts]
	set h_nlost [$self mmg_loss]
}
MMG instproc enter_D {} {
	$self set-state /D
	$self set_TD_timer_conservative
}
MMG instproc enter_H {} {
	$self set_TD_timer_conservative
	$self set-state /H
}
MMG instproc log-loss {} {
	$self debug "LOSS [$self mmg_loss]"
	$self instvar state_ subscription_ pending_ts_
	if { $state_ == "/M" } {
		if [$self exceed_loss_thresh] {
			$self cancel_timer TD
			$self drop-layer
			$self check-equilibrium
			$self enter_D
		}
		return
	}
	if { $state_ == "/S" } {
		$self cancel_timer TD
		set n [$self highest_level_pending]
		if { $n != "" } {
			$self backoff $n
			if { $n == $subscription_ } {
				set ts $pending_ts_($subscription_)
				$self rlm_update_D [expr [$self now] - $ts]
				$self drop-layer
				$self check-equilibrium
				$self enter_D
				return
			}
			if { $n == [expr $subscription_ + 1] } {
				$self cancel_timer TJ
				$self set_TJ_timer
			}
		}
		if [$self our_level_recently_added] {
			$self enter_M
			return
		}
		$self enter_H
		return
	}
	if { $state_ == "/H" || $state_ == "/D" } {
		return
	}
	puts stderr "rlm state machine botched"
	exit -1
}
MMG instproc relax_TJ {} {
	$self instvar subscription_ layer_
	if { $subscription_ > 0 } {
		$layer_($subscription_) relax
		$self check-equilibrium
	}
}
MMG instproc trigger_TD {} {
	$self instvar state_
	if { $state_ == "/H" } {
		$self enter_M
		return
	}
	if { $state_ == "/D" || $state_ == "/M" } {
		$self set-state /S
		$self set_TD_timer_conservative
		return
	}
	if { $state_ == "/S" } {
		$self relax_TJ
		$self set_TD_timer_conservative
		return
	}
	puts stderr "trigger_TD: rlm state machine botched $state)"
	exit -1
}
MMG instproc set_TJ_timer {} {
	global rlm_param
	$self instvar subscription_ layer_
	set n [expr $subscription_ + 1]
	if ![info exists layer_($n)] {
		return
	}
	set I [$layer_($n) timer]
	set d [expr $I / 2.0 + [trunc_exponential $I]]
	$self debug "TJ $d"
	$self set_timer TJ $d
}
MMG instproc set_TD_timer_conservative {} {
	$self instvar TD TDVAR
	set delay [expr $TD + 1.5 * $TDVAR]
	$self set_timer TD $delay
}
MMG instproc set_TD_timer_wait {} {
	$self instvar TD TDVAR
	$self instvar subscription_
	set k [expr $subscription_ / 2. + 1.5]
	$self set_timer TD [expr $TD + $k * $TDVAR]
}
MMG instproc is-recent { ts } {
	$self instvar TD TDVAR
	set ts [expr $ts + ($TD + 2 * $TDVAR)]
	if { $ts > [$self now] } {
		return 1
	}
	return 0
}
MMG instproc level_pending n {
	$self instvar pending_ts_
	if { [info exists pending_ts_($n)] && \
		 [$self is-recent $pending_ts_($n)] } {
		return 1
	}
	return 0
}
MMG instproc level_recently_joined n {
	$self instvar join_ts_
	if { [info exists join_ts_($n)] && \
		 [$self is-recent $join_ts_($n)] } {
		return 1
	}
	return 0
}
MMG instproc pending_inferior_jexps {} {
	set n 0
	$self instvar subscription_
	while { $n <= $subscription_ } {
		if [$self level_recently_joined $n] {
			return 1
		}
		incr n
	}
	$self debug "NO-PEND-INF"
	return 0
}
MMG instproc trigger_TJ {} {
	$self debug "trigger-TJ"
	$self instvar state_ ctrl_ subscription_
	if { ($state_ == "/S" && ![$self pending_inferior_jexps] && \
		  [$self current_layer_getting_packets])  } {
		$self add-layer
		$self check-equilibrium
		set msg "add $subscription_"
		$ctrl_ send $msg
		$self local-join
	}
	$self set_TJ_timer
}
MMG instproc our_level_recently_added {} {
	$self instvar subscription_ layer_
	return [$self is-recent [$layer_($subscription_) last-add]]
}
MMG instproc recv-ctrl msg {
	$self instvar join_ts_ pending_ts_ subscription_
	$self debug "X-JOIN $msg"
	set what [lindex $msg 0]
	if { $what != "add" } {
		return
	}
	set level [lindex $msg 1]
	set join_ts_($level) [$self now]
	if { $level > $subscription_ } {
		set pending_ts_($level) [$self now]
	}
}
MMG instproc local-join {} {
	$self instvar subscription_ pending_ts_ join_ts_
	set join_ts_($subscription_) [$self now]
	set pending_ts_($subscription_) [$self now]
}
MMG instproc debug { msg } {
	$self instvar debug_ subscription_ state_
	if {$debug_} {
		puts stderr "[gettimeofday] layer $subscription_ $state_ $msg"
	}
}
MMG instproc dumpLevel {} {
}
Class Layer
Layer instproc init { mmg } {
	$self next
	$self instvar mmg_ TJ npkts_
	global rlm_param
	set mmg_ $mmg
	set TJ $rlm_param(init-tj)
	set npkts_ 0
}
Layer instproc relax {} {
	global rlm_param
	$self instvar TJ
	set TJ [expr $TJ * $rlm_param(beta)]
	if { $TJ <= $rlm_param(init-tj) } {
		set TJ $rlm_param(init-tj)
	}
}
Layer instproc backoff alpha {
	global rlm_param
	$self instvar TJ
	set TJ [expr $TJ * $alpha]
	if { $TJ >= $rlm_param(max) } {
		set TJ $rlm_param(max)
	}
}
Layer instproc peg-backoff L {
	$self instvar TJ
	set t [$L set TJ]
	if { $t >= $TJ } {
		set TJ $t
	}
}
Layer instproc timer {} {
	$self instvar TJ
	return $TJ
}
Layer instproc last-add {} {
	$self instvar add_time_
	return $add_time_
}
Layer instproc join-group {} {
	$self instvar npkts_ add_time_ mmg_
	set npkts_ [$self npkts]
	set add_time_ [$mmg_ now]
}
Layer instproc leave-group {} {
}
Layer instproc getting-pkts {} {
	$self instvar npkts_
	return [expr [$self npkts] != $npkts_]
}
set rlm_debug_flag 1
Class Layer/mash -superclass Layer
Layer/mash instproc init {mmg net n} {
	$self next $mmg
	$self instvar net_ l_ n_
	set net_ $net
	set n_ $n
	set l_ [$net_ set net_($n)]
}
Layer/mash instproc join-group {} {
	$self instvar mmg_ net_
	set level [expr [$mmg_ set subscription_] - 1]
	$net_ set-subscription-level $level
	$self next
}
Layer/mash instproc leave-group {} {
	$self instvar mmg_ net_
	set level [expr [$mmg_ set subscription_] - 1]
	$net_ set-subscription-level $level
	$self next
}
Layer/mash instproc nlost {} {
	$self instvar l_
	return [$l_ nlost]
}
Layer/mash instproc npkts {} {
	$self instvar l_ n_
	return [$l_ npkts $n_]
}
Class MMG/mash -superclass MMG
MMG/mash instproc init {net caddr} {
	$self instvar net_
	set net_ $net
	$self next [$net set nchan_]
	proc ctrl$self {args} { puts "ctrl: $args" }
	$self set ctrl_ ctrl$self
}
MMG/mash instproc create-layer {layerNo} {
	$self instvar net_
	return [new Layer/mash $self $net_ $layerNo]
}
MMG/mash instproc now {} {
	return [gettimeofday]
}
MMG/mash instproc set_timer {which delay} {
	$self instvar timers_
	if [info exists timers_($which)] {
		puts "timer botched ($which)"
		exit 1
	}
	set delay [expr int($delay * 1000)]
	set timers_($which) [after $delay "$self trigger_timer $which"]
}
MMG/mash instproc trigger_timer {which} {
	$self instvar timers_
	unset timers_($which)
	$self trigger_$which
}
MMG/mash instproc cancel_timer {which} {
	$self instvar ns_ timers_
	if [info exists timers_($which)] {
		after cancel $timers_($which)
		unset timers_($which)
	}
}
MMG/mash instproc debug { msg } {
	$self instvar debug_
	if {!$debug_} { return }
	$self instvar subscription_ state_
	set time [format %.05f [$self now]]
	puts stderr "$time layer $subscription_ $state_ $msg"
}
proc uniform01 {} {
    return [expr double(([random] % 10000000) + 1) / 1e7]
}
proc uniform { a b } {
	return [expr ($b - $a) * [uniform01] + $a]
}
proc exponential mean {
	return [expr - $mean * log([uniform01])]
}
proc trunc_exponential lambda {
	while 1 {
		set u [exponential $lambda]
		if { $u < [expr 4 * $lambda] } {
			return $u
		}
	}
}
Class Network/IP -superclass Network
Network/IP instproc init args {
	puts stderr "Network/IP called... change to Network"
	eval $self next $args
}
Network instproc port args {
	eval $self sport $args
}
proc in_multicast addr {
	return [expr ([lindex [split $addr .] 0] & 0xf0) == 0xe0]
}
Class NetworkLayer
Class NetworkManager
NetworkManager instproc graphics-init n {
	if {$n == 1 || [winfo exists .l]} { return }
	$self instvar nchan_
	set nchan_ $n
	toplevel .l
	set k 0
	while { $k < $nchan_ } {
		radiobutton .l.b$k -command "$self set-subscription-level $k" \
				-text "Level $k" \
				-variable nLayers -value $k
		pack .l.b$k
		incr k
	}
	wm withdraw .l
	bind . <l> {
		if [winfo ismapped .l] {
			wm withdraw .l
		} else {
			wm deiconify .l
		}
	}
}
NetworkManager instproc set-subscription-level n {
	$self instvar agent_ nchan_ session_ net_
	$agent_ set_maxchannel $n
	$session_ set loopbackLayer_ [expr $n + 1]
	set i 0
	while { $i <= $n } {
		$net_($i) enable
		incr i
	}
	while { $i < $nchan_ } {
		$net_($i) disable
		incr i
	}
	global nLayers
	set nLayers $n
}
NetworkLayer instproc init { session addr sport rport ttl channel } {
	$self next
	$self instvar session_ addr_ port_ ttl_ dn_ cn_ channel_ active_
	set addr_ $addr
	set port_ $rport
	set sport_ $sport
	set rport_ $rport
	set session_ $session
	set ttl_ $ttl
	set channel_ $channel
	set dn_ [new Network]
	set result [$dn_ open $addr_ $sport_ $rport_ $ttl_]
	if {$result == {0}} {
		new ErrorWindow {Cannot open network connection.}
		exit 1
	}
	set cn_ [new Network]
	set result [$cn_ open $addr_ [expr $sport_ + 1] [expr $rport_ + 1] $ttl_]
	if {$result == {0}} {
		new ErrorWindow {Cannot open network connection.}
		exit 1
	}
	$cn_ loopback 1
	$session_ data-net $dn_ $channel_
	$session_ ctrl-net $cn_ $channel_
	set active_ 0
	$dn_ drop-membership
	$cn_ drop-membership
	$session_ data-net "" $channel_
	$session_ ctrl-net "" $channel_
	$self set tloss_ 0
}
NetworkLayer instproc destroy {} {
	$self instvar dn_ cn_
	if [info exists dn_] {
		delete $dn_
	}
	if [info exists cn_] {
		delete $cn_
	}
	$self next
}
NetworkLayer instproc data-net {} {
	return [$self set dn_]
}
NetworkLayer instproc ctrl-net {} {
	return [$self set cn_]
}
NetworkLayer instproc enable-send {} {
	$self instvar dn_ cn_ session_ channel_
	$session_ data-net $dn_ $channel_
	$session_ ctrl-net $cn_ $channel_
}
NetworkLayer instproc disable-send {} {
	$self instvar dn_ cn_ session_ channel_
	$session_ data-net "" $channel_
	$session_ ctrl-net "" $channel_
}
NetworkLayer instproc enable {} {
	$self instvar active_ dn_ cn_ session_ channel_
	if !$active_ {
		set active_ 1
		$dn_ add-membership
		$cn_ add-membership
		$session_ data-net $dn_ $channel_
		$session_ ctrl-net $cn_ $channel_
	}
}
NetworkLayer instproc disable {} {
	$self instvar dn_ cn_ active_ session_ channel_
	if $active_ {
		set active_ 0
		$dn_ drop-membership
		$cn_ drop-membership
		$session_ data-net "" $channel_
		$session_ ctrl-net "" $channel_
	}
}
NetworkLayer instproc notify-loss {src} {
	$self instvar loss_ tloss_
	if ![info exists loss_($src)] {
		set loss_($src) 0
	}
	set nloss [$src missing]
	incr tloss_ [expr $nloss - $loss_($src)]
	set loss_($src) $nloss
}
NetworkLayer instproc nlost {} {
	$self instvar tloss_
	return $tloss_
}
NetworkLayer instproc npkts {n} {
	$self instvar agent_
	set npkts 0
	foreach s [$agent_ set sources_] {
		set l [lindex [$s set layers_] $n]
		incr npkts [$l set np_]
	}
	return $npkts
}
NetworkLayer instproc crypt { dc cc } {
	$self instvar dn_ cn_
	$dn_ crypt $dc
	$cn_ crypt $cc
}
NetworkManager instproc init { ab session agent } {
	$self next
	$self instvar session_ agent_ encrypt_ key_ fmt_
	set session_ $session
	set agent_ $agent
	set encrypt_ 0
	set key_ ""
	set fmt_ ""
	$self allocate $ab $session
}
NetworkManager instproc allocate { ab session } {
	$self instvar nchan_ net_ mmg_
	if [info exists nchan_] {
		set oldnchan $nchan_
	} else {
		set oldnchan 0
	}
	set nchan_ 0
	while { $nchan_ < [$ab nchan] } {
		set addr [$ab addr $nchan_]
		set sport [$ab sport $nchan_]
		set rport [$ab rport $nchan_]
		set ttl [$ab ttl $nchan_]
		if [info exists net_($nchan_)] {
			delete $net_($nchan_)
		}
		set net_($nchan_) [new NetworkLayer $session $addr \
				$sport $rport $ttl $nchan_]
		$self instvar agent_
		$net_($nchan_) set agent_ $agent_
		incr nchan_
	}
	set n $nchan_
	while {$n < $oldnchan} {
		if [info exists net_($n)] {
			delete $net_($n)
		}
		incr n
	}
	if [info exists mmg_] {
		delete $mmg_
	}
	$self set-subscription-level 0
	if {$nchan_ == 1} { return }
	if [$self yesno useLayersWindow] {
		$self graphics-init $nchan_
	}
	if [$self get_option useRLM] {
		set caddr ""
		set mmg_ [new MMG/mash $self $caddr]
	}
}
NetworkManager instproc nchan {} {
	return [$self set nchan_]
}
NetworkManager instproc reset ab {
	$self instvar session_
	$self allocate $ab $session_
}
NetworkManager instproc data-net args {
	if { $args == "" } {
		set k 0
	} else {
		set k $args
	}
	$self instvar net_
	return [$net_($k) data-net]
}
NetworkManager instproc ctrl-net args {
	if { $args == "" } {
		set k 0
	} else {
		set k $args
	}
	$self instvar net_
	return [$net_($k) ctrl-net]
}
NetworkManager public loopback enable {
	$self instvar nchan_ net_
	set i 0
	while { $i < $nchan_ } {
		set net $net_($i)
		set dn [$net data-net]
		set cn [$net ctrl-net]
		$dn loopback $enable
		$cn loopback $enable
		incr i
	}
}
NetworkManager instproc install-key key {
	return [$self set_key $key]
}
NetworkManager instproc crypt_all { dc cc } {
	$self instvar net_
	foreach n [array names net_] {
		$net_($n) crypt $dc $cc
	}
}
NetworkManager instproc destroy {} {
	$self instvar net_
	foreach chan [array names net_] {
		delete $net_($chan)
	}
	$self next
}
NetworkManager instproc usingRLM {} {
	$self instvar mmg_
	return [info exists mmg_]
}
NetworkManager instproc notify-loss {src layer} {
	$self instvar net_
	$net_($layer) notify-loss $src
}
NetworkManager instproc crypt_format { key } {
	set k [string first / $key]
	if { $k < 0 } {
		set fmt DES
	} else {
		set fmt [string range $key 0 [expr $k - 1]]
		set key [string range $key [expr $k + 1] end]
	}
	return "$fmt $key"
}
NetworkManager instproc set_key key {
	if { $key == "" } {
		$self crypt_clear
		return ""
	}
	$self instvar encrypt_
	set L [$self crypt_format $key]
	set fmt [lindex $L 0]
	set key [lindex $L 1]
	$self instvar key_
	set key_ $key
	$self instvar dc_ cc_ fmt_
	if { $fmt_ != $fmt } {
		if [info exists dc_] {
			delete $dc_
			unset dc_
		}
		if [info exists cc_] {
			delete $cc_
			unset cc_
		}
		set fmt_ $fmt
	}
	if ![info exists dc_] {
		set clist [Crypt/Data info subclass]
		if { [lsearch -exact $clist Crypt/Data/$fmt] < 0 } {
			return "no $fmt encryption support"
		}
		set dc_ [new Crypt/Data/$fmt]
		set cc_ [new Crypt/Control/$fmt]
	}
	if [$dc_ key $key] {
		$cc_ key $key
		$self crypt_all $dc_ $cc_
		set encrypt_ 1
		return ""
	} else {
		$self crypt_clear
		return "your key is cryptographically weak"
	}
}
NetworkManager instproc crypt_clear {} {
	$self instvar encrypt_ key_
	$self crypt_all "" ""
	set key_ ""
	set encrypt_ 0
}
AnnounceListenManager public init { spec {mtu 1500} } {
	$self next $mtu
	$self instvar data_ snet_ rnet_
	set data_ ""
	set snet_ ""
	set rnet_ ""
	if [regexp {^[0-9]*$} $spec] {
		set rnet_ [new Network]
		$rnet_ open $spec
	} else {
		set ab [new AddressBlock/Simple $spec]
		set addr  [$ab addr]
		set sport [$ab sport]
		set rport [$ab rport]
		set ttl   [$ab ttl]
		delete $ab
		set snet_ [new Network]
		if [in_multicast $addr] {
			$snet_ open $addr $sport $rport $ttl
			set rnet_ $snet_
		} else {
			if { $rport != 0 } {
				set rnet_ [new Network]
				$rnet_ open $rport
			}
			$snet_ open $addr $sport 0 1
		}
	}
	if { $snet_ != "" } {
		$snet_ loopback 1
		$self send_network $snet_
	}
	if { $rnet_ != "" } {
		$self recv_network $rnet_
	}
}
AnnounceListenManager public destroy {} {
	$self instvar snet_ rnet_ timers_
	if { $rnet_==$snet_ } {
		delete $snet_
	} else {
		if { $snet_ != "" } {
			delete $snet_
		}
		if { $rnet_ != "" } {
			delete $rnet_
		}
	}
	if [info exists timers_] {
		foreach t [array names timers_] {
			delete $timers_($t)
		}
	}
	$self next
}
AnnounceListenManager public timer {args} {
	$self instvar timers_
	if {[llength $args]==1} {
		set d __default_timer__
		set t [lindex $args 0]
		if {$t!={}} { $t proc timeout { } "$self send_announcement" }
	} else {
		set d [lindex $args 0]
		set t [lindex $args 1]
		if {$t!={}} { $t proc timeout { } \
				[list $self send_announcement $d] }
	}
	if [info exists timers_($d)] {
		set sched [$timers_($d) is_sched]
		delete $timers_($d)
	} else {
		set sched 0
	}
	if {$t!={}} {
		set timers_($d) $t
		if $sched {
			$t start
		}
	} else {
		catch {unset timers_($d)}
	}
	return $t
}
AnnounceListenManager public get_timer {args} {
	$self instvar timers_
	if {[llength $args]==0} {
		set d __default_timer__
	} else {
		set d [lindex $args 0]
	}
	if [info exists timers_($d)] { return $timers_($d) } else { return "" }
}
AnnounceListenManager public start {args} {
	if { [llength $args]==0 } {
		set t [$self get_timer]
	} else {
		set d [lindex $args 0]
		set t [$self get_timer $d]
	}
	if { $t=={} } {
		set t [new Timer/Periodic]
		$t randomize 1
		if [info exists d] { $self timer $d $t } else { $self timer $t}
	}
	if [info exists d] {$self send_announcement $d} \
			else {$self send_announcement}
	$t start
}
AnnounceListenManager public stop {args} {
	$self instvar timers_
	if {[llength $args]==0} {
		foreach d [array names timers_] {
			$timers_($d) cancel
		}
	} else {
		set d [lindex $args 0]
		$timers_($d) cancel
	}
}
AnnounceListenManager public recv_announcement { addr port data len } {
	puts "ALM::recv_announcement $addr/$port \[$len\]: $data"
}
AnnounceListenManager public send_announcement {args} {
	$self instvar data_
	if {[llength $args]==0} {
		if { $data_!={} } { $self announce $data_ }
	} else {
		$self announce [lindex $args 0]
	}
}
AnnounceListenManager public set_announcement { data } {
	$self set data_ $data
}
AnnounceListenManager public get_announcement { } {
	return [$self set data_]
}
AnnounceListenManager public ttl {num} {
	$self instvar snet_
	$snet_ ttl $num
}
Class AnnounceListenManager/AS -superclass AnnounceListenManager
AnnounceListenManager/AS instproc init { netspec bw atype } {
	random 0
	$self next $netspec 1024
	$self instvar atype_
	set atype_ $atype
	$self instvar agentbytype_
	set agentbytype_(srv) ""
	set agentbytype_(client) ""
	set agentbytype_(hm) ""
	set t [new Timer/Adaptive/ConstBW $bw 3000]
	$t randomize
        $self timer $t
	set o [$self options]
	$o add_default startupWait 60
	$self instvar aliveid_
	set aliveid_ [after [expr [$self get_option startupWait]*1000] "$self check_alive 1"]
}
AnnounceListenManager/AS proc version {} {
	return 2.0
}
AnnounceListenManager/AS public send_announcement {} {
	$self instvar atype_
	set o "ASCP v[$class version]"
	set n $atype_
	set o $o\n$n
	set n [$self agent_instance]
	set o $o\n$n
	set n [$self service_name]
	set o $o\n$n
	set n [$self service_location]
	set o $o\n$n
	set n [$self service_instance]
	set o $o\n$n
	set n [$self ssg_port]
	set o $o\n$n
	set n [$self agent_data]
	set o $o\n$n
	$self announce $o
	$self check_alive 0
}
AnnounceListenManager/AS instproc announce_death {} {
	$self instvar id1_ id2_ atype_
	set o "ASCP v[AnnounceListenManager/AS version]"
	set n $atype_
	set o $o\n$n
	set n [$self agent_instance]
	set o $o\n$n
	set n bye
	set o $o\n$n
	set n -
	set o $o\n$n
	set n -
	set o $o\n$n
	set n -
	set o $o\n$n
	$self announce $o
}
AnnounceListenManager/AS public agent_instance {} {
	return "[pid]@[lookup_host_name [localaddr]]"
}
AnnounceListenManager/AS public agent_data {} {
	return ""
}
AnnounceListenManager/AS public ssg_port {} {
	return "-"
}
AnnounceListenManager/AS instproc service_location {} {
	return "-"
}
AnnounceListenManager/AS instproc destroy {} {
	$self instvar aliveid_
	after cancel $aliveid_
	$self next
}
AnnounceListenManager/AS instproc recv_announcement { addr port data size } {
	$self instvar lastann_ sdp_ agentbytype_ agenttab_ atype_
        set t [$self get_timer]
	$t sample_size $size
	set o [split $data \n]
	if { [lindex $o 0] != "ASCP v[$class version]" } {
		set msg "$self ($class): received non-ASCP v[$class version] announcement from $addr."
		if { $atype_ == "hm" } {
			$self instvar agent_
			$agent_ log $msg
		} else {
			puts stderr $msg
		}
 		return
	}
	set atype [lindex $o 1]
	set aspec [lindex $o 2]
	set srv_name [lindex $o 3]
	set srv_loc [lindex $o 4]
	set srv_inst [lindex $o 5]
	set ssg_port [lindex $o 6]
	set ad [join [lrange $o 7 end] \n]
	if { $srv_name == "DEATH" } {
		set msg "Received death packet from $aspec at $addr - exiting."
		if { $srv_loc == $atype_ } {
			if { $atype_ == "hm" } {
				$self instvar agent_
				$agent_ log $msg
			} else {
				puts stderr $msg
			}
			$self announce_death
			exit 0
		}
		$self recv_msg $atype $aspec $addr DEATH $srv_loc \
			$srv_inst $ssg_port "$ad"
		return
	}
	if { $srv_name == "bye" } {
		$self delete_agent $aspec
		return
	}
	if ![info exists agenttab_($aspec)] {
		$self instvar avgdelta_
		$self register $atype $aspec $addr $srv_name $srv_inst "$ad"
	        $t incr_nsrcs
		set timeout [$self get_option startupWait]
		set avgdelta_($aspec) [expr $timeout / 8]
		lappend agentbytype_($atype) $aspec
	} else {
		set now [gettimeofday]
		set delta [expr $now - $lastann_($aspec,abs)]
		$self instvar avgdelta_
		set avgdelta_($aspec) \
				[expr 0.875*$avgdelta_($aspec)+0.125*$delta]
	}
	set agenttab_($aspec) "$addr {$ad} $atype $srv_name $srv_inst"
	set lastann_($aspec,abs) [gettimeofday]
	set lastann_($aspec,ascii) [gettimeofday ascii]
	$self recv_msg $atype $aspec $addr $srv_name $srv_loc $srv_inst \
			$ssg_port "$ad"
}
AnnounceListenManager/AS instproc advance_timers { delta } {
	$self instvar lastann_ agenttab_ avgdelta_
	set aspecs [array names agenttab_]
	foreach aspec $aspecs {
		set lastann_($aspec,abs) [expr $lastann_($aspec,abs)+$delta]
	}
}
AnnounceListenManager/AS instproc check_alive { timer } {
	$self instvar lastann_ agenttab_ avgdelta_
	set now [gettimeofday]
	set aspecs [array names agenttab_]
	foreach aspec $aspecs {
		set lastann $lastann_($aspec,abs)
		set avgdelta $avgdelta_($aspec)
		set delta [expr $now - $lastann]
		if { $delta > 8 * $avgdelta } {
			$self delete_agent $aspec
		}
	}
	$self instvar aliveid_
	if { $timer } {
		set t [expr [$self get_option startupWait]*1000]
		set aliveid_ [after $t "$self check_alive 1"]
	}
}
AnnounceListenManager/AS instproc delete_agent { aspec } {
 	$self instvar agentbytype_ agenttab_ lastann_ avgdelta_
	if ![info exists agenttab_($aspec)] {
		return
	}
	set a $agenttab_($aspec)
	set addr [lindex $a 0]
	set ad [lindex $a 1]
	set atype [lindex $a 2]
	set srv_name [lindex $a 3]
	set srv_inst [lindex $a 4]
	unset agenttab_($aspec)
	unset lastann_($aspec,abs)
	unset lastann_($aspec,ascii)
	unset avgdelta_($aspec)
	set t $agentbytype_($atype)
	set i [lsearch -exact $t $aspec]
	set agentbytype_($atype) [lreplace $t $i $i]
	[$self get_timer] incr_nsrcs -1
	$self unregister $atype $aspec $addr $srv_name $srv_inst "$ad"
}
AnnounceListenManager/AS instproc agenttab aspec {
	$self instvar agenttab_
	if [info exists agenttab_($aspec)] {
		return $agenttab_($aspec)
	}
	return ""
}
Class AnnounceListenManager/AS/HM -superclass AnnounceListenManager/AS
AnnounceListenManager/AS/HM instproc init { agent spec bw } {
	$self next $spec $bw hm
	$self set agent_ $agent
	[$self get_timer] threshold 10000
}
AnnounceListenManager/AS/HM instproc recv_msg { atype aspec addr srv_name srv_loc srv_inst ssg_port msg } {
	$self instvar agent_
	switch $atype {
	srv {
	}
	hm {
		$self handle_hm_msg $aspec $msg $addr $srv_name $srv_inst
	}
	client {
		set load [HMAgent get_load]
		set hiload [$self get_option highLoad]
		if { [$self get_option noLoad] == "" &&  $load >= $hiload } {
			$agent_ log "HI LOAD load=$load $hiload"
		} else {
			after 2000 $self "handle_client_msg $srv_name \
				$srv_loc $srv_inst {$msg} [gettimeofday]"
		}
	}
	}
}
AnnounceListenManager/AS/HM instproc duphm { name } {
	if { [string compare $name [$self agent_instance]] < 0 } {
		$self instvar agent_
		$agent_ log "duplicate hm: $name [$self agent_instance] - exiting."
		$agent_ doexit
	}
}
AnnounceListenManager/AS/HM instproc handle_hm_msg { aspec msg addr srv_name srv_inst } {
	$self instvar agent_
	switch $srv_name {
	update {
		if { $addr == [localaddr] } {
			$self duphm $aspec
		}
	}
	launch {
		$agent_ suppress_timer $srv_inst
	}
	}
}
AnnounceListenManager/AS/HM instproc handle_client_msg { srv_name srv_loc srv_inst msg ts } {
	$self instvar agent_
	if [$agent_ pending_timer $srv_inst] {
		return
	}
	$self instvar agentbytype_ agenttab_ lastann_
	set srvlist $agentbytype_(srv)
	foreach srvspec $srvlist {
		set srv $agenttab_($srvspec)
		set inst [lindex $srv 4]
		if { $inst == $srv_inst } {
	     		set lastann $lastann_($srvspec,abs)
	     		if { $lastann < $ts - 1 } {
				$self delete_agent $srvspec
				break
			}
			return
		}
	}
	$agent_ sched_launch $srv_name $srv_loc $srv_inst $msg
}
AnnounceListenManager/AS/HM instproc register { atype aspec addr srv_name srv_inst msg } {
	$self instvar agent_
	if { $addr != [localaddr] || $atype != "srv" } {
		return
	}
	$agent_ cancel_timer $srv_inst
}
AnnounceListenManager/AS/HM instproc unregister { atype aspec addr srv_name srv_inst ad } {
	$self instvar agent_
	if { $addr != [localaddr] || $atype != "srv" } {
		return
	}
	$agent_ unregister $aspec $ad
}
AnnounceListenManager/AS/HM instproc announce_launch { srv_inst } {
	set o "ASCP v[AnnounceListenManager/AS version]"
	set n hm
	set o $o\n$n
	set n [$self agent_instance]
	set o $o\n$n
	set n launch
	set o $o\n$n
	set n -
	set o $o\n$n
	set n $srv_inst
	set o $o\n$n
	set n -
	set o $o\n$n
	$self announce $o
}
AnnounceListenManager/AS/HM instproc send_announcement {} {
	$self instvar id1_ id2_
	set o "ASCP v[AnnounceListenManager/AS version]"
	set n hm
	set o $o\n$n
	set n [$self agent_instance]
	set o $o\n$n
	set n update
	set o $o\n$n
	set n -
	set o $o\n$n
	set n -
	set o $o\n$n
	set n -
	set o $o\n$n
	$self announce $o
}
AnnounceListenManager/AS/HM instproc hmnum {} {
	return [llength [$self hmaddrs]]
}
AnnounceListenManager/AS/HM instproc hmaddrs {} {
	$self instvar agenttab_
	set aspecs [array names agenttab_]
	foreach aspec $aspecs {
		set addr [lindex $agenttab_($aspec) 0]
		set d($addr) 1
	}
	return [array names d]
}
Class RTP
Class RTP/Video -superclass RTP
Class RTP/Audio -superclass RTP
RTP private init {} {
	eval $self next
	$self instvar rtp_ptoa_
	set rtp_ptoa_(-1) ""
}
RTP/Audio set default_ptoa_(0) pcm
RTP/Audio set default_ptoa_(1) celp
RTP/Audio set default_ptoa_(2) g721
RTP/Audio set default_ptoa_(3) gsm
RTP/Audio set default_ptoa_(5) dvi
RTP/Audio set default_ptoa_(6) dvi
RTP/Audio set default_ptoa_(7) lpc
RTP/Audio set default_ptoa_(8) pcma
RTP/Audio set default_ptoa_(9) g722
RTP/Audio set default_ptoa_(10) lin16
RTP/Audio set default_ptoa_(11) lin16
RTP/Audio set default_ptoa_(14) mpa
RTP/Audio set default_ptoa_(15) g728
RTP/Video set default_ptoa_(21) pvh
RTP/Video set default_ptoa_(25) cellb
RTP/Video set default_ptoa_(26) jpeg
RTP/Video set default_ptoa_(27) cuseeme
RTP/Video set default_ptoa_(28) nv
RTP/Video set default_ptoa_(29) picw
RTP/Video set default_ptoa_(30) cpv
RTP/Video set default_ptoa_(31) h261
RTP/Video set default_ptoa_(32) mpeg
RTP/Video set default_ptoa_(33) mpegs
RTP/Video set default_ptoa_(42) h263+
RTP/Video set default_ptoa_(34) h263
RTP/Audio set default_ptoa_(126) mp3
RTP/Video set default_ptoa_(127) h261v1
RTP/Video set default_ptoa_(50) sc
RTP/Audio public init args {
	$self next
	$class instvar default_ptoa_
	$self instvar rtp_ptoa_ rtp_atop_
	foreach p [array names default_ptoa_] {
		$self add_mapping $p $default_ptoa_($p)
	}
	foreach mapping [$self get_option rtpMap] {
		set l [split $mapping :]
		set pt [lindex $l 0]
		set fmt [lindex $l 1]
		$self add_mapping $pt $fmt
	}
}
RTP/Video public init args {
	$self next
	$class instvar default_ptoa_
	$self instvar rtp_ptoa_ rtp_atop_
        set rtp_ptoa_(-1) ""
	foreach p [array names default_ptoa_] {
		set rtp_ptoa_($p) $default_ptoa_($p)
		set rtp_atop_($default_ptoa_($p)) $p
	}
	foreach mapping [$self get_option rtpMap] {
		set l [split $mapping :]
		set pt [lindex $l 0]
		set fmt [lindex $l 1]
		$self add_mapping $pt $fmt
	}
	$self instvar classmap_
	set classmap_(pvh) PVH
	set classmap_(h261) H261
	set classmap_(h261v1) H261v1
	set classmap_(nv) NV
	set classmap_(cellb) CellB
	set classmap_(jpeg) JPEG
        set classmap_(h263+) H263+
        set classmap_(h263) H263
	set classmap_(sc) SC
}
RTP/Video public classmap type {
	$self instvar classmap_
	if [info exists classmap_($type)] {
		return $classmap_($type)
	}
	return "Null"
}
RTP public add_mapping {pt fmt} {
	$self instvar rtp_ptoa_ rtp_atop_
	set rtp_ptoa_($pt) $fmt
	set rtp_atop_($fmt) $pt
}
RTP public rtp_type pt {
	$self instvar rtp_ptoa_
	if [info exists rtp_ptoa_($pt)] {
		return $rtp_ptoa_($pt)
	} elseif { $pt < 0 }  {
		return ""
	} else {
		return fmt-$pt
	}
}
RTP public rtp_fmt_number fmt {
	$self instvar rtp_atop_
	if [info exists rtp_atop_($fmt)] {
		return $rtp_atop_($fmt)
	} else {
		return -1
	}
}
RTP public rtp_format src {
	$self instvar rtp_ptoa_
	return [$self rtp_type [$src format]]
}
RTP instproc cname_redundant { name cname } {
	set ni [string first @ $name]
	if { $ni < 0 } {
		return 0
	}
	set ci [string first @ $cname]
	if { $ci < 0 } {
		return 0
	}
	if { [string compare \
		[string range $name 0 $ni] \
		[string range $cname 0 $ci]] == 0 } {
		return 1
	}
	return 0
}
RTP public rtp_representation src {
	set fmt [$self rtp_format $src]
	set name [$src sdes name]
	set cname [$src sdes cname]
	set addr [$src addr]
	if { $name == "" } {
		if { $cname == "" } {
			set srcname $addr
			set srcinfo $addr/$fmt
		} else {
			set srcname $cname
			set srcinfo $addr/$fmt
		}
	} elseif [$self cname_redundant $name $cname] {
		set srcname $name
		set srcinfo $addr/$fmt
	} else {
		set srcname $name
		set srcinfo $cname/$fmt
	}
	return "{$srcname} {$srcinfo}"
}
Class SDPParser
Class SDPMedia
Class SDPTime
Class SDPMessage
SDPParser instproc init { {ordered_syntax 1} } {
	$self next
	$self instvar nextsym_ ordered_syntax_ parse_error_
	set nextsym_(start) "v"
	set nextsym_(v) "o"
	set nextsym_(o) "s"
	set nextsym_(s) "i u e p c b t"
	set nextsym_(i) "u e p c b t"
	set nextsym_(u) "e p c b t"
	set nextsym_(e) "e p c b t"
	set nextsym_(p) "e p c b t"
	set nextsym_(c) "b t "
	set nextsym_(b) "t"
	set nextsym_(t) "t r z k a m"
	set nextsym_(r) "t z k a m"
	set nextsym_(z) "k a m"
	set nextsym_(k) "a m"
	set nextsym_(a) "a m"
	set nextsym_(m) "m i:m c:m b:m k:m a:m v"
	set nextsym_(i:m) "m c:m b:m k:m a:m v"
	set nextsym_(c:m) "m b:m k:m a:m v"
	set nextsym_(b:m) "m k:m a:m v"
	set nextsym_(k:m) "m a:m v"
	set nextsym_(a:m) "m a:m v"
	set ordered_syntax_ $ordered_syntax
	set parse_error_ ""
}
SDPParser instproc check_syntax { last cur media } {
	$self instvar nextsym_
	if ![info exists nextsym_($last)] {
		return ""
	}
	foreach s $nextsym_($last) {
		set t [split $s :]
		if { [lindex $t 0] == $cur } {
			return $s
		}
	}
	return ""
}
SDPParser instproc parse { announcement } {
	$self instvar parse_error_ ordered_syntax_
	set media ""
	set allmsgs ""
	set lasttag "start"
	set lines [split $announcement "\n"]
	set parse_error_ ""
	set lnum 0
	foreach line $lines {
		incr lnum
		set line [string trimright $line]
		if { $line=={} } continue
		set sline [split $line =]
		set tag [lindex $sline 0]
		set value [join [lrange $sline 1 end]]
		set ret [$self check_syntax $lasttag $tag $media]
		if { $ret == "" && $ordered_syntax_==1 } {
			set parse_error_ "$class: syntax error between\
					$lasttag and $tag in line $lnum."
			foreach m $allmsgs {
				delete $m
			}
			return ""
		}
		set lasttag $ret
		switch $tag {
		v {
			set media ""
			set msg [new SDPMessage]
			lappend allmsgs $msg
			$msg set version_ $value
		}
		o {
			if {![info exists msg]} {
				set media ""
				set msg [new SDPMessage]
				lappend allmsgs $msg
				$msg set version_ 0
				set tmp [$msg set msgtext_]
				lappend tmp "v=0"
				$msg set msgtext_ $tmp
			}
			$msg set creator_ [lindex $value 0]
			$msg set createtime_ [lindex $value 1]
			$msg set modtime_  [lindex $value 2]
			$msg set nettype_ [lindex $value 3]
			$msg set addrtype_ [lindex $value 3]
			$msg set createaddr_ [lindex $value 5]
		}
		s {
			$msg set session_name_ $value
		}
		i {
			if { $media != "" } {
				$media set session_info_ $value
			} else {
				$msg set session_info_ $value
			}
		}
		p {
			set tmp ""
			catch { set tmp [$msg set phonelist_] }
			lappend tmp $value
			$msg set phonelist_ $tmp
		}
		e {
			set tmp ""
			catch { set tmp [$msg set emaillist_] }
			lappend tmp $value
			$msg set emaillist_ $tmp
		}
		u {
			$msg set uri_ $value
		}
		c {
			if { $media != "" } {
				$media set nettype_ [lindex $value 0]
				$media set addrtype_ [lindex $value 1]
				$media set caddr_ [lindex $value 2]
			} else {
				$msg set nettype_ [lindex $value 0]
				$msg set addrtype_ [lindex $value 1]
				$msg set caddr_ [lindex $value 2]
			}
		}
		b {
			set bwspec [split $value :]
			if { $media != "" } {
				$media set bwmod_ [lindex $bwspec 0]
				$media set bwval_ [lindex $bwspec 1]
			} else {
				$msg set bwmod_ [lindex $bwspec 0]
				$msg set bwval_ [lindex $bwspec 1]
			}
		}
		t {
			set tdes [new SDPTime]
			$tdes set fields_(t) $value
			$tdes set starttime_ [lindex $value 0]
			$tdes set endtime_ [lindex $value 1]
			set tmp [$msg set alltimedes_]
			lappend tmp $tdes
			$msg set alltimedes_ $tmp
		}
		r {
			$tdes set fields_(r) $value
			$tdes set repeat_interval_ [lindex $value 0]
			$tdes set active_duration_ [lindex $value 1]
			$tdes set offlist_ [lrange $value 2 end]
		}
		z {
			set nval [llength $value]
			if [expr 2 * ($nval / 2) != $nval] {
				foreach m $allmsgs {
					delete $m
				}
				return ""
			}
			$self instvar zoneinfo_
			for { set n 0 } { $n < $nval } { incr n } {
				set adjtime [lindex $value $n]
				incr n
				set offset [lindex $value $n]
				lappend zoneinfo_ "$adjtime $offset"
			}
		}
		k {
			set tmp [split $value :]
			if { $media != "" } {
				$media set crypt_method_ [lindex $tmp 0]
				$media set crypt_key_ [lindex $tmp 1]
			} else {
				$msg set crypt_method_ [lindex $tmp 0]
				$msg set crypt_key_ [lindex $tmp 1]
			}
		}
		a {
			set attribute [split $value ":"]
			set attname [lindex $attribute 0]
			set attval [join [lrange $attribute 1 end] ":"]
			if { $media != "" } {
				set target $media
			} else {
				set target $msg
			}
			if [catch {$target set attributes_($attname)}] {
				$target set attributes_($attname) {}
			}
			$target set attributes_($attname) \
			    [concat [$target set attributes_($attname)] \
				 [list $attval]]
		}
		m {
			set media [new SDPMedia $msg]
			set mt [lindex $value 0]
			$media set mediatype_ $mt
			$media set port_  [lindex $value 1]
			$media set proto_ [lindex $value 2]
			$media set fmt_ [lrange $value 3 end]
			set tmp ""
			catch { set tmp [$msg set media_array_($mt)] }
			lappend tmp $media
			$msg set media_array_($mt) $media
			set tmp [$msg set allmedia_]
			lappend tmp $media
			$msg set allmedia_ $tmp
		}
		default {
			set parse_error_ "$class: error unknown modifier $tag."
			foreach m $allmsgs {
				delete $m
			}
			return ""
		}
		}
		set tmp [$msg set msgtext_]
		lappend tmp $line
		$msg set msgtext_ $tmp
		if { $media != "" && [regexp {[icbka]} $tag] } {
			$media set fields_($tag) $value
		} else {
			$msg set fields_($tag) $value
		}
	}
	foreach msg $allmsgs {
		set tmp [$msg set msgtext_]
		set tmp [join $tmp \n]
		append tmp \n
		$msg set msgtext_ $tmp
	}
	return $allmsgs
}
SDPParser instproc parse_error { } {
	return [$self set parse_error_]
}
SDPMessage instproc init {} {
	$self next
	$self instvar allmedia_ alltimedes_ msgtext_
	set allmedia_ ""
	set alltimedes_ ""
	set msgtext_ ""
}
SDPMessage instproc destroy {} {
	$self instvar allmedia_ alltimedes_
	foreach m $allmedia_ {
		delete $m
	}
	foreach t $alltimedes_ {
		delete $t
	}
	$self next
}
SDPMessage instproc media { media_type } {
	$self instvar media_array_
	if [info exists media_array_($media_type)] {
		return $media_array_($media_type)
	} else {
		return ""
	}
}
SDPMessage instproc have_field { field } {
	$self instvar fields_
	return [info exists fields_($field)]
}
SDPMessage instproc field_value { field } {
	$self instvar fields_
	if [info exists fields_($field)] {
		return $fields_($field)
	} else {
		return ""
	}
}
SDPMessage instproc attributes {} {
	$self instvar attributes_
	if [info exists attributes_] {
		return [array names attributes_]
	} else {
		return ""
	}
}
SDPMessage instproc have_attr { name } {
	$self instvar attributes_
	return [info exists attributes_($name)]
}
SDPMessage instproc attr_value { name } {
    $self instvar attributes_
    if [info exists attributes_($name)] {
	    return $attributes_($name)
    } else {
	    return ""
    }
}
SDPMessage instproc obj2str {} {
	$self instvar attributes_ alltimedes_ allmedia_
	set o "v=[$self field_value v]"
	foreach f { o s i u } {
		if [$self have_field $f] {
			set n "$f=[$self field_value $f]"
			set o $o\n$n
		}
	}
	$self instvar phonelist_ emaillist_
	if [info exists phonelist_] {
		foreach e $phonelist_ {
			set n "p=$e"
			set o $o\n$n
		}
	}
	if [info exists emaillist_] {
		foreach e $emaillist_ {
			set n "e=$e"
			set o $o\n$n
		}
	}
	foreach f { c b } {
		if [$self have_field $f] {
			set n "$f=[$self field_value $f]"
			set o $o\n$n
		}
	}
	foreach t $alltimedes_ {
		set n [$t obj2str]
		set o $o\n$n
	}
	foreach f { z k } {
		if [$self have_field $f] {
			set n "$f=[$self field_value $f]"
			set o $o\n$n
		}
	}
	foreach a [$self attributes] {
		if { $attributes_($a) == "" } {
			set n "a=$a"
		} else {
			set n "a=$a:$attributes_($a)"
		}
		set o $o\n$n
	}
	foreach m $allmedia_ {
		set n [$m obj2str]
		set o $o\n$n
	}
	return $o
}
SDPMessage public unique_key {} {
    if ![$self have_field o] {
	$self warn "in SDPMessage::unique_key without o= field"
	return ""
    }
    set l [split [$self field_value o]]
    set l [lreplace $l 2 2]
    set key [join $l :]
    return $key
}
SDPMessage instproc htmlify_media { } {
    set html {}
    foreach media [$self set allmedia_] {
	append html [$media create_dynamic_html \
		[DynamicHTMLifier set html_(media)]]
    }
    return $html
}
SDPMessage instproc htmlify_times { {single_line 0} } {
    set html {}
    if $single_line { set t time1 } else { set t time }
    foreach time [$self set alltimedes_] {
	set repeat [string tolower [$time readable_repeat]]
	if { [$time set starttime_] != 0 } {
	    append html [$time create_dynamic_html \
			    [DynamicHTMLifier set html_(${t}_$repeat)]]
	} else {
	    append html "Unbounded session"
	}
    }
    return $html
}
SDPMessage instproc htmlify_url { } {
    $self instvar uri_
    if [info exists uri_] {
	return "<a href=\"$uri_\">$uri_</a>"
    } else {
	return ""
    }
}
SDPMessage instproc htmlify_list { varname } {
    set list {}
    foreach elt [$self get $varname] {
	if { $list!={} } {
	    append list ", $elt"
	} else {
	    append list $elt
	}
    }
    return $list
}
SDPMessage instproc get { varname } {
    $self instvar $varname
    if [info exists $varname] {
	return [set $varname]
    } else {
	return ""
    }
}
SDPMedia instproc htmlify_mediatype { } {
    return "[$self set mediatype_]"
}
SDPMedia instproc get { varname } {
    $self instvar $varname
    if [info exists $varname] {
	return [set $varname]
    } elseif { $varname == "spec_" } {
	    set caddr [split [$self get caddr_] /]
	    set port [$self get port_]
	    set spec [lindex $caddr 0]/$port
	    set ttl [lindex $caddr 1]
	    if { $ttl != {} } { append spec /$ttl }
	    return $spec
    } else {
	return ""
    }
}
SDPMedia instproc init {{msg ""}} {
	$self next
	if {$msg == ""} { return }
	$self instvar attributes_ fields_
	set alist [$msg attributes]
	foreach a $alist {
		set attributes_($a) [$msg set attributes_($a)]
	}
	set vlist [$msg info vars]
	foreach f { session_info_ nettype_ addrtype_ caddr_ bwmod_ bwval_
		crypt_method_ crypt_key_ } {
		if { [lsearch -exact $vlist $f] >= 0 } {
			$self set $f [$msg set $f]
		}
	}
	foreach f { i c b k a } {
		if [$msg have_field $f] {
			set fields_($f) [$msg field_value $f]
		}
	}
}
SDPMedia instproc have_field { field } {
	$self instvar fields_
	return [info exists fields_($field)]
}
SDPMedia instproc field_value { field } {
	$self instvar fields_
	if [info exists fields_($field)] {
		return $fields_($field)
	} else {
		return ""
	}
}
SDPMedia instproc have_attr { name } {
	$self instvar attributes_
	return [info exists attributes_($name)]
}
SDPMedia instproc attr_value { name } {
    $self instvar attributes_
    if [info exists attributes_($name)] {
	    return $attributes_($name)
    } else {
	    return ""
    }
}
SDPMedia instproc attributes {} {
	$self instvar attributes_
	if [info exists attributes_] {
		return [array names attributes_]
	} else {
		return ""
	}
}
SDPMedia instproc obj2str {} {
	$self instvar attributes_
	set o "m=[$self field_value m]"
	foreach f { i c b k } {
		if [$self have_field $f] {
			set n "$f=[$self field_value $f]"
			set o $o\n$n
		}
	}
	foreach a [array names attributes_] {
		if { $attributes_($a) == "" } {
			set n "a=$a"
		} else {
			set n "a=$a:$attributes_($a)"
		}
		set o $o\n$n
	}
	return $o
}
SDPTime instproc have_field { field } {
	$self instvar fields_
	return [info exists fields_($field)]
}
SDPTime instproc field_value { field } {
	$self instvar fields_
	if [info exists fields_($field)] {
		return $fields_($field)
	} else {
		return ""
	}
}
SDPTime instproc obj2str {} {
	set o "t=[$self field_value t]"
	if [$self have_field r] {
		set n "r=[$self field_value r]"
		set o $o\n$n
	}
	return $o
}
SDPTime public get { varname } {
    $self instvar $varname
    if [info exists $varname] {
	return [set $varname]
    } else {
	return ""
    }
}
SDPTime public sec_until_current { time_type } {
    set sdp_time [ntp_to_unix [$self get $time_type]]
    set current [clock seconds]
    return [expr $sdp_time - $current]
}
SDPTime public current_in_interval { start end } {
    set current [unix_to_ntp [clock seconds]]
    if { [expr $start == 0 && $end == 0] } {
	return 1
    } elseif { $start == 0 } {
	return [expr $end > $current]
    } elseif { $end == 0 } {
	return [expr $start <= $current]
    } else {
	return [expr $start <= $current && $end > $current]
    }
}
SDPTime public readable_time { time_type } {
    set sec [ntp_to_unix [$self get $time_type]]
    if { $sec == 0 } {
	return *unbounded*
    } else {
	return [clock format $sec -format {%H:%M}]
    }
}
SDPTime public readable_duration { } {
    set duration [$self get active_duration_]
    set hours [expr $duration / 3600]
    if { $hours < 24 } {
	return "$hours hour(s)"
    }
    set days [expr $hours / 24]
    if { $days < 7 } {
	return "$days day(s)"
    }
    set weeks [expr $days / 7]
    return "$weeks week(s)"
}
SDPTime public readable_date { time_type {numonly 0} } {
    set sec [ntp_to_unix [$self get $time_type]]
    if { $sec == 0 } {
	return *unbounded*
    } elseif $numonly {
	return [clock format $sec -format {%m/%d/%y}]
    } else {
	return [clock format $sec -format {%B %d, %Y}]
    }
}
SDPTime public readable_day { time_type } {
    set sec [ntp_to_unix [$self get $time_type]]
    if { $sec == 0 } {
	return *unbounded*
    } else {
	return [clock format $sec -format {%a}]
    }
}
SDPTime public readable_day_full { time_type } {
    set sec [ntp_to_unix [$self get $time_type]]
    if { $sec == 0 } {
	return *unbounded*
    } else {
	return [clock format $sec -format {%A}]
    }
}
SDPTime public readable_zone { time_type } {
    set sec [ntp_to_unix [$self get $time_type]]
    return [clock format $sec -format {%Z}]
}
SDPTime public readable_repeat { } {
    set interval [$self get repeat_interval_]
    if { $interval == 86400 } {
	return Daily
    } elseif { $interval == 604800 } {
	return Weekly
    } else {
	return None
    }
}
set gwstr(video) VGW
set gwstr(sdp) SDGW
set gwstr(audio) AGW
set gwstr(mediaboard) MBGW
set gwstr(mb) MBGW
set gwstr(whiteboard) MBGW
Class GWHandler
Class GWHandler/RTPGW -superclass GWHandler
Class GWHandler/VGW -superclass { GWHandler/RTPGW RTP/Video }
Class GWHandler/AGW -superclass { GWHandler/RTPGW RTP/Audio }
Class GWHandler/MBGW -superclass GWHandler
Class GWHandler/SDGW -superclass GWHandler
Class GWHandler/Mars -superclass GWHandler
Class GWHandler/Aries -superclass GWHandler
Class GWHandler/FXTemp -superclass GWHandler
Class GWHandler/FXForwardBackEnd -superclass GWHandler
Class GWHandler/FXForwardFrontEnd -superclass GWHandler
Class ServiceCreator
Class ServiceCreator/MeGa -superclass ServiceCreator
Class ServiceCreator/Generic -superclass ServiceCreator
Class ServiceCreator/Mars -superclass ServiceCreator
Class ServiceCreator/Aries -superclass ServiceCreator
Class ServiceCreator/FXTemp -superclass ServiceCreator
Class ServiceCreator/FXForwardBackEnd -superclass ServiceCreator
Class ServiceCreator/FXForwardFrontEnd -superclass ServiceCreator
Class GWHandler/MediaPad -superclass GWHandler
Class ServiceCreator/MediaPad -superclass ServiceCreator
ServiceCreator/MediaPad instproc create_handler {srv_inst msg} {
	$self instvar agent_
	set h [new GWHandler/MediaPad $agent_ $srv_inst "" "" ""]
	return $h
}
GWHandler/MediaPad instproc init {agent sname gspec lspec fmt} {
	$self next $agent $sname $gspec $lspec $fmt
	$self instvar serviceInst_
	set serviceInst_ $sname
}
GWHandler/MediaPad instproc execargs {} {
	$self instvar sessSpec_ serviceInst_
	return [list -servinst [list $serviceInst_]]
}
Class Trace
Trace set flags ""
Trace set onoff 0
Trace proc add {args} {
	set f [Trace set flags]
	foreach a $args {
		if {[lsearch -exact $f $a]==-1} {
			lappend f $a
		}
	}
	Trace set flags $f
}
Trace proc rm {args} {
	set f [Trace set flags]
	foreach a $args {
		set idx [lsearch -exact $f $a]
		if {$idx != -1} {
			set f [lreplace $f $idx $idx]
		}
	}
	Trace set flags $f
}
Trace proc on {} {Trace set onoff 1}
Trace proc off {} {Trace set onoff 0}
proc Trc {flag {msg ""}} {
	if ![Trace set onoff] {return}
	set t [clock format [clock seconds] -format {%H:%M:%S}]
	if {$msg == ""} {
		puts "\[$t\] Trc: $flag"
	} else {
		set f [Trace set flags]
		if {$f == "" || [lsearch $f $flag] != -1} {
			puts "\[$t\] Trc - $flag: $msg"
		}
	}
}
Class Observer
Observer instproc init { args } {
	eval [list $self] next $args
}
Observer instproc update { method args } {
	if [$self has_method $method] {
		eval [list $self] [list $method] $args
	}
}
Class Observable
Observable instproc init { args } {
	eval [list $self] next $args
	$self set observers_ { }
}
Observable instproc attach_observer { observer } {
	$self instvar observers_
	lappend observers_ $observer
}
Observable instproc detach_observer { observer } {
	$self instvar observers_
	set idx [lsearch $observers_ $observer]
	if { $idx != -1 } {
		set observers_ [lreplace $observers_ $idx $idx]
	}
}
Observable instproc notify_observers { method args } {
	$self instvar observers_
	if [info exists observers_] {
		foreach observer $observers_ {
			eval [list $observer] update [list $method] $args
		}
	}
}
Class RendezvousManager -superclass {Observer Observable}
RendezvousManager public init {{speclist ""}} {
    Trc $class "--> ${class}::$proc"
    $self next
    $self instvar scopes_ rvMsgs_
    set rvMsgs_ ""
    if {$speclist == ""} {set speclist [$self get_option rendez]}
    if {$speclist == ""} {
	set s 224.2.127.253/1202/32
	$self add_spec $s
	set scopes_($s) "global"
    } else {
	foreach i [split $speclist ,] {
	    $self add_spec $i
	}
    }
}
RendezvousManager public add_spec {s} {
    Trc $class "--> ${class}::$proc"
    $self instvar rv_ local_rv_
    if [info exists rv_($s)] {return}
    set r [new Rendezvous $s]
    set rv_($s) $r
    $r attach_observer $self
    if ![info exists local_rv_] {
	set local_rv_ $s
    }
}
RendezvousManager public rm_spec {s} {
    Trc $class "--> ${class}::$proc"
    $self instvar rv_
    if {[array names rv_ $s] != ""} {
	$rv_($s) detach_observer $self
	delete $rv_($s)
	unset rv_($s)
    } else {
	puts "Error: attempted to remove bad spec `$s'"
    }
}
RendezvousManager public get_specs {} {
    $self instvar rv_
    return [array names rv_]
}
RendezvousManager public get_local_rv {} {
    Trc $class "--> ${class}::$proc"
    $self instvar local_rv_
    return $local_rv_
}
RendezvousManager public query {queryString} {
    Trc $class "--> ${class}::$proc"
    set msgs [$self query_msgs $queryString]
    if {$msgs == ""} {
	return ""
    } else {
	return [lindex $msgs 0]
    }
}
RendezvousManager public query_metadata {queryString} {
    Trc $class "--> ${class}::$proc"
    set msgs [$self query_msgs $queryString]
    if {$msgs == ""} {
	return ""
    } else {
	return [lindex $msgs 0]
    }
}
RendezvousManager public query_msgs {queryString} {
    Trc $class "--> ${class}::$proc $queryString"
    set and [string match "* & *" $queryString]
    set or [string match "* | *" $queryString]
    if {$and && $or } {
	puts "queries with both `and' (&) and `or' (|) \
		is not currently supported... returning {}."
	return ""
    }
    if {$and} {
	set msgs ""
	set q [split $queryString "&"]
	foreach field $q {
	    set field [string trim $field]
	    set msgs [$self field_query $field $msgs]
	    if {$msgs==""} {return ""}
	}
    } else {
	set msgs ""
	set q [split $queryString "|"]
	foreach field $q {
	    set field [string trim $field]
	    foreach msg [$self field_query $field] {
		if {$msg != ""} {lappend msgs $msg}
	    }
	}
	set msgs [$self uniq $msgs]
    }
    Trc $class "matching msgs = $msgs"
    return $msgs
}
RendezvousManager private field_query {qField {msgList ""}} {
    Trc $class "--> ${class}::$proc $qField $msgList"
    $self instvar rvMsgs_
    if {$msgList == ""} {
	set msgList $rvMsgs_
    }
    set results ""
    set is_not_query 0
    if {[string match !* $qField]} {
	set qField [string range $qField 1 end]
	set is_not_query 1
    }
    foreach m $msgList {
	if {[string first "$qField" [$m get_msg]] != -1} {
	    lappend results $m
	}
    }
    if {$is_not_query} {
	set newResults ""
	foreach m $msgList {
	    if {[lsearch -exact $results $m] == -1} {
		lappend newResults $m
	    }
	}
	Trace $class "-- field_query pre-NOT'd results: $results"
	set results $newResults
    }
    Trc $class "-- field_query results: $results"
    return $results
}
RendezvousManager private uniq {l} {
    Trc $class "--> ${class}::$proc"
    set uniqL ""
    foreach i $l {
	if {[lsearch -exact $i $uniqL] == -1} {
	    lappend uniqL $i
	}
    }
    return $uniqL
}
RendezvousManager public recv_msg {rspec addr port data size} {
    Trc $class "--> ${class}::$proc $rspec $data"
    $self instvar rv_ rvMsgs_
    foreach d [split $data \n] {
	set d [string trim $d]
	if {$d == ""} {continue}
	set newrvmsg [new RVMsg $data $rspec $addr/$port]
	$newrvmsg update_meta_field "time=[clock seconds]"
	set type [$newrvmsg get_type]
	set dupmsg -1
	foreach rv $rvMsgs_ {
	    if {[$newrvmsg get_msg] == [$rv get_msg]} {
		set dupmsg $rv
	    }
	}
	if {$dupmsg == -1} {
	    switch $type {
		"query" {set cache_it 0}
		default {set cache_it 1}
	    }
	    if $cache_it {
		lappend rvMsgs_ $newrvmsg
	    }
	    if {$type == "scope"} {
		$self recv_scope $newrvmsg
	    }
	} else {
	    $dupmsg update_meta_field "time=[clock seconds]"
	    delete $newrvmsg
	    set newrvmsg $dupmsg
	}
	$self notify_observers rendez_recv $newrvmsg
	$self notify_observers rendez_recv_$type $newrvmsg
    }
}
RendezvousManager private recv_scope {rv_msg} {
    Trc $class "--> ${class}::$proc"
    $self instvar local_rv_ scopes_
    set sname [$rv_msg get_field name]
    set sspec [$rv_msg get_field spec]
    if {$sname == "" || $sspec == ""} {
	puts "Improperly formatted scope msg: [$rv_msg get_msg]"
    }
    set scopes_($sspec) $sname
    $self add_spec $sspec
    if {$local_rv_ == [$rv_msg rspec]} {
	set local_rv_ $sspec
    }
}
RendezvousManager public get_spec_name {spec} {
    Trc $class "--> ${class}::$proc"
    set r [$self query "scope: & spec=$spec"]
    set n [$r get_field name]
    if {$n == ""} {return $spec}
    return $n
}
RendezvousManager public start {spec msg} {
    Trc $class "--> ${class}::$proc `$spec' announcing `$msg'"
    $self instvar rv_
    if {$spec == ""} {set spec [$self get_local_rv]}
    if [info exists rv_($spec)] {
	$rv_($spec) start $msg
    } else {
	puts "Error: not connected to `$spec': won't send msg to that addr."
    }
}
RendezvousManager public stop {spec msg} {
    Trc $class "--> ${class}::$proc `$spec' stop announcing `$msg'"
    $self instvar rv_
    if {$spec == ""} {set spec [$self get_local_rv]}
    if [info exists rv_($spec)] {
	$rv_($spec) stop $msg
    } else {
	puts "Error: not connected to `$spec': can't stop msgs there."
    }
}
Class Rendezvous -superclass {Observable AnnounceListenManager}
Rendezvous public init {spec} {
    Trc $class "--> ${class}::$proc"
    eval [list $self] next $spec
    $self instvar msgs_ spec_ snet_ rnet_
    set spec_ $spec
    if {$snet_ != ""} {$self ttl 16}
    $self set_timeout 600
    set msgs_ ""
    set t [new Timer/Adaptive/ConstBW 10000]
    $t randomize
    $self timer $t
    $self process_timeouts
}
Rendezvous private recv_announcement {addr port data size} {
    Trc $class "--> ${class}::$proc $data"
    $self instvar spec_
    set t [$self get_timer]
    $t sample_size $size
    foreach msg [split $data \n] {
	$self update_msg $msg
	$self notify_observers recv_msg $spec_ $addr $port $msg $size
    }
}
Rendezvous private update_msg {newMsg} {
    Trc $class "--> ${class}::$proc"
    $self instvar msgs_ msgtimestamps_
    set msgtimestamps_($newMsg) [clock seconds]
    if {[lsearch  $msgs_ $newMsg] != -1} {
	lappend $msgs_ $newMsg
	[$self get_timer] incr_nsrcs
    }
}
Rendezvous private process_timeouts {} {
    Trc $class "--> ${class}::$proc"
    $self instvar msgs_ msgtimestamps_ timeout_
    if {$timeout_ <= 0} {
	return
    }
    set currTime [clock seconds]
    foreach i $msgs_ {
	set t $msgtimestamps_($i)
	if {[expr $currTime - $t] > $timeout_} {
	    puts "Rendezvous: timing out msg $i"
	    set ind [lindex $i $msgs_]
	    set msgs_ [lreplace $msgs_ $ind $ind]
	    unset msgtimestamps_($i)
	    [$self get_timer] incr_nsrcs -1
	}
    }
    after 5000 "catch {$self process_timeouts}"
}
Rendezvous public set_timeout {seconds} {
    Trc $class "--> ${class}::$proc"
    $self instvar timeout_
    set timeout_ $seconds
}
Class RVMsg
RVMsg public init {msg rspec sender_spec} {
    $self instvar msg_ rspec_ sender_spec_ metadata_
    set msg_ $msg
    set rspec_ $rspec
    set sender_spec_ $sender_spec
    set metadata_ "time=[clock seconds]"
}
RVMsg public get_type {} {
    Trc $class "--> ${class}::$proc"
    $self instvar msg_
    set t [string trim [lindex $msg_ 0]]
    set lst [split $t :]
    if {[lindex $lst end] == ""} {
	return [lindex [split $t :] 0]
    }
    return ""
}
RVMsg public fields {} {
    Trc $class "--> ${class}::$proc"
    $self instvar msg_
    set flist ""
    set m [lrange $msg_ 1 end]
    foreach i $m {
	lappend flist [lindex [split $i =] 0]
    }
    return $flist
}
RVMsg public get_field {field} {
    Trc $class "--> ${class}::$proc"
    $self instvar msg_
    set i [lsearch $msg_ "*$field=*"]
    if {$i == -1} {
	return ""
    } else {
	set attVal [lindex $msg_ $i]
	set idx [string first = $attVal]
	return [string range $attVal [expr $idx+1] end]
    }
}
RVMsg public has_field {f} {
    Trc $class "--> ${class}::$proc"
    $self instvar msg_
    set i [lsearch $msg_ "*$field=*"]
    if {$i == -1} {
	return 0
    } else {
	return 1
    }
}
RVMsg public get_msg {} {
    $self instvar msg_
    return $msg_
}
RVMsg public rspec {} {
    $self instvar rspec_
    return $rspec_
}
RVMsg public sender_spec {} {
    $self instvar sender_spec_
    return $sender_spec_
}
RVMsg public sender_addr {} {
    $self instvar sender_spec_
    return [lindex [split $sender_spec_ /] 0]
}
RVMsg public sender_port {} {
    $self instvar sender_spec_
    return [lindex [split $sender_spec_ /] 1]
}
RVMsg public get_metadata {} {
    $self instvar metadata_
    return $metadata_
}
RVMsg public set_metadata {m} {
    $self instvar metadata_
    set metsdata_ $m
}
RVMsg public update_meta_fields {fields} {
    foreach attval $fields {
	$self update_meta_field $attval
    }
}
RVMsg public update_meta_field {m} {
    $self instvar metadata_
    set f [lindex [split $m =] 0]
    set i [lsearch $metadata_ "*$f=*"]
    if {$i == -1} {
	set metsdata_ "$metadata_ $m"
    } else {
	set metadata_ [lreplace $metadata_ $i $i $m]
    }
}
RVMsg public rm_meta_field {f} {
    $self instvar metadata_
    set i [lsearch $metadata_ "*$f=*"]
     if {$i == -1} {
	 return 0
    } else {
	set metadata_ [lreplace $metadata_ $i $i]
	return 1
    }
}
RVMsg public get_meta_field {f} {
    $self instvar metadata_
    set i [lsearch $metadata_ "*$f=*"]
    if {$i == -1} {
	return ""
    } else {
	return [lindex [split [lindex $metadata_ $i] =] 1]
    }
}
RVMsg public has_meta_field {f} {
    Trc $class "--> ${class}::$proc"
    $self instvar metadata_
    set i [lsearch $metadata_ "*$field=*"]
    if {$i == -1} {
	return 0
    } else {
	return 1
    }
}
RVMsg private data {} {
    $self instvar msg_ rspec_ sender_spec_
    return "$rspec_ $sender_spec_ $msg_"
}
Class GWHandler/Device -superclass GWHandler
Class ServiceCreator/Device -superclass ServiceCreator
ServiceCreator/Device instproc init {agent} {
    $self next $agent
    $self instvar rv_
    set rv_ [new RendezvousManager]
}
ServiceCreator/Device instproc destroy {} {
    $self next
    $self instvar rv_
    delete $rv_
}
ServiceCreator/Device instproc create_handler {srv_inst msg} {
    $self instvar agent_ rv_
    set ctrlspec "[$agent_ pick_mcastaddr]/[$agent_ uniqport]"
    set rspec "-rendez [$rv_ get_local_rv]"
    set h [new GWHandler/Device $agent_ $srv_inst $ctrlspec $rspec $msg]
    return $h
}
GWHandler/Device instproc init {agent sname ctrlspec rspec msg} {
    $self next $agent $sname "" "" ""
    $self instvar myargs_
    set myargs_ "$rspec $msg $ctrlspec"
    set serviceInst_ $sname
}
GWHandler/Device instproc execargs {} {
    $self instvar sessSpec_ myargs_
    return "$myargs_"
}
ServiceCreator instproc init { agent } {
	$self next
	$self set agent_ $agent
}
ServiceCreator/Generic instproc create_handler { srv_inst msg } {
	$self instvar agent_
	set h [new GWHandler $agent_ $srv_inst "" "" ""]
	return $h
}
ServiceCreator/FXTemp instproc create_handler {srv_inst msg} {
    $self instvar agent_
    set h [new GWHandler/FXTemp $agent_ $srv_inst $msg]
    return $h;
}
ServiceCreator/FXForwardBackEnd instproc create_handler {srv_inst msg} {
    $self instvar agent_
    set h [new GWHandler/FXForwardBackEnd $agent_ $srv_inst $msg]
    return $h;
}
ServiceCreator/FXForwardFrontEnd instproc create_handler {srv_inst msg} {
    $self instvar agent_
    set h [new GWHandler/FXForwardFrontEnd $agent_ $srv_inst $msg]
    return $h;
}
ServiceCreator/MeGa instproc init { agent } {
	$self next $agent
	$self set sdp_ [new SDPParser]
}
ServiceCreator/MeGa instproc destroy {} {
	$self instvar sdp_
	delete $sdp_
}
ServiceCreator/MeGa instproc create_handler { srv_inst msg } {
	$self instvar sdp_ agent_
	set msg [$sdp_ parse $msg]
	set gspec [$msg set caddr_]
	set media [$msg set allmedia_]
	set fmt [$media set fmt_]
	set mtype [$media set mediatype_]
	set rport [$media set port_]
	set clientaddr [$msg set createaddr_]
	if [$msg have_field b] {
		set bwval [$msg set bwval_]
	} else {
		set bwval "default"
	}
	set sport [$agent_ uniqport]
	if { $rport != 0 } {
		set laddr $clientaddr
	} else {
		set rport $sport
		set laddr [$agent_ pick_mcastaddr]
	}
	set s [split $gspec /]
        set gspec [lindex $s 0]/[lindex $s 1]/none/[lindex $s 2]
	set lspec $laddr/$rport:$sport/none/1
	global gwstr
	if { $mtype == "video" } {
		set lscuba [$msg have_attr localscuba]
		set h [new GWHandler/VGW $agent_ $srv_inst $gspec $lspec $fmt \
				$lscuba $bwval]
	} else {
		set s $gwstr($mtype)
		set h [new GWHandler/$s $agent_ $srv_inst $gspec $lspec $fmt]
	}
	delete $msg
	return $h
}
ServiceCreator/Mars instproc create_handler {srv_inst msg} {
	$self instvar agent_
	set h [new GWHandler/Mars $agent_ $srv_inst "" "" "" $msg]
	return $h
}
ServiceCreator/Aries instproc create_handler {srv_inst msg} {
	$self instvar agent_
	set h [new GWHandler/Aries $agent_ $srv_inst "" "" "" $msg]
	return $h
}
GWHandler instproc init { agent sname gspec lspec fmt } {
	$self next
	$self instvar agent_ sname_ gspec_ lspec_ link_
	set agent_ $agent
	set sname_ $sname
	set gspec_ $gspec
	set lspec_ $lspec
	set link_ 0
	set format_ null
}
GWHandler instproc exec { fname } {
	$self instvar pid_ agent_ link_ gwctrl_
	if $link_ {
		$self instvar clientctrl_ bw_ ofmt_ gspec_ rportspec_
		set s [split $gspec_ /]
		set sspec [lindex $s 0]/[lindex $s 1]/[lindex $s 3]
		set gspec_ none
		set linkargs "-megactrl $gwctrl_ -megaclient $clientctrl_ -sbw $bw_ -ofmt $ofmt_ -sspec $sspec -rport $rportspec_"
	} else {
		set linkargs "-megactrl $gwctrl_"
	}
	set execargs "[$self execargs] $linkargs"
	if { [$self get_option doFork] != "" } {
		set targ ">& /dev/null"
	} else {
		set targ ""
	}
	set path [$self get_option execPath]
	set execstr "$path/smash $fname $execargs"
	if { [catch "eval exec [list $execstr] $targ &" pid_] != 0 } {
		global errorCode
		$agent_ log "hm: error in exec of '$execstr': $errorCode"
		set pid_ -1
		return -1
	} else {
		$agent_ log "$execstr"
	}
	return 0
}
GWHandler/FXTemp instproc init {agent srv_int msg} {
    $self next $agent $srv_int "" "" "";
    $self instvar client_args_;
    set client_args_ $msg;
}
GWHandler/FXTemp instproc execargs {} {
    $self instvar client_args_ sname_
    return "$client_args_ -serv_inst $sname_"
}
GWHandler/FXForwardBackEnd instproc init {agent srv_int msg} {
    $self next $agent $srv_int "" "" "";
    $self instvar client_args_;
    set client_args_ $msg;
}
GWHandler/FXForwardBackEnd instproc execargs {} {
    $self instvar client_args_ sname_
    return "$client_args_ -serv_inst $sname_"
}
GWHandler/FXForwardFrontEnd instproc init {agent srv_int msg} {
    $self next $agent $srv_int "" "" "";
    $self instvar client_args_;
    set client_args_ $msg;
}
GWHandler/FXForwardFrontEnd instproc execargs {} {
    $self instvar client_args_ sname_
    return "$client_args_ -serv_inst $sname_"
}
GWHandler/RTPGW instproc destroy {} {
	$self instvar agent_ cb_
	if [info exists cb_] {
		$agent_ close_cb $cb_
	}
	$self next
}
GWHandler/RTPGW instproc exec { script } {
	$self instvar agent_ cb_
	set cb_ [$agent_ open_cb $self]
	$self init_callbacks
	$self next $script
}
GWHandler/RTPGW instproc alive { info } {
	$self instvar dstspec_
	if ![info exists dstspec_] {
		set dstspec_ 1
		$self cb_init
		update
	}
}
GWHandler/RTPGW instproc init_callbacks {} {
	$self next
	$self instvar cb_
	$cb_ register alive "$self alive"
	$cb_ register activate "$self src_activate"
}
GWHandler/RTPGW instproc src_activate { info src args } {
}
GWHandler/AGW instproc cb_init {} {
	$self instvar cb_ gspec_ lspec_ format_ dstspec_
	$cb_ send cb_init
	$cb_ send cb_sessions global=$gspec_!local=$lspec_
	$cb_ send cb_set global RC 0
	$cb_ send cb_set local RC 1
	$cb_ send cb_set global txonly 1
	$cb_ send cb_set local txonly 1
	$cb_ send cb_set global ofmt $format_
	$cb_ send cb_set local ofmt $format_
}
GWHandler/VGW instproc cb_init {} {
	$self instvar cb_ gspec_ lspec_ format_ dstspec_ lscuba_
	$cb_ send cb_init
	$cb_ send cb_sessions global=$gspec_!local=$lspec_
	if { $lscuba_ == "global" } {
		$cb_ send cb_set global RC 1
	} else {
		$cb_ send cb_set global RC 0
	}
	$cb_ send cb_set local RC 1
	if { $format_ == "null" } {
		$cb_ send cb_set local txonly 1
	}
	$cb_ send cb_set global color 1
	$cb_ send cb_set local color 1
	$cb_ send cb_set global ofmt $format_
	$cb_ send cb_set local ofmt $format_
	$self instvar agent_ cb_
	$agent_ log "DONE [$cb_ set channel_]"
}
GWHandler instproc cb_init {} {
}
GWHandler/VGW instproc init { agent sname gspec lspec fmt lscuba scubabw} {
	$self next $agent $sname $gspec $lspec $fmt
	$self instvar format_
	set format_ [$self rtp_type $fmt]
	if  { $format_ == "" } {
		set format_ null
	}
	$self instvar lscuba_
	if { $lscuba } {
		set lscuba_ local
	} else {
		set lscuba_ global
	}
	$self set gwname_ vgw
	$self set scubabw_ $scubabw
}
GWHandler/AGW instproc init { agent sname gspec lspec fmt } {
	$self next $agent $sname $gspec $lspec $fmt
	$self instvar format_
	set format_ [$self rtp_type $fmt]
	if  { $format_ == "" } {
		set format_ null
	}
	$self set gwname_ agw
}
GWHandler/SDGW instproc init args {
	eval $self next $args
	$self set gwname_ sdgw
}
GWHandler/MBGW instproc init args {
	eval $self next $args
	$self set gwname_ mbgw
}
GWHandler instproc execargs {} {
	return ""
}
GWHandler/VGW instproc execargs {} {
	$self instvar cb_ sname_ lscuba_ scubabw_
	set chan [$cb_ set channel_]
	return "-scuba $lscuba_ -scubabw $scubabw_ -usemega $sname_ -I $chan"
}
GWHandler/AGW instproc execargs {} {
	$self instvar cb_ sname_
	set chan [$cb_ set channel_]
	return "-usemega $sname_ -I $chan"
}
GWHandler/SDGW instproc execargs {} {
	$self instvar sname_ gspec_ lspec_
	return "-usemega $sname_ -gspec $gspec_ -lspec $lspec_"
}
GWHandler/MBGW instproc execargs {} {
	$self instvar sname_ gspec_ lspec_
	return "-usemega $sname_ -gspec $gspec_ -lspec $lspec_"
}
GWHandler/Mars instproc init {agent sname gspec lspec fmt ssd} {
	$self next $agent $sname $gspec $lspec $fmt
	$self instvar ssd_ serv_inst_
	set ssd_ $ssd
	set serv_inst_ $sname
}
GWHandler/Aries instproc init {agent sname gspec lspec fmt ssd} {
	$self next $agent $sname $gspec $lspec $fmt
	$self instvar ssd_ serv_inst_
	set ssd_ $ssd
	set serv_inst_ $sname
}
GWHandler/Mars instproc execargs {} {
	$self instvar ssd_ serv_inst_ agent_
	set unicast_port [lindex [split [lindex [split $ssd_ \n] 4]] 1]
	if { $unicast_port > 0 } {
		set uniqport [$agent_ uniqport]
		$agent_ uniqport
		$agent_ uniqport
	} else {
		set uniqport 0
	}
	return "[list $ssd_] [list $serv_inst_] [list $uniqport]"
}
GWHandler/Aries instproc execargs {} {
	$self instvar ssd_ serv_inst_
	return "[list $ssd_] [list $serv_inst_]"
}
CoordinationBus set protocolId_ ""
CoordinationBus proc.invoke { } {
	$self set protocolId_ cbus/1.0
	if { [info commands mtrace]=="" } {
		proc ::mtrace { args } { }
	}
}
CoordinationBus public init { args } {
	eval [list $self] next
	$self set seqno_ 0
	$self instvar ttl_ srcid_ mediatype_ moduletype_ appname_ appinstance_\
			channel_ mode_
	foreach {key value} $args {
		if { [string index $key 0] != "-" } {
			error "invalid argument '$key'"
		}
		$self set [string range $key 1 end]_ $value
	}
	if { ![info exists ttl_]        } { set ttl_ 0 }
	if { ![info exists mediatype_]  } { set mediatype_ "*" }
	if { ![info exists moduletype_] } { set moduletype_ "*" }
	if { ![info exists appname_]    } { set appname_ "*" }
	if { ![info exists appinstance_]} { set appinstance_ [localaddr]:[pid]}
	if { ![info exists channel_]    } { set channel_ 0 }
	if { ![info exists mode_]       } { set mode_ "readwrite" }
	if { ![info exists srcid_] } {
		set srcid_ "$mediatype_/$moduletype_/$appname_/$appinstance_"
	} else {
		set tmp [split $srcid_ /]
		if { [llength $tmp] != 4 } {
			error "invalid srcid '$srcid_'"
		}
	}
	$self open $channel_ $ttl_ $mode_
}
CoordinationBus public destroy { } {
	$self close
	$self next
}
CoordinationBus public register { event method } {
	$self instvar dispatch_
	if { [llength $method] > 1 } {
		set dispatch_($event,object) [lindex $method 0]
		set dispatch_($event,method) [lindex $method 1]
	} else {
		set dispatch_($event,object) $self
		set dispatch_($event,method) [lindex $method 0]
	}
	set dispatch_($event,argcnt) [$self get_argcnt \
			$dispatch_($event,object) $dispatch_($event,method)]
	if { $dispatch_($event,argcnt) < 0 } {
		set object $dispatch_($event,object)
		unset dispatch_($event,object)
		unset dispatch_($event,method)
		unset dispatch_($event,argcnt)
		error "trying to register undefined method '$method' on object\
				$object"
	}
}
CoordinationBus public unregister { event } {
	$self instvar dispatch_
	if [info exists dispatch_($event,object)] {
		unset dispatch_($event,object)
		unset dispatch_($event,method)
		unset dispatch_($event,argcnt)
	}
}
CoordinationBus public send { args } {
	if { [string compare [lindex $args 0] "-dstid"] == 0 } {
		set dst [lindex $args 1]
		set tmp [split $dst /]
		if { [llength $tmp] != 4 } {
			error "Invalid destination: must be of the form\
					<media-type>/<module-type>/<app-name>/<app-instance>"
		}
		set args [lrange $args 2 end]
	} else {
		set dst "*/*/*/*"
	}
	$self instvar seqno_ srcid_
	if { [llength $args]==0 } {
		error "Must specify event type: \$cb send\
				[-dstid <destination>] $event_type [args...]"
	}
	set headers [list [CoordinationBus set protocolId_] $seqno_ \
			"U" $srcid_ $dst ""]
	$self transmit [concat $headers $args]
}
CoordinationBus private match_wildcards { d s } {
	if { [string compare $d $s]==0 || $d=="*" || $s=="*" } {
		return 1
	} else {
		return 0
	}
}
CoordinationBus private filter { destid } {
	$self instvar srcid_
	set s [split $srcid_ /]
	set d [split $destid /]
	if { [$self match_wildcards [lindex $d 0] [lindex $s 0]] && \
			[$self match_wildcards [lindex $d 1] [lindex $s 1]] &&\
			[$self match_wildcards [lindex $d 2] [lindex $s 2]] &&\
			[$self match_wildcards [lindex $d 3] [lindex $s 3]] } {
		return 1
	} else {
		return 0
	}
}
CoordinationBus private dispatch { packet } {
	set packet [split $packet]
	if { [llength $packet] < 7 } {
		mtrace trcCB "CB: Invalid packet: only [llength $packet]\
				elements"
		return
	}
	set protocolId [lindex $packet 0]
	set seqNo [lindex $packet 1]
	set messageType [lindex $packet 2]
	set srcId [lindex $packet 3]
	set destId [lindex $packet 4]
	set ackList [lindex $packet 5]
	set event [lindex $packet 6]
	set args [lrange $packet 7 end]
	if { $protocolId != [CoordinationBus set protocolId_] } {
		mtrace trcCB "CB: Invalid protocol id '$protocolId': must be\
				[CoordinationBus set protocolId_]"
		return
	}
	$self instvar srcid_
	if { [string compare $srcId $srcid_]==0 } {
		return
	}
	if { ![$self filter $destId] } {
		mtrace trcCB|trcVerbose "CB: filtering out packet meant for\
				'$destId'"
		return
	}
	$self instvar dispatch_
	if { ![info exists dispatch_($event,object)] } {
		mtrace trcCB|trcVerbose "CB: unknown event '$event'"
		return
	}
	if { [expr [llength $args] + 1] != $dispatch_($event,argcnt) } {
		mtrace trcCB "CB: argument mismatch: expected\
				$dispatch_($event,argcnt) arguments,\
				got [llength $args]"
		return
	}
	set info [list cb $self srcid $srcId dstid $destId event $event]
	eval [list $dispatch_($event,object)] \
			[list $dispatch_($event,method)] [list $info] $args
}
CoordinationBus private get_argcnt { object method } {
	if { [$object info procs $method] != "" } {
		return [llength [$object info args $method]]
	}
	set cls [$object info class]
	if { [$cls info instprocs $method] != "" } {
		return [llength [$cls info instargs $method]]
	}
	foreach c [$cls info heritage] {
		if { [$c info instprocs $method] != "" } {
			return [llength [$c info instargs $method]]
		}
	}
	return -1
}
Class MeGa
MeGa instproc init args {
	eval $self next $args
	$self set sdp_ [new SDPParser]
}
MeGa instproc destroy {} {
	$self instvar sdp_
	delete $sdp_
	$self next
}
MeGa proc ctrlchan { media spec } {
	set tmp [split $spec /]
	set addr [lindex $tmp 0]
	if ![in_multicast $addr] {
		return $spec
	}
	set port [lindex $tmp 1]
	switch $media {
	video {
		incr port 2
	}
	audio {
		incr port 4
	}
	mb {
		incr port 6
	}
	sdp {
		incr port 8
	}
	hm {
		incr port 10
	}
	}
	set ttl [lindex $tmp 2]
	return $addr/$port/$ttl
}
Class AnnounceListenManager/AS/Platform -superclass AnnounceListenManager/AS
AnnounceListenManager/AS/Platform instproc init { agent spec bw helper} {
	$self next $spec $bw platform
	$self set agent_ $agent
	set t [new Timer/Adaptive/ConstBW/2step $bw 30000]
	$t randomize
	set h [$helper get_timer]
	$t local_helper $h
	$self timer $t
	$t threshold 10000
}
AnnounceListenManager/AS/Platform instproc recv_announcement { addr port data size } {
	$self instvar lastann_ sdp_ agentbytype_ agenttab_ atype_ agent_
        set t [$self get_timer]
	$t sample_size $size
	set o [split $data \n]
	if { [lindex $o 0] != "ASCP v[AnnounceListenManager/AS version]" } {
		set msg "$self ($class): received non-ASCP v[AnnounceListenManager/AS version] announcement from $addr."
		if { $atype_ == "hm" } {
			$self instvar agent_
			$agent_ log $msg
		} else {
			puts stderr $msg
		}
 		return
	}
	set atype [lindex $o 1]
	set aspec [lindex $o 2]
	set srv_name [lindex $o 3]
	set srv_loc [lindex $o 4]
	set srv_inst [lindex $o 5]
	set ssg_port [lindex $o 6]
	set ad [join [lrange $o 7 end] \n]
	if { $srv_name == "DEATH" } {
		set msg "Received death packet from $aspec at $addr - exiting."
		if { $srv_loc == $atype_ } {
			if { $atype_ == "hm" } {
				$self instvar agent_
				$agent_ log $msg
			} else {
				puts stderr $msg
			}
			$self announce_death
			exit 0
		}
		$self recv_msg $atype $aspec $addr DEATH $srv_loc \
			$srv_inst $ssg_port "$ad"
		return
	}
	if { $srv_name == "bye" } {
		$self delete_agent $aspec
		return
	}
	set pid [lindex [split $aspec @] 0]
	set platformid [lindex [split $aspec @] 1]
	set aspec $platformid
	if ![info exists agenttab_($platformid)] {
		$self instvar avgdelta_
		$self register $atype $aspec $addr $srv_name $srv_inst "$ad"
		$t incr_nsrcs
		set timeout [$self get_option startupWait]
		set avgdelta_($aspec) [expr $timeout / 8]
		lappend agentbytype_($atype) $aspec
	} else {
		set now [gettimeofday]
		set delta [expr $now - $lastann_($aspec,abs)]
		$self instvar avgdelta_
		set avgdelta_($platformid) \
				[expr 0.875*$avgdelta_($aspec)+0.125*$delta]
	}
	set agenttab_($aspec) "$addr {$ad} $atype $srv_name $srv_inst"
	set lastann_($aspec,abs) [gettimeofday]
	set lastann_($aspec,ascii) [gettimeofday ascii]
	$self recv_msg $atype $aspec $addr $srv_name $srv_loc $srv_inst \
			$ssg_port "$ad"
}
AnnounceListenManager/AS/Platform instproc recv_msg { atype aspec addr srv_name srv_loc srv_inst ssg_port msg } {
	$self instvar agent_
	switch $atype {
		platform {
		}
		default {
			puts "Error: atype=$atype"
			exit
		}
	}
}
AnnounceListenManager/AS/Platform instproc send_announcement {} {
	$self instvar id1_ id2_
	set o "ASCP v[AnnounceListenManager/AS version]"
	set n platform
	set o $o\n$n
	set n [$self agent_instance]
	set o $o\n$n
	set n -
	set o $o\n$n
	set n -
	set o $o\n$n
	set n -
	set o $o\n$n
	set n -
	set o $o\n$n
	$self announce $o
}
AnnounceListenManager/AS/Platform instproc handle_platform_msg { aspec msg addr srv_name srv_inst } {
	$self instvar agent_
	switch $srv_name {
	}
}
AnnounceListenManager/AS/Platform public agent_instance {} {
	$self instvar agent_
	return "[pid]@[$agent_ get_option megaCtrl]"
}
AnnounceListenManager/AS/Platform instproc register { atype aspec addr srv_name srv_inst msg } {
	$self instvar agent_
}
AnnounceListenManager/AS/Platform instproc unregister { atype aspec addr srv_name srv_inst ad } {
	$self instvar agent_
}
Class Timer/Adaptive/ConstBW/2step -superclass Timer/Adaptive/ConstBW
Timer/Adaptive/ConstBW/2step public local_helper { local } {
	$self instvar local_
	set local_ $local
}
Timer/Adaptive/ConstBW/2step private adapt {interval} {
	$self instvar avgsize_ bw_ nsrcs_ local_ thresh_
	set t [expr 1000 * ($nsrcs_ * $avgsize_ * 8) / $bw_]
	set l [expr [$local_ nsrcs 0] + 1]
	set t [expr $t / $l]
	if { $t < $thresh_ } {
		return $thresh_
	} else {
		return $t
	}
}
Class HMAgent -superclass Timer
HMAgent instproc init { app logfd } {
    $self next
    $self instvar maxports_ minport_ uniqport_ app_ cbchannel_ logfd_
    $self instvar creators_
    foreach service {
        MeGa Generic Mars MediaPad Aries Device
        FXTemp FXForwardBackEnd FXForwardFrontEnd
        } {
        set creators_($service) [new ServiceCreator/$service $self]
    }
    $self set cbchannel_ 3
    $self set app_ $app
    $self set logfd_ $logfd
    $self set uniqid_ 0
    $self set maxports_ [$self get_option maxPorts]
    $self set minport_ [$self get_option minPort]
    $self set uniqport_ $minport_
    $self log "Start"
    $self init_scripturls
    set f [$app get_option megaConfFile]
    if [file exists $f] {
        $self log "Reading config file $f."
        $self parse_conffile $f
    }
    set megaspec [$self get_option megaCtrl]
    set bw [$self get_option megaCtrlBW]
    $self instvar al_
    set al_(generic) [new AnnounceListenManager/AS/HM $self $megaspec $bw]
    foreach m { audio video sdp mb } {
        set spec [MeGa ctrlchan $m $megaspec]
        set al_($m) [new AnnounceListenManager/AS/HM $self $spec $bw]
    }
    set spec [MeGa ctrlchan hm $megaspec]
    set al_(hm) [new AnnounceListenManager/AS/HM $self $spec $bw]
    if { [$self get_option loadBalance] != "" } {
        $al_(hm) start
        $self read_hmhosts
        $self init_load_check
    } elseif { [$self get_option targetNum] != "" } {
        $al_(hm) start
        $self set trgtnum_ [$self get_option targetNum]
        if { [$self get_option glunix] == "" } {
            $self read_hmhosts
        }
        HMAgent instproc timeout {} { $self target_check }
        $self randomize yes
        set a [$self get_option checkFactor]
        $self msched [expr $a * [$self get_option checkInterval]]
    } else {
        $al_(hm) start
    }
    if {[$self get_option allow_distrib] == "yes"} {
        set gspec [$self get_option glob_chan]
        set al_(platform) \
            [new AnnounceListenManager/AS/Platform $self $gspec $bw $al_(hm)]
        $al_(platform) start
    }
}
HMAgent instproc init_scripturls {} {
    $self instvar scripturls_
    set scripturls_ {
        http://www-mash.cs.berkeley.edu/dist/as/scripts
        http://www.cs.berkeley.edu/~elan/as/scripts
    }
}
HMAgent instproc parse_conffile { f } {
    set fd [open $f r]
    if { $fd < 0 } {
        return
    }
    $self instvar conf_
    while { [gets $fd line] > 0 } {
        set kw [lindex $line 0]
        switch $kw {
        link {
            $self add_option link yes
            set conf_(gwctrl) [lindex $line 1]
            set conf_(clientctrl) [lindex $line 2]
        }
        leaf {
            set conf_(gwctrl) [lindex $line 1]
        }
        media {
            set mtype [lindex $line 1]
            set conf_($mtype,bw) [lindex $line 2]
            set conf_($mtype,ofmt) [lindex $line 3]
        }}
    }
    close $fd
}
HMAgent instproc target_check {} {
    $self instvar al_ trgtnum_
    set n [$al_(hm) hmnum]
    incr n
    set r [expr [random]/double(0x7fffffff)]
    if { $n < $trgtnum_ } {
        set p [expr double($trgtnum_ - $n) / $n]
        if { $r < $p } {
            $self spawn
        }
    } elseif { $n > $trgtnum_ } {
        set p [expr double($n - $trgtnum_) / $n]
        if { $r < $p } {
            $self doexit
            return
        }
    }
    $self msched [$self get_option checkInterval]
}
HMAgent instproc doexit {} {
    $self instvar al_
    $al_(hm) announce_death
    exit 0
}
HMAgent instproc log msg {
    $self instvar logfd_
    if { [$self get_option noLog] != "" } {
        return
    }
    if { $msg == "" } {
        puts $logfd_ ""
    } else {
        puts $logfd_ "\[[$self pid]\] [lrange [gettimeofday ascii] 1 3] $msg"
    }
    flush $logfd_
}
HMAgent instproc pid {} {
    return [pid]
}
HMAgent instproc destroy {} {
    $self instvar al_
    foreach m { audio video sdp mb hm } {
        delete $al_($m)
    }
    $self next
}
HMAgent instproc uniqport {} {
    $self instvar uniqport_ portmap_ maxports_ minport_
    incr uniqport_ 4
    set uniqport_ [expr ($uniqport_ % $maxports_) + $minport_]
        while { [info exists portmap_($uniqport_)] } {
        incr uniqport_ 4
        set uniqport_ [expr ($uniqport_ % $maxports_) + $minport_]
    }
    return $uniqport_
}
HMAgent instproc pick_mcastaddr {} {
    set r1 [expr ([random]%250)+2]
    set r2 [expr ([random]%250)+2]
    return 224.3.$r1.$r2
}
HMAgent instproc launch { srv_name srv_loc srv_inst msg } {
    if { [$self pending_launches] >= [$self get_option maxPending] } {
        $self log "BACKLOG [$self pending_launches]"
        $self cancel_timer $srv_inst
        return
    }
    set load [HMAgent get_load]
    set hiload [$self get_option highLoad]
    $self log "LAUNCH load=$load $hiload"
    if { [$self get_option noLoad] == "" &&  $load >= $hiload } {
        $self cancel_timer $srv_inst
        return
    }
    $self instvar creators_
    set creator $creators_($srv_name)
    set h [$creator create_handler $srv_inst $msg]
    $h set gwctrl_ [$self get_option megaCtrl]
    if { [$self get_option link] == "yes" } {
        $self instvar conf_
        $h set link_ 1
        $h set gwctrl_ $conf_(gwctrl)
        $h set bw_ $conf_($mtype,bw)
        $h set ofmt_ $conf_($mtype,ofmt)
        set a [split $conf_(clientctrl) /]
        if [in_multicast [lindex $a 0]] {
            $h set clientctrl_ $conf_(clientctrl)
            $h set rportspec_ 0
        } else {
            set baseport [$self uniqport]
            set addr [lindex $a 0]
                set ports [split [lindex $a 1] :]
            set sport [lindex $ports 0]
                set rport [lindex $ports 1]
            if { $rport == "*" } {
                set rport [expr $baseport + 2]
            }
            $h set clientctrl_ $addr/$sport:$rport/1
            $h set rportspec_ $baseport:$rport
        }
    }
    set script [$self get_script $srv_name $srv_loc]
    if { $script == "" || [$h exec $script] < 0} {
        delete $h
        $self cancel_timer $srv_inst
        return 0
    } else {
        lappend handlers_ $h
    }
    $self log "announce_launch $srv_inst"
    $self instvar al_
    $al_(hm) announce_launch $srv_inst
    $self set launched_($srv_inst) 1
    return 1
}
::http::formatQuery sdsds
HMAgent instproc get_script { name srv } {
    set o [split $srv :]
    $self instvar scriptfiles_
    if [info exists scriptfiles_($srv)] {
        return $scriptfiles_($srv)
    }
    $self log "get_script $name $srv"
    switch [lindex $o 0] {
    static {
        set path [$self get_option execPath]
        set n $path/[lindex $o 1]
        if [file isfile $n] {
            set scriptfiles_($srv) $n
            return $n
        }
        return ""
    }
    http {
        set d [$self get_option scriptDir]
        if ![file isdirectory $d] {
            file mkdir $d
        }
        $self instvar uniqid_
        set fname $d/as-$uniqid_.mash
        incr uniqid_
        set fd [open $fname w+]
        set t [::http::geturl $srv -channel $fd]
        close $fd
        set code [lindex [::http::code $t] 1]
        if { $code == "200" } {
            $self log "got script from $srv"
            set scriptfiles_($srv) $fname
            ::http::reset $t
            return $fname
        } else {
            $self log "can't get script from $srv."
            ::http::reset $t
            return ""
        }
    }
    urn {
        set n [lindex $o 1]
        set s [$self get_script $name static:$n]
        if { $s != "" } {
            $self log "got $name/$srv from static:$n: $s"
            set scriptfiles_($srv) $s
            return $s
        }
        $self instvar scripturls_
        foreach url $scripturls_ {
            set s [$self get_script $name $url/$n]
            if { $s != "" } {
                $self log "got $name/$srv from $url: $s"
                set scriptfiles_($srv) $s
                return $s
            }
        }
    }
    }
    return ""
}
HMAgent instproc unregister { aspec msg } {
    $self instvar handlers_
    if ![info exists handlers_] {
        return
    }
    set i 0
    set pid [lindex [split $aspec @] 0]
    foreach h $handlers_ {
        if { [$h set pid_] == $pid } {
            delete $h
            set handlers_ [lreplace $handlers_ $i $i]
            return
        }
        incr i
    }
}
HMAgent instproc pending_timer tid {
    $self instvar tid_
    return [info exists tid_($tid)]
}
HMAgent instproc pending_launches {} {
    $self instvar launched_
    return [llength [array names launched_]]
}
HMAgent instproc cancel_timer tid {
    $self instvar tid_ launched_
    if [info exists launched_($tid)] {
        unset launched_($tid)
    }
    if { [info exists tid_($tid)] } {
        $self log "cancelled timer $tid"
        after cancel $tid_($tid)
        unset tid_($tid)
    }
}
HMAgent instproc sched_launch { srv_name srv_loc srv_inst msg } {
    $self instvar al_
    set numhm [$al_(hm) hmnum]
    set T [expr $numhm * 2000]
    set max [$self get_option maxWait]
    if { $T > $max } {
        set $T $max
    }
    set r [HMAgent uniform_timer $T]
    $self log "timer $srv_name $srv_inst $r"
    set tid [after $r "$self launch $srv_name $srv_loc $srv_inst {$msg}"]
    $self instvar tid_
    set tid_($srv_inst) $tid
}
HMAgent proc exp_timer { lambda T } {
    set r [expr [random]/double(0x7fffffff)]
    set o [expr ($T/$lambda) * log((exp($lambda) - 1)*$r + 1)]
    return [expr int($o+0.5)]
}
HMAgent proc uniform_timer { T } {
    set r [expr [random]/double(0x7fffffff)]
    set o [expr $r*$T]
    return [expr int($o+0.5)]
}
HMAgent instproc suppress_timer tid {
    $self instvar tid_ launched_
    $self log "suppress timer $tid"
    if { [info exists tid_($tid)] && ![info exists launched_($tid)] } {
        after cancel $tid_($tid)
        unset tid_($tid)
    }
}
HMAgent instproc close_cb cb {
    set c [$cb set channel_]
    $self instvar chanmap_
    incr chanmap_($c) -1
    if { $chanmap_($c) <= 0 } {
        delete $cb
        unset chanmap_($c)
    }
}
HMAgent instproc open_cb { handler } {
    $self instvar cbchannel_ chanmap_
    set cb [new CoordinationBus -channel $cbchannel_]
    set chanmap_($cbchannel_) 1
    incr cbchannel_
    return $cb
}
HMAgent instproc read_hmhosts {} {
    $self instvar hmhosts_ low_ high_ app_
    set path [$self get_option execPath]
    set f "$path/hmhosts"
    if { $f == "" } {
        $self log "hm: warning: no host file - disabling load_check"
        return
    }
    set fd [open $f r]
    if { $fd <  0 } {
        $self log  "hm: problems opening $f"
        return
    }
    while { [gets $fd line] > 0 } {
        if { [intoa [lookup_host_addr $line]] != [localaddr] } {
            lappend hmhosts_ $line
        }
    }
    close $fd
}
HMAgent instproc init_load_check {} {
    set low_ 0
    set high_ 0
    set t [$self get_option checkInterval]
    after $t "$self load_check"
}
HMAgent instproc load_check {} {
    $self instvar app_ low_ high_ al_
    set load [$self get_load]
    set nsamples [$self get_option loadSamples]
    if { $load > [$self get_option highLoad] } {
        incr high_
        if { $high_ >= $nsamples } {
            if { [$self spawn] != 0 } {
                $self shed_load
            }
        }
    } elseif { $load < [$self get_option lowLoad] } {
        incr low_
        if { $low_ >= $nsamples } {
            set minhm [$self get_option minHmNum]
            set hmnum [$al_(hm) hmnum]
            incr hmnum
            if { $hmnum > $minhm } {
                $self die
                return
            }
        }
    } else {
        set low_ 0
        set high_ 0
    }
    set t [$self get_option checkInterval]
    after $t "$self load_check"
}
HMAgent proc get_load {} {
    set v [catch {open "|uptime"} fd]
    if { $v != 0 } {
        return 0
    }
    set l [gets $fd]
    close $fd
    set n [llength $l]
    set avg [string trim [lindex $l [expr $n - 3]] ,]
    return $avg
}
HMAgent instproc spawn {} {
    $self instvar al_ hmhosts_ app_
        set hmlist [$al_(hm) hmaddrs]
    if { [$self get_option glunix] != "" } {
        set tlist [eval exec "glustat -s l -l"]
    } else {
        set tlist $hmhosts_
    }
    set i [lsearch -exact $tlist [localaddr]]
    set tlist [lreplace $tlist $i $i]
    foreach h $hmlist {
        set i [lsearch -exact $tlist $h]
        set tlist [lreplace $tlist $i $i]
    }
    set n [llength $tlist]
    if { $n == 0 } {
        return 0
    }
    if { [$self get_option glunix] != "" } {
        set r 0
    } else {
        set r [expr [random] % $n]
    }
    set shost [lindex $tlist $r]
    $self dospawn $shost
    return 1
}
HMAgent instproc dospawn { shost } {
    $self instvar app_ al_
    set path [$self get_option execPath]
    set argv [$self get_option execArgs]
    set cmd [$self get_option execCmd]
    $self log "eval exec $cmd $shost $path/smash $path/hm $argv >& /dev/null &"
    if { [catch "eval exec $cmd $shost $path/smash $path/hm $argv >& /dev/null &" t] != 0 } {
        $self log "catch error: $t"
    }
}
HMAgent instproc shed_load {} {
    $self instvar handlers_
    foreach h $handlers_ {
        set pid [$h set pid_]
        set r [expr [random]/double(0x7fffffff)]
        if { $r < 0.5 } {
            $self log "exec kill -9 $pid"
            catch "eval exec kill -9 $pid"
        }
    }
}
HMAgent instproc die {} {
    $self instvar al_ dying_ app_
    set t [$self get_option deathInterval]
    set minwait [$self get_option minDeathWait]
    set r [expr ([random] % $t) + $minwait]
    set dying_ [after $r "$self really_die"]
}
HMAgent instproc really_die {} {
    $self instvar app_ al_ dying_ low_ high_
    $al_(hm) announce_death
    set minhm [$self get_option minHmNum]
    set hmnum [$al_(hm) hmnum]
    incr hmnum
    if { $hmnum > $minhm && \
         [$self get_load] < [$self get_option lowLoad] } {
        $self log "exit 0"
            $self doexit
    }
    unset dying_
    set low_ 0
    set high_ 0
    $self load_check
}
HMAgent instproc recv_death {} {
    $self instvar dying_ low_ high_
    if ![info exists dying_] {
        return
    }
    after cancel $dying_
    unset dying_
    set low_ 0
    set high_ 0
    $self load_check
}
Class HMApplication -superclass Application
HMApplication public init argv {
	$self next hm
	set o [$self options]
	$self init_args $o
	$self init_resources $o
	$o parse_args $argv
	if {[$o get_option userhookFile] != ""} {
		if {[file isfile [$o get_option userhookFile]] && \
			[file readable [$o get_option userhookFile]]} {
			source [$o get_option userhookFile]
		} else {
			puts stderr "Unable to source \"[$o get_option userhookFile]\". Not a file or not readable."
		}
	}
	$self init_local
	if { [$self get_option doFork] != "" } {
		close stdout
		close stdin
		close stderr
		fork
		set logfd [open [$self get_option logFile] a+]
	} else {
		set logfd stdout
	}
	$self add_option execArgs $argv
	new HMAgent $self $logfd
	$self user_hook
}
HMApplication private init_args o {
	$o register_option -u userhookFile
	$o register_boolean_option -lb loadBalance
	$o register_boolean_option -fork doFork
	$o register_boolean_option -glunix glunix
	$o register_boolean_option -noload noLoad
	$o register_boolean_option -nolog noLog
	$o register_option -target targetNum
	$o register_option -int checkInterval
	$o register_option -path execPath
	$o register_option -log logFile
	$o register_option -rcmd execCmd
	$o register_option -conffile megaConfFile
	$o register_option -megactrl megaCtrl
	$o register_option -scriptdir scriptDir
}
HMApplication private init_resources o {
	$o add_default megaCtrl 224.4.5.24/50000/31
	$o add_default megaCtrlBW 20000
	$o add_default megaStartupWait 60
	$o add_default scriptDir /var/tmp
	$o add_default unicastOutput 1
	$o add_default lambda 5.0
	$o add_default maxWait 15000
	$o add_default maxPending 5
	$o add_default minPort 10000
	$o add_default maxPorts 10000
	$o add_default checkFactor 2
	$o add_default checkInterval 20000
	$o add_default deathInterval 10000
	$o add_default minDeathWait 60000
	$o add_default highLoad 1.00
	$o add_default lowLoad 0.05
	$o add_default noLoad yes
	$o add_default execPath [pwd]
	$o add_default execCmd "ssh -n"
	$o add_default minHmNum 1
	$o add_default loadSamples 2
	$o add_default logFile /tmp/hmlog
	$o add_default megaConfFile mega.conf
	$o add_default link no
	$o add_default allow_distrib no
	$o add_default glob_chan 224.4.5.28/55000/15
}
new HMApplication $argv
vwait forever
