#!/bin/sh
# the exec restarts using tclsh which in turn ignores
# the command because of this backslash: \
exec mash-VERSION "$0" -name bin/mars -- "$@"

#
# Copyright (c) 1993-1996 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:
# 1. Redistributions of source code must retain the above copyright
#    notice, this list of conditions and the following disclaimer.
# 2. 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.
# 3. All advertising materials mentioning features or use of this software
#    must display the following acknowledgement:
#	This product includes software developed by the University of
#	California, Berkeley and the Network Research Group at
#	Lawrence Berkeley Laboratory.
# 4. Neither the name of the University nor of the Laboratory may be used
#    to endorse or promote products derived from this software without
#    specific prior written permission.
#
# THIS SOFTWARE IS PROVIDED BY THE REGENTS 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/src/mash/repository/mash/mash-1/head.tcl,v 1.3 1997/08/15 07:23:36 mccanne Exp $ (LBL)
#
Class Log
Log proc name s {
	Log set name_ $s
}
Log proc warn s {
	Log instvar name_
	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_
	set arg_option_($flag) $option
	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_
	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
		}
		if [info exists arg_option_($arg)] {
			$self add_option $arg_option_($arg) $val
			set argv [lrange $argv 1 end]
			continue
		}
		if [info exists arg_bool_($arg)] {
			$self add_option $arg_bool_($arg) $arg_bool_val_($arg)
			continue
		}
		if [info exists arg_list_option_($arg)] {
			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
		}
		$self usage
		$self fatal "unknown command option: $arg"
	}
	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 {
	set mash [glob ~]/.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
	}
}
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 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}} {
	return [$self set ttl_($k)]
}
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"
	}
	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 >= 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 != "" && $fmt != "1" } {
		$self add_option videoFormat $fmt
		$self add_option audioFormat $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 3072000
			} elseif { $ttl <= 64 } {
				set maxbw 1024000
			} elseif  { $ttl <= 128 } {
				set maxbw 128000
			} elseif { $ttl <= 192 } {
				set maxbw 53000
			} else {
				set maxbw 32000
			}
		}
		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 sport_ $sport
	set rport_ $rport
	set session_ $session
	set ttl_ $ttl
	set channel_ $channel
	set dn_ [new Network]
	$dn_ open $addr_ $sport_ $rport_ $ttl_
	set cn_ [new Network]
	$cn_ open $addr_ [expr $sport_ + 1] [expr $rport + 1] $ttl_
	$cn_ loopback 1
	$session_ data-net $dn_ $channel_
	$session_ ctrl-net $cn_ $channel_
	set active_ 0
	$dn_ drop-membership
	$cn_ drop-membership
	$self set tloss_ 0
}
NetworkLayer instproc destroy {} {
	$self instvar dn_ cn_
	delete $dn_
	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
	}
}
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 dc_ cc_ net_
	if [info exists dc_] {
		delete $dc_
	}
	if [info exists cc_] {
		delete $cc_
	}
	foreach dn [array names net_] {
		delete $net_($dn)
	}
	$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_]
}
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
	$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 instvar interval_
	$self next
	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 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
	}
}
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/Service -superclass AnnounceListenManager/AS
AnnounceListenManager/AS/Service instproc init { agent spec bw sspec } {
	$self next $spec $bw srv
	$self set srv_inst_ $sspec
	$self set agent_ $agent
}
AnnounceListenManager/AS/Service instproc recv_msg { atype aspec addr \
	        srv_name srv_loc srv_inst ssg_port msg } {
	$self instvar agent_ srv_inst_
	if { $srv_inst != $srv_inst_ } {
		return
	}
	if { $atype == "client" } {
		$self send_announcement
	} else {
		if { [string compare $aspec [$self agent_instance]] < 0 } {
			puts stderr "duplicate gateway at $addr - exiting."
			$self announce_death
			exit 0
		}
	}
}
AnnounceListenManager/AS/Service instproc register { atype aspec addr \
	        srv_name srv_inst msg } {}
