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

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

Class Log
Log proc name s {
	Log set name_ $s
}
Log proc warn s {
	Log instvar name_
	if [info exists name_] {
		set name $name_
	} else {
		global argv0
		if [info exists argv0] {
			set name [file tail $argv0]
		} else {
			set name mash
		}
	}
	puts stderr "$name_: $s"
}
Log proc fatal s {
	Log warn $s
	exit 1
}
Class Application
Application public init name {
	$self next
	$self instvar name_ class_
	set name_ $name
	$self add_option appname $name
	Log set name_ $name
	set class_ [string toupper [string index $name_ 0]][string \
		range $name_ 1 end]
	catch "tk appname $name"
	Application set instance_ $self
}
Application proc instance {} {
	return [Application set instance_]
}
Application proc name {} {
	return [[Application instance] set name_]
}
Application proc class {} {
	return [[Application instance] set class_]
}
Application proc toplevel w {
	Application instvar visual_ colormap_
	if [info exists visual_] {
		toplevel $w -class [Application class] \
			-visual $visual_ -colormap $colormap_
	} else {
		toplevel $w -class [Application class]
	}
}
global font
set font(helvetica10) {
	normal--*-100-75-75-*-*-*-*
	normal--10-*-*-*-*-*-*-*
	normal--11-*-*-*-*-*-*-*
	normal--*-100-*-*-*-*-*-*
	normal--*-*-*-*-*-*-*-*
}
set font(helvetica12) {
	normal--*-120-75-75-*-*-*-*
	normal--12-*-*-*-*-*-*-*
	normal--14-*-*-*-*-*-*-*
	normal--*-120-*-*-*-*-*-*
	normal--*-*-*-*-*-*-*-*
}
set font(helvetica14) {
	normal--*-140-75-75-*-*-*-*
	normal--14-*-*-*-*-*-*-*
	normal--*-140-*-*-*-*-*-*
	normal--*-*-*-*-*-*-*-*
}
set font(times14) {
	normal--*-140-75-75-*-*-*-*
	normal--14-*-*-*-*-*-*-*
	normal--*-140-*-*-*-*-*-*
	normal--*-*-*-*-*-*-*-*
}
Application instproc search_font { foundry style weight points slant } {
	global font tcl_version tcl_platform
 	if {$tcl_version >= 8} {
 		if {$slant == "r"} {
 			set slant ""
 		} elseif {$slant == "o"} {
 			set slant "italic"
 		}
		if {$weight == "medium"} {
			set weight ""
		}
 		return "$style -$points $weight $slant"
 	}
	foreach f $font($style$points) {
		set fname -$foundry-$style-$weight-$slant-$f
		if [havefont $fname] {
			return $fname
		}
	}
	$self instvar name_
	puts stderr "$name_: can't find $weight $fname font (using fixed)"
	if ![havefont fixed] {
		puts stderr "$name_: can't find fixed font"
		exit 1
	}
	return fixed
}
Application public init_local {} {
	$self instvar name_
	set f ~/.$name_.tcl
	if [file exists $f] {
		uplevel #0 "source $f"
	}
	set script [$self resource startupScript]
	if { $script != "" } {
		uplevel #0 "source $script"
	}
}
Application instproc user_hook {} {
}
Object instproc options {} {
	$self instvar options_
	if ![info exists options_] {
		Object instvar options_
		if ![info exists options_] {
			set options_ [new Configuration]
			global tcl_platform
			if {"$tcl_platform(platform)"=="windows"} {
				$options_ add_default \
					background SystemButtonFace
				$options_ add_default \
					infoHighlightColor SystemHighlightText
			}
		}
	}
	$options_ add_default appname mash
	return $options_
}
Object instproc optionsFrom o {
	$self set options_ $o
}
Class instproc configuration a {
 	$self instvar options_
	if ![info exists options_] {
		set options_ [new Configuration]
	}
	foreach { option value } $a {
		$options_ add_default $option $value
	}
}
Object instproc get_option r {
	set v [[$self options] get_option $r]
	if { $v != "" } {
		return $v
	}
	set cl [$self info class]
	foreach cl "$cl [$cl info heritage]" {
		$cl instvar options_
		if [info exists options_] {
			set v [$options_ get_option $r]
			if { $v != "" } {
				return $v
			}
		}
	}
	return ""
}
Object instproc resource r {
	return [$self get_option $r]
}
Object instproc add_option { r v } {
	return [[$self options] add_option $r $v]
}
Object instproc add_default { r v } {
	return [[$self options] add_default $r $v]
}
Object instproc yesno r {
	set v [$self get_option $r]
	if [string match \[0-9\]* $v] {
		return $v
	}
	if [string match \[tT\]* $v] {
		return 1
	}
	return 0
}
Object instproc debug s {
	if [$self yesno debug] {
		Log warn $s
	}
}
Object instproc warn s {
	Log warn $s
}
Object instproc fatal s {
	Log fatal $s
}
Class Configuration
Configuration public get_option r {
	$self instvar table_ default_
	if [info exists table_($r)] {
		return $table_($r)
	}
	if [info exists default_($r)] {
		return $default_($r)
	}
	return ""
}
Configuration public add_option { r v } {
	$self instvar table_
	set table_($r) $v
}
Configuration public add_default { r v } {
	$self set default_($r) $v
}
Configuration public register_option  { flag option args } {
	$self instvar arg_option_ usage_ arg_option_default_
	set arg_option_($flag) $option
	if { [lindex $args 0] == "-default" } {
		set arg_option_default_($flag) [lindex $args 1]
		set args [lrange $args 2 end]
	}
	set usage_($flag) $args
}
Configuration public register_boolean_option  { flag option args } {
	$self instvar arg_bool_ arg_bool_val_
	set arg_bool_($flag) $option
	if { $args == "" } {
		set args 1
	}
	set arg_bool_val_($flag) $args
}
Configuration public register_list_option {flag option args} {
	$self instvar arg_list_option_
	set arg_list_option_($flag) $option
	set usage_($flag) $args
}
Configuration private is_arg argv {
	if { $argv != "" } {
		return [string match -* [lindex $argv 0]]
	}
	return 0
}
Configuration instproc parse_args argv {
	$self instvar arg_resource_ bool_resource_
	$self instvar arg_option_ arg_bool_ arg_bool_val_ arg_list_option_ \
			arg_option_default_
	if { [info exists arg_resource_] || [info exists bool_resource_] } {
		puts stderr "your application class needs to be fixed"
		exit 1
	}
	while 1 {
		if ![$self is_arg $argv] {
			break
		}
		set arg [lindex $argv 0]
		set argv [lrange $argv 1 end]
		set val [lindex $argv 0]
		if { $arg == "-help" } {
			$self usage
			exit
		}
		if { $arg == "-X" } {
			set L [split $val =]
			if { [llength $L] != 2 } {
				puts stderr "malformed -X argument"
				exit 1
			}
			$self add_option [lindex $L 0] [lindex $L 1]
			set argv [lrange $argv 1 end]
			continue
		}
		set fatal_msg ""
		if [info exists arg_option_($arg)] {
			if { [llength $argv] > 0 && \
					[string index $val 0]!="-" } {
				$self add_option $arg_option_($arg) $val
				set argv [lrange $argv 1 end]
				continue
			}
			set fatal_msg "must be followed by an argument"
		}
		if [info exists arg_bool_($arg)] {
			$self add_option $arg_bool_($arg) $arg_bool_val_($arg)
			continue
		}
		if [info exists arg_list_option_($arg)] {
			if { [llength $argv] > 0 || \
					[string index $val 0]!="-" } {
				set o $arg_list_option_($arg)
				set l [$self get_option $o]
				lappend l $val
				$self add_option $o $l
				set argv [lrange $argv 1 end]
				continue
			}
			set fatal_msg "must be followed by an argument"
		}
		$self usage
		$self fatal "unknown/invalid command option: $arg ($fatal_msg)"
	}
	return $argv
}
Configuration public usage {} {
	set display_args_on_single_line 0
	if { $display_args_on_single_line } {
		puts "usage: [Application name] [join [$self arg_info]]"
	} else {
		puts "usage: [Application name]"
		foreach arg [$self arg_info] {
			puts $arg
		}
	}
}
Configuration private arg_info {} {
	$self instvar arg_option_ arg_bool_ usage_
	foreach arg [array names arg_option_] {
		set r $arg_option_($arg)
		set d [$self get_option $r]
		if { $d != "" || $usage_($arg) != "required"} {
			lappend opt "\[$arg $r ($d)\]"
		} else {
			lappend req "$arg $r"
		}
	}
	foreach arg [array names arg_bool_] {
		set r $arg_bool_($arg)
		set d [$self get_option $r]
		if { $d != "" } {
		        lappend opt "\[$arg ($d)\]"
		} else {
			lappend opt "\[$arg\]"
		}
	}
	if [info exists opt] {
		if [info exists req] {
			return [concat $opt $req]
		} else {
			return $opt
		}
	} else {
		if [info exists req] {
			return $req
		} else {
			return ""
		}
	}
}
Configuration public load_preferences suffixList {
    global env
    if {![info exists env(HOME)]} {
        new ErrorWindow {Your HOME environment variable must be set.}
        exit 1
    }
	set mash [file join $env(HOME) .mash]
	if {[file isdirectory $mash]} {
		$self load_file $mash/prefs
		foreach suffix $suffixList {
			$self load_file $mash/prefs-$suffix
		}
	}
}
Configuration private load_file fname {
	if ![file readable $fname] {
		return
	}
	set f [open $fname r]
	set count 0
	while 1 {
		incr count
		if [eof $f] {
			close $f
			return
		}
		set line [string trim [gets $f]]
		if { $line == {} || [string index $line 0]=="#" } {
			continue
		}
		set colon [string first ":" $line]
		if { $colon==-1 } {
			puts stderr "Invalid line $count in $fname:\
					Must be of the form \"key: value\""
			continue
		}
		set option [string trim [string range $line 0 [expr $colon-1]]]
		set value [string trim [string range $line \
				[expr $colon+1] end]]
		$self add_option $option $value
	}
}
Configuration public open_preferences { suffix {mode w} } {
    global env
    if {![info exists env(HOME)]} {
        new ErrorWindow {Your HOME environment variable must be set.}
        exit 1
    }
	set mash [file join $env(HOME) .mash]
	if {![file exists $mash]} {
		file mkdir $mash
	}
	set f [open $mash/prefs-$suffix $mode 0644]
	return $f
}
Configuration public write_preference { file key value } {
	puts $file "$key: $value"
}
Configuration public close_preferences { file } {
	close $file
}
Class TkWindow -configuration {
	background gray85
}
Class TopLevelWindow -superclass TkWindow
TkWindow public init {path} {
	$self next
	$self instvar path_
	set path_ $path
}
TkWindow public widget_path {} {
	$self instvar path_
	return $path_
}
TkWindow instproc destroy {} {
	$self instvar path_
	if [winfo exists $path_] {
		destroy $path_
	}
	$self next
}
TkWindow instproc highlight { color } {
	$self instvar path_
	if { $path_ != "" } {
		$path_ configure -background $color
		foreach child [winfo children $path_] {
			window_highlight $child $color
		}
	}
}
TkWindow instproc set_background { color } {
	$self instvar path_
	$path_ configure -background $color
}
TopLevelWindow public build_window {} {
	$self instvar path_
	if ![winfo exists $path_] {
		$self build $path_
	}
}
TopLevelWindow instproc toggle {} {
	$self build_window
	$self instvar path_
	set w $path_
	$self instvar __mappedBefore__
	if { [winfo ismapped $w] } {
		wm withdraw $w
		return
	} elseif ![info exists __mappedBefore__] {
		set __mappedBefore__ 1
		wm transient $w .
		update idletasks
		set x [winfo rootx .]
		set y [winfo rooty .]
		incr y [winfo height .]
		incr y -[winfo reqheight $w]
		incr y -20
		incr x [winfo vrootx .]
		incr y [winfo vrooty .]
		if { $y < 0 } { set y 0 }
		if { $x < 0 } {
			set x 0
		} else {
			set right [expr [winfo screenwidth .] - \
					[winfo reqwidth $w]]
			if { $x > $right } {
				set x $right
			}
		}
		wm geometry $w +$x+$y
	}
	wm deiconify $w
}
TopLevelWindow instproc create-window { w title } {
	Application toplevel $w
	set title "[$self get_option iconPrefix] $title"
	wm transient $w .
	wm title $w $title
	wm iconname $w $title
	bind $w <Enter> "focus $w"
	wm withdraw $w
}
Class HelpWindow -superclass TopLevelWindow
HelpWindow instproc create-window { w title items } {
	$self next $w $title
	frame $w.frame -borderwidth 0 -relief flat
	set p $w.frame
	set n 0
	foreach m $items {
		set h $w.h$n
		incr n
		frame $h
		$self helpitem $h $m
		pack $h -expand 1 -fill both
	}
	button $w.frame.ok -text " Dismiss " -borderwidth 2 -relief raised \
		-command "wm withdraw $w" -font [$self get_option medfont]
	pack $w.frame.ok -pady 6 -padx 6 -anchor e
	pack $w.frame -expand 1 -fill both
        wm protocol $w WM_DELETE_WINDOW "wm withdraw $w"
}
HelpWindow instproc helpitem { w text } {
	set f [$self get_option helpFont]
	canvas $w.bullet -width 12 -height 12
	$w.bullet create oval 6 3 12 9 -fill black
	message $w.msg -justify left -anchor w -font $f -width 450 -text $text
	pack $w.bullet -side left -anchor ne -pady 5
	pack $w.msg -side left -expand 1 -fill x -anchor nw
}
Class ErrorWindow -superclass TopLevelWindow
ErrorWindow public init text {
	set w .dialog
	$self next $w
	catch "destroy $w"
	global V
	set applname [Application name]
	if { $applname == "" } {
		set applname "mash shell"
	}
	$self create-window $w "$applname error"
	label $w.label -text "$applname: $text" -font [$self get_option medfont] \
		-borderwidth 2 -relief groove
	button $w.button -text OK -command "$self destroy" \
			-font [$self get_option medfont]
	pack $w.label -expand 1 -fill x -ipadx 4 -ipady 4
	pack $w.button -pady 4
	wm withdraw $w
	update idletasks
	set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
		- [winfo vrootx [winfo parent $w]]]
	set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
		- [winfo vrooty [winfo parent $w]]]
	wm geom $w +$x+$y
	wm deiconify $w
	bind $w <Enter> "focus $w"
	tkwait window .dialog
}
Class CheckButton
CheckButton public init { w args } {
	$self instvar var_ path_
	set path_ $w
	set var_ [TclObject getid]
	eval checkbutton $w -variable $var_ $args
}
CheckButton instproc get_val {} {
	$self instvar var_
	global $var_
	return [set $var_]
}
CheckButton instproc set_val v {
	$self instvar var_
	global $var_
	set $var_ $v
}
CheckButton instproc set-val v { $self set_val $v }
CheckButton instproc get-val {} { $self get_val }
CheckButton instproc unknown args {
	$self instvar path_
	eval $path_ $args
}
Class RadioButtonsObj
RadioButtonsObj public init { w labelsList args } {
    $self instvar var_ path_ numButtons_
    set path_ $w
    set var_ [TclObject getid]
    set c 0
    foreach i $labelsList {
	eval radiobutton $w.rb$c -variable $var_ $args
	$w.rb$c configure -text [list $i]
	$w.rb$c configure -value [list $i]
	pack $w.rb$c -in $w -anchor w
	incr c
    }
    set numButtons_ $c
}
RadioButtonsObj public get_val {} {
    $self instvar var_
    global $var_
    return [set $var_]
}
RadioButtonsObj public set_val {v} {
    $self instvar var_
    global $var_
    set $var_ $v
}
RadioButtonsObj private unknown args {
    $self instvar path_ numButtons_
    for {set i 0} {$i < $numButtons_} {incr i} {
	eval $path_.rb$i $args
    }
}
Class ScaleObj
ScaleObj public init { w args } {
    $self instvar var_ path_
    set path_ $w
    set var_ [TclObject getid]
    eval scale $w -variable $var_ $args
}
ScaleObj public get_val {} {
    $self instvar var_
    global $var_
    return [set $var_]
}
ScaleObj public set_val {v} {
    $self instvar var_
    global $var_
    set $var_ $v
}
ScaleObj private unknown args {
    $self instvar path_
    eval $path_ $args
}
Class EntryObj
EntryObj public init { w args } {
    $self instvar var_ path_
    set path_ $w
    set var_ [TclObject getid]
    eval entry $w -textvariable $var_ $args
}
EntryObj public get_val {} {
    $self instvar var_
    global $var_
    return [set $var_]
}
EntryObj private unknown args {
    $self instvar path_
    eval $path_ $args
}
proc isWidgetObject { cl } {
	if { [$cl info heritage WidgetObject] != {} || $cl=="WidgetObject" } {
		return 1
	} else {
		return 0
	}
}
Class WidgetClass -superclass Class
WidgetClass proc unknown { cl args } {
	set private_options(-configspec) ""
	set private_options(-default) ""
	set private_options(-alias) ""
	set len [llength $args]
	for { set idx 0 } { $idx < $len } { incr idx 2 } {
		if { [info exists private_options([lindex $args $idx])] } {
			set private_options([lindex $args $idx]) \
					[lindex $args [expr $idx+1]]
			set args [lreplace $args $idx [expr $idx+1]]
			incr idx -2
		}
	}
	set idx [lsearch $args "-superclass"]
	if { $idx!=-1 } {
		incr idx
		if { [llength $args] <= $idx } {
			error "missing argument for option '-superclass'"
		}
		set superclasses [lindex $args $idx]
		set need_WidgetObject 1
		foreach superclass $superclasses {
			if { [$superclass info heritage WidgetObject]!="" } {
				set need_WidgetObject 0
				break
			}
		}
		if { $need_WidgetObject && $cl!="WidgetObject"} {
			lappend superclasses WidgetObject
			set args [lreplace $args $idx $idx $superclasses]
		}
	} else {
		if { $cl!="WidgetObject" } {
			lappend args -superclass WidgetObject
		}
	}
	eval [list $self] next [list $cl] $args
	$cl heritage_defaults
	foreach option [array names private_options] {
		set arg $private_options($option)
		$cl set_[string range $option 1 end] $arg
	}
}
WidgetClass proc set_widget_default { } {
	set count 0
	while [winfo exists .dummy_${count}__] { incr count }
	set dummy .dummy_${count}__
	button $dummy
	$self set_widget_default_ $dummy { -background -foreground \
			-activebackground -activeforeground -borderwidth \
			-cursor -disabledforeground -highlightbackground\
			-highlightcolor -highlightthickness -takefocus \
			{-boldfont -font} }
	destroy $dummy
	radiobutton $dummy
	$self set_widget_default_ $dummy { -selectcolor }
	destroy $dummy
	entry $dummy
	$self set_widget_default_ $dummy { -font -selectbackground \
			-selectforeground -selectborderwidth }
	destroy $dummy
}
WidgetClass proc set_widget_default_ { path options } {
	$self instvar widget_defaults_
	foreach option $options {
		if { [llength $option]==1 } {
			set option [lindex $option 0]
			set widget_defaults_($option) [$path cget $option]
		} else {
			set widget_defaults_([lindex $option 0]) \
					[$path cget [lindex $option 1]]
		}
	}
}
WidgetClass proc widget_default { option } {
	$self instvar widget_defaults_
	if { [info exists widget_defaults_($option) ] } {
		return $widget_defaults_($option)
	} else {
		error "no such default option \"$option\""
	}
}
WidgetClass proc translate_default { option value } {
	if { ![string compare $value "WidgetDefault"] } {
		return [WidgetClass widget_default $option]
	} elseif { [regexp {WidgetDefault\((.*)\)} $value dummy \
			defaultOption] } {
		return [WidgetClass widget_default $defaultOption]
	}
	return $value
}
WidgetClass set_widget_default
WidgetClass instproc heritage_defaults { } {
	set heritage [$self info heritage]
	set len [expr [llength $heritage]-1]
	while { $len >= 0 } {
		set cl [lindex $heritage $len]
		incr len -1
		if { [isWidgetObject $cl] } {
			$self configspec_ [$cl info configspec] 1
			$self default_ [$cl info default]
		}
	}
}
WidgetClass instproc set_configspec { specs } {
	$self configspec_ $specs 0
}
WidgetClass instproc configspec_ { specs {isAncestor} } {
	$self instvar configspec_
	foreach spec $specs {
		if { ! $isAncestor } {
			set option  [lindex $spec 0]
			set default [lindex $spec 3]
			set spec [lreplace $spec 3 3 [WidgetClass \
					translate_default $option $default]]
			set configspec_($option) $spec
		}
		option add *$self.[lindex $spec 1] \
				[lindex $spec 3] widgetDefault
	}
}
WidgetClass instproc set_alias { aliases } {
	$self instvar configspec_
	foreach alias $aliases {
		set al   [lindex $alias 0]
		set orig [lindex $alias 1]
		if { ![info exists configspec_($orig)] } {
			error "no configspec $orig (specified in alias list)"
		}
		set configspec_($al) $configspec_($orig)
	}
}
WidgetClass instproc set_default { defaults } {
	$self default_ $defaults
	$self set defaults_ $defaults
}
WidgetClass instproc default_ { defaults } {
	foreach default $defaults {
		set option [lindex $default 0]
		set star [string last "*" $option]
		set dot  [string last "." $option]
		if { $star < $dot } {
			set idx [expr $dot+1]
		} else {
			set idx [expr $star+1]
		}
		option add *${self}$option [WidgetClass translate_default \
				-[string tolower [string range $option $idx \
				end]] [lindex $default 1]] widgetDefault
	}
}
WidgetClass instproc create { widget args } {
	eval [list $self] next [list _o$widget] [list $widget] $args
	return $widget
}
WidgetClass instproc info { option args } {
	if { $option == "default" } {
		if { $args != "" } {
			error "extra arguments in call to 'info $option'"
		}
		return [$self set defaults_]
	} elseif { $option == "configspec" } {
		$self instvar configspec_
		set len [llength $args]
		if { $len == 0 } {
			set list {}
			foreach el [array names configspec_] {
				lappend list $configspec_($el)
			}
			return $list
		}
		if { [llength $args] != 1 } {
			error "extra arguments in call to 'info $option'"
		}
		if { [info exists configspec_($args)] } {
			return $configspec_($args)
		} else {
			return ""
		}
		return [eval [list $self] next [list $option] $args]
	} else {
		return [eval [list $self] next [list $option] $args]
	}
}
WidgetClass WidgetObject -configspec {
	{-options options Options {} widget_options widget_options}
}
WidgetObject instproc init { widget args } {
	$self next
	$self instvar path_ widget_proc_
	set path_ $widget
	$self create_root_widget $widget
	if { ![winfo exists $widget] } {
		error "must create a widget $widget inside\
				[$self info class]::create_root_widget"
	}
	$self instvar widget_proc_
	set widget_proc_ "proc_$self"
	rename $widget $widget_proc_
	proc ::$widget { args } "return \[uplevel [list $self] \$args\]"
	$self build_widget $widget
	set heritage [[$self info class] info heritage]
	set idx 0
	for { set idx [expr [llength $heritage]-1] } {$idx>=0} {incr idx -1} {
		set cl [lindex $heritage $idx]
		if { [isWidgetObject $cl] } {
			$self configure_default $cl
		}
	}
	$self configure_default [$self info class]
	if { $args!="" } {
		eval [list $self] configure $args
	}
	if { [winfo toplevel $path_]==$path_ } {
		bind $widget <Destroy> "if \{\"%W\"==\"$path_\"\} \
				\{delete $self\}"
	} else {
		bind $widget <Destroy> "delete $self"
	}
}
WidgetObject instproc destroy { } {
	$self instvar path_ widget_proc_
	catch {rename $path_ {}}
	catch {rename $widget_proc_ {}}
	$self next
}
WidgetObject instproc create_root_widget { path } {
	frame $path -class [$self info class]
}
WidgetObject instproc build_widget { path } {
}
WidgetObject instproc info { option args } {
	switch $option {
		"path" {
			if { $args != "" } {
				error "extra arguments in call to 'info $option'"
			}
			return [$self set path_]
		}
		"self" { return $self }
		default {
			return [eval [list $self] next [list $option] $args]
		}
	}
}
WidgetObject instproc unknown { method args } {
	return [eval [list $self] widget_proc [list $method] $args]
}
WidgetObject instproc widget_proc { args } {
	$self instvar widget_proc_
	return [eval [list $widget_proc_] $args]
}
WidgetObject instproc config { args } {
	return [eval [list $self] configure $args]
}
WidgetObject instproc configure_default { cl } {
	set path [$self info path]
	set widget_class [winfo class $path]
	if { $widget_class == [$self info class] } {
		foreach spec [$cl info configspec] {
			set optVal [option get $path [lindex $spec 1] $cl]
			$self configure [lindex $spec 0] $optVal
		}
	} else {
		foreach spec [$cl info configspec] {
			$self configure [lindex $spec 0] [lindex $spec 3]
		}
	}
}
WidgetObject instproc configure { args } {
	set len [llength $args]
	switch $len {
		0 { return [$self configure_all] }
		1 { return [$self configure_one $args] }
		default {
			if { $len % 2 != 0 } {
				error "odd number of arguments for configure"
			}
			for { set i 0 } { $i < $len } { incr i 2 } {
				$self configure_one [lindex $args $i] \
						[lindex $args [expr $i+1]]
			}
		}
	}
}
WidgetObject instproc configure_one { args } {
	set option [lindex $args 0]
	if { [string index $option 0] != "-" } {
		error "invalid option $option: must start with -"
	}
	set option [string range $option 1 end]
	set spec [[$self info class] info configspec -$option]
	if { $spec!="" } {
		set config_proc [lindex $spec 4]
		set cget_proc   [lindex $spec 5]
		if { $cget_proc=={} } { set cget_proc $config_proc }
		if { [llength $args] < 2 } {
			return [lreplace $spec 4 end [$self $cget_proc \
					"-$option"]]
		} else {
			return [$self $config_proc "-$option" [lindex $args 1]]
		}
	}
	foreach cl [[$self info class] info heritage] {
		if { [isWidgetObject $cl] } {
			set spec [$cl info configspec -$option]
			if { $spec!="" } {
				set config_proc [lindex $spec 4]
				set cget_proc   [lindex $spec 5]
				if { $cget_proc=={} } {
					set cget_proc $config_proc
				}
				if { [llength $args] < 2 } {
					return [lreplace $spec 4 end \
							[$self $cget_proc \
							"-$option"]]
				} else {
					return [$self $config_proc "-$option" \
							[lindex $args 1]]
				}
			}
		}
	}
	return [eval [list $self] widget_proc configure $args]
}
WidgetObject instproc configure_all { } {
	set result [$self configure_all_ [$self info class]]
	foreach cl [[$self info class] info heritage] {
		if { [isWidgetObject $cl] } {
			set result [concat $result [$self configure_all_ $cl]]
		}
	}
	set result [concat $result [$self widget_proc configure]]
	return $result
}
WidgetObject instproc configure_all_ { cl } {
	set result ""
	foreach spec [$cl info configspec] {
		set option [lindex $spec 0]
		if { $option != "-options" } {
			lappend result [$self configure $option]
		}
	}
	return $result
}
WidgetObject instproc cget { option } {
	return [lindex [$self configure_one $option] 4]
}
WidgetObject instproc widget_options { option args } {
	if { [llength $args]==0 } {
		error "options has no value; cannot read it"
	}
	set root [$self info path]
	foreach option [lindex $args 0] {
		set opt [string trim [lindex $option 0]]
		set arg [lindex $option 1]
		set lastdot [string last . $opt]
		if { $lastdot <= 0 } {
			set path $root
		} else {
			set firstdot  [string first . $opt]
			set path [string range $opt 0 [expr $firstdot-1]]
			set path [$self subwidget $path]
			if { $firstdot < $lastdot } {
				set path $path.[string range $opt \
						[expr $firstdot+1] \
						[expr $lastdot -1]]
			}
		}
		set opt [string range $opt [expr $lastdot+1] end]
		$path configure -$opt $arg
	}
}
WidgetObject instproc subwidget { widget args } {
	set path "[$self info path].$widget"
	if { ![winfo exists $path] } {
		$self instvar subwidgets_
		if { ![info exists subwidgets_($widget)] } {
			error "no subwidget $widget inside [$self info path]"
		}
		set path $subwidgets_($widget)
	}
	if { [llength $args]==0 } {
		return $path
	}
	return [eval [list $path] $args]
}
WidgetObject instproc set_subwidget { name path } {
	$self instvar subwidgets_
	$self set subwidgets_($name) $path
}
WidgetObject instproc ignore_args { args } {
}
WidgetObject instproc do_when_idle { command } {
	$self instvar do_idle_ids_
	set command [string trim $command]
	if ![info exists do_idle_ids_($command)] {
		set do_idle_ids_($command) \
				[after idle "WidgetObject do_idle_ \
				[list $self] [list $command]"]
	}
}
WidgetObject proc do_idle_ { o command } {
	$o instvar do_idle_ids_
	catch {unset do_idle_ids_($command)}
	if { [info command $o]!=$o } {
		return
	}
	set w [$o info path]
	if {![winfo exists $w] || [string compare [winfo class $w] \
			[$o info class]] != 0} {
		return
	} else {
		uplevel #0 $command
	}
}
WidgetClass proc transparent_gif { {color {}} } {
	global TRANSPARENT_GIF_COLOR
	if { $color!={} } {
		set TRANSPARENT_GIF_COLOR $color
	} else {
		set TRANSPARENT_GIF_COLOR [$self widget_default -background]
	}
}
WidgetClass proc EntryBindings { tag } {
	bind $tag <FocusIn>  "$self EntryBindings_FocusIn %W"
	bind $tag <FocusOut> "$self EntryBindings_FocusOut %W"
}
WidgetClass proc EntryBindings_FocusIn { entry } {
	if [string compare [$entry get] ""] {
		$entry selection from 0
		$entry selection to   end
		$entry icursor end
	} else {
		$entry selection clear
	}
}
WidgetClass proc EntryBindings_FocusOut { entry } {
    $entry selection clear
}
WidgetClass EntryBindings Entry
image create photo Icons(check)
Icons(check) put \x47\x49\x46\x38\x39\x61\x16\x0\x14\x0\xC2\x0\x0\xD8\xD8\xD8\xF8\xFC\xF8\x0\x0\x0\x38\xF8\x30\x80\x80\x80\x0\x0\x0\x0\x0\x0\x0\x0\x0\x21\xF9\x4\x1\x0\x0\x0\x0\x2C\x0\x0\x0\x0\x16\x0\x14\x0\x0\x3\x53\x8\xBA\xDC\xFE\x50\x85\x20\x62\x9C\x43\x10\x62\x1B\xCE\x5B\xB7\x7C\x82\xC6\x49\xD3\x43\x9A\x27\x10\xC\x99\xF7\x66\xEC\x38\x9B\x28\x5C\x6E\xAD\xB\x83\x9C\xF\xB0\xE7\xD3\x6D\x84\x3B\x62\x11\x46\x40\xD6\x3C\xBF\x81\x93\xA7\x8A\x46\x93\x4A\x89\x55\xF7\x84\xCC\x7E\x58\x91\x0\xDC\xED\x94\xC2\xA2\x5\x2F\x94\x66\x50\xDB\xF0\x46\x2\x0\x3B
image create photo Icons(cross)
Icons(cross) put \x47\x49\x46\x38\x39\x61\x14\x0\x14\x0\xC2\x0\x0\xD8\xD8\xD8\xF8\xFC\xF8\x0\x0\x0\xF8\x14\x40\x80\x80\x80\x0\x0\x0\x0\x0\x0\x0\x0\x0\x21\xF9\x4\x1\x0\x0\x0\x0\x2C\x0\x0\x0\x0\x14\x0\x14\x0\x0\x3\x56\x8\xBA\xBC\x11\x2D\x8A\xF6\xC6\x88\xCA\x4E\x17\xEC\xD8\x8C\x27\x6C\x95\x26\x10\x8D\xF7\x1\xE5\x77\x12\xA8\x23\xA\x9D\x9\xC3\x4C\xAD\xDA\x37\xB6\x6B\xB7\x98\x6F\xF7\x12\xE\x89\xC6\x23\x11\xB3\xF8\xA9\x40\xA9\x19\x11\x9A\x99\xB5\x5C\xC6\xE7\xAB\x34\xEA\x55\xB1\xB7\x4E\xD7\xB\xE0\xC5\x1E\xC5\xE4\x38\x19\x8C\xB4\xDD\xC9\x5\x8E\xD9\x48\x0\x0\x3B
image create photo Icons(plus)
Icons(plus) put \x47\x49\x46\x38\x39\x61\x12\x0\x12\x0\xC2\x0\x0\xD8\xD8\xD8\x0\x0\x0\xF8\xFC\xF8\xB8\xBC\xB8\x38\xF8\x30\x0\x0\x0\x0\x0\x0\x0\x0\x0\x21\xF9\x4\x1\x0\x0\x0\x0\x2C\x0\x0\x0\x0\x12\x0\x12\x0\x0\x3\x4A\x8\xBA\xDC\xFE\xF0\x85\x39\xA3\x9A\x22\xE7\x2A\xF3\x20\x44\x30\x6C\x4E\x20\xC\x28\x28\xA2\x43\xD0\x98\xAC\xCA\xB6\xC\x1C\x87\x33\x7D\x9\x60\xEF\xE3\xAE\xDD\xEF\x27\xA\x2\x4C\x94\x80\x2A\xA9\x3B\x9E\x6E\x2B\x96\xD1\x9\x9D\x4D\xA9\x29\x9C\xB4\x24\x9D\x6C\x25\x51\x14\x27\x92\xBC\x5A\x22\x9\x0\x3B
image create photo Icons(minus)
Icons(minus) put \x47\x49\x46\x38\x39\x61\x12\x0\x12\x0\xC2\x0\x0\xD8\xD8\xD8\x0\x0\x0\xF8\xFC\xF8\xB8\xBC\xB8\x38\xF8\x30\x0\x0\x0\x0\x0\x0\x0\x0\x0\x21\xF9\x4\x1\x0\x0\x0\x0\x2C\x0\x0\x0\x0\x12\x0\x12\x0\x0\x3\x41\x8\xBA\xDC\xFE\xF0\x85\x39\xA3\x9A\x22\xE7\x2A\xF3\xF8\xDF\xE6\x4\x2\x68\x82\x41\x43\x9E\x67\xBA\xAC\x6C\xFB\xA\x44\x6D\xDF\xC1\xE0\x2\xE4\xED\x13\xB9\x1D\x89\x42\x24\xEA\x66\x31\x19\x32\x79\x64\xC0\x92\xBB\x17\x33\xEA\xCC\x99\x38\x91\xA2\x65\xBB\x48\x0\x0\x3B
image create photo Icons(trashcan)
Icons(trashcan) put \x47\x49\x46\x38\x39\x61\x14\x0\x14\x0\xC2\x0\x0\xD8\xD8\xD8\x50\x54\x50\x0\x0\x0\xB8\xBC\xB8\xF8\xFC\xF8\x0\x0\x0\x0\x0\x0\x0\x0\x0\x21\xF9\x4\x1\x0\x0\x0\x0\x2C\x0\x0\x0\x0\x14\x0\x14\x0\x0\x3\x5C\x8\xBA\xDC\xEE\x21\xCA\xD7\xA2\xB8\x78\x44\x1A\xB0\xCF\xC1\x23\x7D\xD7\x4\x11\x9A\x24\xD\x1A\x14\xC\x4\xCA\x6\x72\xBA\xBC\x5A\xAC\xC1\x7B\x3A\x2B\xAB\xD8\xB\xF5\x52\x85\x18\x34\x22\xAF\xB8\x39\x9\x97\xBB\x63\x5\x46\x18\x46\x9B\x95\x58\x15\x6A\xCA\x2A\x95\x45\x11\xD5\x8A\xC3\x22\xB5\xB8\x5E\xB\xC2\x92\x45\x74\x6B\x17\x6B\x4E\x94\x72\x8C\x76\x8A\xBE\x91\x0\x0\x3B
image create photo Icons(warning)
Icons(warning) put \x47\x49\x46\x38\x39\x61\x28\x0\x28\x0\xC2\x0\x0\xD8\xD8\xD8\x78\x7C\x0\xF8\xFC\x0\xB8\xBC\xB8\x0\x0\x0\x78\x7C\x78\x0\x0\x0\x0\x0\x0\x21\xF9\x4\x1\x0\x0\x0\x0\x2C\x0\x0\x0\x0\x28\x0\x28\x0\x0\x3\xB8\x8\xBA\xDC\xFE\x30\xCA\x49\xAB\xBD\x38\xEB\x17\xFA\xCE\x81\x20\xC\xC4\x67\x85\xE2\x48\x14\xE6\x84\xA6\x2B\xDB\x72\x69\x4A\x16\xF2\xCC\xBC\x75\xAC\xEF\xB5\xDA\x2D\xA7\xE3\x5\x7D\x3F\x63\x70\x98\xB4\x11\x9E\x3\x18\xAE\xD8\x7B\x3E\x9D\xD3\x16\xCF\x7A\x95\x12\x35\x46\x2E\x41\x88\xDC\x84\xB9\xC7\x2C\x38\x28\x10\x2F\xCB\x18\x65\xC0\xAA\x84\x9F\xD8\x2A\x28\x9B\x19\xC7\xB7\xBB\x6C\x76\x2E\x7E\x2\x73\x4A\x22\x7C\x15\x87\x88\x4\x51\x7E\x82\x10\x8B\x30\x84\x2A\x6A\x12\x92\x94\x3D\x96\x91\x99\x24\x8D\x84\x89\x9C\x94\x68\x84\x90\xB\x98\x22\xA4\x7E\xA1\xD\xA8\x79\x8E\xA5\x9B\x40\x99\xB4\x5E\x5F\xA7\xB5\xB5\x43\xB7\xB8\xB9\xA0\x31\xB2\x3B\x62\xC3\xC4\xC3\x38\xC7\x14\xC7\xCA\xCB\xCC\xCD\xC1\xF\xCE\xD1\xCE\x3F\xD4\xD5\xD6\xD7\xD8\x9\x0\x3B
image create photo Icons(minimize)
Icons(minimize) put \x47\x49\x46\x38\x39\x61\x10\x0\xA\x0\xA1\x0\x0\xD8\xD8\xD8\xF8\xFC\xF8\x0\x0\x0\x80\x80\x80\x21\xF9\x4\x1\x0\x0\x0\x0\x2C\x0\x0\x0\x0\x10\x0\xA\x0\x0\x2\x1D\x84\x8F\x79\xC1\xED\x81\x82\x98\xB4\x8A\x11\x6D\x1D\x38\x6B\xAE\x0\xD2\xD6\x85\xE3\x55\x86\x22\xAA\xB6\xEE\x5B\x0\x0\x3B
image create photo Icons(maximize)
Icons(maximize) put \x47\x49\x46\x38\x39\x61\x10\x0\xA\x0\xA1\x0\x0\xD8\xD8\xD8\xF8\xFC\xF8\x0\x0\x0\x80\x80\x80\x21\xF9\x4\x1\x0\x0\x0\x0\x2C\x0\x0\x0\x0\x10\x0\xA\x0\x0\x2\x1D\x84\x8F\xA9\x16\xBB\x21\x86\x43\x50\xC4\x9\xAA\xBD\x6F\x7B\x99\x68\x9E\x5\x32\xE3\x59\x2\xC3\xCA\xB6\x29\x96\x14\x0\x3B
image create photo Icons(folder)
Icons(folder) put \x47\x49\x46\x38\x39\x61\x14\x0\xF\x0\xF2\x0\x0\xD8\xD8\xD8\x7F\x7F\x7F\xFF\xFF\x0\xFF\xFF\xFF\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x21\xF9\x4\x1\x0\x0\x0\x0\x2C\x0\x0\x0\x0\x14\x0\xF\x0\x0\x3\x41\x8\xBA\xDC\xBE\x21\xC6\xF7\x2\x10\x17\x58\xA\x33\xC6\x92\xE4\x4\x43\x69\x9E\x65\x40\x34\xE4\xE7\x79\x2A\x3B\xBC\x2E\xB8\x32\x2D\xD\xDF\xD0\x5C\xBF\x31\xDC\xE0\x57\xB\xF6\x74\x2E\xA3\x22\x47\xBC\x28\x35\xA1\x68\x88\xB7\x20\x58\xAF\x58\x2C\x67\xCB\x48\x0\x0\x3B
image create photo Icons(folderopen)
Icons(folderopen) put \x47\x49\x46\x38\x39\x61\x14\x0\xF\x0\xC2\x0\x0\xD8\xD8\xD8\x78\x7C\x78\xF8\xFC\xF8\xB8\xBC\xB8\xF8\xFC\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x21\xF9\x4\x1\x0\x0\x0\x0\x2C\x0\x0\x0\x0\x14\x0\xF\x0\x0\x3\x45\x8\xBA\xDC\xCE\x21\xC6\xF7\x82\xB8\x37\x50\x28\x6\xF1\x83\x20\x49\x8E\xF5\x9D\x21\x26\x16\x8D\x5\xA2\x68\xC0\x2E\x63\x3D\x12\x32\xA7\xEE\xF2\x90\xD3\x1D\xD8\xAB\x10\x99\x1\x5F\x48\xD9\xF\x28\x44\x11\x8D\x4C\xE4\x49\x6\x55\xD8\x6C\x85\xAA\x22\xCB\xED\x76\x37\xE0\x45\x2\x0\x3B
image create photo Icons(folderup)
Icons(folderup) put \x47\x49\x46\x38\x39\x61\x14\x0\xF\x0\xF2\x0\x0\xD8\xD8\xD8\x7F\x7F\x7F\xFF\xFF\x0\xFF\xFF\xFF\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x21\xF9\x4\x1\x0\x0\x0\x0\x2C\x0\x0\x0\x0\x14\x0\xF\x0\x0\x3\x45\x8\xBA\xDC\xBE\x21\xC6\xF7\x2\x10\x17\x58\xA\x33\xC6\x92\xE4\x4\x43\x69\x9E\x65\x40\x34\xE4\x17\x7C\x9E\xCA\xE\x97\x4\x83\x2B\xD3\x86\x6F\x9C\x43\x34\x90\x27\x23\xD3\xD\x5C\xB7\xDA\x4F\x41\x22\xF2\x70\xB3\xE4\xAD\x8\xE1\x59\x23\x4B\x5\x61\xCB\xED\x76\x39\x60\x46\x2\x0\x3B
image create photo Icons(textfile)
Icons(textfile) put \x47\x49\x46\x38\x39\x61\xF\x0\xF\x0\xA1\x0\x0\xD8\xD8\xD8\x78\x7C\x78\xF8\xFC\xF8\x0\x0\x0\x21\xF9\x4\x1\x0\x0\x0\x0\x2C\x0\x0\x0\x0\xF\x0\xF\x0\x0\x2\x32\x84\x8F\x69\xC1\xCD\xA\x82\x98\xB3\x29\x49\x85\x4B\x92\xD5\x36\x20\x58\x56\x85\x47\xE7\x94\x22\x49\x5\xE6\xA2\xA5\xDA\x1B\xB1\xEA\x19\x37\x37\x6C\xBB\xA2\x3\xA4\x1\x6\xC4\xA2\x11\x82\x34\x14\x0\x0\x3B
image create photo Icons(browse)
Icons(browse) put \x47\x49\x46\x38\x39\x61\x12\x0\x12\x0\x84\x0\x0\xD8\xD8\xD8\x78\x7C\x78\x0\xF8\xF0\xF0\xF8\xF0\x0\x0\x0\xF0\xFC\xF0\x0\xFC\xF0\x0\xF8\xF8\xF0\xF8\xF8\x0\x78\x78\x0\xFC\xF8\xF8\xF8\xF0\x0\x7C\x78\x0\x0\xF0\x0\x0\x78\x0\x0\xF8\x0\x0\x70\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x21\xF9\x4\x1\x0\x0\x0\x0\x2C\x0\x0\x0\x0\x12\x0\x12\x0\x0\x5\x64\x20\x20\x8E\x64\x69\x8A\x41\x1A\x9C\x65\x2A\xC\x2F\x41\xB0\x40\x0\xC3\x85\x90\xCF\x67\x60\xC\xBF\xD7\x61\xC0\x6B\xBD\x4\x88\x9F\x32\x51\x1C\xD9\x14\xB0\x5\x52\xB0\x60\x34\x51\x2F\x25\x10\xC8\x34\xD9\xA8\x43\xE1\xC0\xDA\xCB\x99\x75\xE4\xDE\x11\xF1\x62\x30\xAF\x23\x19\x63\x6E\x25\x34\x1A\xF0\xB8\x8C\xE0\x70\x18\xEE\x79\x27\xE\x2\x80\x34\x25\x83\xF\x78\x86\x24\x10\x7F\x81\x27\x32\x8B\x34\x21\x0\x3B
image create photo Icons(up)
Icons(up) put \x47\x49\x46\x38\x39\x61\x9\x0\x8\x0\xA1\x0\x0\xD8\xD8\xD8\xF8\xFC\xF8\x0\x0\x0\x80\x80\x80\x21\xF9\x4\x1\x0\x0\x0\x0\x2C\x0\x0\x0\x0\x9\x0\x8\x0\x0\x2\x15\x84\x11\xA7\x21\xA3\x28\xA2\x33\x2C\x4A\x68\xED\x8\x5C\x8F\x9\x68\xF\xF0\x4D\x5\x0\x3B
image create photo Icons(down)
Icons(down) put \x47\x49\x46\x38\x39\x61\x9\x0\x8\x0\xA1\x0\x0\xD8\xD8\xD8\xF8\xFC\xF8\x0\x0\x0\x80\x80\x80\x21\xF9\x4\x1\x0\x0\x0\x0\x2C\x0\x0\x0\x0\x9\x0\x8\x0\x0\x2\x14\x4\x82\x61\x1B\xE2\x63\x92\x13\x3\xB6\x39\x2D\xA6\x2C\xAF\xC8\x7D\x6\xB4\x14\x0\x3B
image create photo Icons(fastup)
Icons(fastup) put \x47\x49\x46\x38\x39\x61\x9\x0\x8\x0\xA1\x0\x0\xD8\xD8\xD8\xF8\xFC\xF8\x0\x0\x0\x80\x80\x80\x21\xF9\x4\x1\x0\x0\x0\x0\x2C\x0\x0\x0\x0\x9\x0\x8\x0\x0\x2\x15\x84\x23\x63\x8B\x92\xEC\xA2\x6A\xD1\x8D\x80\xD1\xD8\xA\xD0\xEE\x55\xF\x55\xD\x5\x0\x3B
image create photo Icons(fastdown)
Icons(fastdown) put \x47\x49\x46\x38\x39\x61\x9\x0\x8\x0\xA1\x0\x0\xD8\xD8\xD8\x0\x0\x0\x80\x80\x80\xF8\xFC\xF8\x21\xF9\x4\x1\x0\x0\x0\x0\x2C\x0\x0\x0\x0\x9\x0\x8\x0\x0\x2\x13\x44\x8E\x21\x30\xA9\x0\xDB\x59\x6C\xD8\x17\xDD\x64\x8E\xF2\xD\x65\x5E\x1\x0\x3B
image create photo Icons(cal)
Icons(cal) put \x47\x49\x46\x38\x39\x61\x1C\x0\x14\x0\xA5\x0\x0\xF8\xF8\xF8\xE0\xE0\xF8\x98\x98\xE0\x68\x68\xC0\xF8\xE0\xF8\x0\x0\xC0\x0\x0\x98\x0\x0\x68\xC0\x98\x68\xF8\xF8\xC0\xA8\xC0\xF8\xE0\xC0\x0\xC0\xC0\x98\xC0\xC0\x0\x68\x0\xC0\xE0\xE0\xC0\xF8\xF8\xE0\x68\x68\x68\xA8\xAC\x98\x68\x0\x68\xE0\xE0\x0\xF8\xF8\x98\x68\x68\xE0\x98\x68\x0\x68\x68\x0\xC0\xC0\xE0\xE0\xE0\x68\xC0\x98\x0\xF8\xF8\x68\xE0\xF8\xF8\x98\x68\x68\xF8\xF8\x0\x0\x68\xE0\x98\x68\xC0\xE0\xE0\xE0\xC0\xC0\x68\xF8\xE0\x0\x68\x68\x98\x98\x98\xC0\x0\x68\xC0\x68\x0\x98\xE0\xE0\x98\x0\x0\xE0\x98\x98\x98\xC0\x98\xC0\x98\x98\x0\xE0\xC0\x68\xC0\x98\xE0\xF8\xE0\x68\xF8\xE0\x98\xF8\xE0\xC0\xE0\xC0\x98\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x21\xF9\x4\x1\x0\x0\x0\x0\x2C\x0\x0\x0\x0\x1C\x0\x14\x0\x0\x6\xFD\x40\x80\x70\x48\x2C\x1A\x8F\x48\x40\x40\x30\x68\x12\x92\x50\xA5\xA0\x60\x30\x1C\xC\x88\x44\x32\x80\x54\x50\xAB\xB\x86\xA1\xA1\x35\x6\xA\x8E\x7\xA4\x28\xA8\x1A\x22\xD\x49\x61\x42\x59\xB3\xA9\x87\x85\x5D\xD8\xAE\xD2\x1F\x73\xB\x15\x46\x16\x55\x17\x18\x14\x44\x19\x5F\x6\xB\x9\x4\x19\x1A\x83\x6C\x55\x1B\x11\x1B\x93\x4A\x8C\xD\x1C\x44\x1\x4\x1D\xA0\x0\x8B\x6\x1B\x1E\x11\x89\x43\x85\x86\x1F\x43\x4B\x5\x5\x20\x5\x21\x22\x54\x97\xA5\x99\x1\x6E\x8D\x76\x67\xBB\x6\x17\x23\x86\xC0\x24\x44\xAB\xC0\x9D\x9A\x95\x25\x60\x26\x6E\x74\x7B\x0\x3\x6E\xD\x93\x7D\x1B\xD\x86\x24\x27\x6E\x82\x45\xD3\x95\x83\xBE\x1E\xD\x54\xD0\x5F\xD5\x84\x6E\x28\x29\x1\x20\xBF\xA5\x29\x2A\xD4\x47\x1D\x8C\x6\xF7\xBB\x54\x1E\x2B\x55\x2C\x5C\x45\x2\x98\x18\x80\xE2\xC0\x84\x16\x2C\xE0\x1D\x68\xE1\x82\x14\x3E\x11\x47\x5E\xE4\x83\x57\x5\x96\xA1\x54\xAE\xE6\xAD\xA3\xB8\xEB\xE0\x2\x18\xD1\x0\xB4\xB9\xD0\xC0\x85\x86\x18\x29\x64\xA4\x78\x80\x32\xC5\xC\xD\x29\x52\xC4\x48\x10\x52\x48\x0\x11\x10\x6A\x46\x29\x12\x4\x0\x3B
image create photo Icons(ear)
Icons(ear) put \x47\x49\x46\x38\x37\x61\xD\x0\x14\x0\xF0\x0\x0\xFF\xFF\xFF\x0\x0\x0\x2C\x0\x0\x0\x0\xD\x0\x14\x0\x0\x2\x2D\x84\x8F\x9\xC1\x9D\xAC\xA0\x9\x6A\xD2\x65\x1D\xC6\x72\x7A\x7A\x35\x10\x8\x72\x63\x65\x6D\x48\x58\xAE\xAC\x9A\x95\x57\x45\xA2\x5C\xE4\xCC\xA8\xEE\xAD\x91\xFF\x4B\xE1\x34\x87\x2\x0\x3B
image create photo Icons(hand)
Icons(hand) put \x47\x49\x46\x38\x37\x61\x10\x0\x10\x0\xF0\x0\x0\xFF\xFF\xFF\x0\x0\x0\x2C\x0\x0\x0\x0\x10\x0\x10\x0\x0\x2\x29\x84\xF\x11\xC8\xB9\xEB\x20\x82\xCA\x50\x46\x6F\xDA\x47\x67\xCE\x79\x96\x3\x4E\xD6\xD7\x74\x92\xD4\x68\x69\x7\xBF\xE3\xFC\xB2\x25\xD6\xA6\x76\x6C\xEA\xB9\x51\x0\x0\x3B
image create photo VcrIcons(play)
VcrIcons(play) put \x47\x49\x46\x38\x39\x61\x14\x0\x14\x0\xF7\x0\x0\xD8\xD8\xD8\xF8\xFC\xF8\x39\xF8\x31\x0\x0\x0\x80\x80\x80\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xE1\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xE1\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xC\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xE1\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xC\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x23\xE1\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x23\xE1\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x25\xE1\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xC\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x2A\xE1\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xC\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xC\x0\x0\x0\x8F\x80\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xC\x0\x0\x0\x62\x80\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xC\x0\x0\x0\x23\x80\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xC\x0\x0\x0\x25\x80\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xC\x0\x0\x0\x25\x80\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xC\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xC\x0\x0\x0\x23\x81\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xC\x0\x0\x0\x25\x81\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x11\x0\x0\x0\x25\x81\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x11\x0\x0\x0\x25\x81\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x11\x0\x0\x0\x37\x81\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xC\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x11\x0\x0\x0\xA6\x80\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xC\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x11\x0\x0\x0\x92\x80\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x16\x0\x0\x0\x93\x80\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x16\x0\x0\x0\xCD\x80\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xC\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x16\x0\x0\x0\x45\xE1\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xA7\xA7\xA7\x0\x2F\x0\x4F\x0\x0\x11\xA9\x0\xF8\x23\x0\x0\xB8\x0\x9E\x0\xAC\xAC\xAC\x0\xAD\xAD\xAD\x0\xAE\xAE\xAE\x0\xAF\xAF\xAF\x0\xB0\xB0\xB0\x0\xB1\xB1\xB1\x0\xB3\xB3\xB3\x0\xB4\xB4\xB4\x0\xB5\xB5\xB5\x0\xB6\xB6\xB6\x0\xB7\xB7\xB7\x0\xB8\xB8\xB8\x0\xB9\xB9\xB9\x0\xBA\xBA\xBA\x0\xBB\xBB\xBB\x0\xBC\xBC\xBC\x0\xBD\xBD\xBD\x0\xBE\xBE\xBE\x0\xC0\xC0\xC0\x0\xC1\xC1\xC1\x0\xC2\xC2\xC2\x0\xC3\xC3\xC3\x0\xC4\xC4\xC4\x0\xC5\xC5\xC5\x0\xC6\xC6\xC6\x0\xC7\xC7\xC7\x0\xC8\xC8\xC8\x0\xC9\xC9\xC9\x0\xCA\xCA\xCA\x0\xCC\xCC\xCC\x0\xCD\xCD\xCD\x0\xCE\xCE\xCE\x0\x21\xF9\x4\x1\x0\x0\x1\x0\x2C\x0\x0\x0\x0\x14\x0\x14\x0\x40\x8\x5D\x0\x3\x8\x1C\x48\xB0\xA0\xC1\x81\x2\x12\x2A\x5C\x98\xD0\xD0\x41\x2\x10\x23\x12\x38\x68\x70\x21\x45\x8A\xC\x5\x18\x9A\x66\x48\x22\xC4\x8B\x20\x2B\x66\x14\x10\x32\xC0\x48\x85\x1B\x3B\x4E\x24\xD8\x90\xA3\xC7\x95\x25\x63\xCA\xC4\x48\x72\xA6\xC0\x8C\x32\x4F\x26\x4\xA9\x13\xE5\x47\x96\x23\x39\x4E\x93\x58\x70\xA1\xD0\x97\x7\xA7\x79\x19\xEA\x31\x64\x53\x9B\x32\x3\x2\x0\x3B
image create photo VcrIcons(reverse)
VcrIcons(reverse) put \x47\x49\x46\x38\x39\x61\x14\x0\x14\x0\xF7\x0\x0\xD8\xD8\xD8\xF8\xFC\xF8\x39\xF8\x31\x0\x0\x0\x80\x80\x80\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xE1\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xE1\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xC\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xE1\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xC\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x23\xE1\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x23\xE1\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x25\xE1\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xC\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x2A\xE1\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xC\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xC\x0\x0\x0\x8F\x80\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xC\x0\x0\x0\x62\x80\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xC\x0\x0\x0\x23\x80\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xC\x0\x0\x0\x25\x80\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xC\x0\x0\x0\x25\x80\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xC\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xC\x0\x0\x0\x23\x81\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xC\x0\x0\x0\x25\x81\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x11\x0\x0\x0\x25\x81\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x11\x0\x0\x0\x25\x81\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x11\x0\x0\x0\x37\x81\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xC\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x11\x0\x0\x0\xA6\x80\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xC\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x11\x0\x0\x0\x92\x80\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x16\x0\x0\x0\x93\x80\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x16\x0\x0\x0\xCD\x80\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xC\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x16\x0\x0\x0\x45\xE1\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xA7\xA7\xA7\x0\x41\x0\x4F\x0\x0\x11\xA9\x0\xC0\x0\x9E\x0\xC0\x0\x9E\x0\xAC\xAC\xAC\x0\xAD\xAD\xAD\x0\xAE\xAE\xAE\x0\xAF\xAF\xAF\x0\xB0\xB0\xB0\x0\xB1\xB1\xB1\x0\xB3\xB3\xB3\x0\xB4\xB4\xB4\x0\xB5\xB5\xB5\x0\xB6\xB6\xB6\x0\xB7\xB7\xB7\x0\xB8\xB8\xB8\x0\xB9\xB9\xB9\x0\xBA\xBA\xBA\x0\xBB\xBB\xBB\x0\xBC\xBC\xBC\x0\xBD\xBD\xBD\x0\xBE\xBE\xBE\x0\xC0\xC0\xC0\x0\xC1\xC1\xC1\x0\xC2\xC2\xC2\x0\xC3\xC3\xC3\x0\xC4\xC4\xC4\x0\xC5\xC5\xC5\x0\xC6\xC6\xC6\x0\xC7\xC7\xC7\x0\xC8\xC8\xC8\x0\xC9\xC9\xC9\x0\xCA\xCA\xCA\x0\xCC\xCC\xCC\x0\xCD\xCD\xCD\x0\xCE\xCE\xCE\x0\x21\xF9\x4\x1\x0\x0\x1\x0\x2C\x0\x0\x0\x0\x14\x0\x14\x0\x40\x8\x7B\x0\x3\x8\x1C\x48\xB0\xA0\xC1\x81\x2\x12\x2A\x5C\x28\x0\x1A\x1\x2\x7\xB\xC2\x43\x87\xEE\xA1\xC5\x88\x5\x17\x22\x83\x58\x90\x5C\x45\x8B\xC\x5\x18\x7A\x88\xB1\x64\xC9\x90\x9\x1D\x72\x14\x8\xE0\x21\x4A\x85\x23\x57\x4A\xA4\x68\x91\x40\xC2\x8D\x32\x4D\x6\x0\x80\xE\x1C\x0\x9D\x40\x4F\x8A\x4\xA7\x33\x24\x28\x2\xD8\xE\xBE\x4C\x78\x54\x26\xBF\xA5\xA\x71\x12\x4\x80\xD\x24\xCA\x98\x6\xC1\x91\x23\x57\x53\x23\x49\x8C\x5B\xB9\x3E\x84\x86\x15\x28\x0\x8F\x55\xC9\x5\x8D\x18\x10\x0\x3B
image create photo VcrIcons(pause)
VcrIcons(pause) put \x47\x49\x46\x38\x39\x61\x14\x0\x14\x0\xC2\x0\x0\xD8\xD8\xD8\xF8\xFC\xF8\xB8\xBC\xB8\x0\x0\x0\x80\x80\x80\x0\x0\x0\x0\x0\x0\x0\x0\x0\x21\xF9\x4\x1\x0\x0\x0\x0\x2C\x0\x0\x0\x0\x14\x0\x14\x0\x0\x3\x49\x8\xBA\xDC\xFE\xF0\x85\x19\x16\xAD\x30\x88\x3D\x94\xE6\xD9\x26\xC\x4\xF1\x8D\xA5\x73\x92\xA6\xC8\xAA\x6E\xB9\xA6\xCD\xDC\x72\x34\x63\xDB\x30\x7E\xA3\x84\x1E\x90\x57\x8B\xFD\x5E\x45\x1F\x51\x67\x5C\x5A\x9A\xC6\xC7\x60\xFA\xA2\x22\x1D\xA5\xAC\x22\x9B\x6B\x70\x83\x80\x6F\x64\x4C\x2E\x3\x12\x0\x3B
image create photo VcrIcons(stop)
VcrIcons(stop) put \x47\x49\x46\x38\x39\x61\x10\x0\x14\x0\xC2\x0\x0\xD8\xD8\xD8\x0\x0\x0\xB8\xBC\xB8\x50\x54\x50\xF8\xFC\xF8\x80\x80\x80\x0\x0\x0\x0\x0\x0\x21\xF9\x4\x1\x0\x0\x0\x0\x2C\x0\x0\x0\x0\x10\x0\x14\x0\x0\x3\x3C\x8\xBA\xDC\xFE\x30\xB2\x40\xAB\xD\x62\x8E\xCD\x3B\xD1\x5D\x48\x14\x85\x12\x84\x22\x69\xA2\x9E\xA\x9C\xEC\x36\x96\x6F\x2C\xBB\x70\x3C\xAF\xF6\x5E\xF7\x38\xDB\xC0\x27\x20\x18\x8F\x48\x9F\x82\xC4\x6C\x32\x19\xCE\x28\x4D\x42\xAD\x5A\x1\x9\x0\x3B
image create photo VcrIcons(sstop)
VcrIcons(sstop) put \x47\x49\x46\x38\x39\x61\x14\x0\x10\x0\x80\x0\x0\x0\x0\x0\xBF\xBF\xBF\x21\xF9\x4\x1\x0\x0\x1\x0\x2C\x0\x0\x0\x0\x14\x0\x10\x0\x0\x2\x1C\x8C\x8F\xA9\xCB\xED\xF\x17\x98\x94\xBE\x8A\x2F\xB6\x6E\xF3\xE6\x4D\x9A\x37\x6E\x65\xD6\x85\xD1\xCA\xB6\x4C\x1\x0\x3B
image create photo VcrIcons(splay)
VcrIcons(splay) put \x47\x49\x46\x38\x39\x61\x14\x0\x10\x0\x80\x0\x0\x0\x0\x0\xBF\xBF\xBF\x21\xF9\x4\x1\x0\x0\x1\x0\x2C\x0\x0\x0\x0\x14\x0\x10\x0\x0\x2\x1D\x8C\x8F\xA9\xCB\xED\xF\x17\x88\xA\x58\x7A\xAC\xC6\xBA\xC7\xE\x3E\x60\xD8\x8C\x97\x48\x42\x1E\x37\x61\xEE\x8B\x14\x0\x3B
image create photo VcrIcons(record)
VcrIcons(record) put \x47\x49\x46\x38\x39\x61\x10\x0\x14\x0\xC2\x0\x0\xD8\xD8\xD8\x0\x0\x0\xB8\xBC\xB8\xF8\x14\x40\xF8\xFC\xF8\x80\x80\x80\x0\x0\x0\x0\x0\x0\x21\xF9\x4\x1\x0\x0\x0\x0\x2C\x0\x0\x0\x0\x10\x0\x14\x0\x0\x3\x3C\x8\xBA\xDC\xFE\x30\xB2\x40\xAB\xD\x62\x8E\xCD\x3B\xD1\x5D\x48\x14\x85\x12\x84\x22\x69\xA2\x9E\xA\x9C\xEC\x36\x96\x6F\x2C\xBB\x70\x3C\xAF\xF6\x5E\xF7\x38\xDB\xC0\x27\x20\x18\x8F\x48\x9F\x82\xC4\x6C\x32\x19\xCE\x28\x4D\x42\xAD\x5A\x1\x9\x0\x3B
image create photo VcrIcons(redbullet)
VcrIcons(redbullet) put \x47\x49\x46\x38\x39\x61\xA\x0\xA\x0\xC2\x0\x0\xD8\xD8\xD8\xF8\x60\x40\xF8\x0\x0\xF8\xA4\x0\xB0\x20\x20\x0\x0\x0\x0\x0\x0\x0\x0\x0\x21\xF9\x4\x1\x0\x0\x0\x0\x2C\x0\x0\x0\x0\xA\x0\xA\x0\x0\x3\x1A\x8\xBA\xDC\xBE\x21\x8\x17\x46\x9C\xD0\x5E\xB2\xC4\x15\x2\xA7\x80\x24\x21\x8E\xA1\xE9\x98\xE7\xB3\x24\x0\x3B
image create photo VcrIcons(greenbullet)
VcrIcons(greenbullet) put \x47\x49\x46\x38\x39\x61\xA\x0\xA\x0\xA2\x0\x0\x0\x0\x0\xFF\xFF\xFF\x28\x88\x50\x0\xFC\x0\x30\xCC\x30\x98\xF8\x98\xFF\xFF\xFF\x0\x0\x0\x21\xF9\x4\x1\x0\x0\x6\x0\x2C\x0\x0\x0\x0\xA\x0\xA\x0\x0\x3\x1A\x68\xBA\xDC\xBE\x23\xBA\x51\x22\x61\x34\xE\x22\x16\xB1\x4\xE7\x85\xA1\xD0\x8D\xE6\xC9\xA4\x8F\x93\x0\x0\x3B
image create photo VcrIcons(browse_small)
VcrIcons(browse_small) put \x47\x49\x46\x38\x39\x61\xA\x0\xA\x0\xC2\x0\x0\xD8\xD8\xD8\x78\x7C\x78\x0\xFC\xF8\xF8\xFC\xF8\x0\x0\x0\x0\x7C\x78\x0\x0\xF8\x0\x0\x0\x21\xF9\x4\x1\x0\x0\x0\x0\x2C\x0\x0\x0\x0\xA\x0\xA\x0\x0\x3\x20\x8\x10\xAC\xBE\x62\x8\xF2\x42\x8C\x85\xAA\x20\x65\x76\x96\xF7\x39\x44\x61\x12\x1A\x89\xA\x46\xFA\x0\xAC\xFB\xB0\x6F\x9D\x0\x0\x3B
WidgetClass ScrolledWidget -configspec {
	{ -scrollbar scrollbar Scrollbar {none} config_scroll cget_scroll }
}
ScrolledWidget instproc build_widget { path } {
	frame  $path.dummy -borderwidth 0 -relief flat
	set main [$self create_main_widget $path]
	scrollbar $path.vscroll -orient vertical
	scrollbar $path.hscroll -orient horizontal
	pack $path.dummy -side top -fill both -expand 1
	$self replace_main_widget $main
}
ScrolledWidget instproc replace_main_widget { widget } {
	$self instvar main_
	if { [info exists main_] } {
		if { $main_ == $widget } return
		catch { pack forget $main_ }
	}
	set main_ $widget
	set path [$self info path]
	$path.vscroll configure -command "$main_ yview"
	$path.hscroll configure -command "$main_ xview"
	$main_ configure -yscrollcommand "$path.vscroll set"
	$main_ configure -xscrollcommand "$path.hscroll set"
	pack $main_ -side left -anchor nw -fill both -expand 1 \
			-in $path.dummy
}
ScrolledWidget instproc create_main_widget { path } {
	error "cannot create object of class [$self info class];\
			every subclass MUST redefine the create_main_widget\
			method"
}
ScrolledWidget instproc config_scroll { option scroll } {
	$self instvar main_
	set path [$self info path]
	catch {
		pack forget $path.vscroll
		pack forget $path.hscroll
	}
	switch $scroll {
		horizontal {
			pack $path.hscroll -side bottom -fill x \
					-before $path.dummy
		}
		vertical {
			pack $path.vscroll -side right -fill y \
					-in $path.dummy -before $main_
		}
		both {
			pack $path.hscroll -side bottom -fill x \
					-before $path.dummy
			pack $path.vscroll -side right -fill y \
					-in $path.dummy -before $main_
		}
		auto {
			error "function not implemented"
		}
		default {
			set scroll none
		}
	}
	$self set scroll_ $scroll
}
ScrolledWidget instproc cget_scroll { option } {
	$self instvar scroll_
	if [info exists scroll_] { return $scroll_ } else { return none }
}
WidgetClass ScrolledCanvas -superclass ScrolledWidget
ScrolledCanvas instproc create_main_widget { path } {
	return [canvas $path.bbox]
}
WidgetClass ScrolledText -superclass ScrolledWidget
ScrolledText instproc create_main_widget { path } {
	return [text $path.text]
}
WidgetClass ScrolledWindow -superclass ScrolledCanvas
ScrolledWindow instproc build_widget { path } {
	$self next $path
	frame $path.bbox.window
	$path.bbox create window 0 0 -anchor nw -window $path.bbox.window
	$self set_subwidget window $path.bbox.window
	bind $path.bbox.window <Configure> "+$self ev_window_resize %w %h"
}
ScrolledWindow instproc ev_window_resize { width height } {
	[$self subwidget bbox] configure -scrollregion "0 0 $width $height"
}
WidgetClass ScrolledWindow/Expand -superclass ScrolledWindow
ScrolledWindow/Expand instproc build_widget { path } {
	$self next $path
	set dummy [frame [$self subwidget bbox].dummy_ -width 0 -height 0 \
			-relief flat -bg [[$self subwidget window] cget -bg]]
	pack $dummy -side top -in [$self subwidget window]
	bind [$self subwidget bbox] <Configure> "+$self ev_bbox_resize_ %w %h"
}
ScrolledWindow/Expand instproc ev_bbox_resize_ { w h } {
	set window [$self subwidget window]
	set bbox   [$self subwidget bbox]
	$bbox.dummy_ configure \
			-width [expr $w - ([$bbox cget -bd] + \
			[$window cget -bd] + [$bbox cget -highlightthickness] \
			+ [$window cget -highlightthickness]) * 2]
}
WidgetClass ScrolledWinMgr -superclass ScrolledCanvas
ScrolledWinMgr public add_window { path x y } {
	$self instvar windows_
	set bbox [$self subwidget bbox]
	if { [winfo parent $path] != $bbox } {
		error "$path is not a child of ScrolledWinMgr::holder"
	}
	set id [$bbox create window $x $y -anchor nw -window $path \
			-tags all_windows]
	set windows_($path) $id
	bind $path <Configure> "+$self recompute_scrollregion"
	$self recompute_scrollregion
}
ScrolledWinMgr public move_window { path x y } {
	$self instvar windows_
	set bbox [$self subwidget bbox]
	set current [$bbox coords $windows_($path)]
	set dx [expr $x - [lindex $current 0]]
	set dy [expr $y - [lindex $current 1]]
	$bbox move $windows_($path) $dx $dy
	raise $path
}
ScrolledWinMgr public remove_window { path } {
	$self instvar windows_
	set bbox [$self subwidget bbox]
	$bbox delete $windows_($path)
	unset windows_($path)
}
ScrolledWinMgr public holder { } {
	return [$self subwidget bbox]
}
ScrolledWinMgr private recompute_scrollregion { } {
	set bbox [$self subwidget bbox]
	$bbox configure -scrollregion [$bbox bbox all_windows]
}
WidgetClass ListLabelItem -configspec {
	{ -value       value       Value       {}            config_value }
	{ -select      select      Select      0             config_option }
	{ -highlight   highlight   Highlight   0             config_option }
	{ -relief relief Relief flat config_relief cget_relief }
	{ -normalbackground normalBackground NormalBackground \
			WidgetDefault(-background) config_option }
	{ -normalforeground normalForeground NormalForeground \
			WidgetDefault(-foreground) config_option }
	{ -normalrelief normalRelief NormalRelief flat config_option }
	{ -selectbackground selectBackground SelectBackground WidgetDefault \
			config_option }
	{ -selectforeground selectForeground SelectForeground WidgetDefault \
			config_option }
	{ -selectrelief selectRelief SelectRelief sunken config_option }
	{ -highlightrelief highlightRelief HighlightRelief raised \
			config_option }
}
ListLabelItem instproc init { args } {
	$self instvar config_
	set config_(-value) {}
	set config_(-select) 0
	set config_(-highlight) 0
	set config_(-normalbackground) Black
	set config_(-normalforeground) Black
	set config_(-normalrelief)     flat
	set config_(-selectbackground) Black
	set config_(-selectforeground) Black
	set config_(-selectrelief)     sunken
	set config_(-highlightrelief)  raised
	eval [list $self] next $args
}
ListLabelItem instproc create_root_widget { path } {
	label $path -anchor w
	if { [option get $path padX Label]=="" } {
		$path configure -padx 1
	}
	if { [option get $path padY Label]=="" } {
		$path configure -pady 1
	}
}
ListLabelItem instproc config_value { option args } {
	$self instvar config_
	if { [llength $args]==0 } {
		return [$self widget_proc cget -text]
	} else {
		$self widget_proc configure -text [lindex $args 0]
	}
}
ListLabelItem instproc config_option { option args } {
	$self instvar config_
	if { [llength $args]==0 } {
		return $config_($option)
	} else {
		set value [lindex $args 0]
		set config_($option) $value
		$self config_[string range $option 1 end] $value
	}
}
ListLabelItem instproc config_relief { option value } {
	$self widget_proc configure -relief $value
}
ListLabelItem instproc cget_relief { option } {
	$self widget_proc cget -relief
}
ListLabelItem instproc config_normalbackground { value } {
	if { ![$self set config_(-select)] } {
		$self widget_proc configure -bg $value
	}
}
ListLabelItem instproc config_normalforeground { value } {
	if { ![$self set config_(-select)] } {
		$self widget_proc configure -fg $value
	}
}
ListLabelItem instproc config_normalrelief { value } {
	if { ![$self set config_(-select)] && \
			![$self set config_(-highlight)] } {
		$self widget_proc configure -relief $value
	}
}
ListLabelItem instproc config_selectbackground { value } {
	if { [$self set config_(-select)] } {
		$self widget_proc configure -bg $value
	}
}
ListLabelItem instproc config_selectforeground { value } {
	if { [$self set config_(-select)] } {
		$self widget_proc configure -fg $value
	}
}
ListLabelItem instproc config_selectrelief { value } {
	if { [$self set config_(-select)] && \
		![$self set config_(-highlight)] } {
		$self widget_proc configure -relief $value
	}
}
ListLabelItem instproc config_highlightrelief { value } {
	if { [$self set config_(-highlight)] } {
		$self widget_proc configure -relief $value
	}
}
ListLabelItem instproc config_select { value } {
	$self instvar config_
	if { $value } {
		$self widget_proc configure -bg $config_(-selectbackground)
		$self widget_proc configure -fg $config_(-selectforeground)
		if { !$config_(-highlight) } {
			$self widget_proc configure \
					-relief $config_(-selectrelief)
		}
	} else {
		$self widget_proc configure -bg $config_(-normalbackground)
		$self widget_proc configure -fg $config_(-normalforeground)
		if { !$config_(-highlight) } {
			$self widget_proc configure \
					-relief $config_(-normalrelief)
		}
	}
}
ListLabelItem instproc config_highlight { value } {
	$self instvar config_
	if { $value } {
		$self widget_proc configure -relief $config_(-highlightrelief)
	} else {
		if { $config_(-select) } {
			$self widget_proc configure \
					-relief $config_(-selectrelief)
		} else {
			$self widget_proc configure \
					-relief $config_(-normalrelief)
		}
	}
}
WidgetClass ScrolledListbox -superclass ScrolledWindow -configspec {
	{ -itemclass itemClass ItemClass ListLabelItem config_option }
	{ -browsecmd browseCmd BrowseCmd "" config_option }
	{ -command command Command "" config_option }
	{ -selectmode selectMode SelectMode single config_selectmode }
} -default {
	{ *window.takeFocus 1 }
	{ *window.highlightThickness 0 }
}
ScrolledListbox instproc build_widget { path } {
	$self next $path
	set window [$self subwidget window]
	frame $window.dummy_ -width 0 -height 0 -relief flat \
			-bg [$window cget -bg]
	pack $window.dummy_ -side top
	$self create_bindtag
	$self set count_ 0
	$self set highlight_ ""
}
ScrolledListbox instproc create_bindtag { } {
	bind [$self subwidget bbox] <Configure> "+$self ev_bbox_resize_ %w %h"
	set window [$self subwidget window]
	bind $window <KeyPress-Up> "$self ev_key_up_"
	bind $window <KeyPress-Down> "$self ev_key_down_"
	bind $window <KeyPress-space> "$self ev_key_space_"
	bind Bindings_$self <ButtonPress-1> "+$self selection.toggle -widget \
			\[$self root_widget_ %W\]; $self browse \
			\[$self widget_to_id_ \[$self root_widget_ %W\]\]"
	bind Bindings_$self <Double-1> "+$self invoke \
			\[$self widget_to_id_ \[$self root_widget_ %W\]\]"
	bind Bindings_$self <Enter> "+if \{ \[$self root_widget_ %W\] == \
			\"%W\" \} \{ $self highlight.set -widget %W \}"
	bind Bindings_$self <Leave> "+if \{ \[$self root_widget_ %W\] == \
			\"%W\" \} \{ $self highlight.clear -widget %W \}"
}
ScrolledListbox instproc ev_bbox_resize_ { w h } {
	set window [$self subwidget window]
	set bbox   [$self subwidget bbox]
	$window.dummy_ configure \
			-width [expr $w - ([$bbox cget -bd] + \
			[$window cget -bd] + [$bbox cget -highlightthickness] \
			+ [$window cget -highlightthickness]) * 2]
}
ScrolledListbox instproc ev_key_up_ { } {
	set highlight [$self highlight.get]
	if { $highlight != "" } {
		set list [$self widget_list_]
		set idx [lsearch $list [$self id_to_widget_ $highlight]]
		if { $idx <= 0 } {
			return
		}
		incr idx -1
	} else {
		set idx 0
	}
	$self see $idx
	$self highlight.set $idx
}
ScrolledListbox instproc ev_key_down_ { } {
	set highlight [$self highlight.get]
	if { $highlight != "" } {
		set list [$self widget_list_]
		set idx [lsearch $list [$self id_to_widget_ $highlight]]
		if { $idx < 0 || $idx >= [expr [llength $list]-1] } {
			return
		}
		incr idx 1
	} else {
		set idx 0
	}
	$self see $idx
	$self highlight.set $idx
}
ScrolledListbox instproc ev_key_space_ { } {
	set highlight [$self highlight.get]
	if { $highlight != "" } {
		$self selection.toggle -id $highlight
		$self browse $highlight
	}
}
ScrolledListbox instproc root_widget_ { path } {
	set window [$self subwidget window]
	set widget $path
	while { $widget!="" && [winfo parent $widget] != $window } {
		set widget [winfo parent $widget]
	}
	if { $widget=="" } {
		error "invalid widget $path"
	}
	return $widget
}
ScrolledListbox instproc widget_list_ { } {
	set list [pack slaves [$self subwidget window]]
	return [lrange $list 1 end]
}
ScrolledListbox instproc config_option { option args } {
	$self instvar config_
	if { [llength $args]==0 } {
		return $config_($option)
	} else {
		set config_($option) [lindex $args 0]
	}
}
ScrolledListbox instproc config_selectmode { option args } {
	$self instvar config_
	if { [llength $args]==0 } {
		return $config_(-selectmode)
	}
	set value [lindex $args 0]
	switch -exact -- $value {
		single {
			set config_(-selectmode) "single"
			set selection [lindex [$self selection.get all] 0]
			$self selection.clear all
			if { $selection!="" } {
				$self selection.set -id $selection
			}
		}
		multiple {
			set config_(-selectmode) "multiple"
		}
		none {
			set config_(-selectmode) "none"
			$self selection.clear all
		}
		default {
			error "invalid selectmode \"$value\". must be one of\
					\"single\", \"multiple\", or \"none\""
		}
	}
}
ScrolledListbox instproc browse { id } {
	set browsecmd [$self cget -browsecmd]
	if { $browsecmd!="" } {
		uplevel #0 $browsecmd [list $id]
	}
}
ScrolledListbox instproc invoke { id } {
	set command [$self cget -command]
	if { $command!="" } {
		uplevel #0 $command [list $id]
	}
}
ScrolledListbox instproc ID { idVar arguments { idx 0 } } {
	upvar $idVar id
	if { [llength $arguments] <= $idx } {
		error "missing arguments"
	}
	set arg [lindex $arguments $idx]
	switch -exact -- $arg {
		-id {
			set end [expr $idx+2]
			if { [llength $arguments] < $end } {
				error "missing argument for \"-id\""
			}
			set id [lindex $arguments [expr $idx+1]]
			return $end
		}
		-widget {
			set end [expr $idx+2]
			if { [llength $arguments] < $end } {
				error "missing argument for \"-widget\""
			}
			set widget [lindex $arguments [expr $idx+1]]
			set id [$self widget_to_id_ $widget]
			return $end
		}
		-value {
			set end [expr $idx+2]
			if { [llength $arguments] < $end } {
				error "missing argument for \"-value\""
			}
			set widget [lindex $arguments [expr $idx+1]]
			set id [$self value_to_id_ $widget]
			return $end
		}
		default {
			set id [$self index_to_id_ $arg]
			return [expr $idx+1]
		}
	}
}
ScrolledListbox instproc widget_to_id_ { widget } {
	$self instvar widget_to_id_
	if [info exists widget_to_id_($widget)] {
		return $widget_to_id_($widget)
	} else {
		error "invalid widget \"$widget\""
	}
}
ScrolledListbox instproc value_to_id_ { value } {
	foreach widget [self widget_list_] {
		if { $value == [$self info.value -widget $widget] } {
			return $id
		}
	}
	error "invalid value \"$value\""
}
ScrolledListbox instproc index_to_id_ { index } {
	set widget [lindex [$self widget_list_] $index]
	if { $widget=="" } {
		error "invalid index \"$index\""
	}
	return [$self widget_to_id_ $widget]
}
ScrolledListbox instproc id_to_widget_ { id } {
	$self instvar id_to_widget_
	if [info exists id_to_widget_($id)] {
		return $id_to_widget_($id)
	} else {
		error "invalid id \"$id\""
	}
}
ScrolledListbox instproc id_to_value_ { id } {
	set widget [$self id_to_widget_ $id]
	return [$widget cget -value]
}
ScrolledListbox instproc insert { where args } {
	$self instvar count_ id_to_widget_ widget_to_id_
	switch -exact -- $where {
		end {
			set where ""
		}
		after {
			set idx [$self ID where_id $args]
			set where "-after [$self id_to_widget_ $where_id]"
			set args [lrange $args $idx end]
		}
		before {
			set idx [$self ID where_id $args]
			set where "-before [$self id_to_widget_ $where_id]"
			set args [lrange $args $idx end]
		}
		default {
			error "invalid argument \"$where\". must be one of\
					\"end\", \"after\", or \"before\""
		}
	}
	set window [$self subwidget window]
	set item_class [$self cget -itemclass]
	if { $item_class=="" } {
		error "must configure -itemclass before inserting any elements"
	}
	foreach arg $args {
		if { [lindex $arg 0] == "-id" } {
			if { [llength $arg] <= 1 } {
				error "missing argument for \"-id\""
			}
			set id [lindex $arg 1]
			set arg [lrange $arg 2 end]
		} else {
			set id #$count_
		}
		if { [info exists id_to_widget_($id)] } {
			error "id \"$id\" already exists"
		}
		set widget $window.item_$count_
		incr count_
		$item_class $widget -value $arg
		$self bindtag_recursive_ $widget
		if { $where=="" } {
			pack $widget -side top -fill x -expand 1
		} else {
			eval pack [list $widget] -side top -fill x -expand 1 \
					$where
		}
		set id_to_widget_($id) $widget
		set widget_to_id_($widget) $id
	}
}
ScrolledListbox instproc delete { args } {
	$self instvar id_to_widget_ widget_to_id_ selection_ highlight_
	if { [lindex $args 0]=="all" } {
		if { [llength $args]!=1 } {
			error "extra arguments starting at argument 2"
		}
		foreach widget [$self widget_list_] {
			destroy $widget
		}
		catch {
			unset id_to_widget_
			unset widget_to_id_
			unset selection_
		}
		set highlight_ ""
	} else {
		set id [eval [list $self] info.id $args]
		set widget [$self id_to_widget_ $id]
		destroy $widget
		catch {
			unset id_to_widget_($id)
			unset widget_to_id_($widget)
			unset selection_($id)
		}
		if { $highlight_==$id } {
			set highlight_ ""
		}
	}
}
ScrolledListbox instproc bindtag_recursive_ { widget } {
	$self bindtag_ $widget
	foreach path [winfo children $widget] {
		$self bindtag_recursive_ $path
	}
}
ScrolledListbox instproc bindtag_ { widget } {
	set tags [bindtags $widget]
	if {[lsearch -exact $tags Bindings_$self] == -1} {
		bindtags $widget [concat [list Bindings_$self] $tags]
	}
}
ScrolledListbox instproc see { args } {
	set id [eval [list $self] info.id $args]
	set widget [$self id_to_widget_ $id]
	set y1 [winfo y $widget]
	set y2 [expr $y1 + [winfo height $widget] - 1]
	set viewable [$self subwidget bbox yview]
	set scrollregion [$self subwidget bbox cget -scrollregion]
	set height [expr [lindex $scrollregion 3] - [lindex $scrollregion 1]]
	set bbox_y1 [expr $height * [lindex $viewable 0] + \
			[lindex $scrollregion 1]]
	set bbox_y2 [expr $height * [lindex $viewable 1] + \
			[lindex $scrollregion 1]]
	if { $y1 < $bbox_y1 } {
		set bbox_y1 $y1
		$self subwidget bbox yview moveto \
				[expr double($bbox_y1)/double($height)]
	} elseif { $y2 > $bbox_y2 } {
		set bbox_y1 [expr $y2 - ($bbox_y2 - $bbox_y1)]
		$self subwidget bbox yview moveto \
				[expr double($bbox_y1)/double($height)]
	}
}
ScrolledListbox instproc info { method args } {
	if { [$class info instprocs info.$method] == "info.$method" } {
		return [eval [list $self] [list info.$method] $args]
	} else {
		return [eval [list $self] next [list $method] $args]
	}
}
ScrolledListbox instproc info.id { args } {
	set idx [$self ID id $args]
	if { [llength $args] > $idx } {
		error "extra arguments starting with argument $idx"
	}
	return $id
}
ScrolledListbox instproc info.widget { args } {
	set id [eval [list $self] info.id $args]
	return [$self id_to_widget_ $id]
}
ScrolledListbox instproc info.value { args } {
	set id [eval [list $self] info.id $args]
	return [$self id_to_value_ $id]
}
ScrolledListbox instproc info.all { {what {}} } {
	switch -exact -- $what {
		{} -
		-id {
			set ids {}
			foreach widget [$self widget_list_] {
				lappend ids [$self widget_to_id_ $widget]
			}
			return $ids
		}
		-widget {
			return [$self widget_list_]
		}
		-value {
			set values
			foreach widget [$self widget_list_] {
				set id [$self widget_to_id_ $widget]
				lappend values [$self id_to_value_ $id]
			}
			return $values
		}
		default {
			error "invalid argument \"$what\". must be one of\
					\"-id\", \"-widget\", or \"-value\""
		}
	}
}
ScrolledListbox instproc info.exists { args } {
	set len [llength $args]
	if { $len > 2 } {
		error "extra arguments"
	}
	switch -exact -- [lindex $args 0] {
		-id {
			if { $len < 2 } {
				error "missing argument for \"-id\""
			}
			return [info exists id_to_widget_([lindex $args 1])]
		}
		-widget {
			if { $len < 2 } {
				error "missing argument for \"-widget\""
			}
			return [info exists widget_to_id_([lindex $args 1])]
		}
		-value {
			if { $len < 2 } {
				error "missing argument for \"-widget\""
			}
			return ![catch {$self value_to_id_ [lindex $args 1]}]
		}
		default {
			if { $len > 1 } {
				error "extra arguments"
			}
			return ![catch {$self index_to_id_ [lindex $args 1]}]
		}
	}
}
ScrolledListbox instproc info.numelems { } {
	return [llength [$self widget_list_]]
}
ScrolledListbox instproc selection { method args } {
	eval [list $self] [list selection.$method] $args
}
ScrolledListbox instproc selection.set { args } {
	$self instvar selection_
	set selectmode [$self cget -selectmode]
	if { $selectmode=="none" } {
		return
	}
	if { [lindex $args 0]=="all" } {
		if { [llength $args] > 1 } {
			error "extra arguments starting at argument 2"
		}
		foreach widget [$self widget_list_] {
			$self selection.set -widget $widget
		}
	}
	set id [eval [list $self] info.id $args]
	if { [info exists selection_($id)] } {
		return
	}
	if { [$self cget -selectmode]=="single" } {
		$self selection.clear all
	}
	set selection_($id) 1
	set widget [$self id_to_widget_ $id]
	$widget configure -select 1
}
ScrolledListbox instproc selection.get { args } {
	$self instvar selection_
	if { [llength $args]==0 } {
		return [array names selection_]
	}
	if { [lindex $args 0]=="all" } {
		if { [llength $args] > 1 } {
			error "extra arguments starting at argument 2"
		}
		return [array names selection_]
	}
	set id [eval [list $self] info.id $args]
	if { [info exists selection_($id)] } {
		return $id
	} else {
		return ""
	}
}
ScrolledListbox instproc selection.clear { args } {
	$self instvar selection_
	if { [llength $args]==0 } {
		$self selection.clear_all_
		return
	}
	if { [lindex $args 0]=="all" } {
		if { [llength $args] > 1 } {
			error "extra arguments starting at argument 2"
		}
		$self selection.clear_all_
		return
	}
	set id [eval [list $self] info.id $args]
	if { [info exists selection_($id)] } {
		unset selection_($id)
		[$self id_to_widget_ $id] configure -select 0
	} else {
		return
	}
}
ScrolledListbox instproc selection.clear_all_ { } {
	$self instvar selection_
	foreach id [array names selection_] {
		unset selection_($id)
		[$self id_to_widget_ $id] configure -select 0
	}
}
ScrolledListbox instproc selection.toggle { args } {
	set id [eval [list $self] info.id $args]
	if { [$self selection.get -id $id]=="" } {
		$self selection.set -id $id
	} else {
		$self selection.clear -id $id
	}
}
ScrolledListbox instproc highlight { method args } {
	eval [list $self] [list highlight.$method] $args
}
ScrolledListbox instproc highlight.set { args } {
	$self instvar highlight_
	set id [eval [list $self] info.id $args]
	if { $id == $highlight_ } {
		return
	}
	if { $highlight_!="" } {
		[$self id_to_widget_ $highlight_] configure -highlight 0
	}
	set highlight_ $id
	[$self id_to_widget_ $id] configure -highlight 1
}
ScrolledListbox instproc highlight.get { args } {
	$self instvar highlight_
	if { [llength $args]==0 } {
		return $highlight_
	}
	set id [eval [list $self] info.id $args]
	if { $highlight_==$id } {
		return $id
	} else {
		return ""
	}
}
ScrolledListbox instproc highlight.clear { args } {
	$self instvar highlight_
	if { [llength $args]==0 } {
		[$self id_to_widget_ $highlight_] configure -highlight 0
		set highlight_ ""
	} else {
		set id [eval [list $self] info.id $args]
		if { $highlight_==$id } {
			[$self id_to_widget_ $highlight_] configure \
					-highlight 0
			set highlight_ ""
		}
	}
}
ScrolledListbox instproc highlight.toggle { args } {
	$self instvar highlight_
	if { [llength $args]==0 } {
		$self highlight.clear
	} else {
		set id [eval [list $self] info.id $args]
		if { $id == $highlight_ } {
			$self highlight.clear
		} else {
			$self highlight.set -id $id
		}
	}
}
WidgetClass HierarchicalListboxItem -configspec {
	{ -value       value       Value       {}            config_value }
	{ -select      select      Select      0             config_option }
	{ -highlight   highlight   Highlight   0             config_option }
	{ -normalbackground normalBackground NormalBackground \
			WidgetDefault(-background) config_option }
	{ -normalforeground normalForeground NormalForeground \
			WidgetDefault(-foreground) config_option }
	{ -normalrelief normalRelief NormalRelief flat config_option }
	{ -selectbackground selectBackground SelectBackground WidgetDefault \
			config_option }
	{ -selectforeground selectForeground SelectForeground WidgetDefault \
			config_option }
	{ -selectrelief selectRelief SelectRelief sunken config_option }
	{ -highlightrelief highlightRelief HighlightRelief raised \
			config_option }
} -default {
	{ .borderWidth WidgetDefault }
	{ *font WidgetDefault }
	{ *Label.padX 1 }
	{ *Label.padY 0 }
	{ *Label.borderWidth 0 }
}
HierarchicalListboxItem instproc init { args } {
	$self instvar config_
	set config_(-value) {}
	set config_(-select) 0
	set config_(-highlight) 0
	set config_(-normalbackground) Black
	set config_(-normalforeground) Black
	set config_(-normalrelief)     flat
	set config_(-selectbackground) Black
	set config_(-selectforeground) Black
	set config_(-selectrelief)     sunken
	set config_(-highlightrelief)  raised
	eval [list $self] next $args
}
HierarchicalListboxItem instproc build_widget { path } {
	label $path.padding
	label $path.image
	label $path.text -anchor w
	pack $path.padding -side left
	pack $path.image -side left
	pack $path.text  -side left -fill x -anchor w
}
HierarchicalListboxItem instproc config_value { option args } {
	$self instvar config_
	if { [llength $args]==0 } {
		if [info exists config_(-value)] {
			return $config_(-value)
		} else {
			return ""
		}
	} else {
		set value [lindex $args 0]
		set image [lindex $value 0]
		set config_(-value) [lindex $value 1]
		set split [split $config_(-value) "/"]
		if { $config_(-value)=="/" || [llength $split] <= 1 } {
			set level 0
			set label $config_(-value)
		} else {
			set level [llength $split]
			set label [lindex $split [expr $level-1]]
		}
		$self subwidget padding configure -padx [expr $level * 4]
		$self subwidget image   configure -image $image
		$self subwidget text    configure -text  $label
	}
}
HierarchicalListboxItem instproc config_option { option args } {
	$self instvar config_
	if { [llength $args]==0 } {
		return $config_($option)
	} else {
		set value [lindex $args 0]
		$self config_[string range $option 1 end] $value
		set config_($option) $value
	}
}
HierarchicalListboxItem instproc config_background { value } {
	set path [$self info path]
	$path configure -bg $value
	foreach label [winfo children $path] {
		$label configure -bg $value
	}
}
HierarchicalListboxItem instproc config_foreground { value } {
	foreach label [winfo children [$self info path]] {
		$label configure -fg $value
	}
}
HierarchicalListboxItem instproc config_relief { value } {
	[$self info path] configure -relief $value
}
HierarchicalListboxItem instproc config_normalbackground { value } {
	if { ![$self set config_(-select)] } {
		$self config_background $value
	}
}
HierarchicalListboxItem instproc config_normalforeground { value } {
	if { ![$self set config_(-select)] } {
		$self config_foreground $value
	}
}
HierarchicalListboxItem instproc config_normalrelief { value } {
	if { ![$self set config_(-select)] && \
			![$self set config_(-highlight)] } {
		$self config_relief $value
	}
}
HierarchicalListboxItem instproc config_selectbackground { value } {
	if { [$self set config_(-select)] } {
		$self config_background $value
	}
}
HierarchicalListboxItem instproc config_selectforeground { value } {
	if { [$self set config_(-select)] } {
		$self config_foreground $value
	}
}
HierarchicalListboxItem instproc config_selectrelief { value } {
	if { [$self set config_(-select)] && \
		![$self set config_(-highlight)] } {
		$self config_relief $value
	}
}
HierarchicalListboxItem instproc config_highlightrelief { value } {
	if { [$self set config_(-highlight)] } {
		$self config_relief $value
	}
}
HierarchicalListboxItem instproc config_select { value } {
	$self instvar config_
	if { $value } {
		$self config_background $config_(-selectbackground)
		$self config_foreground $config_(-selectforeground)
		if { !$config_(-highlight) } {
			$self config_relief $config_(-selectrelief)
		}
	} else {
		$self config_background $config_(-normalbackground)
		$self config_foreground $config_(-normalforeground)
		if { !$config_(-highlight) } {
			$self config_relief $config_(-normalrelief)
		}
	}
}
HierarchicalListboxItem instproc config_highlight { value } {
	$self instvar config_
	if { $value } {
		$self config_relief $config_(-highlightrelief)
	} else {
		if { $config_(-select) } {
			$self config_relief $config_(-selectrelief)
		} else {
			$self config_relief $config_(-normalrelief)
		}
	}
}
WidgetClass MultiColumnListbox -superclass ScrolledCanvas -configspec {
	{ -browsecmd browseCmd BrowseCmd "" config_option }
	{ -command command Command "" config_option }
	{ -selectbackground selectBackground SelectBackground #a0a0ff \
			config_option }
	{ -font font Font WidgetDefault	config_option }
} -default {
	{ .scrollbar horizontal }
	{ *hscroll.highlightThickness 0 }
	{ *hscroll.takeFocus 0 }
	{ *bbox.borderWidth 2 }
	{ *bbox.width 400 }
	{ *bbox.height 120 }
}
MultiColumnListbox instproc config_option { option args } {
	$self instvar data
	if { [llength $args] == {} } {
		return $data($option)
	} else {
		set data($option) [lindex $args 0]
	}
}
MultiColumnListbox instproc build_widget { path } {
	$self instvar data
	$self next $path
	set data(canvas) [$self subwidget bbox]
	set data(sbar) [$self subwidget hscroll]
	set data(maxIW) 1
	set data(maxIH) 1
	set data(maxTW) 1
	set data(maxTH) 1
	set data(numItems) 0
	set data(curItem)  {}
	set data(noScroll) 1
	bind $data(canvas) <Configure> "+$self arrange"
	bind $data(canvas) <1>         "$self btn1 %x %y"
	bind $data(canvas) <B1-Motion> "$self motion1 %x %y"
	bind $data(canvas) <Double-1>  "$self double1 %x %y"
	bind $data(canvas) <ButtonRelease-1> "tkCancelRepeat"
	bind $data(canvas) <B1-Leave>  "$self leave1 %x %y"
	bind $data(canvas) <B1-Enter>  "tkCancelRepeat"
	bind $data(canvas) <Up>        "$self up_down -1"
	bind $data(canvas) <Down>      "$self up_down  1"
	bind $data(canvas) <Left>      "$self left_right -1"
	bind $data(canvas) <Right>     "$self left_right  1"
	bind $data(canvas) <Return>    "$self return_key"
	bind $data(canvas) <KeyPress>  "$self key_press %A"
	bind $data(canvas) <Control-KeyPress> ";"
	bind $data(canvas) <Alt-KeyPress>  ";"
	bind $data(canvas) <FocusIn>   "$self focus_in"
}
MultiColumnListbox instproc auto_scan { } {
	$self instvar data
	global tkPriv
	set x $tkPriv(x)
	set y $tkPriv(y)
	if $data(noScroll) {
		return
	}
	if {$x >= [winfo width $data(canvas)]} {
		$data(canvas) xview scroll 1 units
	} elseif {$x < 0} {
		$data(canvas) xview scroll -1 units
	} elseif {$y >= [winfo height $data(canvas)]} {
	} elseif {$y < 0} {
	} else {
		return
	}
	$self motion1 $x $y
	set tkPriv(afterId) [after 50 $self auto_scan]
}
MultiColumnListbox instproc delete_all {} {
	$self instvar data
	$self instvar itemList
	$data(canvas) delete all
	catch {unset data(selected)}
	catch {unset data(rect)}
	catch {unset data(list)}
	catch {unset itemList}
	set data(numItems) 0
	set data(curItem)  {}
}
MultiColumnListbox instproc add {image text} {
	$self instvar data
	$self instvar itemList
	$self instvar textList
	set iTag [$data(canvas) create image 0 0 -image $image -anchor nw]
	set tTag [$data(canvas) create text  0 0 -text  $text  -anchor nw \
			-font $data(-font)]
	set rTag [$data(canvas) create rect  0 0 0 0 -fill "" -outline ""]
	set b [$data(canvas) bbox $iTag]
	set iW [expr [lindex $b 2]-[lindex $b 0]]
	set iH [expr [lindex $b 3]-[lindex $b 1]]
	if {$data(maxIW) < $iW} {
		set data(maxIW) $iW
	}
	if {$data(maxIH) < $iH} {
		set data(maxIH) $iH
	}
	set b [$data(canvas) bbox $tTag]
	set tW [expr [lindex $b 2]-[lindex $b 0]]
	set tH [expr [lindex $b 3]-[lindex $b 1]]
	if {$data(maxTW) < $tW} {
		set data(maxTW) $tW
	}
	if {$data(maxTH) < $tH} {
		set data(maxTH) $tH
	}
	lappend data(list) [list $iTag $tTag $rTag $iW $iH $tW $tH \
			$data(numItems)]
	set itemList($rTag) [list $iTag $tTag $text $data(numItems)]
	set textList($data(numItems)) [string tolower $text]
	incr data(numItems)
}
MultiColumnListbox instproc arrange {} {
	$self instvar data
	if ![info exists data(list)] {
		if {[info exists data(canvas)] && \
				[winfo exists $data(canvas)]} {
			set data(noScroll) 1
			$data(sbar) config -command ""
		}
		return
	}
	set W [winfo width  $data(canvas)]
	set H [winfo height $data(canvas)]
	set pad [expr [$data(canvas) cget -highlightthickness] + \
			[$data(canvas) cget -bd]]
	incr W -[expr $pad*2]
	incr H -[expr $pad*2]
	set dx [expr $data(maxIW) + $data(maxTW) + 4]
	if {$data(maxTH) > $data(maxIH)} {
		set dy $data(maxTH)
	} else {
		set dy $data(maxIH)
	}
	set shift [expr $data(maxIW) + 4]
	set x [expr $pad * 2]
	set y [expr $pad * 1]
	set usedColumn 0
	foreach pair $data(list) {
		set usedColumn 1
		set iTag [lindex $pair 0]
		set tTag [lindex $pair 1]
		set rTag [lindex $pair 2]
		set iW   [lindex $pair 3]
		set iH   [lindex $pair 4]
		set tW   [lindex $pair 5]
		set tH   [lindex $pair 6]
		set i_dy [expr ($dy - $iH)/2]
		set t_dy [expr ($dy - $tH)/2]
		$data(canvas) coords $iTag $x                 [expr $y + $i_dy]
		$data(canvas) coords $tTag [expr $x + $shift] [expr $y + $t_dy]
		$data(canvas) coords $tTag [expr $x + $shift] [expr $y + $t_dy]
		$data(canvas) coords $rTag $x $y [expr $x+$dx] [expr $y+$dy]
		incr y $dy
		if {[expr $y + $dy] >= $H} {
			set y [expr $pad * 1]
			incr x $dx
			set usedColumn 0
		}
	}
	if {$usedColumn} {
		set sW [expr $x + $dx]
	} else {
		set sW $x
	}
	if {$sW < $W} {
		$data(canvas) config -scrollregion "$pad $pad $sW $H"
		$data(sbar) config -command ""
		$data(canvas) xview moveto 0
		set data(noScroll) 1
	} else {
		$data(canvas) config -scrollregion "$pad $pad $sW $H"
		$data(sbar) config -command "$data(canvas) xview"
		set data(noScroll) 0
	}
	set data(itemsPerColumn) [expr ($H-$pad)/$dy]
	if {$data(itemsPerColumn) < 1} {
		set data(itemsPerColumn) 1
	}
	if {$data(curItem) != {}} {
		$self select [lindex [lindex $data(list) $data(curItem)] 2] 0
	}
}
MultiColumnListbox instproc invoke {} {
	$self instvar data
	if {[string compare $data(-command) ""] && \
			[info exists data(selected)]} {
		eval $data(-command) [list $data(selected)]
	}
}
MultiColumnListbox instproc see {rTag} {
	$self instvar data
	$self instvar itemList
	if $data(noScroll) {
		return
	}
	set sRegion [$data(canvas) cget -scrollregion]
	if ![string compare $sRegion {}] {
		return
	}
	if ![info exists itemList($rTag)] {
		return
	}
	set bbox [$data(canvas) bbox $rTag]
	set pad [expr [$data(canvas) cget -highlightthickness] + \
			[$data(canvas) cget -bd]]
	set x1 [lindex $bbox 0]
	set x2 [lindex $bbox 2]
	incr x1 -[expr $pad * 2]
	incr x2 -[expr $pad * 1]
	set cW [expr [winfo width $data(canvas)] - $pad*2]
	set scrollW [expr [lindex $sRegion 2]-[lindex $sRegion 0]+1]
	set dispX [expr int([lindex [$data(canvas) xview] 0]*$scrollW)]
	set oldDispX $dispX
	if {[expr $x2 - $dispX] >= $cW} {
		set dispX [expr $x2 - $cW]
	}
	if {[expr $x1 - $dispX] < 0} {
		set dispX $x1
	}
	if {$oldDispX != $dispX} {
		set fraction [expr double($dispX)/double($scrollW)]
		$data(canvas) xview moveto $fraction
	}
}
MultiColumnListbox instproc select_at_XY {x y} {
	$self instvar data
	$self select [$data(canvas) find closest \
			[$data(canvas) canvasx $x] [$data(canvas) canvasy $y]]
}
MultiColumnListbox instproc select {rTag {callBrowse 1}} {
	$self instvar data
	$self instvar itemList
	if ![info exists itemList($rTag)] {
		return
	}
	set iTag   [lindex $itemList($rTag) 0]
	set tTag   [lindex $itemList($rTag) 1]
	set text   [lindex $itemList($rTag) 2]
	set serial [lindex $itemList($rTag) 3]
	if ![info exists data(rect)] {
		set data(rect) [$data(canvas) create rect 0 0 0 0 \
				-fill $data(-selectbackground) \
				-outline $data(-selectbackground)]
	}
	$data(canvas) lower $data(rect)
	set bbox [$data(canvas) bbox $tTag]
	eval $data(canvas) coords $data(rect) $bbox
	set data(curItem) $serial
	set data(selected) $text
	if {$callBrowse} {
		if [string compare $data(-browsecmd) ""] {
			eval $data(-browsecmd) [list $text]
		}
	}
}
MultiColumnListbox instproc unselect {} {
	$self instvar data
	if [info exists data(rect)] {
		$data(canvas) delete $data(rect)
		unset data(rect)
	}
	if [info exists data(selected)] {
		unset data(selected)
	}
	set data(curItem)  {}
}
MultiColumnListbox instproc get {} {
	$self instvar data
	if [info exists data(selected)] {
		return $data(selected)
	} else {
		return ""
	}
}
MultiColumnListbox instproc btn1 {x y} {
	$self instvar data
	focus $data(canvas)
	$self select_at_XY $x $y
}
MultiColumnListbox instproc motion1 {x y} {
	global tkPriv
	set tkPriv(x) $x
	set tkPriv(y) $y
	$self select_at_XY $x $y
}
MultiColumnListbox instproc double1 {x y} {
	$self instvar data
	if {$data(curItem) != {}} {
		$self invoke
	}
}
MultiColumnListbox instproc return_key {} {
	$self invoke
}
MultiColumnListbox instproc leave1 {x y} {
	global tkPriv
	set tkPriv(x) $x
	set tkPriv(y) $y
	$self auto_scan
}
MultiColumnListbox instproc focus_in {} {
	$self instvar data
	if ![info exists data(list)] {
		return
	}
	if {$data(curItem) == {}} {
		set rTag [lindex [lindex $data(list) 0] 2]
		$self select $rTag
	}
}
MultiColumnListbox instproc up_down {amount} {
	$self instvar data
	if ![info exists data(list)] {
		return
	}
	if {$data(curItem) == {}} {
		set rTag [lindex [lindex $data(list) 0] 2]
	} else {
		set oldRTag [lindex [lindex $data(list) $data(curItem)] 2]
		set rTag [lindex [lindex $data(list) [expr \
				$data(curItem)+$amount]] 2]
		if ![string compare $rTag ""] {
			set rTag $oldRTag
		}
	}
	if [string compare $rTag ""] {
		$self select $rTag
		$self see $rTag
	}
}
MultiColumnListbox instproc left_right {amount} {
	$self instvar data
	if ![info exists data(list)] {
		return
	}
	if {$data(curItem) == {}} {
		set rTag [lindex [lindex $data(list) 0] 2]
	} else {
		set oldRTag [lindex [lindex $data(list) $data(curItem)] 2]
		set newItem [expr $data(curItem)+($amount*\
				$data(itemsPerColumn))]
		set rTag [lindex [lindex $data(list) $newItem] 2]
		if ![string compare $rTag ""] {
			set rTag $oldRTag
		}
	}
	if [string compare $rTag ""] {
		$self select $rTag
		$self see $rTag
	}
}
MultiColumnListbox instproc key_press {key} {
	global tkPriv
	set w [$self info path]
	append tkPriv(ILAccel,$w) $key
	$self goto $tkPriv(ILAccel,$w)
	catch {
		after cancel $tkPriv(ILAccel,$w,afterId)
	}
	set tkPriv(ILAccel,$w,afterId) [after 500 $self reset]
}
MultiColumnListbox instproc goto {text} {
	$self instvar data
	$self instvar textList
	global tkPriv
	if ![info exists data(list)] {
		return
	}
	if {[string length $text] == 0} {
		return
	}
	if {$data(curItem) == {} || $data(curItem) == 0} {
		set start  0
	} else {
		set start  $data(curItem)
	}
	set text [string tolower $text]
	set theIndex -1
	set less 0
	set len [string length $text]
	set len0 [expr $len-1]
	set i $start
	while 1 {
		set sub [string range $textList($i) 0 $len0]
		if {[string compare $text $sub] == 0} {
			set theIndex $i
			break
		}
		incr i
		if {$i == $data(numItems)} {
			set i 0
		}
		if {$i == $start} {
			break
		}
	}
	if {$theIndex > -1} {
		set rTag [lindex [lindex $data(list) $theIndex] 2]
		$self select $rTag 0
		$self see $rTag
	}
}
MultiColumnListbox instproc reset { } {
	global tkPriv
	set w [$self info path]
	catch {unset tkPriv(ILAccel,$w)}
}
Class SDPParser
Class SDPMedia
Class SDPTime
Class SDPMessage
SDPParser instproc init { {ordered_syntax 1} } {
	$self next
	$self instvar nextsym_ ordered_syntax_ parse_error_
	set nextsym_(start) "v"
	set nextsym_(v) "o"
	set nextsym_(o) "s"
	set nextsym_(s) "i u e p c b t"
	set nextsym_(i) "u e p c b t"
	set nextsym_(u) "e p c b t"
	set nextsym_(e) "e p c b t"
	set nextsym_(p) "e p c b t"
	set nextsym_(c) "b t "
	set nextsym_(b) "t"
	set nextsym_(t) "t r z k a m"
	set nextsym_(r) "t z k a m"
	set nextsym_(z) "k a m"
	set nextsym_(k) "a m"
	set nextsym_(a) "a m"
	set nextsym_(m) "m i:m c:m b:m k:m a:m v"
	set nextsym_(i:m) "m c:m b:m k:m a:m v"
	set nextsym_(c:m) "m b:m k:m a:m v"
	set nextsym_(b:m) "m k:m a:m v"
	set nextsym_(k:m) "m a:m v"
	set nextsym_(a:m) "m a:m v"
	set ordered_syntax_ $ordered_syntax
	set parse_error_ ""
}
SDPParser instproc check_syntax { last cur media } {
	$self instvar nextsym_
	if ![info exists nextsym_($last)] {
		return ""
	}
	foreach s $nextsym_($last) {
		set t [split $s :]
		if { [lindex $t 0] == $cur } {
			return $s
		}
	}
	return ""
}
SDPParser instproc parse { announcement } {
	$self instvar parse_error_ ordered_syntax_
	set media ""
	set allmsgs ""
	set lasttag "start"
	set lines [split $announcement "\n"]
	set parse_error_ ""
	set lnum 0
	foreach line $lines {
		incr lnum
		set line [string trimright $line]
		if { $line=={} } continue
		set sline [split $line =]
		set tag [lindex $sline 0]
		set value [join [lrange $sline 1 end]]
		set ret [$self check_syntax $lasttag $tag $media]
		if { $ret == "" && $ordered_syntax_==1 } {
			set parse_error_ "$class: syntax error between\
					$lasttag and $tag in line $lnum."
			foreach m $allmsgs {
				delete $m
			}
			return ""
		}
		set lasttag $ret
		switch $tag {
		v {
			set media ""
			set msg [new SDPMessage]
			lappend allmsgs $msg
			$msg set version_ $value
		}
		o {
			if {![info exists msg]} {
				set media ""
				set msg [new SDPMessage]
				lappend allmsgs $msg
				$msg set version_ 0
				set tmp [$msg set msgtext_]
				lappend tmp "v=0"
				$msg set msgtext_ $tmp
			}
			$msg set creator_ [lindex $value 0]
			$msg set createtime_ [lindex $value 1]
			$msg set modtime_  [lindex $value 2]
			$msg set nettype_ [lindex $value 3]
			$msg set addrtype_ [lindex $value 3]
			$msg set createaddr_ [lindex $value 5]
		}
		s {
			$msg set session_name_ $value
		}
		i {
			if { $media != "" } {
				$media set session_info_ $value
			} else {
				$msg set session_info_ $value
			}
		}
		p {
			set tmp ""
			catch { set tmp [$msg set phonelist_] }
			lappend tmp $value
			$msg set phonelist_ $tmp
		}
		e {
			set tmp ""
			catch { set tmp [$msg set emaillist_] }
			lappend tmp $value
			$msg set emaillist_ $tmp
		}
		u {
			$msg set uri_ $value
		}
		c {
			if { $media != "" } {
				$media set nettype_ [lindex $value 0]
				$media set addrtype_ [lindex $value 1]
				$media set caddr_ [lindex $value 2]
			} else {
				$msg set nettype_ [lindex $value 0]
				$msg set addrtype_ [lindex $value 1]
				$msg set caddr_ [lindex $value 2]
			}
		}
		b {
			set bwspec [split $value :]
			if { $media != "" } {
				$media set bwmod_ [lindex $bwspec 0]
				$media set bwval_ [lindex $bwspec 1]
			} else {
				$msg set bwmod_ [lindex $bwspec 0]
				$msg set bwval_ [lindex $bwspec 1]
			}
		}
		t {
			set tdes [new SDPTime]
			$tdes set fields_(t) $value
			$tdes set starttime_ [lindex $value 0]
			$tdes set endtime_ [lindex $value 1]
			set tmp [$msg set alltimedes_]
			lappend tmp $tdes
			$msg set alltimedes_ $tmp
		}
		r {
			$tdes set fields_(r) $value
			$tdes set repeat_interval_ [lindex $value 0]
			$tdes set active_duration_ [lindex $value 1]
			$tdes set offlist_ [lrange $value 2 end]
		}
		z {
			set nval [llength $value]
			if [expr 2 * ($nval / 2) != $nval] {
				foreach m $allmsgs {
					delete $m
				}
				return ""
			}
			$self instvar zoneinfo_
			for { set n 0 } { $n < $nval } { incr n } {
				set adjtime [lindex $value $n]
				incr n
				set offset [lindex $value $n]
				lappend zoneinfo_ "$adjtime $offset"
			}
		}
		k {
			set tmp [split $value :]
			if { $media != "" } {
				$media set crypt_method_ [lindex $tmp 0]
				$media set crypt_key_ [lindex $tmp 1]
			} else {
				$msg set crypt_method_ [lindex $tmp 0]
				$msg set crypt_key_ [lindex $tmp 1]
			}
		}
		a {
			set attribute [split $value ":"]
			set attname [lindex $attribute 0]
			set attval [join [lrange $attribute 1 end] ":"]
			if { $media != "" } {
				set target $media
			} else {
				set target $msg
			}
			if [catch {$target set attributes_($attname)}] {
				$target set attributes_($attname) {}
			}
			$target set attributes_($attname) \
			    [concat [$target set attributes_($attname)] \
				 [list $attval]]
		}
		m {
			set media [new SDPMedia $msg]
			set mt [lindex $value 0]
			$media set mediatype_ $mt
			$media set port_  [lindex $value 1]
			$media set proto_ [lindex $value 2]
			$media set fmt_ [lrange $value 3 end]
			set tmp ""
			catch { set tmp [$msg set media_array_($mt)] }
			lappend tmp $media
			$msg set media_array_($mt) $media
			set tmp [$msg set allmedia_]
			lappend tmp $media
			$msg set allmedia_ $tmp
		}
		default {
			set parse_error_ "$class: error unknown modifier $tag."
			foreach m $allmsgs {
				delete $m
			}
			return ""
		}
		}
		set tmp [$msg set msgtext_]
		lappend tmp $line
		$msg set msgtext_ $tmp
		if { $media != "" && [regexp {[icbka]} $tag] } {
			$media set fields_($tag) $value
		} else {
			$msg set fields_($tag) $value
		}
	}
	foreach msg $allmsgs {
		set tmp [$msg set msgtext_]
		set tmp [join $tmp \n]
		append tmp \n
		$msg set msgtext_ $tmp
	}
	return $allmsgs
}
SDPParser instproc parse_error { } {
	return [$self set parse_error_]
}
SDPMessage instproc init {} {
	$self next
	$self instvar allmedia_ alltimedes_ msgtext_
	set allmedia_ ""
	set alltimedes_ ""
	set msgtext_ ""
}
SDPMessage instproc destroy {} {
	$self instvar allmedia_ alltimedes_
	foreach m $allmedia_ {
		delete $m
	}
	foreach t $alltimedes_ {
		delete $t
	}
	$self next
}
SDPMessage instproc media { media_type } {
	$self instvar media_array_
	if [info exists media_array_($media_type)] {
		return $media_array_($media_type)
	} else {
		return ""
	}
}
SDPMessage instproc have_field { field } {
	$self instvar fields_
	return [info exists fields_($field)]
}
SDPMessage instproc field_value { field } {
	$self instvar fields_
	if [info exists fields_($field)] {
		return $fields_($field)
	} else {
		return ""
	}
}
SDPMessage instproc attributes {} {
	$self instvar attributes_
	if [info exists attributes_] {
		return [array names attributes_]
	} else {
		return ""
	}
}
SDPMessage instproc have_attr { name } {
	$self instvar attributes_
	return [info exists attributes_($name)]
}
SDPMessage instproc attr_value { name } {
    $self instvar attributes_
    if [info exists attributes_($name)] {
	    return $attributes_($name)
    } else {
	    return ""
    }
}
SDPMessage instproc obj2str {} {
	$self instvar attributes_ alltimedes_ allmedia_
	set o "v=[$self field_value v]"
	foreach f { o s i u } {
		if [$self have_field $f] {
			set n "$f=[$self field_value $f]"
			set o $o\n$n
		}
	}
	$self instvar phonelist_ emaillist_
	if [info exists phonelist_] {
		foreach e $phonelist_ {
			set n "p=$e"
			set o $o\n$n
		}
	}
	if [info exists emaillist_] {
		foreach e $emaillist_ {
			set n "e=$e"
			set o $o\n$n
		}
	}
	foreach f { c b } {
		if [$self have_field $f] {
			set n "$f=[$self field_value $f]"
			set o $o\n$n
		}
	}
	foreach t $alltimedes_ {
		set n [$t obj2str]
		set o $o\n$n
	}
	foreach f { z k } {
		if [$self have_field $f] {
			set n "$f=[$self field_value $f]"
			set o $o\n$n
		}
	}
	foreach a [$self attributes] {
		if { $attributes_($a) == "" } {
			set n "a=$a"
		} else {
			set n "a=$a:$attributes_($a)"
		}
		set o $o\n$n
	}
	foreach m $allmedia_ {
		set n [$m obj2str]
		set o $o\n$n
	}
	return $o
}
SDPMessage public unique_key {} {
    if ![$self have_field o] {
	$self warn "in SDPMessage::unique_key without o= field"
	return ""
    }
    set l [split [$self field_value o]]
    set l [lreplace $l 2 2]
    set key [join $l :]
    return $key
}
SDPMessage instproc htmlify_media { } {
    set html {}
    foreach media [$self set allmedia_] {
	append html [$media create_dynamic_html \
		[DynamicHTMLifier set html_(media)]]
    }
    return $html
}
SDPMessage instproc htmlify_times { {single_line 0} } {
    set html {}
    if $single_line { set t time1 } else { set t time }
    foreach time [$self set alltimedes_] {
	set repeat [string tolower [$time readable_repeat]]
	if { [$time set starttime_] != 0 } {
	    append html [$time create_dynamic_html \
			    [DynamicHTMLifier set html_(${t}_$repeat)]]
	} else {
	    append html "Unbounded session"
	}
    }
    return $html
}
SDPMessage instproc htmlify_url { } {
    $self instvar uri_
    if [info exists uri_] {
	return "<a href=\"$uri_\">$uri_</a>"
    } else {
	return ""
    }
}
SDPMessage instproc htmlify_list { varname } {
    set list {}
    foreach elt [$self get $varname] {
	if { $list!={} } {
	    append list ", $elt"
	} else {
	    append list $elt
	}
    }
    return $list
}
SDPMessage instproc get { varname } {
    $self instvar $varname
    if [info exists $varname] {
	return [set $varname]
    } else {
	return ""
    }
}
SDPMedia instproc htmlify_mediatype { } {
    return "[$self set mediatype_]"
}
SDPMedia instproc get { varname } {
    $self instvar $varname
    if [info exists $varname] {
	return [set $varname]
    } elseif { $varname == "spec_" } {
	    set caddr [split [$self get caddr_] /]
	    set port [$self get port_]
	    set spec [lindex $caddr 0]/$port
	    set ttl [lindex $caddr 1]
	    if { $ttl != {} } { append spec /$ttl }
	    return $spec
    } else {
	return ""
    }
}
SDPMedia instproc init {{msg ""}} {
	$self next
	if {$msg == ""} { return }
	$self instvar attributes_ fields_
	set alist [$msg attributes]
	foreach a $alist {
		set attributes_($a) [$msg set attributes_($a)]
	}
	set vlist [$msg info vars]
	foreach f { session_info_ nettype_ addrtype_ caddr_ bwmod_ bwval_
		crypt_method_ crypt_key_ } {
		if { [lsearch -exact $vlist $f] >= 0 } {
			$self set $f [$msg set $f]
		}
	}
	foreach f { i c b k a } {
		if [$msg have_field $f] {
			set fields_($f) [$msg field_value $f]
		}
	}
}
SDPMedia instproc have_field { field } {
	$self instvar fields_
	return [info exists fields_($field)]
}
SDPMedia instproc field_value { field } {
	$self instvar fields_
	if [info exists fields_($field)] {
		return $fields_($field)
	} else {
		return ""
	}
}
SDPMedia instproc have_attr { name } {
	$self instvar attributes_
	return [info exists attributes_($name)]
}
SDPMedia instproc attr_value { name } {
    $self instvar attributes_
    if [info exists attributes_($name)] {
	    return $attributes_($name)
    } else {
	    return ""
    }
}
SDPMedia instproc attributes {} {
	$self instvar attributes_
	if [info exists attributes_] {
		return [array names attributes_]
	} else {
		return ""
	}
}
SDPMedia instproc obj2str {} {
	$self instvar attributes_
	set o "m=[$self field_value m]"
	foreach f { i c b k } {
		if [$self have_field $f] {
			set n "$f=[$self field_value $f]"
			set o $o\n$n
		}
	}
	foreach a [array names attributes_] {
		if { $attributes_($a) == "" } {
			set n "a=$a"
		} else {
			set n "a=$a:$attributes_($a)"
		}
		set o $o\n$n
	}
	return $o
}
SDPTime instproc have_field { field } {
	$self instvar fields_
	return [info exists fields_($field)]
}
SDPTime instproc field_value { field } {
	$self instvar fields_
	if [info exists fields_($field)] {
		return $fields_($field)
	} else {
		return ""
	}
}
SDPTime instproc obj2str {} {
	set o "t=[$self field_value t]"
	if [$self have_field r] {
		set n "r=[$self field_value r]"
		set o $o\n$n
	}
	return $o
}
SDPTime public get { varname } {
    $self instvar $varname
    if [info exists $varname] {
	return [set $varname]
    } else {
	return ""
    }
}
SDPTime public sec_until_current { time_type } {
    set sdp_time [ntp_to_unix [$self get $time_type]]
    set current [clock seconds]
    return [expr $sdp_time - $current]
}
SDPTime public current_in_interval { start end } {
    set current [unix_to_ntp [clock seconds]]
    if { [expr $start == 0 && $end == 0] } {
	return 1
    } elseif { $start == 0 } {
	return [expr $end > $current]
    } elseif { $end == 0 } {
	return [expr $start <= $current]
    } else {
	return [expr $start <= $current && $end > $current]
    }
}
SDPTime public readable_time { time_type } {
    set sec [ntp_to_unix [$self get $time_type]]
    if { $sec == 0 } {
	return *unbounded*
    } else {
	return [clock format $sec -format {%H:%M}]
    }
}
SDPTime public readable_duration { } {
    set duration [$self get active_duration_]
    set hours [expr $duration / 3600]
    if { $hours < 24 } {
	return "$hours hour(s)"
    }
    set days [expr $hours / 24]
    if { $days < 7 } {
	return "$days day(s)"
    }
    set weeks [expr $days / 7]
    return "$weeks week(s)"
}
SDPTime public readable_date { time_type {numonly 0} } {
    set sec [ntp_to_unix [$self get $time_type]]
    if { $sec == 0 } {
	return *unbounded*
    } elseif $numonly {
	return [clock format $sec -format {%m/%d/%y}]
    } else {
	return [clock format $sec -format {%B %d, %Y}]
    }
}
SDPTime public readable_day { time_type } {
    set sec [ntp_to_unix [$self get $time_type]]
    if { $sec == 0 } {
	return *unbounded*
    } else {
	return [clock format $sec -format {%a}]
    }
}
SDPTime public readable_day_full { time_type } {
    set sec [ntp_to_unix [$self get $time_type]]
    if { $sec == 0 } {
	return *unbounded*
    } else {
	return [clock format $sec -format {%A}]
    }
}
SDPTime public readable_zone { time_type } {
    set sec [ntp_to_unix [$self get $time_type]]
    return [clock format $sec -format {%Z}]
}
SDPTime public readable_repeat { } {
    set interval [$self get repeat_interval_]
    if { $interval == 86400 } {
	return Daily
    } elseif { $interval == 604800 } {
	return Weekly
    } else {
	return None
    }
}
Class PaneManager
PaneManager instproc pane_drag {master D} {
	$self instvar pane_
	if [info exists pane_(lastD)] {
		if ![info exists pane_(lastPercent)] {
			set pane_(lastPercent) $pane_(-percent)
		}
		set delta [expr double($pane_(lastD) - $D) \
				/ $pane_(size)]
		set pane_(lastPercent) [expr $pane_(lastPercent) - $delta]
		set pane_(-percent) $pane_(lastPercent)
		if {$pane_(-percent) < 0.0} {
			set pane_(-percent) 0.0
		} elseif {$pane_(-percent) > 1.0} {
			set pane_(-percent) 1.0
		}
		if {0} {
			$self pane_geometry $master
		} else {
			if {$pane_(D) == "X"} {
				place $pane_(divider) -relx $pane_(-percent)
				place $pane_(grip) -relx $pane_(-percent)
			} else {
				place $pane_(divider) -rely $pane_(-percent)
				place $pane_(grip) -rely $pane_(-percent)
			}
		}
	}
	set pane_(lastD) $D
}
PaneManager instproc pane_stop {master} {
	$self instvar pane_
	if {1} {
		$self pane_geometry $master
	}
	catch {unset pane_(lastD)}
	catch {unset pane_(lastPercent)}
}
PaneManager instproc pane_geometry {master} {
	$self instvar pane_
	raise $pane_(divider)
	raise $pane_(grip)
	if {$pane_(D) == "X"} {
		place $pane_(1) -relwidth $pane_(-percent)
		place $pane_(2) -relwidth [expr 1.0 - $pane_(-percent)]
		place $pane_(divider) -relx $pane_(-percent)
		place $pane_(grip) -relx $pane_(-percent)
		set pane_(size) [winfo width $master]
	} else {
		place $pane_(1) -relheight $pane_(-percent)
		place $pane_(2) -relheight [expr 1.0 - $pane_(-percent)]
		place $pane_(divider) -rely $pane_(-percent)
		place $pane_(grip) -rely $pane_(-percent)
		set pane_(size) [winfo height $master]
	}
}
PaneManager public percent { {p {}} } {
	$self instvar pane_
	if { $p == {} } { return $pane_(-percent) }
	if { $p < 0.0 } { set p 0.0 }
	if { $p > 1.0 } { set p 1.0 }
	set pane_(-percent) $p
	$send pane_geometry
}
proc pane_test {{p .p} {orient vert}} {
	catch {destroy $p}
	frame $p -width 200 -height 200
	button $p.1 -bg blue -text foo
	button $p.2 -bg green -text bar
	pack $p -expand true -fill both
	pack propagate $p off
	new PaneManager $p.1 $p.2 -in $p -orient $orient -percent 0.3
}
PaneManager instproc init {f1 f2 args} {
	$self instvar pane_
	set t(-orient) vertical
	set t(-percent) 0.5
	set t(-in) [winfo parent $f1]
	array set t $args
	set master $t(-in)
	array set pane_ [array get t]
	set pane_(1) $f1
	set pane_(2) $f2
	if { [winfo toplevel $master] == $master } {
		set parent $master
	} else {
		set parent [winfo parent $master]
	}
	set pane_(divider) [frame $parent.divider$self -width 2 -height 2 \
			-bd 2 -relief groove]
	set pane_(grip) [frame $parent.grip$self -background gray50 \
			-width 10 -height 10 -bd 1 -relief raised \
			-cursor crosshair]
	if {[string match vert* $pane_(-orient)]} {
		set pane_(D) Y
		place $pane_(1) -in $master -x 0 -rely 0.0 -anchor nw \
				-relwidth 1.0 -height -1
		place $pane_(2) -in $master -x 0 -rely 1.0 -anchor sw \
				-relwidth 1.0 -height -1
		place $pane_(divider) -in $master -anchor w -relx 0.0 \
				-relwidth 1.0
		place $pane_(grip) -in $master -anchor c -relx 0.8
	} else {
		set pane_(D) X
		place $pane_(1) -in $master -relx 0.0 -y 0 -anchor nw \
				-relheight 1.0 -width -1
		place $pane_(2) -in $master -relx 1.0 -y 0 -anchor ne \
				-relheight 1.0 -width -1
		place $pane_(divider) -in $master -anchor n -rely 0.0 \
				-relheight 1.0
		place $pane_(grip) -in $master -anchor c -rely 0.8
	}
	bind $master <Configure> [list $self pane_geometry $master]
	bind $pane_(grip) <ButtonPress-1> \
			[list $self pane_drag $master %$pane_(D)]
	bind $pane_(grip) <B1-Motion> \
			[list $self pane_drag $master %$pane_(D)]
	bind $pane_(grip) <ButtonRelease-1> \
			[list $self pane_stop $master]
	set pane_(master) $master
	$self pane_geometry $master
}
PaneManager public destroy {} {
	$self instvar pane_
	destroy $pane_(divider)
	destroy $pane_(grip)
	if [winfo exists $pane_(1)] { place forget $pane_(1) }
	if [winfo exists $pane_(2)] { place forget $pane_(2) }
	if [winfo exists $pane_(master)] { bind $pane_(master) <Configure> "" }
	$self next
}
WidgetClass ASMonitorUI -default {
	{ *ScrolledListbox*Canvas.relief sunken }
	{ *ScrolledListbox*Canvas.borderWidth 1 }
	{ *ScrolledListbox.scrollbar both }
	{ *ScrolledListbox.bbox.highlightThickness 1 }
	{ *ScrolledListbox.Scrollbar.borderWidth 1 }
	{ *ScrolledListbox.Scrollbar.borderWidth 1 }
	{ *ScrolledListbox.Scrollbar.highlightThickness 1 }
	{ *ScrolledListbox.Scrollbar.width 10 }
	{ *ScrolledListbox*Canvas.width 170 }
	{ *ScrolledListbox*Canvas.height 140 }
	{ *HierarchicalListboxItem.borderWidth 1 }
	{ *HierarchicalListboxItem*font WidgetDefault(-boldfont) }
	{ *Button.borderWidth 1 }
	{ *Button.pady 0 }
}
ASMonitorUI proc.invoke {} {
	$self instvar atype_map_ atype_clr_
	set atype_map_(hm) "Host Managers"
	set atype_map_(srv) "Servents"
	set atype_map_(client) "Clients"
	set atype_map_(all) "All Agents"
	set atype_clr_(hm) blue
	set atype_clr_(srv) red
	set atype_clr_(client) darkgreen
	set atype_clr_(all) black
}
ASMonitorUI public destroy {} {
	$self instvar sdp_ agent_info_ agent_list_ paneMgr_
	delete $sdp_
	foreach name [array names agent_info_] {
		delete $agent_info_($name)
	}
	foreach name [array names agent_list_] {
		delete $agent_list_($name)
	}
	delete $paneMgr_(1)
	delete $paneMgr_(2)
	$self next
}
ASMonitorUI public build_widget {path} {
	$self instvar sdp_
	set sdp_ [new SDPParser]
	global mash
	set toplevel [winfo toplevel $path]
	wm title $toplevel "Active Service Monitor v$mash(version)"
	frame $path.bottom
	label $path.asctrl -text "Control Address: [$self get_option asCtrl]"\
			-anchor w
	button $path.quit -text "Quit" -command "exit" -font \
			[WidgetClass widget_default -boldfont]
	pack $path.asctrl -fill both -expand 1 -anchor w -side left \
			-in $path.bottom
	pack $path.quit -fill y -anchor w -side left -in $path.bottom
	pack $path.bottom -side bottom -fill x
	frame $path.encloser
	frame $path.left_encloser
	ASInfoWindow $path.default_info -relief sunken -borderwidth 1 \
			-width 200
	pack $path.default_info -fill both -expand 1 -side right
	frame $path.lb_frame
	ScrolledListbox $path.agenttypes -itemclass HierarchicalListboxItem \
			-browsecmd "$self select_agent_list"
	label $path.death_label -text "Send death packet to:" -anchor w
	button $path.death -text "All Agents" -command \
			"$self send_death_pkt" -anchor w
	pack $path.death_label -fill x -side top -anchor w -in $path.lb_frame
	pack $path.death -fill x -side top -in $path.lb_frame
	frame $path.frame
	pack $path.frame -fill both -expand 1 -side top -in $path.lb_frame
	$path.left_encloser configure -width 195 -height 320
	$self set paneMgr_(1) [new PaneManager $path.agenttypes \
			$path.lb_frame -in $path.left_encloser \
			-orient vertical -percent 0.4]
	$path.encloser configure -width 400 -height 320
	pack $path.encloser -side top -fill both -expand 1
	$self set paneMgr_(2) [new PaneManager $path.left_encloser \
			$path.default_info -in $path.encloser \
			-orient horizontal -percent 0.4]
	$self agent_list hm ""
	$self agent_list srv ""
	$self agent_list client ""
	$self agent_list all ""
	$self instvar agentlists_
	$agentlists_(all) browse_me
	$path.agenttypes selection set -id all
	set o [$self get_option doLog]
	if { $o != "" } {
		$self instvar log_
		foreach a [split $o :] {
			set log_($a) 1
		}
	}
}
ASMonitorUI public application {a} {
	$self set appl_ $a
}
ASMonitorUI private send_death_pkt {} {
	$self instvar appl_
	set l [$self info path].agenttypes
	set sel [lindex [$l selection get] 0]
	if {$sel != {}} {
		set sel [split $sel ,]
		set atype [lindex $sel 0]
		set srv_name [lindex $sel 1]
		if { $atype != "client" } {
			if { [string match "MeGa*" $srv_name] } {
				set srv_name [string range $srv_name 6 end]
				$appl_ build_death $srv_name
			} elseif { $atype=="srv" } {
				if { $srv_name!="" } {
					$appl_ build_death srv
				} else {
					foreach m {audio video sdp mb srv} {
						$appl_ build_death $m
					}
				}
			} elseif { $atype=="hm" } {
				$appl_ build_death hm
			} elseif { $atype=="all" } {
				foreach m {audio video sdp mb hm srv} {
					$appl_ build_death $m
				}
			}
		}
	}
}
ASMonitorUI private select_agent_list {id} {
	$self instvar agentlists_
	if [info exists agentlists_($id)] {
		$agentlists_($id) browse_me
	}
	set button [$self subwidget death]
	if [string match "client*" $id] {
		$button configure -state disabled -text "Client"
	} else {
		switch -exact -- $id {
			hm { set text "All Host Managers" }
			srv { set text "All Servents" }
			all { set text "All Agents" }
			default {
				if [string match "srv,MeGa: *" $id] {
					set text [string tolower [string range\
							$id 10 end]]
					set text "[string toupper [string \
							index $text 0]][string\
							range $text 1 end]\
							Agents"
				} else {
					set text "All Non-MeGa Agents"
				}
			}
		}
		$button configure -state normal -text $text
	}
}
ASMonitorUI public recv_msg {atype aspec addr srv_name srv_loc srv_inst \
		ssg_port agent_data delta} {
	$self instvar sdp_
	if {$srv_name=="MeGa"} {
		set sdp [$sdp_ parse $agent_data]
		set media [lindex [$sdp set allmedia_] 0]
		if { $media == "" } {return}
		set qualified_srv_name "$srv_name: [$media set mediatype_]"
	} else {
		set qualified_srv_name $srv_name
		set sdp ""
	}
	set a [$self agent_info $aspec $atype $qualified_srv_name]
	$a update $atype $aspec $addr $qualified_srv_name $srv_loc $srv_inst \
			$ssg_port $agent_data $sdp $delta
	if {$srv_name=="MeGa"} {
		delete $sdp
	}
}
ASMonitorUI public register {atype aspec addr srv_name srv_inst agent_data} {
	$self recv_msg $atype $aspec $addr $srv_name "" $srv_inst - \
			$agent_data ""
	$self instvar log_
	if [info exists log_($atype)] {
		puts "register: [gettimeofday] + $aspec $atype\
				$qualified_srv_name $addr"
	}
}
ASMonitorUI public unregister {atype aspec addr srv_name srv_inst agent_data} {
	$self instvar sdp_
	if {$srv_name=="MeGa"} {
		set agent_data [$sdp_ parse $agent_data]
		set media [lindex [$agent_data set allmedia_] 0]
		if { $media == "" } {
			delete $agent_data
			return
		}
		append srv_name ": [$media set mediatype_]"
		delete $agent_data
	}
	set a [$self agent_info $aspec $atype $srv_name]
	delete $a
	$self instvar log_
	if [info exists log_($atype)] {
		puts "unregister: [gettimeofday] + $aspec $atype\
				$srv_name $addr"
	}
}
ASMonitorUI public agent_info {aspec atype srv_name} {
	$self instvar agent_info_
	if ![info exists agent_info_($aspec)] {
		set agent_info_($aspec) [new ASAgentInfo $self $aspec $atype \
				$srv_name]
	}
	return $agent_info_($aspec)
}
ASMonitorUI public agent_list {atype srv_name} {
	$self instvar agent_list_
	if ![info exists agent_list_($atype,$srv_name)] {
		set agent_list_($atype,$srv_name) [new ASAgentList $self \
				$atype $srv_name]
	}
	return $agent_list_($atype,$srv_name)
}
Class ASAgentInfo
ASAgentInfo public init {ui aspec atype srv_name} {
	$self next
	$self instvar name_ ui_ windows_
	ASMonitorUI instvar atype_clr_
	set windows_ {}
	set ui_ $ui
	set name_(aspec) $aspec
	set name_(atype) $atype
	set name_(srv_name) $srv_name
	set list [$ui agent_list $atype $srv_name]
	$list insert $self $aspec $atype_clr_($atype)
	set glist [$ui agent_list $atype ""]
	if { $glist != $list } {
		$glist insert $self "$srv_name: $aspec" $atype_clr_($atype)
	}
	set glist [$ui agent_list all ""]
	if { $srv_name!={} } {
		set label "${srv_name}($atype): $aspec"
	} else { set label "$atype: $aspec" }
	$glist insert $self $label $atype_clr_($atype)
	if { [$ui_ subwidget default_info current]=={} } {
		$glist browse_agent $self
	}
}
ASAgentInfo public destroy {} {
	$self instvar ui_ name_ windows_ name_
	if { [lsearch $windows_ [$ui_ subwidget default_info info self]]!=-1} {
		$ui_ subwidget default_info attach {}
	}
	set list [$ui_ agent_list $name_(atype) $name_(srv_name)]
	$list delete $self
	if { $name_(srv_name)!={} } {
		if [$list is_empty] {
			delete $list
		}
	}
	set glist [$ui_ agent_list $name_(atype) ""]
	if { $glist != $list } {
		$glist delete $self
	}
	set glist [$ui_ agent_list all ""]
	$glist delete $self
	$ui_ instvar agent_info_
	unset agent_info_($name_(aspec))
	$self next
}
ASAgentInfo public attach {window} {
	$self instvar windows_
	lappend windows_ $window
}
ASAgentInfo public detach {window} {
	$self instvar windows_
	set idx [lsearch -exact $windows_ $window]
	if { $idx!=-1 } { set windows_ [lreplace $windows_ $idx $idx] }
}
ASAgentInfo public update {atype aspec addr srv_name srv_loc srv_inst ssg_port\
		agent_data sdp delta} {
	$self instvar fields_ prv_fields_
	set fields_(srv_loc) $srv_loc
	set fields_(srv_inst) $srv_inst
	set fields_(ssg_port) $ssg_port
	set fields_(agent_data) $agent_data
	set fields_(delta) $delta
	set fields_(last_heard) [gettimeofday ascii]
	set fields_(heard_from) $addr
	if { $sdp=={} } {
		set fields_(sdp) 0
	} else {
		set fields_(sdp) 1
		if { $atype=="srv" } {
			set prv_fields_(o) [join [$sdp field_value o] :]
			set prv_fields_(s) [join [$sdp field_value s] :]
			set prv_fields_(toolname) [$sdp attr_value tool]
			set prv_fields_(sessions) ""
			foreach media [$sdp set allmedia_] {
				set tmp [split [$media set caddr_] /]
				set caddr [lindex $tmp 0]/[$media set \
						port_]/[lindex $tmp 1]
				append prv_fields_(sessions) "\n$caddr"
			}
			set prv_fields_(sessions) [string range \
					$prv_fields_(sessions) 1 end]
		} elseif { $atype=="client" } {
			set prv_fields_(o) [join [$sdp field_value o] :]
			set prv_fields_(s) [join [$sdp field_value s] :]
			set prv_fields_(toolname) [$sdp attr_value tool]
			set prv_fields_(global) [$sdp set caddr_]
			set prv_fields_(local) [[$sdp set allmedia_] set \
					caddr_]
			set prv_fields_(bw) ""
			if [$sdp have_field b] {
				set bwval [$sdp set bwval_]
				set bwval [$self format_bps $bwval]
				set prv_fields_(bw) $bwval
			}
		}
	}
	$self instvar windows_
	foreach w $windows_ {
		$w update
	}
}
ASAgentInfo private 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.0f kb/s" [expr $bps / 1000.]]
	} else {
		set bps [format "%.1f Mb/s" [expr $bps / 1000000.]]
	}
	return $bps
}
Class ASAgentList
ASAgentList public init {ui atype srv_name} {
	$self next
	$self instvar widget_ ui_ agentlists_id_
	$ui instvar agentlists_
	set n [ASMonitorUI set atype_map_($atype)]
	set clr [ASMonitorUI set atype_clr_($atype)]
	if { $srv_name != "" } {
		append n "/$srv_name"
		$ui subwidget agenttypes insert after -id $atype \
				[list -id $atype,$srv_name {} $n]
		set agentlists_($atype,$srv_name) $self
		set agentlists_id_ $atype,$srv_name
	} else {
		$ui subwidget agenttypes insert end [list -id $atype \
				Icons(minimize) $n]
		set agentlists_($atype) $self
		set agentlists_id_ $atype
	}
	set w [$ui subwidget agenttypes info widget -id $agentlists_id_]
	$w configure -normalforeground $clr -selectforeground $clr
	set ui_ $ui
	option add *agentlist$self*borderWidth 1
	set widget_ [ScrolledListbox [$ui info path].agentlist$self -options \
			{ { bbox.height 140 } } \
			-browsecmd "$self browse_agent" \
			-command "$self browse_agent_new_window"]
}
ASAgentList public destroy {} {
	$self instvar ui_ agentlists_id_
	$ui_ instvar agent_list_
	unset agent_list_($agentlists_id_)
	$ui_ subwidget agenttypes delete -id $agentlists_id_
	$self next
}
ASAgentList public insert {info label clr} {
	$self instvar widget_
	$widget_ insert end "-id $info $label"
	set w [$widget_ info widget -id $info]
	$w configure -normalforeground $clr -selectforeground $clr
}
ASAgentList public delete {info} {
	$self instvar widget_
	$widget_ delete -id $info
}
ASAgentList public is_empty {} {
	$self instvar widget_
	if { [$widget_ info numelems] <= 0 } { return 1 } else { return 0 }
}
ASAgentList public browse_me { } {
	$self instvar ui_ widget_
	pack forget [pack slaves [$ui_ info path].frame]
	pack $widget_ -in [$ui_ info path].frame -fill both -expand 1
	if { [$widget_ info numelems] > 0 } {
		$self browse_agent [$widget_ info id 0]
	}
}
ASAgentList public browse_agent {id} {
	$self instvar widget_ ui_
	if { [lindex [$widget_ selection get] 0] != $id } {
		$widget_ selection set -id $id
	}
	$ui_ subwidget default_info attach $id $self
}
ASAgentList public browse_agent_new_window {id} {
	$self instvar widget_
	set w .agent_info_$id
	if [winfo exists $w] {
		wm deiconify $w
		return
	}
	$id instvar name_
	toplevel $w
	wm title $w "Agent Info: $name_(aspec) ($name_(atype):\
			$name_(srv_name))"
	ASInfoWindow $w.info
	pack $w.info -side top -fill both -expand 1
	button $w.dismiss -bd 1 -pady 0 -text "Dismiss" \
			-command "destroy $w"
	pack $w.dismiss -side right
	$w.info attach $id
	after "2000" delete $id
}
WidgetClass ASInfoWindow -default {
	{ *ScrolledWindow*Canvas.width 200 }
	{ *ScrolledWindow.scrollbar both }
	{ *ScrolledWindow.bbox.highlightThickness 1 }
	{ *ScrolledWindow.Scrollbar.borderWidth 1 }
	{ *ScrolledWindow.Scrollbar.borderWidth 1 }
	{ *ScrolledWindow.Scrollbar.highlightThickness 1 }
	{ *ScrolledWindow.Scrollbar.width 10 }
}
ASInfoWindow proc.invoke {} {
	$self instvar labels_
	set labels_(srv_loc)      "Service location"
	set labels_(srv_inst)     "Service instance"
	set labels_(ssg_port)     "SSG port"
	set labels_(last_heard)   "Last heard"
	set labels_(heard_from)   "Heard from"
	set labels_(delta)        "Delta"
	set labels_(agent_data)   "Agent data"
	set labels_(o)            "Agent ID"
	set labels_(s)            "Session ID"
	set labels_(toolname)     "Tool"
	set labels_(sessions)     "Sessions"
	set labels_(global)       "Global addr"
	set labels_(local)        "Local addr"
	set labels_(bw)           "Bandwidth"
}
ASInfoWindow public build_widget path {
	ScrolledWindow $path.scroll
	pack $path.scroll -fill both -expand 1
	set path [$path.scroll subwidget window]
	label $path.name -bd 1 -relief sunken -anchor w -foreground \
			[WidgetClass widget_default -disabledforeground] \
			-text "No agent exists"
	pack $path.name -fill x -side top
	frame $path.labels
	frame $path.values
	$self create_label srv_loc
	$self create_label srv_inst
	$self create_label ssg_port
	$self create_label last_heard
	$self create_label heard_from
	$self create_label delta
	$self create_label agent_data
	pack $path.labels -side left -anchor n
	pack $path.values -fill x -expand 1 -side left -anchor n
}
ASInfoWindow public destroy {} {
	$self instvar obj_
	if {[info exists obj_] && [ASAgentInfo info instances $obj_]==$obj_} {
		$obj_ detach $self
	}
	$self next
}
ASInfoWindow public create_label { name {after_id {}} } {
	ASInfoWindow instvar labels_
	set path [[$self info path].scroll subwidget window]
	label $path.labels.$name -text "$labels_($name):" -anchor w \
			-justify left -font [WidgetClass widget_default -font]
	label $path.$name -anchor w -justify left \
			-font [WidgetClass widget_default -font]
	if { $after_id=={} } {
		pack $path.labels.$name -fill x -anchor n -expand 1
		pack $path.$name -in $path.values -fill x -anchor n -expand 1
	} else {
		pack $path.labels.$name -fill x -anchor n -expand 1 \
				-before $path.labels.$after_id
		pack $path.$name -in $path.values -fill x -anchor n -expand 1\
				-before $path.$after_id
	}
}
ASInfoWindow public current {} {
	$self instvar obj_
	if [info exists obj_] { return $obj_ }  else { return {} }
}
ASInfoWindow public attach {obj {list {}}} {
	$self instvar obj_ list_
	if { [info exists list_] && $list_!={} && ($list_!=$list || \
			$obj_!=$obj) } {
		if { $list_!=$list } { [$list_ set widget_] selection clear }
		$obj_ instvar prv_fields_
		set path [[$self info path].scroll subwidget window]
		foreach name [array names prv_fields_] {
			if [winfo exists $path.$name] {
				destroy $path.labels.$name
				destroy $path.$name
			}
		}
	}
	if [info exists obj_] { $obj_ detach $self }
	if { $obj=={} } {
		set path [[$self info path].scroll subwidget window]
		$path.name configure -text "No agent exists" -foreground \
				[WidgetClass widget_default \
				-disabledforeground]
		$obj_ instvar fields_
		foreach name  [array names fields_] {
			if [winfo exists $path.$name] {
				$path.$name configure -text ""
			}
		}
		unset obj_
		unset list_
	} else {
		$obj attach $self
		set obj_ $obj
		set list_ $list
		$self update
	}
}
ASInfoWindow public update {} {
	$self instvar obj_
	$obj_ instvar name_ fields_ prv_fields_
	set path [$self info path]
	set path [$path.scroll subwidget window]
	if { $name_(srv_name)!={} } {
		set text "$name_(srv_name)($name_(atype)): $name_(aspec)"
	} else {
		set text "$name_(atype): $name_(aspec)"
	}
	$path.name configure -text $text -foreground \
			[ASMonitorUI set atype_clr_($name_(atype))]
	foreach name [array names fields_] {
		if [winfo exists $path.$name] {
			$path.$name configure -text $fields_($name)
		}
	}
	foreach name [array names prv_fields_] {
		if ![winfo exists $path.$name] {
			$self create_label $name delta
		}
		$path.$name configure -text $prv_fields_($name)
	}
}
Object instproc has_method { method } {
	if { [$self info procs $method]!="" } {
		return 1
	}
	return [[$self info class] has_method $method]
}
Class instproc has_method { method } {
	if { [$self info instprocs $method]!="" } {
		return 1
	}
	foreach cl [$self info heritage] {
		if { [$cl info instprocs $method]!="" } {
			return 1
		}
	}
	return 0
}
proc version {} {
	global mash
	return $mash(version)
}
proc local_fqdn {} {
	set host ""
	catch {set host [lookup_host_name [localaddr]]}
	if { [string first . $host] < 0 } {
		return ""
	}
	return $host
}
proc email_heuristic {} {
	set user [user_heuristic]
	set addr [local_fqdn]
	if { $addr == "" } {
		return ""
	}
	return $user@$addr
}
proc user_heuristic {} {
	global env
	if [info exists env(USER)] {
		set user $env(USER)
	} elseif [info exists env(LOGNAME)] {
		set user $env(LOGNAME)
	} else {
		catch {set env(USER) [getusername]}
		if [info exists env(USER)] {
			return $env(USER)
		}
		return "UNKNOWN"
	}
}
proc format_fps f {
	set fps $f
	if { $fps < .1 } {
		set fps "0 f/s"
	} elseif { $fps < 10 } {
		set fps [format "%.1f f/s" $fps]
	} else {
		set fps [format "%2.0f f/s" $fps]
	}
	return $fps
}
proc format_bps b {
	set bps $b
	if { $bps < 1 } {
		set bps "0 bps"
	} elseif { $bps < 1000 } {
		set bps [format "%3.0f bps" $bps]
	} elseif { $bps < 1000000 } {
		set bps [format "%3.1f kb/s" [expr $bps / 1000.]]
	} else {
		set bps [format "%.2f Mb/s" [expr $bps / 1000000.]]
	}
	return $bps
}
proc gettime {sec} {
    clock format $sec
}
proc sdr_gettimeofday {} {
    clock seconds
}
proc gettimenow {} {
    gettime [clock seconds]
}
proc getreadabletime {} {
    return [clock format [clock seconds] -format {%H:%M, %d/%m/%y}]
}
proc unix_to_ntp {unixtime} {
    set oddoffset 2208988800
    if {$unixtime==0} {return 0}
    return [format %u [expr $unixtime + $oddoffset]]
}
proc ntp_to_unix {ntptime} {
    set oddoffset 2208988800
    if {($ntptime==0)||($ntptime==1)} {return $ntptime}
    if {[catch {expr $ntptime - $oddoffset}] !=0} {
	    return 0
    }
    return [format %u [expr $ntptime - $oddoffset]]
}
proc duration_readable {secs {option terse}} {
	set ret ""
	set r [expr round($secs)]
	set h [expr $r / 3600]
	set r [expr $r % 3600]
	set m [expr $r / 60]
	set s [expr $r % 60]
	if {$option == "verbose"} then {
		if {$h} {
			set ret "$ret $h\h"
		}
		if {$m} {
			set ret "$ret $m\m"
		}
		if {$s} {
			set ret "$ret and $s\s"
		}
	} else {
		set ret "$h:$m:$s"
	}
		return $ret
}
proc in_multicast addr {
	return [expr ([lindex [split $addr .] 0] & 0xf0) == 0xe0]
}
proc invalid_addr a {
    set l [split $a .]
    if {[llength $l] != 4} { return 1 }
    foreach i $l {
	if {![is_number $i] || $i<0 || $i>255} { return 1 }
    }
    return 0
}
proc is_number n {
    if [catch {expr $n}] {
	return 0
    }
	return 1
}
proc parray {a {pattern *}} {
    upvar 1 $a array
    if ![array exists array] {
        error "\"$a\" isn't an array"
    }
    set maxl 0
    foreach name [lsort [array names array $pattern]] {
        if {[string length $name] > $maxl} {
            set maxl [string length $name]
        }
    }
    set maxl [expr {$maxl + [string length $a] + 2}]
    foreach name [lsort [array names array $pattern]] {
        set nameString [format %s(%s) $a $name]
        puts stdout [format "%-*s = %s" $maxl $nameString $array($name)]
    }
}
Class AddressBlock -configuration {
	defaultTTL 1
	maxbw -1
}
Class AddressBlock/RTP -superclass AddressBlock
Class AddressBlock/Simple -superclass AddressBlock
AddressBlock instproc init spec {
	$self next
	$self set nchan_ 0
	foreach s [split $spec ,] {
		set err [$self parse $s]
		if { $err != "" } {
			$self fatal $err
		}
	}
}
AddressBlock instproc data-port p {
	return [expr $p &~ 1]
}
AddressBlock instproc fmt {} {
	$self instvar fmt_
	if [info exists fmt_] { return $fmt_ } else { return "" }
}
AddressBlock instproc ctrl-port p {
	return [expr [$self data-port $p] + 1]
}
AddressBlock instproc addr {{k 0}} {
	return [$self set addr_($k)]
}
AddressBlock instproc sport {{k 0}} {
	return [$self set sport_($k)]
}
AddressBlock instproc rport {{k 0}} {
	return [$self set rport_($k)]
}
AddressBlock instproc ttl {{k 0}} {
	$self instvar ttl_
	if [info exists ttl_($k)] { return $ttl_($k) } else { return {} }
}
AddressBlock instproc nchan {} {
	return [$self set nchan_]
}
AddressBlock instproc parse s {
	set dst [split $s /]
	set n [llength $dst]
	if { $n < 2 } {
		return "must specify both address and port in the form addr/port ($s)"
	}
	set addr [lindex $dst 0]
	set ports [split [lindex $dst 1] :]
	set sport [lindex $ports 0]
	if { [llength $ports] == 1 } {
		set rport $sport
	} else {
		set rport [lindex $ports 1]
	}
	set firstchar [string index $addr 0]
	if [string match \[a-zA-Z\] $firstchar] {
		set s [gethostbyname $addr]
		if { $s == "" } {
			return "cannot lookup host name: $addr"
		}
		set addr $s
	}
	foreach port "$sport $rport" {
		if { ![string match \[0-9\]* $port] || $port >= 65536 } {
			$self fatal "illegal port '$port'"
		}
	}
	set ttl [$self get_option defaultTTL]
	set cnt 1
	if { $n >= 3 } {
		set fmt [lindex $dst 2]
		if { $n==3 && [regexp {^[0-9]+$} $fmt] } {
			set ttl $fmt
			set fmt {}
		}
		if { $n >= 4 } {
			set ttl [lindex $dst 3]
			if { $n > 4 } {
				set cnt [lindex $dst 4]
				if { ![string match \[0-9\]* $cnt] ||
				     $cnt >= 20 } {
					return "$dst: bad layered addr count"
					exit 1
				}
				if { $n > 5 } {
					return "$dst: malformed address"
				}
			}
		}
	}
	if { $ttl < 0 || $ttl > 255 } {
		return "$dst: invalid ttl ($ttl)"
	}
	set oct [split $addr .]
	set base [lindex $oct 0].[lindex $oct 1].[lindex $oct 2]
	set off [lindex $oct 3]
	$self instvar addr_ sport_ rport_ ttl_ nchan_
	set i 0
	while { $i < $cnt } {
		set sp [$self data-port $sport]
		set rp [$self data-port $rport]
		set addr_($nchan_) $base.$off
		set sport_($nchan_) $sp
		set rport_($nchan_) $rp
		set ttl_($nchan_) $ttl
		if [in_multicast $addr] {
			incr off
		}
		incr sport 2
		incr rport 2
		incr i
		incr nchan_
	}
	if { [info exists fmt] && $fmt != "" } {
		$self set fmt_ $fmt
	}
	if [info exists confid] {
		$self add_option confid $confid
	}
	if [info exists ttl] {
		$self add_option defaultTTL $ttl
	}
	$self bandwidth_heuristic
}
AddressBlock instproc bandwidth_heuristic {} {
	$self instvar nchan_ addr_ ttl_ maxbw_
	set i 0
	while { $i < $nchan_ } {
		set maxbw [$self get_option maxbw]
		if { $maxbw <= 0 } {
			set ttl $ttl_($i)
			if { $ttl <= 16 || ![in_multicast $addr_($i)] } {
				set maxbw 10000000
			} elseif { $ttl <= 64 } {
				set maxbw 4000000
			} elseif  { $ttl <= 128 } {
				set maxbw 1000000
			} elseif { $ttl <= 192 } {
				set maxbw 128000
			} else {
				set maxbw 56000
			}
		}
		set maxbw_($i) $maxbw
		incr i
	}
}
AddressBlock/Simple instproc data-port p {
	return $p
}
AddressBlock/RTP instproc data-port p {
	return [expr $p &~ 1]
}
set rlm_param(alpha) 4
set rlm_param(alpha) 2
set rlm_param(beta) 0.75
set rlm_param(init-tj) 1.5
set rlm_param(init-tj) 10
set rlm_param(init-tj) 5
set rlm_param(init-td) 5
set rlm_param(init-td-var) 2
set rlm_param(max) 600
set rlm_param(max) 60
set rlm_param(g1) 0.25
set rlm_param(g2) 0.25
Class MMG
MMG instproc init { levels } {
	$self next
	$self instvar debug_ env_ maxlevel_
	set debug_ 0
	set env_ [lindex [split [$self info class] /] 1]
	set maxlevel_ $levels
	global rlm_debug_flag
	if [info exists rlm_debug_flag] {
		set debug_ $rlm_debug_flag
	}
	$self instvar TD TDVAR state_ subscription_
	global rlm_param
	set TD $rlm_param(init-td)
	set TDVAR $rlm_param(init-td-var)
	set state_ /S
	$self instvar layer_ layers_
	set i 1
	while { $i <= $maxlevel_ } {
		set layer_($i) [$self create-layer [expr $i - 1]]
		lappend layers_ $layer_($i)
		incr i
	}
	set subscription_ 0
	$self add-layer
	set state_ /S
	$self set_TJ_timer
}
MMG instproc set-state s {
	$self instvar state_
	set old $state_
	set state_ $s
	$self debug "FSM: $old -> $s"
}
MMG instproc drop-layer {} {
	$self dumpLevel
	$self instvar subscription_ layer_
	set n $subscription_
	if { $n > 0 } {
		$self debug "DRP-LAYER $n"
		$layer_($n) leave-group
		incr n -1
		set subscription_ $n
	}
	$self dumpLevel
}
MMG instproc add-layer {} {
	$self dumpLevel
	$self instvar maxlevel_ subscription_ layer_
	set n $subscription_
	if { $n < $maxlevel_ } {
		$self debug "ADD-LAYER"
		incr n
		set subscription_ $n
		$layer_($n) join-group
	}
	$self dumpLevel
}
MMG instproc current_layer_getting_packets {} {
	$self instvar subscription_ layer_ TD
	set n $subscription_
	if { $n == 0 } {
		return 0
	}
	set l $layer_($subscription_)
	$self debug "npkts [$l npkts]"
	if [$l getting-pkts] {
		return 1
	}
	set delta [expr [$self now] - [$l last-add]]
	if { $delta > $TD } {
		set TD [expr 1.2 * $delta]
	}
	return 0
}
MMG instproc mmg_loss {} {
	$self instvar layers_
	set loss 0
	foreach l $layers_ {
		incr loss [$l nlost]
	}
	return $loss
}
MMG instproc mmg_pkts {} {
	$self instvar layers_
	set npkts 0
	foreach l $layers_ {
		incr npkts [$l npkts]
	}
	return $npkts
}
MMG instproc check-equilibrium {} {
	global rlm_param
	$self instvar subscription_ maxlevel_ layer_
	set n [expr $subscription_ + 1]
	if { $n >= $maxlevel_ || [$layer_($n) timer] >= $rlm_param(max) } {
		set eq 1
	} else {
		set eq 0
	}
	$self debug "EQ $eq"
}
MMG instproc backoff-one { n alpha } {
	$self debug "BACKOFF $n by $alpha"
	$self instvar layer_
	$layer_($n) backoff $alpha
}
MMG instproc backoff n {
	$self debug "BACKOFF $n"
	global rlm_param
	$self instvar maxlevel_ layer_
	set alpha $rlm_param(alpha)
	set L $layer_($n)
	$L backoff $alpha
	incr n
	while { $n <= $maxlevel_ } {
		$layer_($n) peg-backoff $L
		incr n
	}
	$self check-equilibrium
}
MMG instproc highest_level_pending {} {
	$self instvar maxlevel_
	set m ""
	set n 0
	incr n
	while { $n <= $maxlevel_ } {
		if [$self level_pending $n] {
			set m $n
		}
		incr n
	}
	return $m
}
MMG instproc rlm_update_D  D {
	global rlm_param
	$self instvar TD TDVAR
	set v [expr abs($D - $TD)]
	set TD [expr $TD * (1 - $rlm_param(g1)) \
				+ $rlm_param(g1) * $D]
	set TDVAR [expr $TDVAR * (1 - $rlm_param(g2)) \
		       + $rlm_param(g2) * $v]
}
MMG instproc exceed_loss_thresh {} {
	$self instvar h_npkts h_nlost
	set npkts [expr [$self mmg_pkts] - $h_npkts]
	if { $npkts >= 10 } {
		set nloss [expr [$self mmg_loss] - $h_nlost]
		set loss [expr double($nloss) / ($nloss + $npkts)]
		$self debug "H-THRESH $nloss $npkts $loss"
		if { $loss > 0.25 } {
			return 1
		}
	}
	return 0
}
MMG instproc enter_M {} {
	$self set-state /M
	$self set_TD_timer_wait
	$self instvar h_npkts h_nlost
	set h_npkts [$self mmg_pkts]
	set h_nlost [$self mmg_loss]
}
MMG instproc enter_D {} {
	$self set-state /D
	$self set_TD_timer_conservative
}
MMG instproc enter_H {} {
	$self set_TD_timer_conservative
	$self set-state /H
}
MMG instproc log-loss {} {
	$self debug "LOSS [$self mmg_loss]"
	$self instvar state_ subscription_ pending_ts_
	if { $state_ == "/M" } {
		if [$self exceed_loss_thresh] {
			$self cancel_timer TD
			$self drop-layer
			$self check-equilibrium
			$self enter_D
		}
		return
	}
	if { $state_ == "/S" } {
		$self cancel_timer TD
		set n [$self highest_level_pending]
		if { $n != "" } {
			$self backoff $n
			if { $n == $subscription_ } {
				set ts $pending_ts_($subscription_)
				$self rlm_update_D [expr [$self now] - $ts]
				$self drop-layer
				$self check-equilibrium
				$self enter_D
				return
			}
			if { $n == [expr $subscription_ + 1] } {
				$self cancel_timer TJ
				$self set_TJ_timer
			}
		}
		if [$self our_level_recently_added] {
			$self enter_M
			return
		}
		$self enter_H
		return
	}
	if { $state_ == "/H" || $state_ == "/D" } {
		return
	}
	puts stderr "rlm state machine botched"
	exit -1
}
MMG instproc relax_TJ {} {
	$self instvar subscription_ layer_
	if { $subscription_ > 0 } {
		$layer_($subscription_) relax
		$self check-equilibrium
	}
}
MMG instproc trigger_TD {} {
	$self instvar state_
	if { $state_ == "/H" } {
		$self enter_M
		return
	}
	if { $state_ == "/D" || $state_ == "/M" } {
		$self set-state /S
		$self set_TD_timer_conservative
		return
	}
	if { $state_ == "/S" } {
		$self relax_TJ
		$self set_TD_timer_conservative
		return
	}
	puts stderr "trigger_TD: rlm state machine botched $state)"
	exit -1
}
MMG instproc set_TJ_timer {} {
	global rlm_param
	$self instvar subscription_ layer_
	set n [expr $subscription_ + 1]
	if ![info exists layer_($n)] {
		return
	}
	set I [$layer_($n) timer]
	set d [expr $I / 2.0 + [trunc_exponential $I]]
	$self debug "TJ $d"
	$self set_timer TJ $d
}
MMG instproc set_TD_timer_conservative {} {
	$self instvar TD TDVAR
	set delay [expr $TD + 1.5 * $TDVAR]
	$self set_timer TD $delay
}
MMG instproc set_TD_timer_wait {} {
	$self instvar TD TDVAR
	$self instvar subscription_
	set k [expr $subscription_ / 2. + 1.5]
	$self set_timer TD [expr $TD + $k * $TDVAR]
}
MMG instproc is-recent { ts } {
	$self instvar TD TDVAR
	set ts [expr $ts + ($TD + 2 * $TDVAR)]
	if { $ts > [$self now] } {
		return 1
	}
	return 0
}
MMG instproc level_pending n {
	$self instvar pending_ts_
	if { [info exists pending_ts_($n)] && \
		 [$self is-recent $pending_ts_($n)] } {
		return 1
	}
	return 0
}
MMG instproc level_recently_joined n {
	$self instvar join_ts_
	if { [info exists join_ts_($n)] && \
		 [$self is-recent $join_ts_($n)] } {
		return 1
	}
	return 0
}
MMG instproc pending_inferior_jexps {} {
	set n 0
	$self instvar subscription_
	while { $n <= $subscription_ } {
		if [$self level_recently_joined $n] {
			return 1
		}
		incr n
	}
	$self debug "NO-PEND-INF"
	return 0
}
MMG instproc trigger_TJ {} {
	$self debug "trigger-TJ"
	$self instvar state_ ctrl_ subscription_
	if { ($state_ == "/S" && ![$self pending_inferior_jexps] && \
		  [$self current_layer_getting_packets])  } {
		$self add-layer
		$self check-equilibrium
		set msg "add $subscription_"
		$ctrl_ send $msg
		$self local-join
	}
	$self set_TJ_timer
}
MMG instproc our_level_recently_added {} {
	$self instvar subscription_ layer_
	return [$self is-recent [$layer_($subscription_) last-add]]
}
MMG instproc recv-ctrl msg {
	$self instvar join_ts_ pending_ts_ subscription_
	$self debug "X-JOIN $msg"
	set what [lindex $msg 0]
	if { $what != "add" } {
		return
	}
	set level [lindex $msg 1]
	set join_ts_($level) [$self now]
	if { $level > $subscription_ } {
		set pending_ts_($level) [$self now]
	}
}
MMG instproc local-join {} {
	$self instvar subscription_ pending_ts_ join_ts_
	set join_ts_($subscription_) [$self now]
	set pending_ts_($subscription_) [$self now]
}
MMG instproc debug { msg } {
	$self instvar debug_ subscription_ state_
	if {$debug_} {
		puts stderr "[gettimeofday] layer $subscription_ $state_ $msg"
	}
}
MMG instproc dumpLevel {} {
}
Class Layer
Layer instproc init { mmg } {
	$self next
	$self instvar mmg_ TJ npkts_
	global rlm_param
	set mmg_ $mmg
	set TJ $rlm_param(init-tj)
	set npkts_ 0
}
Layer instproc relax {} {
	global rlm_param
	$self instvar TJ
	set TJ [expr $TJ * $rlm_param(beta)]
	if { $TJ <= $rlm_param(init-tj) } {
		set TJ $rlm_param(init-tj)
	}
}
Layer instproc backoff alpha {
	global rlm_param
	$self instvar TJ
	set TJ [expr $TJ * $alpha]
	if { $TJ >= $rlm_param(max) } {
		set TJ $rlm_param(max)
	}
}
Layer instproc peg-backoff L {
	$self instvar TJ
	set t [$L set TJ]
	if { $t >= $TJ } {
		set TJ $t
	}
}
Layer instproc timer {} {
	$self instvar TJ
	return $TJ
}
Layer instproc last-add {} {
	$self instvar add_time_
	return $add_time_
}
Layer instproc join-group {} {
	$self instvar npkts_ add_time_ mmg_
	set npkts_ [$self npkts]
	set add_time_ [$mmg_ now]
}
Layer instproc leave-group {} {
}
Layer instproc getting-pkts {} {
	$self instvar npkts_
	return [expr [$self npkts] != $npkts_]
}
set rlm_debug_flag 1
Class Layer/mash -superclass Layer
Layer/mash instproc init {mmg net n} {
	$self next $mmg
	$self instvar net_ l_ n_
	set net_ $net
	set n_ $n
	set l_ [$net_ set net_($n)]
}
Layer/mash instproc join-group {} {
	$self instvar mmg_ net_
	set level [expr [$mmg_ set subscription_] - 1]
	$net_ set-subscription-level $level
	$self next
}
Layer/mash instproc leave-group {} {
	$self instvar mmg_ net_
	set level [expr [$mmg_ set subscription_] - 1]
	$net_ set-subscription-level $level
	$self next
}
Layer/mash instproc nlost {} {
	$self instvar l_
	return [$l_ nlost]
}
Layer/mash instproc npkts {} {
	$self instvar l_ n_
	return [$l_ npkts $n_]
}
Class MMG/mash -superclass MMG
MMG/mash instproc init {net caddr} {
	$self instvar net_
	set net_ $net
	$self next [$net set nchan_]
	proc ctrl$self {args} { puts "ctrl: $args" }
	$self set ctrl_ ctrl$self
}
MMG/mash instproc create-layer {layerNo} {
	$self instvar net_
	return [new Layer/mash $self $net_ $layerNo]
}
MMG/mash instproc now {} {
	return [gettimeofday]
}
MMG/mash instproc set_timer {which delay} {
	$self instvar timers_
	if [info exists timers_($which)] {
		puts "timer botched ($which)"
		exit 1
	}
	set delay [expr int($delay * 1000)]
	set timers_($which) [after $delay "$self trigger_timer $which"]
}
MMG/mash instproc trigger_timer {which} {
	$self instvar timers_
	unset timers_($which)
	$self trigger_$which
}
MMG/mash instproc cancel_timer {which} {
	$self instvar ns_ timers_
	if [info exists timers_($which)] {
		after cancel $timers_($which)
		unset timers_($which)
	}
}
MMG/mash instproc debug { msg } {
	$self instvar debug_
	if {!$debug_} { return }
	$self instvar subscription_ state_
	set time [format %.05f [$self now]]
	puts stderr "$time layer $subscription_ $state_ $msg"
}
proc uniform01 {} {
    return [expr double(([random] % 10000000) + 1) / 1e7]
}
proc uniform { a b } {
	return [expr ($b - $a) * [uniform01] + $a]
}
proc exponential mean {
	return [expr - $mean * log([uniform01])]
}
proc trunc_exponential lambda {
	while 1 {
		set u [exponential $lambda]
		if { $u < [expr 4 * $lambda] } {
			return $u
		}
	}
}
Class Network/IP -superclass Network
Network/IP instproc init args {
	puts stderr "Network/IP called... change to Network"
	eval $self next $args
}
Network instproc port args {
	eval $self sport $args
}
proc in_multicast addr {
	return [expr ([lindex [split $addr .] 0] & 0xf0) == 0xe0]
}
Class NetworkLayer
Class NetworkManager
NetworkManager instproc graphics-init n {
	if {$n == 1 || [winfo exists .l]} { return }
	$self instvar nchan_
	set nchan_ $n
	toplevel .l
	set k 0
	while { $k < $nchan_ } {
		radiobutton .l.b$k -command "$self set-subscription-level $k" \
				-text "Level $k" \
				-variable nLayers -value $k
		pack .l.b$k
		incr k
	}
	wm withdraw .l
	bind . <l> {
		if [winfo ismapped .l] {
			wm withdraw .l
		} else {
			wm deiconify .l
		}
	}
}
NetworkManager instproc set-subscription-level n {
	$self instvar agent_ nchan_ session_ net_
	$agent_ set_maxchannel $n
	$session_ set loopbackLayer_ [expr $n + 1]
	set i 0
	while { $i <= $n } {
		$net_($i) enable
		incr i
	}
	while { $i < $nchan_ } {
		$net_($i) disable
		incr i
	}
	global nLayers
	set nLayers $n
}
NetworkLayer instproc init { session addr sport rport ttl channel } {
	$self next
	$self instvar session_ addr_ port_ ttl_ dn_ cn_ channel_ active_
	set addr_ $addr
	set port_ $rport
	set sport_ $sport
	set rport_ $rport
	set session_ $session
	set ttl_ $ttl
	set channel_ $channel
	set dn_ [new Network]
	set result [$dn_ open $addr_ $sport_ $rport_ $ttl_]
	if {$result == {0}} {
		new ErrorWindow {Cannot open network connection.}
		exit 1
	}
	set cn_ [new Network]
	set result [$cn_ open $addr_ [expr $sport_ + 1] [expr $rport_ + 1] $ttl_]
	if {$result == {0}} {
		new ErrorWindow {Cannot open network connection.}
		exit 1
	}
	$cn_ loopback 1
	$session_ data-net $dn_ $channel_
	$session_ ctrl-net $cn_ $channel_
	set active_ 0
	$dn_ drop-membership
	$cn_ drop-membership
	$session_ data-net "" $channel_
	$session_ ctrl-net "" $channel_
	$self set tloss_ 0
}
NetworkLayer instproc destroy {} {
	$self instvar dn_ cn_
	if [info exists dn_] {
		delete $dn_
	}
	if [info exists cn_] {
		delete $cn_
	}
	$self next
}
NetworkLayer instproc data-net {} {
	return [$self set dn_]
}
NetworkLayer instproc ctrl-net {} {
	return [$self set cn_]
}
NetworkLayer instproc enable-send {} {
	$self instvar dn_ cn_ session_ channel_
	$session_ data-net $dn_ $channel_
	$session_ ctrl-net $cn_ $channel_
}
NetworkLayer instproc disable-send {} {
	$self instvar dn_ cn_ session_ channel_
	$session_ data-net "" $channel_
	$session_ ctrl-net "" $channel_
}
NetworkLayer instproc enable {} {
	$self instvar active_ dn_ cn_ session_ channel_
	if !$active_ {
		set active_ 1
		$dn_ add-membership
		$cn_ add-membership
		$session_ data-net $dn_ $channel_
		$session_ ctrl-net $cn_ $channel_
	}
}
NetworkLayer instproc disable {} {
	$self instvar dn_ cn_ active_ session_ channel_
	if $active_ {
		set active_ 0
		$dn_ drop-membership
		$cn_ drop-membership
		$session_ data-net "" $channel_
		$session_ ctrl-net "" $channel_
	}
}
NetworkLayer instproc notify-loss {src} {
	$self instvar loss_ tloss_
	if ![info exists loss_($src)] {
		set loss_($src) 0
	}
	set nloss [$src missing]
	incr tloss_ [expr $nloss - $loss_($src)]
	set loss_($src) $nloss
}
NetworkLayer instproc nlost {} {
	$self instvar tloss_
	return $tloss_
}
NetworkLayer instproc npkts {n} {
	$self instvar agent_
	set npkts 0
	foreach s [$agent_ set sources_] {
		set l [lindex [$s set layers_] $n]
		incr npkts [$l set np_]
	}
	return $npkts
}
NetworkLayer instproc crypt { dc cc } {
	$self instvar dn_ cn_
	$dn_ crypt $dc
	$cn_ crypt $cc
}
NetworkManager instproc init { ab session agent } {
	$self next
	$self instvar session_ agent_ encrypt_ key_ fmt_
	set session_ $session
	set agent_ $agent
	set encrypt_ 0
	set key_ ""
	set fmt_ ""
	$self allocate $ab $session
}
NetworkManager instproc allocate { ab session } {
	$self instvar nchan_ net_ mmg_
	if [info exists nchan_] {
		set oldnchan $nchan_
	} else {
		set oldnchan 0
	}
	set nchan_ 0
	while { $nchan_ < [$ab nchan] } {
		set addr [$ab addr $nchan_]
		set sport [$ab sport $nchan_]
		set rport [$ab rport $nchan_]
		set ttl [$ab ttl $nchan_]
		if [info exists net_($nchan_)] {
			delete $net_($nchan_)
		}
		set net_($nchan_) [new NetworkLayer $session $addr \
				$sport $rport $ttl $nchan_]
		$self instvar agent_
		$net_($nchan_) set agent_ $agent_
		incr nchan_
	}
	set n $nchan_
	while {$n < $oldnchan} {
		if [info exists net_($n)] {
			delete $net_($n)
		}
		incr n
	}
	if [info exists mmg_] {
		delete $mmg_
	}
	$self set-subscription-level 0
	if {$nchan_ == 1} { return }
	if [$self yesno useLayersWindow] {
		$self graphics-init $nchan_
	}
	if [$self get_option useRLM] {
		set caddr ""
		set mmg_ [new MMG/mash $self $caddr]
	}
}
NetworkManager instproc nchan {} {
	return [$self set nchan_]
}
NetworkManager instproc reset ab {
	$self instvar session_
	$self allocate $ab $session_
}
NetworkManager instproc data-net args {
	if { $args == "" } {
		set k 0
	} else {
		set k $args
	}
	$self instvar net_
	return [$net_($k) data-net]
}
NetworkManager instproc ctrl-net args {
	if { $args == "" } {
		set k 0
	} else {
		set k $args
	}
	$self instvar net_
	return [$net_($k) ctrl-net]
}
NetworkManager public loopback enable {
	$self instvar nchan_ net_
	set i 0
	while { $i < $nchan_ } {
		set net $net_($i)
		set dn [$net data-net]
		set cn [$net ctrl-net]
		$dn loopback $enable
		$cn loopback $enable
		incr i
	}
}
NetworkManager instproc install-key key {
	return [$self set_key $key]
}
NetworkManager instproc crypt_all { dc cc } {
	$self instvar net_
	foreach n [array names net_] {
		$net_($n) crypt $dc $cc
	}
}
NetworkManager instproc destroy {} {
	$self instvar net_
	foreach chan [array names net_] {
		delete $net_($chan)
	}
	$self next
}
NetworkManager instproc usingRLM {} {
	$self instvar mmg_
	return [info exists mmg_]
}
NetworkManager instproc notify-loss {src layer} {
	$self instvar net_
	$net_($layer) notify-loss $src
}
NetworkManager instproc crypt_format { key } {
	set k [string first / $key]
	if { $k < 0 } {
		set fmt DES
	} else {
		set fmt [string range $key 0 [expr $k - 1]]
		set key [string range $key [expr $k + 1] end]
	}
	return "$fmt $key"
}
NetworkManager instproc set_key key {
	if { $key == "" } {
		$self crypt_clear
		return ""
	}
	$self instvar encrypt_
	set L [$self crypt_format $key]
	set fmt [lindex $L 0]
	set key [lindex $L 1]
	$self instvar key_
	set key_ $key
	$self instvar dc_ cc_ fmt_
	if { $fmt_ != $fmt } {
		if [info exists dc_] {
			delete $dc_
			unset dc_
		}
		if [info exists cc_] {
			delete $cc_
			unset cc_
		}
		set fmt_ $fmt
	}
	if ![info exists dc_] {
		set clist [Crypt/Data info subclass]
		if { [lsearch -exact $clist Crypt/Data/$fmt] < 0 } {
			return "no $fmt encryption support"
		}
		set dc_ [new Crypt/Data/$fmt]
		set cc_ [new Crypt/Control/$fmt]
	}
	if [$dc_ key $key] {
		$cc_ key $key
		$self crypt_all $dc_ $cc_
		set encrypt_ 1
		return ""
	} else {
		$self crypt_clear
		return "your key is cryptographically weak"
	}
}
NetworkManager instproc crypt_clear {} {
	$self instvar encrypt_ key_
	$self crypt_all "" ""
	set key_ ""
	set encrypt_ 0
}
Class Timer
Class Timer/Periodic -superclass Timer
Class Timer/Adaptive -superclass Timer
Class Timer/Adaptive/ConstBW -superclass Timer/Adaptive
Timer public init {} {
	$self next
	$self randomize 0
	$self set randwt_ 1.0
}
Timer public destroy {} {
	$self cancel
	$self next
}
Timer public randomize { {yesno 1} {randwt {}} } {
	if { $randwt!={} } {
		$self set randwt_ $randwt
	}
	if {$yesno=="yes"} {set yesno 1} elseif {$yesno=="no"} {set yesno 0}
	$self set randomize_ $yesno
}
Timer private sched { t } {
	$self msched $t
}
Timer public msched { t } {
	$self instvar id_ randomize_ randwt_
	if [info exists id_] {
		puts stderr "warning: $self ([$self info class]):\
				overlapping timers"
	}
	if $randomize_ {
		set r [expr [random]/double(0x7fffffff)-0.5]
		set t [expr $t+$t*$r*$randwt_]
	}
	set t [expr int($t+0.5)]
	set id_ [after $t "$self do_timeout"]
}
Timer private do_timeout {} {
	$self instvar id_
	if ![info exists id_] {
		puts stderr "warning: $self ($class) no timer id_"
	} else {
		unset id_
	}
	$self timeout
}
Timer public is_sched { } {
	$self instvar id_
	return [info exists id_]
}
Timer public cancel {} {
	$self instvar id_
	if [info exists id_] {
		after cancel $id_
		unset id_
	}
}
Timer/Periodic public init { {period 5000} } {
	$self next
	$self set period_ $period
}
Timer/Periodic public start { {period {}} } {
	$self instvar period_
	if { $period!={} } { set period_ $period }
	if [$self is_sched] { $self cancel }
	$self msched $period_
}
Timer/Periodic instproc do_timeout {} {
	$self instvar period_
	$self next
	if { [info commands $self]=="" } return
	$self msched $period_
}
Timer/Adaptive public init { {interval 5000} } {
	$self next
	$self set interval_ $interval
}
Timer/Adaptive public start {} {
	$self instvar interval_
	if [$self is_sched] { $self cancel }
	set interval_ [$self adapt $interval_]
	$self msched [expr int($interval_+0.5)]
}
Timer/Adaptive public do_timeout {} {
	$self next
	if { [info commands $self]=="" } return
	$self instvar interval_
	set interval_ [$self adapt $interval_]
	$self msched [expr int($interval_+0.5)]
}
Timer/Adaptive private adapt {interval} {
	return $interval
}
Timer/Adaptive/ConstBW public init { bw {thresh {}} {size_gain {}} } {
	$self instvar size_gain_ avgsize_ nsrcs_ bw_ thresh_ interval_
	if { $size_gain!={} } {
		set size_gain_ $size_gain
	} else {
		set size_gain_ 0.125
	}
	set avgsize_ 28
	set nsrcs_ 0
	set bw_ $bw
	if { $thresh=={} } {
		set thresh_ 500
	} else {
		set thresh_ $thresh
	}
	$self next $thresh_
}
Timer/Adaptive/ConstBW public threshold { {thresh {}} } {
    $self instvar thresh_
    if {$thresh=={}} {
	return $thresh_
    } else {
	set thresh_ $thresh
    }
}
Timer/Adaptive/ConstBW public bandwidth { {bw {}} } {
    $self instvar bw_
    if {$bw=={}} {
	return $bw_
    } else {
	set bw_ $bw
    }
}
Timer/Adaptive/ConstBW public sample_size { size } {
	$self instvar avgsize_ size_gain_
	set avgsize_ [expr $avgsize_ + $size_gain_ * ($size + 28 - $avgsize_)]
}
Timer/Adaptive/ConstBW public update_nsrcs { nsrcs } {
	$self set nsrcs_ $nsrcs
}
Timer/Adaptive/ConstBW public nsrcs { nsrcs } {
	return [$self set nsrcs_]
}
Timer/Adaptive/ConstBW public incr_nsrcs { {incr 1} } {
        $self instvar nsrcs_
        incr nsrcs_ $incr
}
Timer/Adaptive/ConstBW private adapt {interval} {
	$self instvar avgsize_ bw_ nsrcs_ thresh_
	set t [expr 1000 * ($nsrcs_ * $avgsize_ * 8) / $bw_]
	if { $t < $thresh_ } {
		return $thresh_
	} else {
		return $t
	}
}
AnnounceListenManager public init { spec {mtu 1500} } {
	$self next $mtu
	$self instvar data_ snet_ rnet_
	set data_ ""
	set snet_ ""
	set rnet_ ""
	if [regexp {^[0-9]*$} $spec] {
		set rnet_ [new Network]
		$rnet_ open $spec
	} else {
		set ab [new AddressBlock/Simple $spec]
		set addr  [$ab addr]
		set sport [$ab sport]
		set rport [$ab rport]
		set ttl   [$ab ttl]
		delete $ab
		set snet_ [new Network]
		if [in_multicast $addr] {
			$snet_ open $addr $sport $rport $ttl
			set rnet_ $snet_
		} else {
			if { $rport != 0 } {
				set rnet_ [new Network]
				$rnet_ open $rport
			}
			$snet_ open $addr $sport 0 1
		}
	}
	if { $snet_ != "" } {
		$snet_ loopback 1
		$self send_network $snet_
	}
	if { $rnet_ != "" } {
		$self recv_network $rnet_
	}
}
AnnounceListenManager public destroy {} {
	$self instvar snet_ rnet_ timers_
	if { $rnet_==$snet_ } {
		delete $snet_
	} else {
		if { $snet_ != "" } {
			delete $snet_
		}
		if { $rnet_ != "" } {
			delete $rnet_
		}
	}
	if [info exists timers_] {
		foreach t [array names timers_] {
			delete $timers_($t)
		}
	}
	$self next
}
AnnounceListenManager public timer {args} {
	$self instvar timers_
	if {[llength $args]==1} {
		set d __default_timer__
		set t [lindex $args 0]
		if {$t!={}} { $t proc timeout { } "$self send_announcement" }
	} else {
		set d [lindex $args 0]
		set t [lindex $args 1]
		if {$t!={}} { $t proc timeout { } \
				[list $self send_announcement $d] }
	}
	if [info exists timers_($d)] {
		set sched [$timers_($d) is_sched]
		delete $timers_($d)
	} else {
		set sched 0
	}
	if {$t!={}} {
		set timers_($d) $t
		if $sched {
			$t start
		}
	} else {
		catch {unset timers_($d)}
	}
	return $t
}
AnnounceListenManager public get_timer {args} {
	$self instvar timers_
	if {[llength $args]==0} {
		set d __default_timer__
	} else {
		set d [lindex $args 0]
	}
	if [info exists timers_($d)] { return $timers_($d) } else { return "" }
}
AnnounceListenManager public start {args} {
	if { [llength $args]==0 } {
		set t [$self get_timer]
	} else {
		set d [lindex $args 0]
		set t [$self get_timer $d]
	}
	if { $t=={} } {
		set t [new Timer/Periodic]
		$t randomize 1
		if [info exists d] { $self timer $d $t } else { $self timer $t}
	}
	if [info exists d] {$self send_announcement $d} \
			else {$self send_announcement}
	$t start
}
AnnounceListenManager public stop {args} {
	$self instvar timers_
	if {[llength $args]==0} {
		foreach d [array names timers_] {
			$timers_($d) cancel
		}
	} else {
		set d [lindex $args 0]
		$timers_($d) cancel
	}
}
AnnounceListenManager public recv_announcement { addr port data len } {
	puts "ALM::recv_announcement $addr/$port \[$len\]: $data"
}
AnnounceListenManager public send_announcement {args} {
	$self instvar data_
	if {[llength $args]==0} {
		if { $data_!={} } { $self announce $data_ }
	} else {
		$self announce [lindex $args 0]
	}
}
AnnounceListenManager public set_announcement { data } {
	$self set data_ $data
}
AnnounceListenManager public get_announcement { } {
	return [$self set data_]
}
AnnounceListenManager public ttl {num} {
	$self instvar snet_
	$snet_ ttl $num
}
Class AnnounceListenManager/AS -superclass AnnounceListenManager
AnnounceListenManager/AS instproc init { netspec bw atype } {
	random 0
	$self next $netspec 1024
	$self instvar atype_
	set atype_ $atype
	$self instvar agentbytype_
	set agentbytype_(srv) ""
	set agentbytype_(client) ""
	set agentbytype_(hm) ""
	set t [new Timer/Adaptive/ConstBW $bw 3000]
	$t randomize
        $self timer $t
	set o [$self options]
	$o add_default startupWait 60
	$self instvar aliveid_
	set aliveid_ [after [expr [$self get_option startupWait]*1000] "$self check_alive 1"]
}
AnnounceListenManager/AS proc version {} {
	return 2.0
}
AnnounceListenManager/AS public send_announcement {} {
	$self instvar atype_
	set o "ASCP v[$class version]"
	set n $atype_
	set o $o\n$n
	set n [$self agent_instance]
	set o $o\n$n
	set n [$self service_name]
	set o $o\n$n
	set n [$self service_location]
	set o $o\n$n
	set n [$self service_instance]
	set o $o\n$n
	set n [$self ssg_port]
	set o $o\n$n
	set n [$self agent_data]
	set o $o\n$n
	$self announce $o
	$self check_alive 0
}
AnnounceListenManager/AS instproc announce_death {} {
	$self instvar id1_ id2_ atype_
	set o "ASCP v[AnnounceListenManager/AS version]"
	set n $atype_
	set o $o\n$n
	set n [$self agent_instance]
	set o $o\n$n
	set n bye
	set o $o\n$n
	set n -
	set o $o\n$n
	set n -
	set o $o\n$n
	set n -
	set o $o\n$n
	$self announce $o
}
AnnounceListenManager/AS public agent_instance {} {
	return "[pid]@[lookup_host_name [localaddr]]"
}
AnnounceListenManager/AS public agent_data {} {
	return ""
}
AnnounceListenManager/AS public ssg_port {} {
	return "-"
}
AnnounceListenManager/AS instproc service_location {} {
	return "-"
}
AnnounceListenManager/AS instproc destroy {} {
	$self instvar aliveid_
	after cancel $aliveid_
	$self next
}
AnnounceListenManager/AS instproc recv_announcement { addr port data size } {
	$self instvar lastann_ sdp_ agentbytype_ agenttab_ atype_
        set t [$self get_timer]
	$t sample_size $size
	set o [split $data \n]
	if { [lindex $o 0] != "ASCP v[$class version]" } {
		set msg "$self ($class): received non-ASCP v[$class version] announcement from $addr."
		if { $atype_ == "hm" } {
			$self instvar agent_
			$agent_ log $msg
		} else {
			puts stderr $msg
		}
 		return
	}
	set atype [lindex $o 1]
	set aspec [lindex $o 2]
	set srv_name [lindex $o 3]
	set srv_loc [lindex $o 4]
	set srv_inst [lindex $o 5]
	set ssg_port [lindex $o 6]
	set ad [join [lrange $o 7 end] \n]
	if { $srv_name == "DEATH" } {
		set msg "Received death packet from $aspec at $addr - exiting."
		if { $srv_loc == $atype_ } {
			if { $atype_ == "hm" } {
				$self instvar agent_
				$agent_ log $msg
			} else {
				puts stderr $msg
			}
			$self announce_death
			exit 0
		}
		$self recv_msg $atype $aspec $addr DEATH $srv_loc \
			$srv_inst $ssg_port "$ad"
		return
	}
	if { $srv_name == "bye" } {
		$self delete_agent $aspec
		return
	}
	if ![info exists agenttab_($aspec)] {
		$self instvar avgdelta_
		$self register $atype $aspec $addr $srv_name $srv_inst "$ad"
	        $t incr_nsrcs
		set timeout [$self get_option startupWait]
		set avgdelta_($aspec) [expr $timeout / 8]
		lappend agentbytype_($atype) $aspec
	} else {
		set now [gettimeofday]
		set delta [expr $now - $lastann_($aspec,abs)]
		$self instvar avgdelta_
		set avgdelta_($aspec) \
				[expr 0.875*$avgdelta_($aspec)+0.125*$delta]
	}
	set agenttab_($aspec) "$addr {$ad} $atype $srv_name $srv_inst"
	set lastann_($aspec,abs) [gettimeofday]
	set lastann_($aspec,ascii) [gettimeofday ascii]
	$self recv_msg $atype $aspec $addr $srv_name $srv_loc $srv_inst \
			$ssg_port "$ad"
}
AnnounceListenManager/AS instproc advance_timers { delta } {
	$self instvar lastann_ agenttab_ avgdelta_
	set aspecs [array names agenttab_]
	foreach aspec $aspecs {
		set lastann_($aspec,abs) [expr $lastann_($aspec,abs)+$delta]
	}
}
AnnounceListenManager/AS instproc check_alive { timer } {
	$self instvar lastann_ agenttab_ avgdelta_
	set now [gettimeofday]
	set aspecs [array names agenttab_]
	foreach aspec $aspecs {
		set lastann $lastann_($aspec,abs)
		set avgdelta $avgdelta_($aspec)
		set delta [expr $now - $lastann]
		if { $delta > 8 * $avgdelta } {
			$self delete_agent $aspec
		}
	}
	$self instvar aliveid_
	if { $timer } {
		set t [expr [$self get_option startupWait]*1000]
		set aliveid_ [after $t "$self check_alive 1"]
	}
}
AnnounceListenManager/AS instproc delete_agent { aspec } {
 	$self instvar agentbytype_ agenttab_ lastann_ avgdelta_
	if ![info exists agenttab_($aspec)] {
		return
	}
	set a $agenttab_($aspec)
	set addr [lindex $a 0]
	set ad [lindex $a 1]
	set atype [lindex $a 2]
	set srv_name [lindex $a 3]
	set srv_inst [lindex $a 4]
	unset agenttab_($aspec)
	unset lastann_($aspec,abs)
	unset lastann_($aspec,ascii)
	unset avgdelta_($aspec)
	set t $agentbytype_($atype)
	set i [lsearch -exact $t $aspec]
	set agentbytype_($atype) [lreplace $t $i $i]
	[$self get_timer] incr_nsrcs -1
	$self unregister $atype $aspec $addr $srv_name $srv_inst "$ad"
}
AnnounceListenManager/AS instproc agenttab aspec {
	$self instvar agenttab_
	if [info exists agenttab_($aspec)] {
		return $agenttab_($aspec)
	}
	return ""
}
Class AnnounceListenManager/AS/ASMon -superclass AnnounceListenManager/AS
AnnounceListenManager/AS/ASMon instproc init { agent spec bw } {
	$self next $spec $bw mgamon
	$self instvar agent_
	set agent_ $agent
}
AnnounceListenManager/AS/ASMon instproc build_announcement {} {
	puts stderr "AS Monitor build_announcement called!"
	return ""
}
AnnounceListenManager/AS/ASMon instproc recv_msg { atype aspec addr srv_name\
		srv_loc srv_inst ssg_port agent_data } {
	$self instvar agent_ avgdelta_
	if { $srv_name == "DEATH" } {
		return
	}
	if { $atype=="hm" } { set srv_name "" }
	$agent_ recv_msg $atype $aspec $addr $srv_name $srv_loc $srv_inst\
			$ssg_port $agent_data $avgdelta_($aspec)
}
AnnounceListenManager/AS/ASMon instproc register { atype aspec addr srv_name \
		srv_inst agent_data } {
	$self instvar agent_
	if { $atype=="hm" } { set srv_name "" }
	$agent_ register $atype $aspec $addr $srv_name $srv_inst $agent_data
}
AnnounceListenManager/AS/ASMon instproc unregister { atype aspec addr srv_name\
		srv_inst agent_data } {
	$self instvar agent_
	if { $atype=="hm" } { set srv_name "" }
	$agent_ unregister $atype $aspec $addr $srv_name $srv_inst $agent_data
}
Class MeGa
MeGa instproc init args {
	eval $self next $args
	$self set sdp_ [new SDPParser]
}
MeGa instproc destroy {} {
	$self instvar sdp_
	delete $sdp_
	$self next
}
MeGa proc ctrlchan { media spec } {
	set tmp [split $spec /]
	set addr [lindex $tmp 0]
	if ![in_multicast $addr] {
		return $spec
	}
	set port [lindex $tmp 1]
	switch $media {
	video {
		incr port 2
	}
	audio {
		incr port 4
	}
	mb {
		incr port 6
	}
	sdp {
		incr port 8
	}
	hm {
		incr port 10
	}
	}
	set ttl [lindex $tmp 2]
	return $addr/$port/$ttl
}
Class ASMonApplication -superclass Application
ASMonApplication instproc init argv {
	$self next asmon
	$self instvar ui_
	set o [$self options]
	$self init_args $o
	$self init_resources $o
	$o parse_args $argv
	if {[$o get_option userhookFile] != ""} {
		if {[file isfile [$o get_option userhookFile]] && \
			[file readable [$o get_option userhookFile]]} {
			source [$o get_option userhookFile]
		} else {
			puts stderr "Unable to source \"[$o get_option userhookFile]\". Not a file or not readable."
		}
	}
	set ui_ [ASMonitorUI .top]
	pack .top -fill both -expand 1
	.top application $self
	$self init_network .top
	$self user_hook
}
ASMonApplication instproc init_args o {
	$o register_option -u userhookFile
	$o register_option -log doLog
	$o register_option -megactrl asCtrl
}
ASMonApplication instproc init_resources o {
	$o add_default defaultTTL 1
	$o add_default asCtrl 224.4.5.24/50000/31
	$o add_default asCtrlBW 20000
}
ASMonApplication instproc init_network { ui } {
	set megaspec [$self get_option asCtrl]
	set bw [$self get_option asCtrlBW]
	$self instvar al_
	foreach m { audio video sdp mb hm srv } {
		set spec [MeGa ctrlchan $m $megaspec]
		set al_($m) [new AnnounceListenManager/AS/ASMon \
				$ui $spec $bw]
	}
}
ASMonApplication instproc build_death { atype } {
	$self instvar al_
	set al $al_($atype)
	set o "ASCP v[AnnounceListenManager/AS version]"
	set n mgamon
	set o $o\n$n
	set n [$al agent_instance]
	set o $o\n$n
	set n "DEATH"
	set o $o\n$n
	set n $atype
	set o $o\n$n
	set n "-"
	set o $o\n$n
	set n "-"
	set o $o\n$n
	$al announce $o
}
new ASMonApplication $argv
