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

#
# 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 TCP
Class TCP/Server -superclass TCP
Class TCP/Client -superclass TCP
TCP public destroy {} {
	$self close
	$self next
}
TCP public shutdown {} {
}
TCP public set_binary { {flag 1} } {
	$self instvar chan_
	if { $flag } {
		fconfigure $chan_ -translation {binary binary}
	} else {
		fconfigure $chan_ -translation {auto auto}
	}
}
TCP public open { chan {blocking 0} } {
	$self instvar chan_
	set chan_ $chan
	fileevent $chan_ readable "$self readable"
	if { $blocking } {
		fconfigure $chan_ -blocking true
	} else {
		fconfigure $chan_ -blocking false
	}
}
TCP public is_open { } {
	$self instvar chan_
	if { [info exists chan_] && ![eof $chan_] } {
		return 1
	}
	return 0	
}
TCP public close {} {
	$self instvar chan_
	if [info exists chan_] {
		close $chan_
		unset chan_
	}
}
TCP public channel {} {
	$self instvar chan_
	if [info exists chan_] { return $chan_ } else { return "" }
}
TCP private readable {} {
	$self instvar chan_
	set cnt [gets $chan_ s]
	if { $cnt < 0 } {
		if [eof $chan_] {
			$self close
			$self shutdown
		}
		return
	}
	if { $cnt >= 0 } {
		$self recv $s
	}
}
TCP public send s {
	$self instvar chan_
	puts -nonewline $chan_ $s
	flush $chan_
}
TCP public send_data {} {
	$self instvar chan_ data_
	puts -nonewline $chan_ $data_
	flush $chan_
}
TCP public sendline s {
	$self instvar chan_
	puts $chan_ $s
	flush $chan_
}
TCP public recv s {
}
TCP/Client public init args {
}
TCP/Client public open { host port {blocking 0} } {
	$self instvar chan_
	set chan_ [socket $host $port]
	fileevent $chan_ readable "$self readable"
	if { $blocking } {
		fconfigure $chan_ -blocking true
	} else {
		fconfigure $chan_ -blocking false
	}
}
TCP/Server public open { port {create_channel {}} } {
	$self instvar chan_ client_class_ create_channel_proc_
	set chan_ [socket -server "$self accept" $port]
	if { $create_channel != {} } {
		if { [Class info instances $create_channel]!="" } {
			set client_class_ $create_channel
		} else {
			set create_channel_proc_ $create_channel
		}
	}
}
TCP/Server public close { } {
	$self instvar client_class_ create_channel_proc_
	if [info exists client_class_] {
		unset client_class_
	}
	if [info exists create_channel_proc_] {
		unset create_channel_proc_
	}
	$self next
}
TCP/Server private accept { chan host port } {
	set o [$self create_channel $chan]
}
TCP/Server private create_channel { chan } {
	$self instvar client_class_ create_channel_proc_
	if [info exists create_channel_proc_] {
		eval $create_channel_proc_ $chan
	} elseif [info exists client_class_] {
		set o [new $client_class_]
		$o open $chan
	} else {
		error "must redefine TCP/Server::create_channel in a subclass\
				\nor specify a channel creation mechanism in\
				TCP/Server::open"
	}
}
set MTrace(trcNone)      {0x00000000 {none}}
set MTrace(trcNet)       {0x00000001 {Network}}
set MTrace(trcSRM)       {0x00000002 {SRM}}
set MTrace(trcArchive)   {0x00000004 {Archive}}
set MTrace(trcMB)        {0x00000008 {Mediaboard}}
set MTrace(trcFCA)       {0x00000010 {Floor control}}
set MTrace(trcLTS)       {0x00000020 {Logical Time System}}
set MTrace(trcTGMB)      {0x00000040 {TopGun MediaBoard}}
set MTrace(trcCB)        {0x00000080 {Coordination Bus}}
set MTrace(trcVerbose)   {0x20000000 {Verbose}}
set MTrace(trcExcessive) {0x40000000 {Excessive}}
set MTrace(trcTmp)       {0x80000000 {Temp}}
set MTrace(trcAll)       {0xFFFFFFFF {All}}
if { [Class info instances MTrace]=="" } {
    proc MTrace { args } {
	    return MTrace
    }
}
MTrace proc init { flags } {
	global MTrace
	MTrace instvar mtrace
	set mtrace [new MTrace]
	$mtrace create_window
	foreach flag $flags {
		if { [info exists MTrace($flag)] } {
			set bits [lindex $MTrace($flag) 0]
			set msg  [lindex $MTrace($flag) 1]
			$mtrace tkvar flag_$flag
			set flag_$flag 1
			$mtrace set_flag $bits
		}
	}
	return $mtrace
}
MTrace instproc create_window { } {
	global mash
	if { $mash(environ) == "smash" } return
	$self instvar path_
	global MTrace
	set count 0
	while { [winfo exists ".mtrace_$count"] } { incr count }
	set path_ ".mtrace_$count"
	toplevel $path_
	wm title $path_ "MASH Trace"
	wm withdraw $path_
	set main [frame $path_.main -bd 1 -relief sunken]
	pack $main -side top -fill both -expand 1 -padx 5 -pady 3
	foreach flag [array names MTrace] {
		$self tkvar flag_$flag
		set flag_$flag 0
		checkbutton $main.$flag -text [lindex $MTrace($flag) 1] \
				-variable [$self tkvarname flag_$flag] \
				-command "$self toggle_flag $flag" \
				-bd 1 -pady 0 -anchor w
		pack $main.$flag -pady 0 -padx 5 -fill x -expand 1
	}
	button $path_.button -text "Dismiss" -command "$self toggle_window" \
			-pady 0
	pack $path_.button -anchor e -padx 5 -pady 2
	return $path_
}
MTrace instproc toggle_window { } {
	global mash
	if { $mash(environ) == "smash" } return
	$self instvar path_
	if { [winfo ismapped $path_] } {
		wm withdraw $path_
	} else {
		wm deiconify $path_
	}
}
MTrace instproc toggle_flag { flag } {
	global MTrace
	$self tkvar flag_$flag
	if { [set flag_$flag] } {
		$self set_flag [lindex $MTrace($flag) 0]
	} else {
		$self reset_flag [lindex $MTrace($flag) 0]
	}
}
proc mtrace { flags args } {
        global MTrace
	set bits 0
	foreach flag [split $flags "|"] {
		set bits [expr $bits | [lindex $MTrace($flag) 0]]
	}
	MTrace instvar mtrace
	if [info exists mtrace] {
		$mtrace trace $bits $args
	}
}
Class TCP/HTTP_Server -superclass TCP
TCP/HTTP_Server public init { http_server } {
    $self next
    $self set http_server_ $http_server
    $self init_vars
}
TCP/HTTP_Server private init_vars { } {
    $self instvar headers_done_ num_data_bytes_ headers_ data_
    set headers_done_ 0
    set num_data_bytes_ 0
    set headers_ ""
    set data_ ""
}
TCP/HTTP_Server private readable { } {
    $self instvar chan_ headers_done_ num_data_bytes_
    fconfigure $chan_ -blocking 0
    fconfigure $chan_ -translation binary
    if { $headers_done_ == 0 } {
	$self next
    } elseif { $num_data_bytes_ > 0 } {
	set socket [read $chan_ $num_data_bytes_]
	if { [string length $socket] == 0 } {
	    if { [eof $chan_] } {
		mtrace trcNet "-> eof reached"
		mtrace trcNet $socket
		$self close
		$self shutdown
	    }
	    return
	} else {
	    $self recv $socket
	}
    } else {
	mtrace trcNet "** Error: readable called with no data to read."
    }
}
TCP/HTTP_Server private recv { socket } {
    $self instvar num_data_bytes_ headers_done_ headers_ data_
    if { $headers_done_ == 0 } {
	if { [string compare "" [string trim $socket] ] == 0 } {
	    set headers_done_ 1
	    mtrace trcNet "-> End of headers"
	} else {  
	    mtrace trcNet $socket
	    $self parse_header $socket
	}
    } elseif { $num_data_bytes_ > 0 } {
	set num_bytes_read [string length $socket]
	set num_data_bytes_ [expr $num_data_bytes_ - $num_bytes_read]
	append data_ $socket
	mtrace trcNet "-> Bytes read / bytes left: $num_bytes_read /\
		$num_data_bytes_"
    } else {
	mtrace "-> Nothing received"
    }
    if { [expr $headers_done_ == 1 && $num_data_bytes_ == 0] } {
	mtrace trcNet "-> Calling handle_request"
	$self instvar http_server_
	$http_server_ handle_request $self $headers_ $data_
	$self init_vars
    }
}
TCP/HTTP_Server private parse_header { header } {
    puts "got header '$header'"
    set req_line [string first "HTTP" $header]
    if { $req_line != -1 } {
	set hdr_list [split $header]
	set title [string tolower [lindex $hdr_list 0] ]
	set value [lindex $hdr_list 1]
    } else {
	set colon_pos [string first ":" $header]
	set header_len [expr [string length $header] - 1]
	set title [string range $header 0 [expr $colon_pos - 1] ]
	set title [string tolower [string trim $title :] ]
	set value [string range $header [expr $colon_pos + 1] $header_len]
	set value [string trim $value]
	if { $title  == "content-length" } {
	    $self instvar num_data_bytes_
	    set num_data_bytes_ $value
	    mtrace trcNet "-> Number of data bytes expected: $num_data_bytes_"
	}
    }
    mtrace trcNet "-> Header title: $title"
    mtrace trcNet "-> Header value: $value"
    $self instvar headers_
    lappend headers_ $title $value
}
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
	}
}
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 HTTP_Server -configuration {
	server_port 4444
}
HTTP_Server public init { } {
    $self instvar status_table_
    set status_table_(200) "OK"
    set status_table_(204) "No Content"
    set status_table_(400) "Bad Request"
    set status_table_(500) "Internal Server Error"
}
HTTP_Server public destroy { } {
    $self close
    $self next
}
HTTP_Server public open { port } {
    $self instvar server_
    set server_ [new TCP/Server]
    $server_ open $port "$self create_channel"
    $self set port_ $port
	puts "opened server at port '$port'"
}
HTTP_Server public close { } {
    $self instvar server_
    if [info exists server_] {
	delete $server_
	unset server_
    }
}
HTTP_Server public port { } {
	return [$self set port_]
}
HTTP_Server private create_channel { chan } {
    set socket [new TCP/HTTP_Server $self]
    $socket open $chan
    $socket set_binary
    return $socket
}
HTTP_Server public handle_request { socket headers data } {
    mtrace trcNet "Error: HTTP_Server is an abstract base class."
    error "HTTP_Server is an abstract base class."
    $self close
    $self shutdown    
}
HTTP_Server public headers_to_array { headers result_var } {
	upvar $result_var result
	array set result [lrange $headers 2 end]
	set result(method) [lindex $headers 0]
	set result(url) [lindex $headers 1]
}
HTTP_Server private extract_url { headers } {
    array set hdr_array $headers
    set get_pair [array get hdr_array "get"]
    set url ""
    if { [llength $get_pair] > 0 } {
	set url [lindex $get_pair 1]
	mtrace trcNet "-> URL received: $url"
    }
    return $url
}
HTTP_Server private send_html { socket data } {
    mtrace trcNet "-> Sending generic reply"
    $self send_reply $socket $data "text/html" 200
}
HTTP_Server private send_reply { socket data data_type status_code } {
    mtrace trcNet "-> Sending reply"
    set status_msg [$self get_status_msg $status_code]
    set status "HTTP/1.0 $status_code $status_msg"
    set data_len [string length $data]
    set header_list [list "content-type" $data_type \
	    "content-length" $data_len]
    set headers [$self construct_headers $status $header_list]
    $socket send $headers
    $socket send $data
    $socket close
    $socket shutdown
}
HTTP_Server private construct_headers { status header_list } {
    set headers $status
    append headers "\r\n"
    set num_hdrs [llength $header_list]
    set current 0
    while { $num_hdrs > $current } {
	append headers [lindex $header_list $current]
	append headers ": "
	append headers [lindex $header_list [expr $current + 1] ]
	append headers "\r\n"
	set current [expr $current + 2]
    }
    append headers "\r\n"
    mtrace trcNet "-> Constructed headers:"
    mtrace trcNet $headers
    return $headers
}
HTTP_Server private get_status_msg { status_code } {
    $self instvar status_table_
    return $status_table_($status_code)
}
Class HTTP_Server/MASH_Server -superclass HTTP_Server
HTTP_Server/MASH_Server public init { } {
    $self next
    $self instvar html_dir_
    set html_dir_ ~/mash-1/tcl/applications/mash_server/html/
    set html_dir_ [$self get_option html_dir]
}
HTTP_Server/MASH_Server public add_agent { agent } {
    $self instvar agents_
    lappend agents_ $agent
}
HTTP_Server/MASH_Server public handle_request { socket headers data } {
    $self instvar agents_ html_dir_
    set url [string trimleft [$self extract_url $headers] /]
    set key [$self extract_key $url]
    set data ""
    set isRawData 0
    set page { }
    set type "text/html"
    set source [$self find_source $socket]
    foreach a $agents_ {
	set page [$a handle_request $url $key $source]
	set data [$self get_data $page]
	if { $data != "" } {
	    break
	}
    }
    puts $url
    if { [string length $url] == 0 } {
	set url mash_server.html
    }
    if { $data == "" } {
	if { [string match "*.html" $url] || [string match "*.txt" $url] } {
	    mtrace trcNet "-> Nondynamic page requested."
	    append html_file $html_dir_ $url
	    set data [read_file $html_file]
	    set page [list $data 200 $type]
	} else {
	    mtrace trcNet "-> Data requested."
	    append data_file $html_dir_ $url
	    set data [read_file $data_file]
	    set isRawData 1
	}
    }
    if { $isRawData == 1 } {
	set status "HTTP/1.0 200 OK"
	set data_len [string length $data]
	set header_list [list "content-type" "image/gif" \
		"content-length" $data_len]
	set headers [$self construct_headers $status $header_list]
	$socket send $headers
	$socket set_binary
	set chan [$socket channel]
	fconfigure $chan -blocking 0
	fconfigure $chan -translation cr
	puts -nonewline $chan $data
	flush $chan
	$socket close
	$socket shutdown
    } else {
	set status [$self get_status $page]
	set type [$self get_type $page]
	$self send_reply $socket $data $type $status
    }
}
HTTP_Server/MASH_Server private get_data { page } {
    return [lindex $page 0]
}
HTTP_Server/MASH_Server private get_status { page } {
    return [lindex $page 1]
}
HTTP_Server/MASH_Server private get_type { page } {
    return [lindex $page 2]
}
HTTP_Server/MASH_Server private extract_key { url } {
    set offset [string last ^ $url]
    set key [string range $url [expr $offset + 1] \
	    [string length $url] ]
    return [string trimleft [string tolower $key] -:]
}
HTTP_Server/MASH_Server private find_source { socket } {
    set chan [$socket channel]
    set host [lindex [fconfigure $chan -peername] 1]
    mtrace trcNet "-> Client hostname: $host"
    return $host
}
proc write_to_file { filename string } {
    set fileid [open $filename "WRONLY CREAT TRUNC"]
    puts $fileid $string
    close $fileid
}
proc file_dump { filename } {
    set fileid [open $filename "r"]
    set data [read $fileid]
    close $fileid
    return $data
}
proc prepend_to_file { filename string } {
    set orig [read_file $filename]
    set fileid [open $filename "WRONLY CREAT TRUNC"]
    close $fileid
    set fileid [open $filename "WRONLY CREAT APPEND"]
    puts $fileid $string
    puts $fileid $orig
    close $fileid
}
proc read_file { filename } {
    set exists [file exists $filename]
    set data ""
    if { $exists == 1 } {
	set fileid [open $filename "r"]
	set data [read $fileid]
	close $fileid
    }
    return $data
}
proc get_key { program } {
    return [string tolower [string trimleft [$program unique_key] -:]]
}
proc edit_html { str } {
    regsub -all -- < $str {\&lt} str
    regsub -all -- > $str {\&gt} str
    return $str
}
Class Play_Agent
Play_Agent public init { } {
    $self instvar archive_ archive_dir_ play_list_
    set archive_ [$self get_option archive_root]
    set archive_dir_ [$self get_option archive_dir]
    append archive_ $archive_dir_
    set play_list_ {}
}
Play_Agent private update_playlist { } {
	$self instvar archive_ play_list_
	cd $archive_
        if {[string toupper [$self get_option hierarchy]] == "YES"} {
puts "hier"
	    set ctgfiles [glob -nocomplain -- */*/*.ctg]
	} else {
puts "no hier"
	    set ctgfiles [glob -nocomplain -- */*.ctg]
	}
	mtrace trcNet "-> Files received: $ctgfiles"
	foreach f $ctgfiles {
		set elt [lsearch $play_list_ $f]
		if { $elt == -1 } {
			if { [string match *START_STREAM* [read_file $f]] } {
				set catalog [new SessionCatalog]
				$catalog open $f
				lappend new_play_list $f $catalog
				$catalog close
			}
		}  else {
			lappend new_play_list [lindex $play_list_ $elt] [lindex $play_list_ [incr elt]]
		}
	}
	set play_list_ $new_play_list
}
Play_Agent public return_progs { } {
    $self instvar play_list_
    $self update_playlist
    return $play_list_
}
Play_Agent public return_program { filename } {
    $self instvar archive_ play_list_
    set catalog [new SessionCatalog]
    cd $archive_
    if [catch {$catalog open $filename}] {
	return ""
    }
    $catalog read
    set msg [lindex [ [new SDPParser 0] parse [$catalog get_sdp]] 0]
    set program [new Program $msg]
    $catalog destroy
    return $program
}
Play_Agent public return_file_contents { filename } {
    $self instvar archive_
    cd $archive_
    return [read_file $filename]
}
Play_Agent public return_full_path { filename } {
    $self instvar archive_
    append path $archive_ $filename
    return $path
}
Play_Agent public return_rel_path { filename } {
    $self instvar archive_dir_
    append path $archive_dir_ $filename
    return $path
}
Class HTTP_Agent -configuration {
	server_port 4444
}
HTTP_Agent public init { } {
    $self instvar valid_clients_
    set client_str [$self get_option valid_clients]
    set valid_clients_ [split $client_str]
}
HTTP_Agent public handle_request { url key source } {
    mtrace trcNet "Error: HTTP_Agent is an abstract base class."
    error "HTTP_Agent is an abstract base class."
    exit
}
HTTP_Agent private get_page { page_type } {
    mtrace trcNet "-> Creating $page_type page"
    set page [$self create_dynamic_html \
	    [DynamicHTMLifier set html_($page_type)]]
    return $page
}
HTTP_Agent private htmlify_messages { page_type } {
    $self instvar list_
    $self update_agent_list
    array set agent_array $list_
    set html {}
    foreach key [$self sort [array names agent_array]] {
	append html [$agent_array($key) create_dynamic_html \
		[DynamicHTMLifier set html_($page_type)]]
    }
    return $html
}
HTTP_Agent private update_agent_list { } {
    $self instvar agent_ list_
    set list_ [$agent_ return_progs]
}
HTTP_Agent private sort { list } {
    return [lsort -command "$self sort_compare_" $list]
}
HTTP_Agent private sort_compare_ { key1 key2 } {
    $self instvar list_
    array set agent_array $list_
    return [string compare \
	    [string tolower [$agent_array($key1) set session_name_]] \
	    [string tolower [$agent_array($key2) set session_name_]]]
}
HTTP_Agent private get_desc_page { key type } {
    $self instvar list_
    $self update_agent_list
    array set agent_array $list_
    append html_page $type _desc
    mtrace trcNet "-> Creating description page"
    set desc_page [$agent_array($key) create_dynamic_html \
	    [DynamicHTMLifier set html_($html_page)]]
    return $desc_page
}
HTTP_Agent private get_error_page { msg } {
    set page "<html><body bgcolor=#FFFFFF> $msg </body></html>"
    return $page
}
HTTP_Agent private validate_source { source } {
    $self instvar valid_clients_
    if { [llength $valid_clients_] == 0 } {
	return 1
    }
    set source [string tolower $source]
    mtrace trcNet "-> Validating source $source"
    foreach client $valid_clients_ {
	mtrace trcNet "-> Checking client: $client"
	if [string match $client $source] {
	    return 1
	}
    }
    return 0
}
Class HTTP_Agent/Play_Agent -superclass HTTP_Agent
HTTP_Agent/Play_Agent public init { } {
    $self next
    $self instvar agent_ play_server_
    set agent_ [new Play_Agent]
    set play_server_ [$self get_option play_server_addr]
}
HTTP_Agent/Play_Agent public handle_request { url filename source } {
    $self instvar agent_ play_server_
    mtrace trcNet "-> Play_Agent::handle_request called"
    set page ""
    set status 200
    set type "text/html"
    if { $url == "playback_list.html" } {
	mtrace trcNet "-> Request for the playback list received."
	set page [$self get_page playback_list]
    } elseif { [string match playback_desc^* $url] } {
	mtrace trcNet "-> SDP Description requested"
	set program [$agent_ return_program $filename]
	if { $program == "" } {
	    set msg "No session information available."
	    set page [$self get_error_page $msg]
	} else {
	    set page [$self get_desc_page $filename playback]
	}
    } elseif { [string match playback^* $url] } {
	    mtrace trcNet "-> Request to playback session received."
	    set header "START_DESCR\n"
	    append header "file: [$agent_ return_full_path $filename]\n"
	    append header "server: $play_server_\n"
	    append header "END_DESCR\n"
	    set catalog "$header [$agent_ return_file_contents $filename]"
	    set mashlet_dir [$self get_option mashlet_dir]
	    if { $mashlet_dir == "" } {
		    set server_port [$self get_option server_port]
		    global mash
		    set mashlet_dir "http://[localaddr]:$server_port/$mash(version)"
	    }
	    set page "
	            label .label -text {Please wait while mashlets are\
				    imported}
		    pack .label -fill both -expand 1
		    update
	            global env 
	            set env(TCLCL_IMPORT_DIRS) $mashlet_dir
	            set x 0; import MSP_Application MSP_Application/Rover
		    destroy .label
	            set argv \[list -msp {$catalog}\]
		    if { \$mash(environ)==\"mplug\" } {
			    new MSP_Application/Rover/MPlug \$argv
		    } else {
			    new MSP_Application/Rover .main \$argv
		    }
	    "
	    set type "x-mash/x-script"
    } elseif { [string match asplayback^* $url] } {
	    mtrace trcNet "-> Request for assisted playback received."
	    set header "START_DESCR\n"
	    append header "file: [$agent_ return_full_path $filename]\n"
	    append header "server: $play_server_\n"
	    append header "END_DESCR\n"
	    set catalog "$header [$agent_ return_file_contents $filename]"
	    set mashlet_dir [$self get_option mashlet_dir]
	    set megafor [$self get_option megafor]
	    if { $mashlet_dir == "" } {
		    set server_port [$self get_option server_port]
		    global mash
		    set mashlet_dir "http://[localaddr]:$server_port/$mash(version)"
	    }
	    set page "
	            global env 
	            set env(TCLCL_IMPORT_DIRS) $mashlet_dir
	            set x 0; import MSP_Application MSP_Application/Rover
	            set argv \[list -msp {$catalog} -vusemega [random] -ausemega [random] -vrport 10004:10006 -arport 10008:10010 -vmegactrl $megafor:10006/1 -amegactrl $megafor:10010/1 -scuba\]
		    if { \$mash(environ)==\"mplug\" } {
			    new MSP_Application/Rover/MPlug \$argv
		    } else {
			    new MSP_Application/Rover .main \$argv
		    }
	    "
	    set type "x-mash/x-script"
    }
    return [list $page $status $type]
}
HTTP_Agent/Play_Agent private sort_compare_ { filename1 filename2 } {
    $self instvar list_ agent_
    array set agent_array $list_
	return [string compare $filename1 $filename2]
}
Class SDP_Agent
SDP_Agent public init { } {
    $self instvar sessions_ sdp_list_
    set session_ ~/mash-1/tcl/applications/mash_server/sessions/
    set sessions_ [$self get_option sdp_sessions_dir]
    set sdp_list_ {}
    $self read_cache
}
SDP_Agent private read_cache { } {
    $self instvar sessions_ sdp_list_
    mtrace trcNet "In SDP_Agent::read_cache"
    cd $sessions_
    set msgfiles [glob -nocomplain -- *]
    foreach f $msgfiles {
	set msg_str [read_file $f]
	set msg [lindex [ [new SDPParser 0] parse $msg_str] 0]
	set program [new Program $msg]
	set sdp_time [$msg set alltimedes_]
	set end_time [[lindex $sdp_time 0] set endtime_]
	set end_offset [[lindex $sdp_time 0] sec_until_current endtime_]
	if { $end_offset < 0 && $end_time != 0 } {
	    file delete $f
	} else {
	    lappend sdp_list_ [get_key $program] $msg
	}
    }
}
SDP_Agent public addprog { source program } {
    $self instvar sessions_ sdp_list_
    set key [get_key $program]
    set msg [$program base]
    if { [lsearch -exact $sdp_list_ $key] == -1 } {
	mtrace trcNet "-> Received announcment: $key"
	lappend sdp_list_ $key $msg
	append filename $sessions_ $key
	write_to_file $filename [$msg obj2str]
    }
}
SDP_Agent public updateprog { source program } {
    $self instvar sessions_ sdp_list_
    set key [get_key $program]
    set msg [$program base]
    append filename $sessions_ $key
    mtrace trcNet "-> Updating announcment: $key"
    set exists [file exists $filename]
    if { $exists } {
	set index [expr [lsearch -exact $sdp_list_ $key] + 1]
	set sdp_list_ [lreplace $sdp_list_ $index $index $msg]
	write_to_file $filename [$msg obj2str]
    } else {
	$self addprog $source $program
    }
}
SDP_Agent public removeprog { source program } {
    $self instvar sessions_ sdp_list_
    set key [get_key $program]
    append filename $sessions_ $key
    mtrace trcNet "-> Removing announcment: $key"
    set index [lsearch -exact $sdp_list_ $key]
    if { $index != -1 } {
	set sdp_list_ [lreplace $sdp_list_ $index [expr $index + 1]]
    } else {
	mtrace trcNet "-> Announcement not in sdp_list_."
    }
    if { [expr [llength $sdp_list_] % 2] != 0 } {
	puts "removeprog produced an invalid sdp_list_."
	exit
    }
    file delete $filename
}
SDP_Agent public addsource { source } {
}
SDP_Agent public return_progs { } {
    $self instvar sdp_list_
    return $sdp_list_
}
Class ScopeZone
ScopeZone public init {range {bw 200} {name ""}} {
    $self instvar range_ bw_
    set range_ $range
    set bw_ $bw
    if {$range == "224.2.128.0/17"} {
	$self set sapAddr_ "224.2.127.254/9875"
	$self set name_ "Global"
	return
    }
    if {$name != ""} {
	$self set name_ $name
    } else {
	$self set name_ "Admin Zone $range"
    }
    $self set sapAddr_ [$self addr $range]
}
ScopeZone private addr {spec} {
    if {$spec == "224.2.128.0/17"} {
	return "224.2.127.254/9875"
    }
    set l [split $spec /]
    set len [llength $l]
    if { $len < 2 || $len > 3} {
	$self warn "Bogus scope zone spec $spec"
	exit 1
    }
    set base [lindex $l 0]
    set mask [lindex $l 1]
    set comps [split $base .]
    if {[llength $comps] != 4 || $mask > 24} {
	$self warn "Bogus scope zone spec $spec"
	exit 1
    }
    set a [lindex $comps 0]
    set b [lindex $comps 1]
    set c [lindex $comps 2]
    set d [lindex $comps 3]
    if {$a<224 || $a>239 || $b<0 || $b>255 || $c<0 || $c>255 || $d<0 || $d>255} {
	$self warn "Bogus scope zone spec $spec"
	exit 1
    }
    if {$mask < 16} {
	set b [expr $b | ~((-1)<<(16-$mask))]
	set mask 16
    }
    if {$mask < 24} {
	set c [expr $c | ~((-1)<<(24-$mask))]
	set mask 24
    }
    set d [expr $d | ~((-1)<<(32-$mask))]
    if {$len == 3} {
	set port [lindex $l 2]
    } else {
	set port 9875
    }
    set addr "$a.$b.$c.$d/$port"
    return $addr
}
ScopeZone public name {} {
    return [$self set name_]
}
ScopeZone public bw {} {
    return [$self set bw_]
}
ScopeZone public range {} {
    return [$self set range_]
}
ScopeZone public sapAddr {} {
    return [$self set sapAddr_]
}
ScopeZone private inet_addr {a} {
    set l [split $a .]
    set addr [expr [lindex $l 0] <<24]
    incr addr [expr [lindex $l 1] <<16]
    incr addr [expr [lindex $l 2] <<8]
    incr addr [lindex $l 3]
    return $addr
}
ScopeZone public isin {addr} {
    $self instvar range_
    set l [split $range_ /]
    set base [$self inet_addr [lindex $l 0]]
    set mask [lindex $l 1]
    set addr [$self inet_addr $addr]
    if {$base == [expr $addr & ((-1)<<(32-$mask))]} {
	return 1
    }
    return 0
}
Class SDPParser
Class SDPMedia
Class SDPTime
Class SDPMessage 
SDPParser instproc init { {ordered_syntax 1} } {
	$self next
	$self instvar nextsym_ ordered_syntax_ parse_error_
	set nextsym_(start) "v"
	set nextsym_(v) "o"
	set nextsym_(o) "s"
	set nextsym_(s) "i u e p c b t"
	set nextsym_(i) "u e p c b t"
	set nextsym_(u) "e p c b t"
	set nextsym_(e) "e p c b t"
	set nextsym_(p) "e p c b t"
	set nextsym_(c) "b t "
	set nextsym_(b) "t"
	set nextsym_(t) "t r z k a m"
	set nextsym_(r) "t z k a m"
	set nextsym_(z) "k a m"
	set nextsym_(k) "a m"
	set nextsym_(a) "a m"
	set nextsym_(m) "m i:m c:m b:m k:m a:m v"
	set nextsym_(i:m) "m c:m b:m k:m a:m v"
	set nextsym_(c:m) "m b:m k:m a:m v"
	set nextsym_(b:m) "m k:m a:m v"
	set nextsym_(k:m) "m a:m v"
	set nextsym_(a:m) "m a:m v"
	set ordered_syntax_ $ordered_syntax
	set parse_error_ ""
}
SDPParser instproc check_syntax { last cur media } {
	$self instvar nextsym_
	if ![info exists nextsym_($last)] {
		return ""
	}
	foreach s $nextsym_($last) {
		set t [split $s :]
		if { [lindex $t 0] == $cur } {
			return $s
		}
	}
	return ""
}
SDPParser instproc parse { announcement } {
	$self instvar parse_error_ ordered_syntax_
	set media ""
	set allmsgs ""
	set lasttag "start"
	set lines [split $announcement "\n"]
	set parse_error_ ""
	set lnum 0
	foreach line $lines {
		incr lnum
		if { $line=={} } continue
		set sline [split $line =]
		set tag [lindex $sline 0]
		set value [join [lrange $sline 1 end]]
		set ret [$self check_syntax $lasttag $tag $media]
		if { $ret == "" && $ordered_syntax_==1 } {
			set parse_error_ "$class: syntax error between\
					$lasttag and $tag in line $lnum."
			foreach m $allmsgs {
				delete $m
			}
			return ""
		}
		set lasttag $ret
		switch $tag {
		v { 
			set media ""
			set msg [new SDPMessage]
			lappend allmsgs $msg
			$msg set version_ $value
		}
		o {
			$msg set creator_ [lindex $value 0]
			$msg set createtime_ [lindex $value 1]
			$msg set modtime_  [lindex $value 2]
			$msg set nettype_ [lindex $value 3]	
			$msg set addrtype_ [lindex $value 3]
			$msg set createaddr_ [lindex $value 5]
		}
		s {	
			$msg set session_name_ $value 
		}
		i {	
			if { $media != "" } {
				$media set session_info_ $value 
			} else {
				$msg set session_info_ $value 
			}
		}
		p {
			set tmp "" 
			catch { set tmp [$msg set phonelist_] }
			lappend tmp $value
			$msg set phonelist_ $tmp
		}
		e { 
			set tmp "" 
			catch { set tmp [$msg set emaillist_] }
			lappend tmp $value
			$msg set emaillist_ $tmp
		}
		u { 
			$msg set uri_ $value
		} 
		c {
			if { $media != "" } {
				$media set nettype_ [lindex $value 0]
				$media set addrtype_ [lindex $value 1]
				$media set caddr_ [lindex $value 2]
			} else {
				$msg set nettype_ [lindex $value 0]
				$msg set addrtype_ [lindex $value 1]
				$msg set caddr_ [lindex $value 2]
			}
		}
		b {
			set bwspec [split $value :]
			if { $media != "" } {
				$media set bwmod_ [lindex $bwspec 0]
				$media set bwval_ [lindex $bwspec 1]
			} else {
				$msg set bwmod_ [lindex $bwspec 0]
				$msg set bwval_ [lindex $bwspec 1]
			}
		}
		t {
			set tdes [new SDPTime]
			$tdes set fields_(t) $value
			$tdes set starttime_ [lindex $value 0]
			$tdes set endtime_ [lindex $value 1]
			set tmp [$msg set alltimedes_]
			lappend tmp $tdes
			$msg set alltimedes_ $tmp
		}
		r {
			$tdes set fields_(r) $value
			$tdes set repeat_interval_ [lindex $value 0]
			$tdes set active_duration_ [lindex $value 1]
			$tdes set offlist_ [lrange $value 2 end]
		}
		z {
			set nval [llength $value]
			if [expr 2 * ($nval / 2) != $nval] {
				foreach m $allmsgs {
					delete $m
				}
				return ""
			}
			$self instvar zoneinfo_
			for { set n 0 } { $n < $nval } { incr n } {
				set adjtime [lindex $value $n]
				incr n
				set offset [lindex $value $n]
				lappend zoneinfo_ "$adjtime $offset"
			}
		}
		k {
			set tmp [split $value :]
			if { $media != "" } {
				$media set crypt_method_ [lindex $tmp 0]
				$media set crypt_key_ [lindex $tmp 1]
			} else {
				$msg set crypt_method_ [lindex $tmp 0]
				$msg set crypt_key_ [lindex $tmp 1]
			}
		}
		a {
			set attribute [split $value ":"]
			set attname [lindex $attribute 0]
			set attval [join [lrange $attribute 1 end] ":"]
			if { $media != "" } {
				set target $media
			} else {
				set target $msg
			}
			if [catch {$target set attributes_($attname)}] {
				$target set attributes_($attname) {}
			}
			$target set attributes_($attname) \
			    [concat [$target set attributes_($attname)] \
				 [list $attval]]
		}
		m {
			set media [new SDPMedia $msg]
			set mt [lindex $value 0]
			$media set mediatype_ $mt
			$media set port_  [lindex $value 1]
			$media set proto_ [lindex $value 2]
			$media set fmt_ [lrange $value 3 end]
			set tmp ""
			catch { set tmp [$msg set media_array_($mt)] }
			lappend tmp $media
			$msg set media_array_($mt) $media
			set tmp [$msg set allmedia_]
			lappend tmp $media
			$msg set allmedia_ $tmp
		}
		default {
			set parse_error_ "$class: error unknown modifier $tag."
			foreach m $allmsgs {
				delete $m
			}
			return ""
		}
		}
		set tmp [$msg set msgtext_]
		lappend tmp $line
		$msg set msgtext_ $tmp
		if { $media != "" } {
			$media set fields_($tag) $value
		} else {
			$msg set fields_($tag) $value
		}
	}
	foreach msg $allmsgs {
		set tmp [$msg set msgtext_]
		set tmp [join $tmp \n]
		append tmp \n
		$msg set msgtext_ $tmp
	}
	return $allmsgs
}
SDPParser instproc parse_error { } {
	return [$self set parse_error_]
}
SDPMessage instproc init {} {
	$self next
	$self instvar allmedia_ alltimedes_ msgtext_
	set allmedia_ ""
	set alltimedes_ ""
	set msgtext_ ""
}
SDPMessage instproc destroy {} {
	$self instvar allmedia_ alltimedes_
	foreach m $allmedia_ {
		delete $m
	}
	foreach t $alltimedes_ {
		delete $t
	}
	$self next
}
SDPMessage instproc media { media_type } {
	$self instvar media_array_
	if [info exists media_array_($media_type)] {
		return $media_array_($media_type)
	} else {
		return ""
	}
}
SDPMessage instproc have_field { field } {
	$self instvar fields_
	return [info exists fields_($field)]
}
SDPMessage instproc field_value { field } {
	$self instvar fields_
	if [info exists fields_($field)] {
		return $fields_($field)
	} else {
		return ""
	}
}
SDPMessage instproc attributes {} {
	$self instvar attributes_
	if [info exists attributes_] {
		return [array names attributes_]
	} else {
		return ""
	}
}
SDPMessage instproc have_attr { name } {
	$self instvar attributes_
	return [info exists attributes_($name)]
}
SDPMessage instproc attr_value { name } {
    $self instvar attributes_
    if [info exists attributes_($name)] {
	    return $attributes_($name)
    } else {
	    return ""
    }
}
SDPMessage instproc obj2str {} {
	$self instvar attributes_ alltimedes_ allmedia_
	set o "v=[$self field_value v]"
	foreach f { o s i u } {
		if [$self have_field $f] {
			set n "$f=[$self field_value $f]"
			set o $o\n$n
		}
	}
	$self instvar phonelist_ emaillist_
	if [info exists phonelist_] {
		foreach e $phonelist_ {
			set n "p=$e"
			set o $o\n$n
		}
	}
	if [info exists emaillist_] {
		foreach e $emaillist_ {
			set n "e=$e"
			set o $o\n$n
		}
	}
	foreach f { c b } {
		if [$self have_field $f] {
			set n "$f=[$self field_value $f]"
			set o $o\n$n
		}
	}
	foreach t $alltimedes_ {
		set n [$t obj2str]
		set o $o\n$n
	}
	foreach f { z k } {
		if [$self have_field $f] {
			set n "$f=[$self field_value $f]"
			set o $o\n$n
		}
	}
	foreach a [$self attributes] {
		if { $attributes_($a) == "" } {
			set n "a=$a"
		} else {
			set n "a=$a:$attributes_($a)"
		}
		set o $o\n$n
	}
	foreach m $allmedia_ {
		set n [$m obj2str]
		set o $o\n$n
	}
	return $o
}
SDPMessage public unique_key {} {
    if ![$self have_field o] {
	$self warn "in SDPMessage::unique_key without o= field"
	return ""
    }
    set l [split [$self field_value o]]
    set l [lreplace $l 2 2]
    set key [join $l :]
    return $key
}
SDPMessage instproc htmlify_media { } {
    set html {}
    foreach media [$self set allmedia_] {
	append html [$media create_dynamic_html \
		[DynamicHTMLifier set html_(media)]]
    }
    return $html
}
SDPMessage instproc htmlify_times { } {
    set html {}
    foreach time [$self set alltimedes_] {
	set repeat [string tolower [$time readable_repeat]]
	if { [$time set starttime_] != 0 } {
	    append html [$time create_dynamic_html \
		    [DynamicHTMLifier set html_(time_$repeat)]]
	} else {
	    append html "Unbounded session"
	}
    }
    return $html
}
SDPMessage instproc htmlify_url { } {
    $self instvar uri_
    if [info exists uri_] {
	return "<a href=\"$uri_\">$uri_</a>"
    } else {
	return ""
    }
}
SDPMessage instproc htmlify_list { varname } {
    set list {}
    foreach elt [$self get $varname] {
	if { $list!={} } {
	    append list ", $elt"
	} else {
	    append list $elt
	}
    }
    return $list
}
SDPMessage instproc get { varname } {
    $self instvar $varname
    if [info exists $varname] {
	return [set $varname]
    } else {
	return ""
    }
}
SDPMedia instproc htmlify_mediatype { } {
    return "[$self set mediatype_]"
}
SDPMedia instproc get { varname } {
    $self instvar $varname
    if [info exists $varname] {
	return [set $varname]
    } else {
	return ""
    }
}
SDPMedia instproc init {{msg ""}} {
	$self next
	if {$msg == ""} { return }
	$self instvar attributes_ fields_
	set alist [$msg attributes]
	foreach a $alist {
		set attributes_($a) [$msg set attributes_($a)]
	}
	set vlist [$msg info vars]
	foreach f { session_info_ nettype_ addrtype_ caddr_ bwmod_ bwval_ 
		crypt_method_ crypt_key_ } {
		if { [lsearch -exact $vlist $f] >= 0 } {
			$self set $f [$msg set $f]
		}
	}
	foreach f { i c b k a } {
		if [$msg have_field $f] {
			set fields_($f) [$msg field_value $f]
		}
	}
}
SDPMedia instproc have_field { field } {
	$self instvar fields_
	return [info exists fields_($field)]
}
SDPMedia instproc field_value { field } {
	$self instvar fields_
	if [info exists fields_($field)] {
		return $fields_($field)
	} else {
		return ""
	}
}
SDPMedia instproc have_attr { name } {
	$self instvar attributes_
	return [info exists attributes_($name)]
}
SDPMedia instproc attr_value { name } {
    $self instvar attributes_
    if [info exists attributes_($name)] {
	    return $attributes_($name)
    } else {
	    return ""
    }
}
SDPMedia instproc attributes {} {
	$self instvar attributes_
	if [info exists attributes_] {
		return [array names attributes_]
	} else {
		return ""
	}
}
SDPMedia instproc obj2str {} {
	$self instvar attributes_
	set o "m=[$self field_value m]"
	foreach f { i c b k } {
		if [$self have_field $f] {
			set n "$f=[$self field_value $f]"
			set o $o\n$n
		}
	}
	foreach a [array names attributes_] {
		if { $attributes_($a) == "" } {
			set n "a=$a"
		} else {
			set n "a=$a:$attributes_($a)"
		}
		set o $o\n$n
	}
	return $o
}
SDPTime instproc have_field { field } {
	$self instvar fields_
	return [info exists fields_($field)]
}
SDPTime instproc field_value { field } {
	$self instvar fields_
	if [info exists fields_($field)] {
		return $fields_($field)
	} else {
		return ""
	}
}
SDPTime instproc obj2str {} {
	set o "t=[$self field_value t]"
	if [$self have_field r] {
		set n "r=[$self field_value r]"
		set o $o\n$n
	}
	return $o
}
SDPTime public get { varname } {
    $self instvar $varname
    if [info exists $varname] {
	return [set $varname]
    } else {
	return ""
    }
}
SDPTime public sec_until_current { time_type } {
    set sdp_time [ntp_to_unix [$self get $time_type]]
    set current [clock seconds]
    return [expr $sdp_time - $current]
}
SDPTime public current_in_interval { start end } {
    set current [unix_to_ntp [clock seconds]]
    if { [expr $start == 0 && $end == 0] } {
	return 1
    } elseif { $start == 0 } {
	return [expr $end > $current]
    } elseif { $end == 0 } {
	return [expr $start <= $current]
    } else {
	return [expr $start <= $current && $end > $current]
    }
}
SDPTime public readable_time { time_type } {
    set sec [ntp_to_unix [$self get $time_type]]
    if { $sec == 0 } {
	return *unbounded*
    } else {
	return [clock format $sec -format {%H:%M}]
    }
}
SDPTime public readable_duration { } {
    set duration [$self get active_duration_]
    set hours [expr $duration / 3600]
    if { $hours < 24 } {
	return "$hours hour(s)"
    }
    set days [expr $hours / 24]
    if { $days < 7 } {
	return "$days day(s)"
    }
    set weeks [expr $days / 7]
    return "$weeks week(s)"
}
SDPTime public readable_date { time_type } {
    set sec [ntp_to_unix [$self get $time_type]]
    if { $sec == 0 } {
	return *unbounded*
    } else {
	return [clock format $sec -format {%B %d, %Y}]
    }
}
SDPTime public readable_day { time_type } {
    set sec [ntp_to_unix [$self get $time_type]]
    if { $sec == 0 } {
	return *unbounded*
    } else {
	return [clock format $sec -format {%a}]
    }
}
SDPTime public readable_day_full { time_type } {
    set sec [ntp_to_unix [$self get $time_type]]
    if { $sec == 0 } {
	return *unbounded*
    } else {
	return [clock format $sec -format {%A}]
    }
}
SDPTime public readable_zone { time_type } {
    set sec [ntp_to_unix [$self get $time_type]]
    return [clock format $sec -format {%Z}]
}
SDPTime public readable_repeat { } {
    set interval [$self get repeat_interval_]
    if { $interval == 86400 } {
	return Daily
    } elseif { $interval == 604800 } {
	return Weekly
    } else {
	return None
    }
}
Class Program
Program public init {args} {
    $self next
    $self set complete_ 0
    $self set msgs_ {}
    foreach m $args {
	$self message $m
    }
}
Program public destroy {} {
}
Program public complete {} {
    return [$self set complete_]
}
Program public base {} {
    $self instvar msgs_
    if {[llength $msgs_] < 1} {
	return ""
    }
    return [lindex $msgs_ 0]
}
Program public have_attr {a} {
    $self instvar msgs_
    foreach m $msgs_ {
	if [$m have_attr $a] {
	    return 1
	}
    }
    return 0
}
Program public attr_value {a} {
    $self instvar msgs_
    foreach m $msgs_ {
	set v [$m attr_value $a]
	if {$v != ""} {
	    return $v
	}
    }
    return ""
}
Program public have_field {f} {
    $self instvar msgs_
    foreach m $msgs_ {
	if [$m have_field $f] {
	    return 1
	}
    }
    return 0
}
Program public field_value {f} {
    $self instvar msgs_
    foreach m $msgs_ {
	set v [$m field_value $f]
	if {$v != ""} {
	    return $v
	}
    }
    return ""
}
Program public unique_key {} {
    set b [$self base]
    if {$b == ""} { return "" }
    return [$b unique_key]
}
Program private parse_layers {attr begin end total} {
    upvar $begin b $end e $total t
    set l [split $attr "/"]
    set len [llength $l]
    if {$len < 1 || $len > 2} {
	$self warn "Malformed layers attribute \"$t\""
	return 1
    }
    if {$len == 2} {
	set t [lindex $l 1]
    } else {
	set t ""
    }
    set layers [lindex $l 0]
    set bounds [split $layers "-"]
    set b [lindex $bounds 0]
    set l [llength $bounds]
    if {$l == 1} {
	set e $b
    } elseif {$l == 2 } {
	set e [lindex $bounds 1]
    } else {
	$self warn "Malformed layers attribute \"$t\""
	return 1
    }
    return 0
}
Program public message {msg} {
    $self instvar msgs_ complete_
    set len [llength $msgs_]
    if {$len == 0} {
	set msgs_ [list $msg]
	set complete_ 1
	foreach m [$msg set allmedia_] {
	    if [$m have_attr layers] {
		set a [$m attr_value layers]
		if [$self parse_layers $a begin end total] {
		    continue
		}
		if {$begin > 0} {
		    set complete_ 0
		}
		if {$total != "" && $end < [expr $total-1]} {
		    set complete_ 0
		}
	    }
	}
	return 1
    }
    set layered 0
    foreach m [$msg set allmedia_] {
	if [$m have_attr layers] {
	    set layered 1
	    break
	}
    }
    if {$layered == 0} {
	if {$len == 1} {
	    return [$self update $msg 0]
	} else {
	    $self warn "Got apparent layered announcement without layers attribute"
	    return 0
	}
    }
    foreach m [$msg set allmedia_] {
	if [$m have_attr layers] {
	    break
	}
    }
    set type [$m set mediatype_]
    if [$self parse_layers [$m attr_value layers] begin end total] {
	delete $msg
	return
    }
    set position end
    set i 0
    while {$i < $len} {
	set a [[[lindex $msgs_ $i] media $type] attr_value layers]
	if [$self parse_layers $a begin2 end2 total2] {
	    $self fatal "have message is msgs_ with bogus layers attr"
	}
	if {$begin == $begin2 && $end == $end2} {
	    return [$self update $msg $i]
	}
	if {$begin < $begin2} {
	    set position $i
	    break
	}
	incr i
    }
    set msgs_ [linsert $msgs_ $position $msg]
    incr len
    set next 0
    set i 0
    while {$i < $len} {
	set a [[[lindex $msgs_ $i] media $type] attr_value layers]
	if [$self parse_layers $a begin end total2] {
	    $self fatal "have message is msgs_ with bogus layers attr"
	}
	if {$begin == $next} {
	    set next [expr $end+1]
	} else {
	    return 0
	}
	incr i
    }
    if {$total != "" && $next != $total} {
	return 0
    }
    set complete_ 1
    return 1
}
Program private update {msg i} {
    $self instvar msgs_
    set old [lindex $msgs_ $i]
    set oldversion [lindex [$old field_value o] 2]
    set newversion [lindex [$msg field_value o] 2]
    if {$newversion > $oldversion} {
	set msgs_ [lreplace $msgs_ $i $i $msg]
	delete $old
	return 1
    } else {
	delete $msg
	return 0
    }
}
Class ProgramSource
ProgramSource public init {rcvr} {
    $self set rcvr_ $rcvr
    $rcvr addsource $self
    $self set sdp_ [new SDPParser]
}
ProgramSource public recv {data} {
    $self process [string trim $data]
}
ProgramSource private process {data} {
    $self instvar sdp_ rcvr_
    set progs {}
    foreach msg [$sdp_ parse $data] {
	set o [$msg unique_key]
	$self instvar progs_
	if ![info exists progs_($o)] {
	    set p [new Program $msg]
	    set o [$msg unique_key]
	    $self set progs_($o) $p
	    if [$p complete] {
		$rcvr_ addprog $self $p
	    }
	} else {
	    set p $progs_($o)
	    set wascomplete [$p complete]
	    if [$p message $msg] {
		if {$wascomplete == 0} {
		    $self instvar rcvr_
		    $rcvr_ addprog $self $p
		} else {
		    $rcvr_ updateprog $self $p
		}
	    }
	}
	lappend progs $p
    }
    return $progs
}
ProgramSource public timeout {p timeout} {
    $self instvar timeouts_
    set o [$p unique_key]
    if [info exists timeouts_($o)] {
	after cancel $timeouts_($o)
    }
    set timeouts_($o) [after [expr 1000*$timeout] "$self remove $p"]
}
ProgramSource public remove {p} {
    $self instvar progs_ rcvr_
    set o [$p unique_key]
    if {![info exists progs_($o)] || $progs_($o) != $p} {
	$self warn "inconsistency in ProgramSource::remove"
	return
    }
    $rcvr_ removeprog $self $p
    delete $p
    unset progs_($o)
}
ProgramSource private readcache {} {
    $self instvar cache_
    if {![info exists cache_] || ![file readable $cache_]} {
	return
    }
    set fp [open $cache_ r]
    set progs [$self process [read $fp]]
    close $fp
    foreach p $progs {
	$self timeout $p 1800
    }
}
ProgramSource public shutdown {} {
    $self writecache
}
ProgramSource private writecache {} {
    $self instvar cache_
    if ![info exists cache_] { return }
    if ![file isdirectory [file dirname $cache_]] {
	file mkdir [file dirname $cache_]
    }
    if [catch {set fp [open $cache_ w]} m] {
	$self warn "couldn't open cache file $cache_ for writing: $m"
	return
    }
    $self instvar progs_
    foreach o [array names progs_] {
	foreach m [$progs_($o) set msgs_] {
	    puts $fp [$m set msgtext_]
	}
    }
    close $fp
}
ProgramSource public periodic-writecache {time} {
    $self writecache
    after [expr 1000 * $time] "$self periodic-writecache $time"
}
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 Timer/Adaptive/SAP -superclass Timer/Adaptive
Timer/Adaptive/SAP public init { alm } {
	$self set alm_ $alm
	$self next
}
Timer/Adaptive/SAP private adapt {interval} {
	$self instvar alm_
	return [expr 1000*[$alm_ interval 1]]
}
Class AnnounceListenManager/SAP/Nsdr -superclass AnnounceListenManager/SAP
AnnounceListenManager/SAP/Nsdr public init {s mtu scope} {
	set ttl [$self get_option sapTTL]
	set spec "[$scope sapAddr]/none/$ttl"
	$self next $spec $mtu
	$self set bw_ [$scope bw]
	$self set s_ $s
	$self set avgsize_ 500
	$self set nsrcs_ 0
}
AnnounceListenManager/SAP/Nsdr public destroy {} {
	$self next
}
AnnounceListenManager/SAP/Nsdr private recv_announcement args {
	$self instvar s_
	eval $s_ recv $self $args
}
AnnounceListenManager/SAP/Nsdr public sample_size {size} {
	$self instvar avgsize_
	set avgsize_ [expr $avgsize_ + ($size-$avgsize_)>>3]
}
AnnounceListenManager/SAP/Nsdr public incrnsrcs {n} {
	$self instvar nsrcs_
	incr nsrcs_ $n
}
AnnounceListenManager/SAP/Nsdr public interval {rand} {
	$self instvar avgsize_ nsrcs_ bw_
	set i [expr 8 * $avgsize_ * $nsrcs_ / $bw_]
	if {$rand != 0} {
		set r1 [expr [random]/double(0x7fffffff)]
		set r2 [expr ($r1*2.0/3.0) + 2.0/3.0]
		set i [expr int($i*$r2)]
	}
	if {$i < 5} {
		set i 5
	}
	return $i
}
AnnounceListenManager/SAP/Nsdr public start {msg} {
	$self instvar nsrcs_
	incr nsrcs_
	$self timer $msg [new Timer/Adaptive/SAP $self]
	$self next $msg
}
AnnounceListenManager/SAP/Nsdr private send_announcement {msg} {
	set text [$msg set msgtext_]
	$self sample_size [string length $text]
	$self announce $text
}
Class ProgramSource/SAP -superclass ProgramSource
ProgramSource/SAP public init {ui args} {
	$self next $ui
	$self instvar scopes_ addrs_ cache_ announce_file_
	set scopes_ {}
	set addrs_ {}
	foreach scope $args {
		lappend scopes_ $scope
		set al [new AnnounceListenManager/SAP/Nsdr $self 2048 $scope]
		lappend addrs_ $al
	}
	set dir [$self get_option cachedir]
	if {![info exists cache_] && $dir != ""} {
		set cache_ [file join $dir global]
	}
	$self readcache
	set write_interval [$self get_option cacheWriteInterval]
	if {$write_interval != ""} {$self periodic-writecache $write_interval }
	set a [lindex $addrs_ 0]
	if {$a == ""} {
		set announce_file_ ""
	} else {
		set if [[$a set snet_] interface]
		set announce_file_ [file join $dir announce-$if]
	}
	if [file readable $announce_file_] {
		$self instvar sdp_
		set fp [open $announce_file_ r]
		set msgs [$sdp_ parse [read $fp]]
		close $fp
		foreach m $msgs {
			set p [new Program $m]
			$self announce $p
		}
	}
}
ProgramSource/SAP public destroy {} {
	$self next
	$self instvar addrs_
	foreach a $addrs_ { delete $a }
}
ProgramSource/SAP public name {} {
	return "SAP: Global"
}
ProgramSource/SAP public scopes {} {
	return [$self set scopes_]
}
ProgramSource/SAP public recv {child addr port data size} {
	$self instvar progs_
	set old [array size progs_]
	set objs [$self next $data]
	$child incrnsrcs [expr [array size progs_] - $old]
	$child sample_size $size
	$self instvar progs_ timeouts_
	foreach o $objs {
		set t [expr 10 * [$child interval 0]]
		if {$t < 1800} { set t 1800 }
		$self timeout $o $t
	}
}
ProgramSource/SAP private timestamp-gt {a b} {
	if {$b == 0} { return 1 }
	if {$a > 0 && $b < 0} { return 0 }
	return [expr $a > $b]
}
ProgramSource/SAP public announce {prog} {
	$self instvar announce_file_ rcvr_
	puts "announcing $prog"
	foreach msg [$prog set msgs_] {
		set al [$self alof $msg]
		$al start $msg
		if {$announce_file_ != ""} {
			if [catch {set fp [open $announce_file_ w]} m] {
				$self warn "couldn't open announcements file\
						for writing: $m"
				continue
			}
			puts $fp [$msg set msgtext_]
			close $fp
		}
	}
	set end 0
	foreach t [[$prog base] set alltimedes_] {
		set newend [$t set endtime_]
		puts "$newend > $end returns [$self timestamp-gt $newend $end]"
		if [$self timestamp-gt $newend $end] { set end $newend }
	}
	if {$end != 0} {
		set wait [format %u [expr $end - 2208988800 - [clock seconds]]]
		puts "deleting after $wait seconds"
		after [expr int($wait * 1000)] "$self stop-announce $prog"
	}
}
ProgramSource/SAP public stop-announce {prog} {
	$self instvar announce_file_ sdp_ rcvr_
	foreach msg [$prog set msgs_] {
		set al [$self alof $msg]
		$al stop $msg
		set backup $announce_file_
		append backup "~"
		file delete $backup
		if {[catch {file copy $announce_file_ $backup} m] \
				|| [catch {set fp [open $backup r]} m] \
				|| [catch {set fp2 [open $announce_file_ w]} m]} {
			$self warn "couldn't fix announcement file: $m"
			continue
		}
		set buffer ""
		while ![eof $fp] {
			set line [gets $fp]
			puts "got line \"$line\""
			if {![eof $fp] && [string compare $line "v=0"] != 0} {
				append buffer $line
				append buffer \n
				continue
			}
			if {[string trim $buffer] != ""} {
				puts "got message:\n$buffer"
				set msg2 [$sdp_ parse $buffer]
				if {[$msg unique_key] != [$msg2 unique_key]} {
					puts $fp2 $buffer
				}
				delete $msg2
			}
			set buffer $line
			append buffer \n
		}
		close $fp
		close $fp2
	}
	$rcvr_ removeprog $self $prog
}
ProgramSource/SAP private alof {msg} {
	$self instvar scopes_ addrs_
	if [$msg have_field c] {
		set addr [$msg set caddr_]
	} else {
		set media [lindex [$msg set allmedia_] 0]
		set addr [$media set caddr_]
	}
	set addr [lindex [split $addr /] 0]
	set i 0
	set found 0
	set len [llength $scopes_]
	while {$i < $len} {
		set scope [lindex $scopes_ $i]
		if [$scope isin $addr] {
			set found 1
			break
		}
		incr i
	}
	if {$found == 0} {
		$self fatal "Program/SAP got address ($addr) not in any knwon scope"
	}
	return [lindex $addrs_ $i]
}
Class HTTP_Agent/SDP_Agent -superclass HTTP_Agent
HTTP_Agent/SDP_Agent public init { } {
    $self add_default sapTTL 127
    $self next
    $self instvar agent_
    set agent_ [new SDP_Agent]
    set zone [new ScopeZone 224.2.128.0/17]
    new ProgramSource/SAP $agent_ $zone
}
HTTP_Agent/SDP_Agent public handle_request { url key source } {
    $self instvar list_
    mtrace trcNet "-> SDP_Agent::handle_request called"
    set page ""
    set status 200
    set type "text/html"
    if { $url == "sessions_list.html" } {
	mtrace trcNet "-> SDP Announcements page requested"
	set page [$self get_page sessions_list]
    } elseif { [string match sessions_desc^* $url] } {
	mtrace trcNet "-> SDP Description requested"
	set page [$self get_desc_page $key sessions]
    } elseif { [string match view^* $url] } {
	mtrace trcNet "-> View Session requested"
	$self update_agent_list
	array set desc_array $list_
	set msg_str [$desc_array($key) obj2str]
	set sdp_announcement $msg_str
	set mashlet_dir [$self get_option mashlet_dir]
	if { $mashlet_dir == "" } {
		set server_port [$self get_option server_port]
		global mash
		set mashlet_dir "http://[localaddr]:$server_port/$mash(version)"
	}
	set page "
	            label .label -text {Please wait while mashlets are\
				    imported}
		    pack .label -fill both -expand 1
		    update
	            global env 
	            set env(TCLCL_IMPORT_DIRS) $mashlet_dir
	            set x 0; import WidgetClass Icons MuiApplication MuiApplication/MPlug
		    destroy .label
	            WidgetClass transparent_gif	            
                    if { \$mash(environ)==\"mplug\" } {
			    new MuiApplication/MPlug {-sdp {$msg_str}}
                    } else {
                            new MuiApplication .\[pid\] {-sdp {$msg_str}}
                    }
	         "
	set type "x-mash/x-script"
    } elseif { [string match asview^* $url] } {
	mtrace trcNet "-> Assisted View Session requested"
	$self update_agent_list
	array set desc_array $list_
	set msg_str [$desc_array($key) obj2str]
	set sdp_announcement $msg_str
	set mashlet_dir [$self get_option mashlet_dir]
	if { $mashlet_dir == "" } {
		set server_port [$self get_option server_port]
		global mash
		set mashlet_dir "http://[localaddr]:$server_port/$mash(version)"
	}
	set page "
	            global env 
	            set env(TCLCL_IMPORT_DIRS) $mashlet_dir
	            set x 0; import WidgetClass Icons MuiApplication MuiApplication/MPlug
	            WidgetClass transparent_gif	            
                    if { \$mash(environ)==\"mplug\" } {
			    new MuiApplication/MPlug {-sdp {$msg_str} -usemega}
                    } else {
                            new MuiApplication .\[pid\] {-sdp {$msg_str} -usemega}
                    }
	         "
	set type "x-mash/x-script"
    }
    return [list $page $status $type]
}
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)
}
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
		}
	}
}
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]
}
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/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_
}
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/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"]
}
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
}
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 Rec_Agent
Rec_Agent public init { } {
    $self instvar archive_ schedule_ rec_list_ max_duration_
    set archive_ /h/mash/archive/web/
    set schedule_ ~/mash-1/tcl/applications/mash_server/schedule/
    set archive_ [$self get_option archive_root]
    append archive_ [$self get_option archive_dir]
    set schedule_ [$self get_option rec_schedule_dir]
    set max_duration_ [expr [$self get_option max_duration] * 60]
    set rec_list_ {}
    $self read_cache
}
Rec_Agent private read_cache { } {
    mtrace trcNet "In Rec_Agent::read_cache"
    $self instvar schedule_ rec_list_
    cd $schedule_
    set ctgfiles [glob -nocomplain -- *]
    foreach f $ctgfiles {
	mtrace trcNet "-> Reading file $f"
	set catalog [new SessionCatalog]
	$catalog open $f
	$catalog read
	set msg [lindex [ [new SDPParser 0] parse [$catalog get_sdp]] 0]
	set program [new Program $msg]
	lappend rec_list_ $f $msg
	set start_time [$catalog get_info rec_start]
	set end_time [$catalog get_info rec_end]
	$self reschedule $program $start_time $end_time
	$catalog destroy
    }
}
Rec_Agent private reschedule { program start_time end_time } {
    mtrace trcNet "In Rec_Agent::reschedule"
    set current [clock seconds]
    set start_offset [expr $start_time - $current]
    set end_offset [expr $end_time - $current]
    if { $end_offset < 0 } {
	$self removeprog $program
	return
    } else {
	$self schedule stop $program $end_offset
    }
    if { $start_offset <= 0 } {
	$self start_recording $program
    } else {
	$self schedule start $program $start_offset
    }
}
Rec_Agent public record { program } {
    $self instvar archive_ stop_status_array_ start_status_array_ \
	    max_duration_
    set key [get_key $program]
    set sdp_time [ [$program base] set alltimedes_]
    set repeat [$sdp_time readable_repeat]
    set start_time [ntp_to_unix [$sdp_time set starttime_]]
    set end_time [ntp_to_unix [$sdp_time set endtime_]]
    set current [clock seconds]
    set session_zone [$sdp_time readable_zone starttime_]
    set current_zone [clock format $current -format {%Z}]
    if { $session_zone != $current_zone } {
	set offset 3600
	if { [string match *D* $current_zone] } {
	    set offset -3600
	}
	set start_time [expr $start_time + $offset]
	set end_time [expr $end_time + $offset]
    }
    set start_offset [expr $start_time - $current]
    set end_offset [expr $end_time - $current]
    set max_duration_offset 0
    set act_start_time 0
    set act_end_time 0    
    if { $end_offset < 0 && $end_time != 0 } {
	set start_status_array_($key) "Session expired; no recording made"
	set stop_status_array_($key) ""
    } elseif { $repeat == "None" } {
	if { $start_time <= $current && $current < $end_time || \
		$start_time == 0 && $end_time == 0 || \
		$start_time == 0 && $current < $end_time || \
		$start_time <= $current && $end_time == 0 } {
	    $self start_recording $program
	    set act_start_time $current
	    set max_duration_offset $max_duration_
	} elseif { $start_offset >= 0 } {
	    $self schedule start $program $start_offset
	    set act_start_time [expr $current + $start_offset]
	    set max_duration_offset [expr $start_offset + $max_duration_]
	} else {
	    puts "Error: Recording not scheduled or started."
	    exit
	}
	if { $end_time == 0 || $end_offset >= $max_duration_offset } {
	    $self schedule stop $program $max_duration_offset
	    set act_end_time [expr $current + $max_duration_offset]
	} elseif { $end_offset >= 0 && $end_offset < $max_duration_offset } {
	    $self schedule stop $program $end_offset
	    set act_end_time [expr $current + $end_offset]
	} else {
	    puts "Error: Recording end not scheduled."
	    exit
	}
    } else {
	set interval [$sdp_time get repeat_interval_]
	set duration [$sdp_time get active_duration_]
	set offset_list [$sdp_time get offlist_]
	set rep_start $start_time
	set rep_end [expr $start_time + $duration]
	set end_offset [expr $rep_end - $current]
	set start_scheduled 0
	while {	$rep_start < $end_time && $current < $end_time } {
	    if { $current < $rep_start } {
		set start_offset [expr $rep_start - $current]
		$self schedule start $program $start_offset
		set act_start_time [expr $current + $start_offset]
		set max_duration_offset [expr $start_offset + $max_duration_]
		set start_scheduled 1
	    } elseif { $rep_start <= $current && $current < $rep_end } {
		$self start_recording $program
		set act_start_time $current
		set max_duration_offset $max_duration_
		set start_scheduled 1
	    }
	    if { $start_scheduled } {
		if { $end_offset < $max_duration_offset } {
		    $self schedule stop $program $end_offset
		    set act_end_time [expr $current + $end_offset]
		} else {
		    $self schedule stop $program $max_duration_offset
		    set act_end_time [expr $current + $max_duration_offset]
		}
		break
	    }
	    set rep_start [expr $rep_start + $interval]
	    set rep_end [expr $rep_start + $duration]
	    set end_offset [expr $rep_end - $current]
	    mtrace trcNet "-> start/current/end: \
		    [$self readable_time $rep_start]/\
		    [$self readable_time $current]/\
		    [$self readable_time $rep_end]"
	}
    }
    $self addprog $program $act_start_time $act_end_time
}
Rec_Agent private schedule { command program interval } {
    $self instvar stop_status_array_ start_status_array_
    mtrace trcNet "-> Schedule $command recording."
    append full_command $command _recording
    $self schedule_helper "$self $full_command $program" $program $interval
    set key [get_key $program]
    set time_str [$self readable_time [expr [clock seconds] + $interval]]
    if { $command == "start" } {
	set start_status_array_($key) "Scheduled for $time_str"
    } elseif { $command == "stop" } {
	set stop_status_array_($key) "Scheduled for $time_str"
    } else {
	puts "Error: Invalid command to schedule"
	exit
    }
}
Rec_Agent private readable_time { time } {
    return [clock format $time -format {%a %B %d, %Y at %H:%M}]
}
Rec_Agent private schedule_helper { command program interval } {
    $self instvar schedule_array_
    if { $interval < 0 } {
	puts "Error: Parameter interval to proc schedule < 0"
	exit
    }
    mtrace trcNet "-> Scheduling command: $command"
    set interval_ms [expr $interval * 1000]
    set extra 0
    if { $interval_ms < 0 } {
	set extra [expr $extra + 86400]
	set interval [expr $interval - 86400]
	set interval_ms [expr $interval * 1000]
    }
    set new_command ""
    if { $extra == 0 } {
	after $interval_ms $command
	set new_command $command
    } elseif { $extra > 0 } {
	set extra_ms [expr $extra * 1000]
	set new_command "$self schedule_helper $command $program $extra_ms"
	after $interval_ms "$self schedule_helper $command $program $extra_ms"
    } else {
	puts "Error: $extra < 0"
	exit
    }
    mtrace trcNet "-> Command scheduled: $new_command"
    set key [get_key $program]
    set schedule_array_($key) $new_command
}
Rec_Agent private addprog { program start_time end_time } {
    $self instvar schedule_ rec_list_
    set key [get_key $program]
    set msg [$program base]
    lappend rec_list_ $key $msg
    append filename $schedule_ $key
    set catalog [new SessionCatalog]
    $catalog open $filename w
    $catalog write_sdp [$msg obj2str]
    $catalog write_info "rec_start=$start_time\nrec_end=$end_time"
    $catalog destroy
}
Rec_Agent public return_progs { } {
    $self instvar rec_list_
    return $rec_list_
}
Rec_Agent public return_path { key } {
    $self instvar module_array_ archive_
    set path ""
    if { [array names module_array_ $key] != "" } {
	append path $module_array_($key) "/cat.ctg"
    }
    return $path
}
Rec_Agent public return_status { type key } {
    $self instvar start_status_array_ stop_status_array_ \
	    module_array_ archive_
    if { $type == "start" } {
	set status $start_status_array_($key)
	if { $status == "Recording" } {
	    append filename $archive_ $module_array_($key) "/cat.ctg"
	    if { ![string match *START_STREAM* [read_file $filename]] } {
		set status "Recording (waiting for video/audio stream)."
	    }
	}
    } elseif { $type == "stop" } {
	set status $stop_status_array_($key)	
    } else {
	puts "Error: Invalid type to return_status."
	exit
    }
    return $status
}
Rec_Agent private start_recording { program } {
    mtrace trcNet "-> Starting recorder"
    $self instvar archive_ archive_array_ start_status_array_ \
	    module_array_ schedule_array_
    set key [get_key $program]
    set module [string trim [clock clicks] -]
    set module_array_($key) $module
    set archive_sys [new ArchiveSystem/Record]
    $archive_sys open $archive_ $module
    $archive_sys write_announcement $program
    set current [$self readable_time [clock seconds]]
    set info "record_start=$current"
    $archive_sys write_info $info
    $archive_sys record_program $program $module
    set archive_array_($key) $archive_sys
    set start_status_array_($key) "Recording"
    set exists [array names schedule_array_ $key]
    if { $exists != "" } {
    }
}
Rec_Agent public stop_recording { program } {
    $self instvar archive_array_ schedule_array_ start_status_array_ \
	    end_status_array_ rec_list_ archive_ module_array_
    set key [get_key $program]
    set start_status [$self return_status start $key]
    mtrace trcNet "-> Start status: $start_status"
    set is_recording [string match *Recording* $start_status]
    set is_expired [string match *expired* $start_status]
    set is_scheduled [string match *Scheduled* $start_status]
    if { $is_recording } {
	set current [$self readable_time [clock seconds]]
	set info "record_end=$current"
	$archive_array_($key) write_info $info
	$archive_array_($key) close
	delete $archive_array_($key)
	append directory $archive_ $module_array_($key)
	append filename $directory /cat.ctg
	set rec_started [string match *START_STREAM* [read_file $filename]]
	if { !$rec_started } {
	    mtrace trcNet "-> Deleting archive directory"
	    file delete $filename
	    file delete $directory
	}
    } elseif { $is_scheduled } {
	after cancel $schedule_array_($key)
    } elseif { $is_expired } { 
    } else {
	mtrace trcNet "-> Unknown start status"
	exit
    }
    $self removeprog $program
    set start_status_array_($key) "Recording stopped"
    set end_status_array_($key) ""
}
Rec_Agent private removeprog { program } {
    $self instvar schedule_ rec_list_
    set key [get_key $program]
    mtrace trcNet "-> Removing recording: $key"
    set index [lsearch -exact $rec_list_ $key]
    set rec_list_ [lreplace $rec_list_ $index [expr $index + 1]]
    append filename $schedule_ $key
    file delete $filename
}
Class HTTP_Agent/Rec_Agent -superclass HTTP_Agent
HTTP_Agent/Rec_Agent public init { } {
    $self next
    $self instvar agent_ html_dir_ sessions_dir_
    set agent_ [new Rec_Agent]
    set html_dir_ ~/mash-1/tcl/applications/mash_server/html/
    set html_dir_ [$self get_option html_dir]
    set sessions_dir_ [$self get_option sdp_sessions_dir]
}
HTTP_Agent/Rec_Agent public handle_request { url key source } {
    $self instvar agent_ html_dir_
    mtrace trcNet "-> Rec_Agent::handle_request called"
    set page ""
    set status 200
    set type "text/html"
    set msg ""
    if { [string match record^* $url] } {
	mtrace trcNet "-> Request to record program received"
	if { [$self validate_source $source] } {
	    set scheduled [$self check_scheduled $key]
	    if { $scheduled == 0 } {
		set program [$self get_program $key]
		if { $program != "" } {
		    $agent_ record $program
		    append html_file $html_dir_ recordings.html
		    set page [read_file $html_file]
		} else {
		    mtrace trcNet "-> File does not exist in session cache."
		    set msg "Session expired or not in cache."
		    set page [$self get_error_page $msg]
		}
	    } else {
		mtrace trcNet "-> Program already scheduled: $scheduled"
		append html_file $html_dir_ recordings.html
		set page [read_file $html_file]
	    }
	} else {
	    set msg "Access to recorder not granted."
	    set page [$self get_error_page $msg]
	}
   } elseif { $url == "recordings_list.html" } {
	mtrace trcNet "-> Recordings schedule page requested"
	set page [$self get_page recordings_list]
    } elseif { [string match stop_record^* $url] } {
	mtrace trcNet "-> Request to stop recording received"
	if { [$self validate_source $source] } {
	    $agent_ stop_recording [$self get_program $key]
	    set page [$self get_page recordings_list]
	} else {
	    set msg "Access to recorder not granted."
	    set page [$self get_error_page $msg]
	}
    } elseif { [string match recordings_status^* $url] } {
	mtrace trcNet "-> Request for recording status received"
	set page [$self get_status_page $key]
    }
    return [list $page $status $type]
}
HTTP_Agent/Rec_Agent private get_status_page { key } {
    $self instvar list_ agent_
    $self update_agent_list
    array set rec_array $list_
    set status_page [$rec_array($key) create_dynamic_html \
	    [DynamicHTMLifier set html_(recordings_status)]]
    set start_status [$agent_ return_status start $key]
    set stop_status [$agent_ return_status stop $key]
    set path [$agent_ return_path $key]
    append status_page "Start status: " $start_status "<br>\n"
    append status_page "Stop status: " $stop_status "<br>\n"
    append status_page "Recording location: $path <br>\n"
    append status_page "</body>\n</html>"
    return $status_page
}
HTTP_Agent/Rec_Agent private get_program { key } {
    $self instvar sessions_dir_
    append filename $sessions_dir_ $key
    if { [file exists $filename] } {
	set data [file_dump $filename]
	set msg [lindex [ [new SDPParser 0] parse $data] 0]
	set program [new Program $msg]
    } else {
	mtrace trcNet "-> $filename does not exist in cache."
	set program ""
    }
    return $program
}
HTTP_Agent/Rec_Agent private check_scheduled { key } {
    $self instvar list_
    $self update_agent_list
    set exists [lsearch -exact $list_ $key]
    if { $exists == -1 } {
	return 0
    } else {
	return 1
    }
}
Class DynamicHTMLifier
DynamicHTMLifier proc init_ { } {
    $self parentify HTTP_Agent/Play_Agent
    $self parentify HTTP_Agent/SDP_Agent
    $self parentify HTTP_Agent/Rec_Agent
    $self parentify SDPMessage
    $self parentify SDPMedia
    $self parentify SDPTime
    $self parentify Program
    $self parentify SessionCatalog
    set html_dir ~/mash-1/tcl/applications/mash_server/html/
    set o [$self options]
    $o load_preferences "pathfinder"
    set html_dir [$self get_option html_dir]
    append playback_list $html_dir playback_list.html
    $self set htmlfiles_(playback_list) $playback_list
    append playback_msg $html_dir playback_msg.html
    $self set htmlfiles_(playback_msg) $playback_msg
    append playback_desc $html_dir playback_desc.html
    $self set htmlfiles_(playback_desc) $playback_desc
    append sessions_list $html_dir sessions_list.html
    $self set htmlfiles_(sessions_list) $sessions_list
    append sessions_msg $html_dir sessions_msg.html
    $self set htmlfiles_(sessions_msg) $sessions_msg
    append sessions_desc $html_dir sessions_desc.html
    $self set htmlfiles_(sessions_desc) $sessions_desc
    append media $html_dir media.html
    $self set htmlfiles_(media) $media
    append time_none $html_dir time_none.html
    $self set htmlfiles_(time_none) $time_none
    append time_weekly $html_dir time_weekly.html
    $self set htmlfiles_(time_weekly) $time_weekly
    append time_daily $html_dir time_daily.html
    $self set htmlfiles_(time_daily) $time_daily
    append recordings_list $html_dir recordings_list.html
    $self set htmlfiles_(recordings_list) $recordings_list
    append recordings_msg $html_dir recordings_msg.html
    $self set htmlfiles_(recordings_msg) $recordings_msg
    append recordings_status $html_dir recordings_status.html
    $self set htmlfiles_(recordings_status) $recordings_status
    $self read_html
    after 900 "$self read_html"
}
DynamicHTMLifier proc parentify { cls } {
    set super [$cls info superclass]
    set idx [lsearch -exact $super Object]
    if { $idx!=-1 } {
	set super [lreplace $super $idx $idx]
    }
    lappend super $self
    $cls superclass $super
}
DynamicHTMLifier proc read_html { } {
    $self instvar htmlfiles_
    foreach file [array names htmlfiles_] {
	puts "Reading HTML file: $htmlfiles_($file)"
	$self read_file $htmlfiles_($file) $file
    }
}
DynamicHTMLifier proc read_file { filename subscript } {
    $self instvar html_
    set html_($subscript) ""
    set file [open $filename]
    while { ![eof $file] } {
	append html_($subscript) "[gets $file]\n"
    }
    close $file
}
DynamicHTMLifier instproc create_dynamic_html { html } {
    set new_html { }
    set idx [string first "<%" $html]
    while { $idx != -1 } {
	append new_html [string range $html 0 [expr $idx-1]]
	set html [string range $html [expr $idx+2] end]
	set idx [string first ">" $html]
	if { $idx==-1 } {
	    error "Error in dynamic HTML: Can't find closing '>'"
	}
	set cmd [string range $html 0 [expr $idx-1]]
	set html [string range $html [expr $idx+1] end]
	append new_html [eval $cmd]
	set idx [string first "<%" $html]
    }
    append new_html $html
    return $new_html
}
DynamicHTMLifier init_
MTrace init { trcNet }
set server [new HTTP_Server/MASH_Server]
set sdp_agent [new HTTP_Agent/SDP_Agent]
set rec_agent [new HTTP_Agent/Rec_Agent]
set play_agent [new HTTP_Agent/Play_Agent]
$server add_agent $sdp_agent
$server add_agent $rec_agent
$server add_agent $play_agent
$server open [$server get_option server_port]
vwait forever