AnnounceListenManager/AS/Service instproc unregister { atype aspec addr \
	        srv_name srv_inst msg } {
	$self instvar agentbytype_ srv_inst_ agenttab_
	if { $atype != "client" || $srv_inst != $srv_inst_ } {
		return
	}
	foreach aspec $agentbytype_(client) {
		set sid [lindex $agenttab_($aspec) 4]
		if { $sid == $srv_inst_ } {
			return
		}
	}
	puts stderr "no more clients -- exiting"
	exit 0
}
AnnounceListenManager/AS/Service instproc service_instance {} {
	$self instvar srv_inst_
	return $srv_inst_
}
Class SessionCatalog
SessionCatalog public init { } {
    $self instvar sdp_
    $self next
    $self set file_ ""
    $self set filename_ ""
    $self set sdp_ ""
    $self set info_ ""
}
SessionCatalog public destroy { } {
    $self close
    $self next
}
SessionCatalog public open { filename { mode "r" } { permissions 0644 } } {
    $self instvar file_ filename_ line_no_
    set file_ [open $filename $mode $permissions]
    $self clear
    set filename_ $filename
}
SessionCatalog private clear { } {
    $self set filename_ ""
    $self set line_no_ 0
    $self instvar streams_
    catch { unset streams_ }
    set streams_(all) ""
}
SessionCatalog instproc close { } {
    $self instvar file_
    if { $file_!="" } {
	close $file_
	set file_ ""
	set filename_ ""
    }
}
SessionCatalog instproc is_opened { } {
    $self instvar file_
    if { $file_=="" } { return 0 } else { return 1 }
}
SessionCatalog instproc filename { } {
    return [$self set filename_]
}
SessionCatalog instproc write_sdp { sdp } {
    $self instvar file_
    if { $file_=="" } { error "file not opened" }
    puts $file_ "START_SDP"
    puts $file_ $sdp
    puts $file_ "END_SDP"
    flush $file_
}
SessionCatalog instproc write_info { info } {
    $self instvar file_
    if { $file_ == "" } { error "file not opened" }
    puts $file_ "START_INFO"
    puts $file_ $info
    puts $file_ "END_INFO"
    flush $file_
}
SessionCatalog instproc write_stream { id session datafile indexfile } {
    $self instvar file_
    if { $file_=="" } { error "file not opened" }
    puts $file_ "START_STREAM"
    puts $file_ "\tid=$id"
    puts $file_ "\tsession=$session"
    puts $file_ "\tdatafile=$datafile"
    puts $file_ "\tindexfile=$indexfile"
    puts $file_ "END_STREAM"
    flush $file_
}
SessionCatalog public read { } {
    $self instvar file_ line_no_
    if { $file_=="" } { error "file not opened" }
    while { [$self read_line_ line] } {
	if { ![regexp "START_(.*)" $line dummy block_type] } {
	    error "parse error at line $line_no_ in header file"
	}
	$self read_block_ [string tolower $block_type]
    }
}
SessionCatalog public parse {msg } {
	$self instvar msg_ cur_line_
	$self clear
	set msg_ [split [string trim $msg] "\n"]
	for {set cur_line_ 0} {$cur_line_ < [llength $msg_]} {incr cur_line_} {
		set line [lindex $msg_ $cur_line_]
		if { ![regexp "START_(.*)" $line dummy block_type] } {
			error "parse error"
		}
		incr cur_line_
		$self parse_block_ [string tolower $block_type] 
    }
}
SessionCatalog private read_line_ { lineVar } {
    upvar $lineVar line
    $self instvar file_ line_no_
    while { ![eof $file_] } {
	incr line_no_
	gets $file_ line
	set line [string trim $line]
	if { [string length $line]!=0 && [string index $line 0]!="#"} {
	    return 1
	}
    }
    return 0
}
SessionCatalog private parse_block_ { block_type  } {
	$self instvar msg_ cur_line_
	set msg {}
	for {} {$cur_line_ < [llength $msg_]} {incr cur_line_} {
		set line [lindex $msg_ $cur_line_]
		if { [regexp "END_(.*)" $line dummy end_type] } {
			set end_type [string tolower $end_type]
			if { $block_type != $end_type } {
				error "expected END_$block_type;\
						got END_$end_type at\
						line $line_no_ in header file"
			}
			$self handle_read_${block_type}_ $msg
			return
		}
		append msg "$line\n"
	}
	error "unexpected EOF at line $cur_line_; expected END_$block_type"
}
SessionCatalog private read_block_ { block_type } {
    set msg {}
    while { [$self read_line_ line] } {
	if { [regexp "END_(.*)" $line dummy end_type] } {
	    set end_type [string tolower $end_type]
	    if { $block_type != $end_type } {
		error "expected END_$block_type;\
			got END_$end_type at\
			line $line_no_ in header file"
	    }
	    $self handle_read_${block_type}_ $msg
	    return
	}
	append msg "$line\n"
    }
    error "unexpected EOF at line $line_no_; expected END_$block_type"
}
SessionCatalog instproc handle_read_info_ { msg } {
    $self instvar info_
    append info_ $msg
    return
}
SessionCatalog private handle_read_descr_ {msg } {
	$self instvar desc_
	set desc_ $msg
	return
}
SessionCatalog private handle_read_sdp_ { msg } {
    $self instvar sdp_
    set sdp_ $msg
    return
}
SessionCatalog public get_sdp {} {
    $self instvar sdp_
    return $sdp_
}
SessionCatalog public get_info { type } {
    $self instvar info_
    set return_info ""
    set info_list [split $info_ "=\n"]
    set index [lsearch -exact $info_list $type]
    if { $index != -1 } {
	set return_info [lindex $info_list [expr $index + 1]]
    }
    return $return_info
}
SessionCatalog public get_desc {} {
    $self instvar desc_
    return $desc_
}
SessionCatalog private handle_read_stream_ { msg } {
    $self instvar streams_ filename_ line_no_
    foreach line [split $msg "\n"] {
	if { $line=={} } continue
	set line [split $line "="]
	set attribute [string trim [lindex $line 0]]
	set value     [string trim [lindex $line 1]]
	set header($attribute) $value
    }
    if { ![info exists header(id)] } {
	error "could not find the \"id\" field in STREAM block at\
		line $line_no_"
    }
    set id $header(id)
    if { ![info exists header(session)] } {
	error "could not find the \"session\" field in STREAM block at\
		line $line_no_"
    }
    set streams_($id,session) $header(session)
    if { ![info exists header(datafile)] } {
	error "could not find the \"datafile\" field in STREAM block\
		at line $line_no_"
    } else {
	set streams_($id,datafile) [file join \
		[file dirname $filename_] $header(datafile)]
    }
    if { [info exists header(indexfile)] } {
	if { $header(indexfile)=="" } {
	    set streams_($id,indexfile) ""
	} else {
	    set streams_($id,indexfile) [file join [file dirname \
		    $filename_] $header(indexfile)]
	}
    } else {
	set streams_($id,indexfile) "[file rootname \
		$streams_($id,datafile)].idx"
    }
    lappend streams_(all) $id
}
SessionCatalog instproc info { method args } {
    eval [list $self] [list info.$method] $args
}
SessionCatalog instproc info.streams { } {
    $self instvar streams_
    return $streams_(all)
}
SessionCatalog instproc info.session { id } {
    $self instvar streams_
    return $streams_($id,session)
}
SessionCatalog instproc info.datafile { id } {
    $self instvar streams_
    return $streams_($id,datafile)
}
SessionCatalog instproc info.indexfile { id } {
    $self instvar streams_
    return $streams_($id,indexfile)
}
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}
    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
}
Class RTPApplication -superclass Application
RTPApplication public init name {
	$self next $name
}
RTPApplication public run_resource_dialog { name email } {
	set font [$self get_option medfont]
	set w .form
	global V
	frame $w
	frame $w.msg -relief ridge
	label $w.msg.label -font $font -wraplength 4i \
		-justify left -text \
"Please specify values for the following resources. \
These strings will identify you by name and by email address \
in any RTP-based conference.  Please use your real name and \
affiliation instead of a ``handle'', e.g., ``Jane Doe (ACME Research)''. \
The values you enter will be saved in ~/.mash/prefs so you will \
not have to re-enter them." -relief ridge
	pack $w.msg.label -padx 6 -pady 6
	pack $w.msg -side top
	foreach i {name email} {
		frame $w.$i -bd 2
		entry $w.$i.entry -relief sunken
		label $w.$i.label -width 10 -anchor e
		pack $w.$i.label -side left
		pack $w.$i.entry -side left -fill x -expand 1 -padx 8
	}
	$w.name.label config -text rtpName:
	$w.email.label config -text rtpEmail:
	pack $w.msg -pady 10
	pack $w.name $w.email -side top -fill x
	$w.$i.entry insert 0 [email_heuristic]
	frame $w.buttons
	button $w.buttons.accept -text Accept -command "set dialogDone 1"
	button $w.buttons.dismiss -text Quit -command "set dialogDone -1"
	pack $w.buttons.accept $w.buttons.dismiss \
		-side left -expand 1 -padx 20 -pady 10
	pack $w.buttons
	pack $w -padx 10
	global dialogDone
	while { 1 } {
		set dialogDone 0
		focus $w.name.entry
		tkwait variable dialogDone
		if { $dialogDone < 0 } {
			exit 0
		}
		set name [string trim [$w.name.entry get]]
		if { [string length $name] <= 3 } {
			new ErrorWindow "please enter a reasonable name"
			continue
		}
		set email [string trim [$w.email.entry get]]
		if { [string first . $email] < 0 || \
			[string first @ $email] < 0 } {
			new ErrorWindow "email address should have form user@host.domain"
			continue
		}
		break
	}
	set mash [glob ~]/.mash
	if ![file exists $mash] {
		file mkdir $mash
	}
	set f [open $mash/prefs a+ 0644]
	puts $f "rtpName: $name"
	puts $f "rtpEmail: $email"
	close $f
	pack forget $w
	destroy $w
}
RTPApplication public check_rtp_sdes {} {
	set name [$self get_option rtpName]
	if { $name == "" } {
		set name [$self get_option sessionName]
		option add *rtpName $name startupFile
	}
	set email [$self get_option rtpEmail]
	if { $name == "" || $email == "" } {
		$self run_resource_dialog $name $email
	}
}
RTPApplication private check_hostspec { argv megaSession } {
	if { $argv == "" } {
		if { $megaSession == "" } {
			$self fatal "destination address required"
		}
	} elseif { [llength $argv] > 1 } {
		set extra [lindex $argv 1]
		$self fatal "extra arguments (starting with $extra)"
	}
	return $argv
}
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
		}
	}
}
Source/RTP set reportLoss_ 0
Session/RTP set nb_ 0
Session/RTP set nf_ 0
Session/RTP set np_ 0
Session/RTP set loopback_ 1
Source/RTP set badsesslen_ 0
Source/RTP set badsessver_ 0
Source/RTP set badsessopt_ 0
Source/RTP set badsdes_ 0
Source/RTP set badbye_ 0
SourceLayer/RTP set nchan_ 1
Session/RTP set badversion_ 0
Session/RTP set badoptions_ 0
Session/RTP set badfmt_ 0
Session/RTP set badext_ 0
Session/RTP set nrunt_ 0
Session/RTP set loopbackLayer_ 1000
Source/RTP public layer-stat which {
	$self instvar layers_
	set s 0
	foreach l $layers_ {
		set s [expr $s + [$l set $which]]
	}
	return $s
}
Source/RTP public ns {} {
	$self instvar layers_
	set s 0
	foreach l $layers_ {
		set s [expr $s + [$l set cs_] - [$l set fs_]]
	}
	return $s
}
Source/RTP public missing {} {
	$self instvar layers_
	set s 0
	foreach l $layers_ {
		set nm [expr [$l set cs_] - [$l set fs_] - [$l set np_]]
		if { $nm > 0 } {
			set s [expr $s + $nm]
		}
	}
	return $s
}
Source/RTP instproc is_mixer {} {
	return [expr [$self srcid] != [$self ssrc]]
}
SourceLayer/RTP set nrunt_ 0
SourceLayer/RTP set ndup_ 0
SourceLayer/RTP set fs_ 0
SourceLayer/RTP set cs_ 0
SourceLayer/RTP set np_ 0
SourceLayer/RTP set nf_ 0
SourceLayer/RTP set nb_ 0
SourceLayer/RTP set nm_ 0
Source/RTP public init { sm srcid ssrc addr } {
	$self next $srcid $ssrc $addr
	$self set sm_ $sm
	$self instvar layers_
	set k 0
	set report 0
	if { [$sm info vars network_] != "" } {
		set net [$sm set network_]
		set n [$net set nchan_]
		set report [$net usingRLM]
	} else {
		set n [SourceLayer/RTP set nchan_]
	}
	while { $k < $n } {
		set l [new SourceLayer/RTP]
		lappend layers_ $l
		$self layer $k $l
		incr k
	}
	$self set reportLoss_ $report
}
Source/RTP public getid {} {
	set name [$self sdes name]
	if { $name == "" } {
		set name [$self sdes cname]
		if { $name == "" } {
			set name [$self addr]
		}
	}
	return $name
}
Source/RTP public format_name {} {
	$self instvar sm_
	return [$sm_ rtp_type [$self format]]
}
Class MediaAgent -superclass {SourceManager Observable}
foreach method "unregister activate deactivate \
		trigger_media \
		trigger_format \
		trigger_sdes \
		trigger_idle \
		notify" {
	Source/RTP public $method {args} \
		"\$self instvar sm_ ; eval \$sm_ $method \$self \$args"
	MediaAgent public $method src "\$self notify_observers $method \$src"
}
MediaAgent public init {} {
	$self next
	$self set sources_ ""
}
MediaAgent public active_list {} {
	$self instvar active_
	if ![info exists active_] {
		return ""
	}
	return [array names active_]
}
MediaAgent public activate src {
	$self instvar active_
	set active_($src) 1
	$self notify_observers activate $src
}
MediaAgent public deactivate src {
	$self instvar active_
	unset active_($src)
	$self notify_observers deactivate $src
}
MediaAgent public unregister src {
	$self notify_observers unregister $src
	$self instvar sources_
	set k [lsearch -exact $sources_ $src]
	set sources_ [lreplace $sources_ $k $k]
}
MediaAgent public attach o {
	$self attach_observer $o
	$self instvar sources_ active_
	foreach s $sources_ {
		$o update register $s
		if [info exists active_($s)] {
			$o update activate $s
			$s enable_trigger
		}
	}
}
MediaAgent public detach o {
	$self detach_observer $o
	$self instvar sources_ active_
	foreach s $sources_ {
		if [info exists active_($s)] {
			$o update deactivate $s
		}
		$o update unregister $s
	}
}
MediaAgent public create-source { srcid ssrc addr srcsess } {
	set s [new Source/RTP $self $srcid $ssrc $addr]
	$s set session_ $srcsess
	$self instvar sources_
	lappend sources_ $s
	return $s
}
Class RTPAgent -superclass MediaAgent -configuration {
	mtu 1024 
	loopback 0
	siteDropTime "300"
}
RTPAgent public init {ab {callback {}} } {
	$self next
	$self instvar session_ mtu_ callback_
        if { $callback!={} } { set callback_ $callback }
	set session_ [$self create_session]
	$session_ sm $self
	$session_ buffer-pool [new BufferPool]
	if { $ab != "" } {
		$self reset $ab
	}
	set mtu_ [$self get_option mtu]
	global V
	set V(sm) $self
}
RTPAgent public destroy {} {
	$self instvar session_ network_
	delete $session_
	delete $network_
	$self next
}
RTPAgent public reset_spec spec {
	set ab [new AddressBlock $spec]
	$self reset $ab
	delete $ab
}
RTPAgent public reset ab {
	$self instvar network_ session_ sources_
    if {[$ab info class] != "AddressBlock"} {
	$self reset_spec $spec
    }
	if [info exists network_] {	
		delete $network_
	}
	set network_ [new NetworkManager $ab $session_ $self]
	$self app_loopback 1
	$self net_loopback [$self get_option loopback]
	set key [$self get_option sessionKey]
	if { $key != "" } {
		$network_ install-key $key
	}
	$self instvar local_
	if ![info exists local_] {
		$self mk_local_source
	}
	$session_ max-bandwidth [expr [$ab set maxbw_(0)]/1000.]
        $self instvar callback_
        if [info exists callback_] {
                eval $callback_ [list $ab]
	} else {
	        catch {[Application instance] reset $ab}
	}
}
RTPAgent private notify {src layer} {
	$self instvar network_
	if ![$network_ usingRLM] { return }
	$network_ notify-loss $src $layer
}
RTPAgent public stats {} {
	set s [$self set session_]
	return " \
		Bad-RTP-version [$s set badversion_] \
		Bad-RTPv1-options [$s set badoptions_] \
		Bad-Payload-Format [$s set badfmt_] \
		Bad-RTP-Extension [$s set badext_] \
		Runts [$s set nrunt_]"
}
RTPAgent private mk_local_source {} {
	$self instvar network_ session_ local_
	set net [$network_ data-net 0]
	set a [$net addr]
	set srcid [$session_ random-srcid $a]
	set src [$self create-local $srcid [$net interface]]
	set local_ $src
	$self notify_observers register $local_
	set cname [$self get_option cname]
	if { $cname == "" } {
		set interface [$net interface]
		if { $interface == "0.0.0.0" } {
			set interface [$session_ local-addr-heuristic]
		}
		set cname [user_heuristic]@$interface
	}
	$src sdes name [$self get_option rtpName]
	$src sdes email [$self get_option rtpEmail]
	$src sdes cname $cname
	set tool [Application name]\-[version]
	global tcl_platform
	if {[info exists tcl_platform(os)] && $tcl_platform(os) != "" && \
			$tcl_platform(os) != "unix"} {
		set p $tcl_platform(os)
		if {$tcl_platform(osVersion) != ""} {
			set p $p-$tcl_platform(osVersion)
		}
		if {$tcl_platform(machine) != ""} {
			set p $p-$tcl_platform(machine)
		}
		set tool "$tool/$p"
	}
	$src sdes tool $tool
	return $src
}
RTPAgent public have_network {} {
	$self instvar network_
	return [info exists network_]
}
RTPAgent public have_localsrc {} {
	$self instvar local_
	return [info exists local_]
}
RTPAgent public install-key key {
	$self instvar network_
	if [info exists network_] {
		$network_ install-key $key
	}
}
RTPAgent public network {} {
	$self instvar network_
	if ![info exists network_] {
		return none
	}
	return [$network_ data-net 0]
}
RTPAgent public session-addr {} {
	$self instvar network_
	if ![info exists network_] {
		return none
	}
	return [[$self network] addr]
}
RTPAgent public session-port {} {
	$self instvar network_
	if ![info exists network_] {
		return none
	}
	return [[$self network] port]
}
RTPAgent public session-rport {} {
	$self instvar network_
	if ![info exists network_] {
		return none
	}
	return [[$self network] rport]
}
RTPAgent public session-sport {} {
	$self instvar network_
	if ![info exists network_] {
		return none
	}
	return [[$self network] sport]
}
RTPAgent public get_local_srcid {} {
	$self instvar network_
	if ![info exists network_] {
		return none
	}
	$self instvar local_
	return [$local_ srcid]
}
RTPAgent public get_transmitter {} {
	return [$self set session_]
}
RTPAgent public session-ttl {} {
	$self instvar network_
	if ![info exists network_] {
		return none
	}
	return [[$self network] ttl]
}
RTPAgent public local-name {} {
	$self instvar network_
	if ![info exists network_] {
		return none
	}
	$self instvar local_
	return [$local_ sdes name]
}
RTPAgent public set_local_sdes { which value } {
	$self instvar local_
	$local_ sdes $which $value
}
RTPAgent public crypt_clear {} {
	if [info exists network_] {
		$network_ crypt_clear
	}
}
RTPAgent public shutdown {} {
	$self instvar session_
	$session_ exit
}
RTPAgent public set_maxchannel n {}
RTPAgent public set-bandwidth bps {
	[$self set session_] data-bandwidth $bps
}
RTPAgent public net_loopback enable {
	$self instvar network_
	$network_ loopback $enable
}
RTPAgent public app_loopback enable {
	$self instvar session_
	$session_ set loopback_ $enable
}
RTPAgent public set-bandwidth bps {
	[$self set session_] data-bandwidth $bps
}
Module/RTPPlay instproc init {} {
	$self next
}
Class RTPPlayAgent -superclass RTPAgent
RTPPlayAgent instproc init { session addr } {
	$self set options_ [new Configuration]
	$self add_default defaultTTL 1
	set ab [new AddressBlock $addr]
	$self next $ab
	$self instvar archive_session_
	$self instvar bufferPool_
	set archive_session_ $session
	set media [$session media]
	set Media_ [string toupper [string index $media 0]][string range \
                        $media 1 end]
	set bufferPool_ [new BufferPool/RTP] 
}
RTPPlayAgent instproc destroy {} {
	$self instvar bufferPool_
	delete $bufferPool_
	$self next
}
RTPPlayAgent instproc buffer_pool {} {
	$self instvar bufferPool_
	return $bufferPool_
}
RTPPlayAgent instproc get_session {} {
	$self instvar session_
	return $session_
}
RTPPlayAgent public reset ab {
	$self instvar network_ session_ sources_
	if [info exists network_] {	
		delete $network_
	}
	set network_ [new NetworkManager $ab $session_ $self]
	$self app_loopback 0
	$self net_loopback 1
	set key [$self get_option sessionKey]
	if { $key != "" } {
		$network_ install-key $key
	}
	$session_ max-bandwidth [expr [$ab set maxbw_(0)]/1000.]
	catch {[Application instance] reset $ab}
}
RTPPlayAgent instproc mk_local_source {ssrc ccname rtpName rtpEmail} {
	$self instvar network_ session_ local_
	set net [$network_ data-net 0]
	set srcid $ssrc
	set src [$self create-local $srcid [$net interface]]
	set local_ $src
	$self notify_observers register $local_
	set cname $ccname
	if { $cname == "" } {
		set interface [$net interface]
		if { $interface == "0.0.0.0" } {
			set interface [$session_ local-addr-heuristic]
		}
		set cname [user_heuristic]@$interface
	}
	$src sdes name $rtpName
	$src sdes email $rtpEmail
	$src sdes cname $cname
	set tool [$self get_option appname]\-[version]
	global tcl_platform
	if {[info exists tcl_platform(os)] && $tcl_platform(os) != "" && \
			$tcl_platform(os) != "unix"} {
		set p $tcl_platform(os)
		if {$tcl_platform(osVersion) != ""} {
			set p $p-$tcl_platform(osVersion)
		}
		if {$tcl_platform(machine) != ""} {
			set p $p-$tcl_platform(machine)
		}
		set tool "$tool/$p"
	}
	$src sdes tool $tool
	return $src
}
RTPPlayAgent instproc create_session {} {
	$self instvar Media_
	$self instvar session_
	set session_ [new Session/RTP/Play]
	if { $session_ == "" } {
		$self fatal "creation of Session/RTP/Play failed!"
	}
	$self app_loopback 0
	$self set-bandwidth 1024
	return $session_
}
RTPPlayAgent instproc activate src {
	$self instvar decoders_
	set h [new Module/RTPPlay]  
	lappend decoders_ $h
	$src data-handler $h
	$self next $src
}
RTPPlayAgent instproc deactivate src {
	$self instvar decoders_
	set d [$src handler]
	set k [lsearch -exact $decoders_ $d]
	set decoders_ [lreplace $decoders_ $k $k]
	$self next $src
	delete $d
}
Class ArchiveSession/Play -superclass Observable
set classes [ArchiveStream info superclass]
set objectIdx [lsearch $classes Observable]
if { $objectIdx == -1 } {
	ArchiveStream superclass [concat Observable $classes]
}
ArchiveSession/Play instproc media { args } {
	switch -exact -- [llength $args] {
		0 {
			if [info exists media_] {
				return $media_
			} else {
				return ""
			}
		}
		1 {
			$self set media_ [lindex $args 0]
			return
		}
		default {
			error "too many arguments"
		}
	}
}
Class RTPApplication/Player -superclass RTPApplication
RTPApplication/Player instproc init {media} {
	$self next player
	$self add_option sessionType rtpv2
	$self add_option defaultTTL 15
	$self add_option cname Archive
}
Class ArchiveSession/Play/RTP -superclass ArchiveSession/Play
ArchiveSession/Play/RTP instproc init { media addr} {
	$self next
	$self instvar media_
	$self instvar agent_
	$self instvar stream_num_
	$self instvar vcn_ vdn_
	set stream_num_ 0
	$self set media_ $media
	$self set agent_ [new RTPPlayAgent $self $addr]
}
ArchiveSession/Play/RTP instproc destroy {} {
	$self instvar agent_
	$self instvar stream_list_
	puts "ArchiveSession/Play/RTP destroy"
	foreach stream $stream_list_ {
		delete $stream
	}
	delete $agent_
	$self next
}
ArchiveSession/Play/RTP instproc media {} {
	$self instvar media_
	return $media_
}
ArchiveSession/Play/RTP instproc attach_stream { stream } {
	$self instvar vdn_ vcn_
	$self instvar agent_
	$self instvar stream_list_
	set session [$agent_ get_session]
	$stream attach_agent $session
	$stream buffer_pool [$agent_ buffer_pool]
	$stream header_info hdr
	lappend stream_list_ $stream
	if {[string first "Recorded Source" $hdr(name)] == -1} {
		set hdr(name) "Recorded Source:$hdr(name)" }
	set src [$agent_ mk_local_source $hdr(ssrc) $hdr(cname) $hdr(name) $hdr(email)]
}
ArchiveSession/Play/RTP instproc create_stream { } {
	return [new ArchiveStream/Play/RTP]
}
ArchiveSession/Play/RTP instproc stream_done { stream } {
}
ArchiveStream/Play public init {} {
	$self next 
	$self set offset_ 0.0
}
Session/SRM set nb_ 0
Session/SRM set nf_ 0
Session/SRM set np_ 0
Session/SRM set loopbackLayer_ 1000
Session/SRM set loopback_ 1
Class SRMAgent -superclass SourceManager/SRM
SourceManager/SRM instproc create-source { uid addr } {
    $self instvar map_ src_update_handler_
    if ![info exists map_($addr,$uid)] {
	set s [new Source/SRM $uid $addr]
	$self do_src_update $s
	set map_($addr,$uid) $s                
    } else {
	set s $map_($addr,$uid)      
    }
    return $s	
}
SourceManager/SRM instproc do_src_update { src } {
    $self instvar src_update_handler_
    if { [info exists src_update_handler_] } {
	if { $src_update_handler_ != {} } {
	    $src_update_handler_ new_source $src
	    set cname_update_body "$src_update_handler_ cname_update \
		    \{$src\} \$newname"
	    $src proc cname_update { newname } $cname_update_body
	}
    }
}
SourceManager/SRM instproc attach_src_update_handler { src_update_handler } {
    $self instvar map_ src_update_handler_
    set src_update_handler_ $src_update_handler
    foreach elem [array names map_ *] {
	$self do_src_update $map_($elem)
    }
}
SourceManager/SRM instproc get_source {addr uid} {
    $self instvar map_
    if [info exists map_($addr,$uid)] {
	return $map_($addr,$uid)
    } else {
	return ""
    }
}
SRMAgent instproc init { {luid {}} {laddr {}} {lcname {}} } {
	$self next 
	$self set luid_   $luid
	$self set laddr_  $laddr
	$self set lcname_ $lcname
}
SRMAgent instproc destroy {} {
	$self instvar network_ session_
	if [info exists network_] {
		delete $network_
	}
	if [info exists session_] {
	    delete $session_
	}
}
SRMAgent instproc net_loopback enable {
	$self instvar network_
	$network_ loopback $enable
}
SRMAgent instproc create-local { {uid {}} {addr {}} {cname {}} } {
        if { $uid=={} } {
                set uid [$self default-local-uid]
        }
        if { $addr=={} } {
                set addr [$self default-local-addr]
        }
        set local_src [$self local $uid $addr]
        if { $cname=={} } {
                set cname [$self get_option rtpName]
        }
        $local_src cname $cname
        return $local_src
}
SRMAgent instproc create-session { appmgr {src_update_handler {}} } {
        set session [new Session/SRM]
        $self app-mgr $appmgr
        $self set src_update_handler_ $src_update_handler
        $session app-mgr $appmgr
        $session agent $self
        $self set session_ $session
        return $session
}
SRMAgent instproc reset_spec spec {
	set ab [new AddressBlock $spec]
	$self reset $ab
	delete $ab
}
SRMAgent instproc reset { ab } {
	$self instvar default_local_ luid_ laddr_ lcname_ network_ session_
	if [info exists network_] {
		delete $network_
	}
	set network_ [new NetworkManager $ab $session_ $self]
	set key [$self get_option sessionKey]
	if { $key != "" } {
		$network_ install-key $key
	}
	if ![info exists default_local_] {
		set default_local_ [$self create-local $luid_ $laddr_ $lcname_]
	}
	catch {[Application instance] reset $ab}
}
SRMAgent instproc set_maxchannel { n } {} 
Session/SRM instproc destroy {} {
    	$self instvar bufferPool_ sa_timer_
    	if [info exists bufferPool_] {
	    	delete $bufferPool_
	}
	if [info exists sa_timer_] {
	    	delete $sa_timer_
	}
	$self next
}
Session/SRM instproc default-local { } {
    $self instvar agent_
    return [$agent_ default-local]
}
Session/SRM instproc create-local {args} {
        return [eval [$self set agent_] create-local $args]
}
Session/SRM instproc start_timers {} {
    $self instvar sa_timer_
    set sa_timer_ [new TimerSA]
    $self sa-timer $sa_timer_
    $sa_timer_ proc reset {} {
	$self period 3000
    }	
    $sa_timer_ proc faster {} {
	$self period 500
    }
    $sa_timer_ faster
}
Session/SRM instproc agent { a } {
	$self source-manager $a
        $self set agent_ $a
	$self instvar bufferPool_
	set bufferPool_ [new BufferPool/SRM]
	$bufferPool_ source-manager $a
	$self buffer-pool $bufferPool_
}
Session/SRM instproc get_agent {} {
	return [$self set agent_]
}
SRMAgent instproc default-local { } {
    $self instvar default_local_
    if { [info exists default_local_] } {
	return $default_local_
    } else {
	return ""
    }
}
SRMAgent instproc have_network {} {
	$self instvar network_
	return [info exists network_]
}
SRMAgent instproc install-key {key} {
	$self instvar network_
	if [info exists network_] {
		$network_ install-key $key
	}
}
SRMAgent instproc network {} {
	$self instvar network_
	if ![info exists network_] {
		return none
	}
	return [$network_ data-net 0]
}
SRMAgent instproc session-addr {} {
	$self instvar network_
	if ![info exists network_] {
		return none
	}
	return [[$self network] addr]
}
SRMAgent instproc session-port {} {
	$self instvar network_
	if ![info exists network_] {
		return none
	}
	return [[$self network] port]
}
SRMAgent instproc session-rport {} {
	$self instvar network_
	if ![info exists network_] {
		return none
	}
	return [[$self network] rport]
}
SRMAgent instproc session-sport {} {
	$self instvar network_
	if ![info exists network_] {
		return none
	}
	return [[$self network] sport]
}
SRMAgent instproc session-ttl {} {
	$self instvar network_
	if ![info exists network_] {
		return none
	}
	return [[$self network] ttl]
}
SRMAgent instproc crypt_clear {} {
	if [info exists network_] {
		$network_ crypt_clear
	}
}
Class ArchiveSession/Play/Mediaboard \
		-superclass {ArchiveSession/Play MB_Manager/Play}
Class ArchiveSession/Play/SRM -superclass ArchiveSession/Play/Mediaboard
ArchiveSession/Play/Mediaboard instproc init { media addr } {
	$self next
        ArchiveSession/Play/Mediaboard instvar count_
	if ![info exists count_] {
		set count_ 1
	}
	$self set stream_list_ ""
	$self create_session $addr
	$self media $media
}
ArchiveSession/Play/Mediaboard instproc destroy {} {
	$self instvar agent_ stream_list_
	foreach stream $stream_list_ {
		delete $stream
	}
	delete $agent_
	$self next
}
ArchiveSession/Play/Mediaboard instproc create_session { addr \
		{src_update_handler {}} } {
	$self instvar session_ agent_
        set agent_ [new SRMAgent]
	set session_ [$agent_ create-session $self $src_update_handler]
	$agent_ set default_local_ ""
	$self reset $addr
	$self attach_session $session_
}
ArchiveSession/Play/Mediaboard instproc reset { addr } {
	$self instvar session_ agent_
	set had_network [$agent_ have_network] 
	set ab [new AddressBlock $addr]
	$agent_ reset $ab
	delete $ab
	set net [$agent_ set network_]
	[$net data-net] loopback 1
	[$net ctrl-net] loopback 1
	if !$had_network {
		$session_ start_timers
	}
}
ArchiveSession/Play/Mediaboard instproc srm_session { } {
	return [$self set session_]
}
ArchiveSession/Play/Mediaboard instproc srm_source_mgr { } {
	return [$self set agent_]
}
ArchiveSession/Play/Mediaboard instproc source_id { original uidVar addrVar } {
	upvar $uidVar uid $addrVar addr
	$self instvar agent_
	ArchiveSession/Play/Mediaboard instvar count_
	set uid 0x[$agent_ default-local-uid]
	puts "uid: $uid count: $count_"
	set uid [expr ($uid << 16) | $count_]
	set uid [format "%x" $uid]
	incr count_
	puts "uid: $uid count: $count_"
	set addr {}
}
ArchiveSession/Play/Mediaboard instproc attach_stream { stream } {
	set datafile [$stream datafile]
	if { $datafile=={} } {
		error "no data file associated with stream"
	}
	$datafile header hdr
	$self instvar stream_list_
	lappend stream_list_ $stream
	$self source_id $hdr(cname) uid addr
	$self create_srm_source $stream $uid $addr "Recorded stream: $hdr(name)"
}
ArchiveSession/Play/Mediaboard instproc create_stream { } {
	return [new ArchiveStream/Play/Mediaboard]
}
Class ArchiveSession/Record -superclass Observable
set classes [ArchiveStream info superclass]
set objectIdx [lsearch $classes Observable]
if { $objectIdx == -1 } {
	ArchiveStream superclass [concat Observable $classes]
}
ArchiveSession/Record instproc init { media } {
	$self next
	$self set stream_count_ 0
	$self media $media
}
ArchiveStream/Record public destroy {} {
	$self next
}
ArchiveSession/Record instproc catalog { args } {
	$self instvar catalog_
	if { [llength $args]==0 } {
		if [info exists catalog_] {
			return $catalog_
		} else {
			return ""
		}
	} else {
		set catalog_ [lindex $args 0]
	}
}
ArchiveSession/Record instproc save_in { args } {
	switch -exact -- [llength $args] {
		0 {
			if [info exists directory_] {
				return $directory_
			} else {
				return ""
			}
		}
		1 {
			$self set directory_ [lindex $args 0]
			return
		}
		default {
			error "too many arguments"
		}
	}
}
ArchiveSession/Record instproc session_id { args } {
	switch -exact -- [llength $args] {
		0 {
			if [info exists session_id_] {
				return $session_id_
			} else {
				return ""
			}
		}
		1 {
			$self set session_id_ [lindex $args 0]
			return
		}
		default {
			error "too many arguments"
		}
	}
}
ArchiveSession/Record instproc media { args } {
	$self instvar media_
	switch -exact -- [llength $args] {
		0 {
			if [info exists media_] {
				return $media_
			} else {
				return ""
			}
		}
		1 {
			$self set media_ [lindex $args 0]
			$class instvar media_count_
			if { ![info exists media_count_($media_)] } {
				set media_count_($media_) 0
			}
			incr media_count_($media_)
			$self set media_count_ $media_count_($media_)
			return
		}
		default {
			error "too many arguments"
		}
	}
}
ArchiveSession/Record instproc generate_filename { } {
	$self instvar directory_ session_id_ media_ media_count_ stream_count_
	set name ""
	if { $session_id_!="" } {
		append name "${session_id_}-"
	}
	incr stream_count_
	append name "${media_}${media_count_}-${stream_count_}"
	return [file join $directory_ $name]
}
ArchiveStream/Record instproc bind { session } {
	$self set archive_session_ $session
	if { [catch {
		set filename [$session generate_filename]
		set dataFile  [new ArchiveFile/Data]
		$dataFile open "${filename}.dat" "w"
		set indexFile [new ArchiveFile/Index]
		$indexFile open "${filename}.idx" "w"
		$self write_to_catalog $session $filename
		$session notify_observers new_stream $self
		$self notify_observers filename "${filename}.dat \[.idx\]"
		$self datafile  $dataFile
		$self indexfile $indexFile
	} error] } {
		return $error
	}
	return ""
}
ArchiveStream/Record instproc write_to_catalog { session filename } {
	set catalog [$session catalog]
	if { $catalog=="" } return
	set dirname    [file dirname $filename]
	set catalogdir [file dirname [$catalog filename]]
	if { [string first $catalogdir $dirname]==0 } {
		set dirname [file split $dirname]
		set ignore [llength [file split $catalogdir]]
		set dirname [lrange $dirname $ignore end]
		if { [llength $dirname]==0 } {
			set filename [file tail $filename]
		} else {
			set filename [eval file join $dirname \
					[list [file tail $filename]]]
		}
	}
	$session instvar media_ media_count_
	$catalog write_stream $self "$media_$media_count_" \
			"${filename}.dat" "${filename}.idx"
}
ArchiveStream/Record instproc session { } {
	return [$self set archive_session_]
}
ArchiveStream/Record instproc media { } {
	return [[$self set archive_session_] media]
}
Module/RTPRecord instproc init {} {
	set nb_ 0
	$self next
}
Class RTPRecordAgent -superclass RTPAgent 
RTPRecordAgent instproc init { session addr } {
	$self instvar Media_ archive_session_
	set archive_session_ $session
	set media [$session media]
	set Media_ [string toupper [string index $media 0]][string range \
			$media 1 end]
	set app [new RTPApplication/Recorder $media]
	set ab [new AddressBlock $addr]
	eval $self next $ab
}
RTPRecordAgent instproc destroy {} {
	$self instvar streams_
	if [info exists streams_] {
		foreach strm $streams_ {
			delete $strm
		}
	}
	$self next
}
RTPRecordAgent instproc activate src {
puts stderr "RTPRecordAgent::activate [$src getid]"
	$self instvar archive_session_ streams_
	set stream [new ArchiveStream/Record/RTP $archive_session_]
	set error [$stream bind $archive_session_]
	if { $error != "" } {
		$src data-handler [new Module/VideoDecoder/Null]
		$src ctrl-handler [new Module/VideoDecoder/Null]
		$self notify_observers archive_error $error
puts $error
exit 1
		return
	}
	$stream write_headers
	set rcvr [new Module/RTPRecord]
	set crcvr [new Module/RTPRecordCtrl]
	$stream attach $rcvr $crcvr
	$stream source $src
	$rcvr attach $stream
	$crcvr attach $stream
	$src data-handler $rcvr
	$src ctrl-handler $crcvr
	lappend streams_ $stream
	$self next $src
}
RTPRecordAgent instproc deactivate src {
	$self next $src
}
RTPRecordAgent instproc create_session {} {
	$self instvar Media_
	set session [new Session/RTP/${Media_}/Archive]
	if { $session == "" } {
		$self fatal "creation of Session/RTP/${Media_}/Archive failed"
		exit 1
	}
	return $session
}
ArchiveStream/Record/RTP instproc init { session } {
	$self instvar archive_session_
	set archive_session_ $session
	$self next $session
	$self init_file_header
}
Class RTPApplication/Recorder -superclass RTPApplication
RTPApplication/Recorder instproc init {media} {
	$self next recorder
	$self add_option sessionType rtpv2
	$self add_option network ip
	$self add_option defaultTTL 15
	$self add_option cname Archive
}
Class ArchiveSession/Record/RTP -superclass ArchiveSession/Record
ArchiveSession/Record/RTP instproc init { media addr } {
	set media [string tolower $media]
	$self next $media
	set Media [string toupper [string index $media 0]][string range \
			$media 1 end]
	$self set agent_ [new RTPRecordAgent $self $addr]
}
ArchiveSession/Record/RTP instproc destroy { } {
	$self instvar agent_
	delete $agent_
}
Class ArchiveSession/Record/Mediaboard \
		-superclass {ArchiveSession/Record MB_Manager/Record}
Class ArchiveSession/Record/SRM -superclass ArchiveSession/Record/Mediaboard
ArchiveSession/Record/Mediaboard instproc init { media addr } {
	$self next $media
	$self instvar session_ sm_ agent_
        set agent_ [new SRMAgent 0xFFFFFF]
	set session_ [$agent_ create-session $self $self]
	$self reset $addr
	$self attach_session $session_
}
ArchiveSession/Record/Mediaboard instproc destroy { } {
    	$self instvar agent_
    	delete $agent_
	$self next
}
ArchiveSession/Record/Mediaboard instproc reset { addr } {
	$self instvar session_ agent_
	set had_network [$agent_ have_network] 
	set ab [new AddressBlock $addr]
	$agent_ reset $ab
	delete $ab
	set net [$agent_ set network_]
	[$net data-net] loopback 1
	[$net ctrl-net] loopback 1
	if !$had_network {
		$session_ start_timers
	}	
}
ArchiveSession/Record/Mediaboard instproc srm_session { } {
	return [$self set session_]
}
ArchiveSession/Record/Mediaboard instproc srm_source_mgr { } {
	return [$self set sm_] 
}
ArchiveSession/Record/Mediaboard instproc new_source { src } {
}
ArchiveStream/Record/Mediaboard instproc init { session } {
	$self next $session
	$self init_file_header
	$self set after_id_ [after 2000 "$self do_periodic"]
}
ArchiveStream/Record/Mediaboard instproc destroy { } {
	$self instvar after_id_
	if [info exists after_id_] {
		after cancel $after_id_
		unset after_id_
	}
	$self next
}
ArchiveStream/Record/Mediaboard private do_periodic { } {
	$self write_headers
	$self set after_id_ [after 2000 "$self do_periodic"]
}
Class ArchiveSystem
Class ArchiveSystem/Record -superclass ArchiveSystem
Class ArchiveSystem/Play -superclass ArchiveSystem
ArchiveSystem public init {} {
}
ArchiveSystem private check_dir dir {
    if ![file exists $dir] {
	catch "file mkdir $dir"
	if ![file isdirectory $dir] {
	    return "$dir: can't create"
	}
    } elseif ![file isdirectory $dir] {
	return "$dir: not a directory"
    }
    return ""
}
ArchiveSystem/Record private destroy {} {
    $self instvar sessions_
    foreach s $sessions_ {
	delete $s
    }
    $self next
}
ArchiveSystem/Record public open { path module } {
    $self instvar catalog_ module_
    set err [$self check_dir $path]
    if { $err != "" } {
	return $err
    }
    set module_ $path/$module
    set err [$self check_dir $module_]
    if { $err != "" } {
	return $err
    }
    set catalog_ [new SessionCatalog]
    $catalog_ open $module_/cat.ctg w 0644
}
ArchiveSystem/Play public init {} {
	$self instvar sesslist_
	set sesslist_ ""
	$self next
}
ArchiveSystem/Play public open { path module } {
	set module_ $path/$module
	if ![file isdirectory $path] {
		return "$path: no such directory"
	}
	$self instvar catalog_
	set catalog_ [new SessionCatalog]
	$catalog_ open $module_
	$self scan_catalog
}
ArchiveSystem/Play public open {module} {
	set module_ $module
	if ![file isfile $module_] {
		return "$module_: no such file"
	}
	$self instvar catalog_
	set catalog_ [new SessionCatalog]
	$catalog_ open $module_
	$self scan_catalog
}
ArchiveSystem/Play public query_sessions {} {
	$self instvar sesslist_
	return $sesslist_
}
ArchiveSystem/Play private scan_catalog {} {
    $self instvar catalog_ start_ end_ srcs_ lts_ sesslist_
    catch "unset start_ end_"
    if [catch "$catalog_ read" error] {
	return $error
    }
    foreach src [$catalog_ info streams] {
	    set sess [$catalog_ info session $src]
	    lappend srcs_($sess) $src
	    if {[lsearch $sesslist_ $sess]==-1} {
		    lappend sesslist_ [$catalog_ info session $src]
	    }
    }
    set lts_ [new LTS]
}
ArchiveSystem/Play private at { logical_time cmd } {
    $self instvar lts_ start_
    set diff [expr $logical_time - ([$lts_ now_logical] - $start_) ]
    if { $diff < 0 } {
	set diff 0
    }
    set ms [expr int(1000 * $diff + 0.5)]
    puts "$logical_time, [$lts_ now_logical], $ms"
    after $ms $cmd
}
ArchiveSystem/Play public play_session { spec media } {
    $self instvar srcs_
    foreach s [array names srcs_] {
	if { [string first $media $s] >= 0 } {
	    $self create_playback_session $spec $media $s
	    return 1
	}
    }
    return 0
}
ArchiveSystem/Play private destroy {} {
    $self instvar sessions_ streamlist_
    foreach s $sessions_ { 
	delete $s
    }
}
ArchiveSystem/Play private create_playback_session { spec media sessionTag } {
	$self instvar start_ end_
    if { $media == "audio" || $media == "video" } {
	set protocol RTP
    } else {
	set protocol Mediaboard
    }
    set session [new ArchiveSession/Play/$protocol $media $spec]
    $self instvar sessions_
    lappend sessions_ $session
    $self instvar srcs_ start_ end_ catalog_ streamlist_
    set file [new ArchiveFile]
    foreach src $srcs_($sessionTag) {
	set datafile [$catalog_ info datafile $src]
	set indexfile [$catalog_ info indexfile $src]
	if [catch {$file open $datafile} error] {
	    delete $file
	    return "$datafile: can't open"
	}
	if [catch {$file header data_hdr} error] {
	    delete $file
	    return "$datafile: bad header format"
	}
	$file close
	if [catch {$file open $indexfile} error] {
	    delete $file
	    return "$indexfile: can't open"
	}
	if [catch {$file header index_hdr} error] {
	    delete $file
	    return "$indexfile: bad header format"
	}
	$file close
	foreach fld "protocol media cname name" {
	    if { $data_hdr($fld) != $index_hdr($fld) } {
		delete $file
		return \
			"data/index attribute mismatch\n\t(attr $fld, data $datafile, index $indexfil)"
	    }
	}
	if ![info exists start_] {
	    set start_ $data_hdr(start)
	    set end_ $data_hdr(end)
	} else {
	    if { $data_hdr(start) < $start_ } {
		set start_ $data_hdr(start)
	    }
	    if { $data_hdr(end) > $end_ } {
		set end_ $data_hdr(end)
	    }
	}
	set df [new ArchiveFile/Data]
	$df open $datafile
	set if [new ArchiveFile/Index]
	$if open $indexfile
	set stream [$session create_stream]
	$stream datafile $df 
	$stream indexfile $if
	$stream lts [new LTS]
	$session attach_stream $stream
	lappend streamlist_ $stream
    }
    $self rewind
    return ""
}
ArchiveSystem/Play public get_mapping {} {
	$self instvar lts_ start_
	set system [$lts_ now_system]
	set logical [$lts_ now_logical]
	set offset [expr $logical - $start_]
	return "$system $offset"
}
ArchiveSystem/Play public get_start {} {
	$self instvar start_
	return $start_
}
ArchiveSystem/Play public get_end {} {
	$self instvar end_
	return $end_
}
ArchiveSystem/Play public rewind {} {
    $self goto 0
}
ArchiveSystem/Play public goto { t } {
    $self instvar start_ streamlist_ lts_
    $lts_ now_logical [expr $start_ + $t]
    foreach s $streamlist_ {
	[$s lts] now_logical [expr $start_ + $t - [$s set offset_]]
    }
}
ArchiveSystem/Play public start {} {
    $self instvar streamlist_ lts_
    $lts_ speed 1.0
    foreach s $streamlist_ {
	[$s lts] speed 1.0
    }
}
ArchiveSystem/Play public stop {} {
    $self instvar streamlist_ lts_
    $lts_ speed 0.0
    foreach s $streamlist_ {
	[$s lts] speed 0.0
    }
}
ArchiveSystem public close { } {
    $self instvar catalog_
    delete $catalog_
    unset catalog_
}
ArchiveSystem public record_rtp_session { spec media tag } {
    set session [new ArchiveSession/Record/RTP $media $spec]
    $self instvar catalog_ module_
    $session catalog $catalog_
    $session save_in $module_
    $session session_id $tag\_$media
    $self instvar sessions_
    lappend sessions_ $session
}
ArchiveSystem public record_mb_session { spec tag } {
    set session [new ArchiveSession/Record/Mediaboard mediaboard $spec]
    $self instvar catalog_ module_
    $session catalog $catalog_
    $session save_in $module_
    $session session_id $tag\_mb
    $self instvar sessions_
    lappend sessions_ $session
}
ArchiveSystem public record_program { program tag } {
    set session_list {}
    set msg [$program base]
    set all_media [$msg set allmedia_]
    set num_media [llength $all_media]
    while { $num_media > 0 } {
	set num_media [expr $num_media - 1]
	set media [lindex $all_media $num_media]
	set mediatype [string tolower [$media set mediatype_]]
	set fmt [$media set fmt_]
	set addr_and_ttl [split [$media set caddr_] /]
	set addr [lindex $addr_and_ttl 0]
	set ttl [lindex $addr_and_ttl 1]
	set port [$media set port_]
	set spec ""
	append spec $addr "/" $port "/" $fmt "/" $ttl
	if { $mediatype == "audio" || $mediatype == "video" } {
	    $self record_rtp_session $spec $mediatype $tag
	} else {
		$self record_mb_session $spec $tag
	}
    }
}
ArchiveSystem public write_announcement { program } {
    $self instvar catalog_
    $catalog_ write_sdp [[$program base] obj2str]
}
ArchiveSystem public write_info { info } {
    $self instvar catalog_
    $catalog_ write_info $info
}
Class SSACServer
SSACServer public init {app msg} {
	$self instvar app_ scheduled_ session_
	set app_ $app
	set scheduled_ ""
	set session_(seqno) 0
	$self parse $msg
	$self begin
	$self init_net
}
SSACServer public recv_msg {msg} {
	$self instvar session_  app_
	$self parse $msg
	$self change_time $session_(offset)
	$app_ set_seqno [incr session_(seqno)]
}
SSACServer private parse {msg} {
	$self instvar sesslist_ session_
	puts "MSG: $msg :MSG"
	set lines [split $msg "\n"]
	set seqno [lindex [split [lindex $lines 0]] 1]
	if {$seqno > $session_(seqno) } {
	set session_(seqno) $seqno
	set session_(filename) [lindex [split [lindex $lines 1]] 1]
	set session_(offset) [lindex [split [lindex $lines 2]] 1]
	}
}
SSACServer private init_net {} {
	$self instvar sesslist_ session_ app_
	$app_ set_filename $session_(filename)
	$app_ set_duration $session_(duration)
	foreach sess $sesslist_ {
		$app_ add_sessinfo $sess $session_($sess,Address)
	}
	$app_ set_seqno [incr session_(seqno)]
}
SSACServer private begin {} {
	$self instvar  session_ sesslist_ player_
	set player_ [new ArchiveSystem/Play]
	$player_ open $session_(filename)
	set sesslist_ [$player_ query_sessions]
	puts "Sesslist: $sesslist_"
	foreach sess $sesslist_ {
		set session_($sess,Address) [$self alloc_mcast_addr]/[$self alloc_port]
		set session_($sess,Media) [string trimright $sess "0123456789"]
		if {$session_($sess,Media) == "audio"} {
			set session_($sess,Address) $session_($sess,Address)/PCM/15
		} elseif {$session_($sess,Media) == "video"} {
			set session_($sess,Address) $session_($sess,Address)/null/15
		} else {
			set session_($sess,Address) $session_($sess,Address)/15
		}
		puts "********* $sess $session_($sess,Address) $session_($sess,Media) **********"
		$player_ create_playback_session $session_($sess,Address) $session_($sess,Media) $sess
	}
	$self change_time $session_(offset)
	set start [$player_ get_start]
	set end [$player_ get_end]
	set session_(duration) [expr $end - $start]
	puts $session_(duration)
}
SSACServer private begin2 {} {
	$self instvar  session_ sesslist_ player_
	set player_ [new ArchiveSystem/Play]
	$player_ open $session_(filename)
	set sesslist_ [$player_ query_sessions]
	puts "Sesslist: $sesslist_"
	foreach sess $sesslist_ {
		set session_($sess,Media) [string trimright $sess "0123456789"]
		switch $session_($sess,Media) {
			video {
				set session_($sess,Address) 224.8.8.1/8000/null/15
			}
			audio {
				set session_($sess,Address) 224.8.8.2/8000/PCM/15
			}
			mediaboard {
				set session_($sess,Address) 224.8.8.3/8000/null/15
			}
		}
		puts "********* $sess $session_($sess,Address) $session_($sess,Media) **********"
		$player_ create_playback_session $session_($sess,Address) $session_($sess,Media) $sess
	}
	$self change_time $session_(offset)
	set start [$player_ get_start]
	set end [$player_ get_end]
	set session_(duration) [expr $end - $start]
	puts $session_(duration)
}
SSACServer public get_mapping {} {
	$self instvar player_
	return [$player_ get_mapping]
}
SSACServer private change_time {new} {
	$self instvar player_
	puts "NEW $new"
	if { [string compare $new "PAUSE"] == 0} {
		$player_ stop
	} else {
		$player_ start
		$player_ goto $new
		$player_ start
	}
}
SSACServer private start_time2 {} {
	$self instvar lts_ timemap_
	set newwords [split [lindex $timemap_ 1] ":"]
	set newwall [lindex $newwords 0]
	puts $newwall
	set newref [lindex $newwords 1]
	puts $newref
	$lts_ speed 0.0
	if {$newwall=="now"} {
		puts "logically [$lts_ now_logical]"
		puts "setting to $newref"
		$lts_ now_logical $newref
		set now [$lts_ now_system]
		$lts_ speed 1.0
		set timemap_ $now:$newref
		puts "Playing"
	} else {
		set nowwall [$lts_ now_system]
		puts "nowwall $nowwall"
		if {$newwall < $nowwall} {
			set diff [expr $nowwall - $newwall]
			puts "difference $diff"
			set newerref [expr $newref + $diff]
			puts "newerref $newerref"
			$lts_ now_logical $newerref
			$lts_ speed 1.0
			puts "LTS done setting speed"
		} else {
			puts "XXX"
			$lts_ set_reference $newref $newwall
			$lts_ speed 1.0
		}
	}
}
SSACServer instproc alloc_port {  } {
	set r01 [expr [random]/double(0x7fffffff)]
	return [expr round(8392 + $r01 * 8192)]
}
SSACServer instproc alloc_mcast_addr {  } {
	set lo1 round([expr [random]/double(0x7fffffff) * 256])
	set lo2 round([expr [random]/double(0x7fffffff) * 256])
	return "224.2.[expr round($lo1)].[expr round($lo2)]"
}
Class AnnounceListenManager/AS/Service/Mars -superclass AnnounceListenManager/AS/Service
AnnounceListenManager/AS/Service/Mars public init {argv} {
	$self instvar  ssac_ timemap_ lastseqno_ ssd_ serv_inst_
	set ssd [lindex $argv 0]
	set serv_inst_ [lindex $argv 1]
	set megactrl [lindex $argv 3]
	$self next $self $megactrl 20000 $serv_inst_
	set ssd_(filename) ""
	set ssd_(duration) ""
	set ssd_(sesslist) ""
	set lastseqno_ 0
	set ssac_ [new SSACServer $self $ssd]
}
AnnounceListenManager/AS/Service/Mars public service_name {} {
	return Mars
}
AnnounceListenManager/AS/Service/Mars public recv_msg {atype aspec addr srv_name srv_loc srv_inst ssg_port ssd} {
	$self instvar ssac_  lastseqno_ serv_inst_
	if { $srv_name == "DEATH" } {
		puts stderr "Received death packet from $aspec at $addr - exiting."
		$self announce_death
		exit 0
	}
	$self next $atype $aspec $addr $srv_name $srv_loc $srv_inst $ssg_port $ssd
	if {$serv_inst_ != $srv_inst} {
		return
	}
	set seqno [lindex [split [lindex [split $ssd "\n"] 0]] 1]
	puts "Seqno $seqno"
	if {$seqno > $lastseqno_} {
		$ssac_ recv_msg $ssd
		set lastseqno_ $seqno
	}
}
AnnounceListenManager/AS/Service/Mars public set_agent_data {newmsg} {
	$self instvar ssd_out_
	set ssd_out_ $newmsg
}
AnnounceListenManager/AS/Service/Mars public set_filename {filename} {
	$self instvar ssd_
	set ssd_(filename) $filename
}
AnnounceListenManager/AS/Service/Mars public set_duration {duration} {
	$self instvar ssd_
	set ssd_(duration) $duration
}
AnnounceListenManager/AS/Service/Mars public add_sessinfo {sessname sessaddr} {
	$self instvar ssd_
	lappend ssd_(sesslist) $sessname
	set ssd_($sessname,Address) $sessaddr
}
AnnounceListenManager/AS/Service/Mars public set_seqno {seqno} {
	$self instvar ssd_
	set ssd_(seqno) $seqno
}
AnnounceListenManager/AS/Service/Mars public agent_data {} {
	$self instvar ssd_ ssac_
	set aa "Seqno $ssd_(seqno)"
	set a "PSID $ssd_(filename)"
	set c "Duration $ssd_(duration)"
	set cc "Current [$ssac_ get_mapping]"
	set d ""
	foreach sess $ssd_(sesslist) {
		set d "$d\nSName $sess\nAddress $ssd_($sess,Address)"
	}
	set response "$aa\n$a\n$c\n$cc$d\n"
	puts "Sending: $response"
	if {$ssd_(seqno) > 0 } {
		return $response
	} else {
		return ""
	}
}
set app [new AnnounceListenManager/AS/Service/Mars $argv]
vwait forever
