#################################################################
# mmucl.tcl - base mmucl library
# 
# Copyright (C) 1997-1999 Mark Patton
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
###################################################################

namespace eval mmucl {}

source [file join $config(lib_dir) lib misc.tcl]

# All user scripts are evaluated in a seperate interp.
# Action and alias scrips are actually hidden procs in the user interp
# prefixed by "__". Procs of form "MCname" are made available as aliases
# in the user interp.

proc mmucl::init {} {
    variable Mmucl
    variable Ansi
    global argv env config

    array set Ansi {
	reset 0 bold 1 dim 2 underline 4 blink 5 reverse 7
	
	black 30 red 31 green 32 yellow 33 brown 33 blue 34
	magenta 35 cyan 36 grey 37 gray 37 white 37 default 39
	
	bg_black 40 bg_red 41 bg_green 42 bg_yellow 43 bg_brown 43
	bg_blue 44 bg_magenta 45 bg_cyan 46 bg_grey 47 bg_gray 47
	bg_white 47 bg_default 49
    }

    array set Mmucl {
	cfg,reconnect      1
	cfg,actions        1
	cfg,subs           1
	cfg,end_color      grey
	cfg,error_color    red
	cfg,report_color   {bold green}
	cfg,print_color   {bold}
	cfg,script_char    /
	cfg,verbatim_char  \\
	cfg,timeout        20
	cfg,strip_ansi     1
	cfg,action_by_line 0
	cfg,echo           1
	cfg,echo_color     yellow
	cfg,hist_min       3
	cfg,hist_keep      20
	cfg,keep_line      1
	cfg,split_char     ;
	host    ""
	port    ""
	login   {}
	attempt 0
	connect 0
	chars   {}
	actions {}
	subs    {}
	history {}
	hist_loc 0
	rxp,strip_mudout {\r|\xFF.\W?|\0}
	rxp,strip_ansi   {\x1B\[[0-9;]*m}
	buf ""
	flush_id ""
    }
    
    # a command may have previously been added
    lappend Mmucl(dump) action rxp_action alias char config sub rxp_sub

    file mkdir [file join $config(rc_dir) chars]
    
    interp create mmucl

    foreach proc {proc info rename array source} {
	mmucl hide $proc
	mmucl alias $proc mmucl invokehidden $proc
    }

    foreach proc [info commands ::mmucl::MC*] {
	mmucl alias [string range $proc 11 end] $proc
    }
    mmucl alias debug uplevel #0

    foreach rc {.config .char mmucl.rc} {
	set rc [file join $config(rc_dir) $rc]
	if {[file exists $rc] && [catch {mmucl invokehidden source $rc} err]} {
	    report error "$rc: $err"
	}
    }
    
    if {[set i [lsearch -regexp $argv {^(-e|-exec|--exec|-eval|--eval)$}]] \
	    != -1} {
	if {[catch {mmucl eval [lindex $argv [incr i]]} err]} {
	    report error "command line: $err"
	}
	set argv [lreplace $argv [expr {$i - 1}] $i]
    }

    rename init ""
    return
}

# unsupported command that toggles printing of time to do read_mud

proc mmucl::MCprofile {bool} {
    variable Mmucl

    if {$Mmucl(connect)} {
	if {$bool} {
	    fileevent $Mmucl(sock) readable {
		mmucl::print [time {mmucl::read_mud}]
	    }
	} else {
	    fileevent $Mmucl(sock) readable mmucl::read_mud
	}
    }

    return
}

# hid commands have side effect of removing user procs
# of same name as hid proc

proc mmucl::hid_proc {name arglist body} {
    hid_del $name
    mmucl invokehidden proc $name $arglist $body
    mmucl hide $name

    return
}

proc mmucl::hid_del {proc} {
    catch {mmucl invokehidden rename $proc ""}
    catch {
	mmucl expose $proc
	mmucl invokehidden rename $proc ""
    }

    return
}

proc mmucl::hid_body {proc} {
    catch {mmucl invokehidden rename $proc ""}
    mmucl expose $proc
    set body [mmucl invokehidden info body $proc]
    mmucl hide $proc
    
    return $body
}

proc mmucl::to_ansi {str attribs} {
    variable Ansi

    append new \x1B\[0
    foreach attrib $attribs {
	if {[info exists Ansi($attrib)]} {
	    append new \; $Ansi($attrib)
	}
    }

    return [append new m $str]
}

# convert format pattern to a regexp

proc mmucl::fmt2rxp {fmt} {
    set charmap {
	%% %
	** *
	^^ ^
	$$ $
	|| |
	\\  \\\\
	[  \\[
	]  \\]
	(  \\(
	)  \\)
	\{ \\\}
	\} \\\{
	+  \\+
	.  \\.
	?  \\?
	%a \x1B\\[([0-9;]*)m
	%w (\\S+)
	%s (.+)
	%c (.)
	%d (\\d+)
	* (?:[.\n]*)
    }

    append rxp (?n) [string map $charmap $fmt]
    regexp -- $rxp ""

    return $rxp
}

# Called when there is mud output.
# It buffers an incomplete line and flushes it
# if read_mud is not called again soon.

proc mmucl::read_mud {} {
    variable Mmucl

    append mudout $Mmucl(buf) [read $Mmucl(sock)]
    regsub -all $Mmucl(rxp,strip_mudout) $mudout "" mudout

    after cancel $Mmucl(flush_id)
    
    if {[regexp {^(.*?)([^\n]+)$} $mudout x mudout Mmucl(buf)]} {
	set Mmucl(flush_id) [after 500 mmucl::mudout_flush]
    } else {
        set Mmucl(buf) ""
    }

    handle_mudout $mudout
    
    if {[eof $Mmucl(sock)]}  {
	MCdisconnect
    }
    
    return
}

proc mmucl::mudout_flush {} {
    variable Mmucl

    handle_mudout $Mmucl(buf)
    set Mmucl(buf) ""
}

# Check actions, do subs, and then display.

proc mmucl::handle_mudout {mudout} {
    variable Mmucl

    if {$Mmucl(cfg,actions)} {
	set mudout2 $mudout

	if {$Mmucl(cfg,strip_ansi)} {
	    regsub -all $Mmucl(rxp,strip_ansi) $mudout2 "" mudout2
	}
	
	if {$Mmucl(cfg,action_by_line)} {
	    foreach line [split $mudout2 \n] {
		do_actions $line
	    }
	} else {
	    do_actions $mudout2
	}
    }

    if {$Mmucl(cfg,subs)} {
	foreach {id patt} $Mmucl(subs) {
	    regsub -all -- $patt $mudout $Mmucl(spec,$id) mudout
	}
    }

    display $mudout
}

proc mmucl::do_actions {str} {
    variable Mmucl

    foreach {id patt} $Mmucl(actions) {
	if {[regexp -- $patt $str 0 1 2 3 4 5 6 7 8 9]} {
	    if {[catch {mmucl invokehidden __ac_$id $0 $1 $2 $3 $4\
		    $5 $6 $7 $8 $9} error]} {
		report error "action {[string range $id 2 end]}: $error"
	    }
	}
    }
}


# inform the user about an error or other event

proc mmucl::report {event args} {
    variable Mmucl
    
    set color $Mmucl(cfg,report_color)
    switch -exact -- $event {
	error {
	    set color $Mmucl(cfg,error_color)
	    set msg [lindex $args 0]
	} timeout {
	    set msg "connection timed out"
	} reconnect {
	    set msg "reconnecting... ($Mmucl(attempt)\
		    of $Mmucl(cfg,reconnect))" 
	} attempt {
	    set msg "connecting to [lindex $args 0]:[lindex $args 1]..."
	} connect {
	    set h [fconfigure $Mmucl(sock) -peername]
	    set msg "connected to [lindex $h 1]([lindex $h 0]):[lindex $h 2]"
	} closed {
	    set msg "connection closed"
	} stop_attempt {
	    set msg "connection attempt stopped"
	}
    }
    
    MCecho [MCcolor "** " bold $msg $color]

    return
}

# Display a line to the user.

proc mmucl::print {str} {
    variable Mmucl

    display [MCcolor $str $Mmucl(cfg,print_color)]\n
    return
}

# check args to a command that may have options (subcommands)

proc mmucl::check {name syntax arglist {opts 0}} {
    if {$opts} {
	if {[llength $arglist] == 0} {
	    error "wrong # args: should be \"$name option arg...\""
	}
	
	set opt [lindex $arglist 0]
	array set opt_syntax $syntax
	set opt_matches [lmatch_prefix [array names opt_syntax] $opt]

	if {[llength $opt_matches] == 0} {
	    error "bad option $opt: must be\
		    \"[join [array names opt_syntax] {, }]\""
	} elseif {[llength $opt_matches] > 1} {
	    error "ambiguous option $opt: could be [join $opt_matches {, }]"
	}
	set opt [lindex $opt_matches 0]

	set arglist [lrange $arglist 1 end]
	set syntax $opt_syntax($opt)
	append name " " $opt
    }

    set usage "wrong # args: should be \"$name"

    set i 0
    foreach part $syntax {
    	switch -exact -- [lindex $part 0] {
            ? {
		if {$i < [llength $arglist]} {
		    set var([lindex $part 1]) [lindex $arglist $i]
		    incr i
		} elseif {[llength $part] == 3} {
	       	    set var([lindex $part 1]) [lindex $part 2]  
		}

		append usage " " \[[lindex $part 1]\]
	    } - {
		foreach switch [set switches [lrange $part 1 end]] {
		    set var($switch) 0
		}

		foreach switch [lrange $arglist $i end] {
		    if {![string equal -length 1 $switch -]} {
			break
		    } elseif {[string equal $switch --]} {
			incr i
			break
		    }
		    
		    set switch [string range $switch 1 end]
		    if {[lsearch -exact $switches $switch] == -1} {
			error "bad switch \"-$switch\": must be \
				-[join $switches {, -}], or --"
		    }
		    set var($switch) [incr i]
		}
		
		append usage " --"
	    } + {
		set var([lindex $part 1]) [lindex $arglist $i]
		incr i
		
		append usage " " [lindex $part 1]
	    }
	}
    }
    
    if {$i != [llength $arglist]} {
        error [append usage \"]
    }

    uplevel 1 [list array set arg [array get var]]
    
    return [expr {$opts ? $opt : ""}]
}

proc mmucl::MCcheck {args} {
    check check {{- opts} {+ name} {+ syntax} {+ arglist}} $args

    set name $arg(name)
    set syntax $arg(syntax)
    set arglist $arg(arglist)
    set opts $arg(opts) 
    unset arg
    
    set opt [check $name $syntax $arglist $opts]
    mmucl invokehidden array set arg [array get arg]
    
    return $opt
}

proc mmucl::MCecho {args} {
    display [join $args]\n
    return
}

proc mmucl::MCcolor {args} {
    variable Mmucl

    foreach {str color} $args {
	append ansi [to_ansi $str $color]
    }
    
    return [append ansi [to_ansi "" $Mmucl(cfg,end_color)]]
}

# Evaluate a line of input from the user.

proc mmucl::MCparse {str} {
    variable Mmucl

    if {[string equal -length 1 $str $Mmucl(cfg,verbatim_char)]} {
	MCwrite [string range $str 1 end]
    } elseif {[string equal -length 1 $str $Mmucl(cfg,script_char)]} {
	return [mmucl eval [string range $str 1 end]]
    } elseif {[string equal $str ""]} {
	MCwrite ""
    } else {
	foreach cmd [split $str $Mmucl(cfg,split_char)] {
	    regexp {^(\S*)\s*(.*)$} $cmd x alias arg

	    if {[info exists Mmucl(al_$alias)]} {
                regexp {^(\S*)\s*(\S*)\s*(\S*).*$} $arg x 1 2 3

		if {[catch {
		    mmucl invokehidden __al_$alias $arg $1 $2 $3
		} error]} {
		    error "alias \"$alias\": $error"
		}
	    } else {
		MCwrite $cmd
	    }
	}
    }
    
    return
}

proc mmucl::meta_parse {str} {
    variable Mmucl

    if {$Mmucl(cfg,echo)} {
	MCecho [MCcolor $str $Mmucl(cfg,echo_color)]
    }
    
    if {[catch {MCparse $str} val]} {
	report error $val
    } elseif {![string equal $val ""]} {
	print $val
    }

    if {[string length $str] >= $Mmucl(cfg,hist_min)} {
	set Mmucl(history) [lreplace $Mmucl(history) 0 \
		[expr {[llength $Mmucl(history)] - $Mmucl(cfg,hist_keep)}]]
	lappend Mmucl(history) $str
	set Mmucl(hist_loc) [llength $Mmucl(history)]
    }

    return
}

proc mmucl::MCmmucl {args} {
    variable Mmucl
    global config

    set syntax {
	lib_dir {}
	rc_dir  {}
	host    {}
	port    {}
	version {}
	connect {}
	interface {}
    }
    
    switch -exact -- [check mmucl $syntax $args 1] {
	lib_dir {
	    return $config(lib_dir)
	} rc_dir {
	    return $config(rc_dir)
	} host {
	    return $Mmucl(host)
	} port {
	    return $Mmucl(port)
	} version {
	    return $config(version)
	} connect {
	    return $Mmucl(connect)
	} interface {
	    return $config(interface)
	}
    }

    return
}

proc mmucl::MCconnect {args} {
    variable Mmucl

    check connect {{+ host} {+ port} {? login {}}} $args

    if {[catch {concat $arg(login)}]} {
	error "login must be a list"
    }

    if {$Mmucl(connect)} {
	error "already connected"
    }

    if {[catch {incr arg(port) 0}]} {
	error "bad port $arg(port), must be integer"
    }

    catch {after cancel $Mmucl(timeout_id)}
    
    set Mmucl(timeout_id) [after [expr {$Mmucl(cfg,timeout) * 1000}] \
	    [list mmucl::connect_timeout $arg(host) $arg(port) $arg(login)]]

    report attempt $arg(host) $arg(port)
    update

    if {[catch {set Mmucl(sock) [socket -async $arg(host) $arg(port)]} err]} {
	after cancel $Mmucl(timeout_id)
	error $err
    } else {
	fconfigure $Mmucl(sock) -blocking 0 -translation {binary auto}

	fileevent $Mmucl(sock) readable [list mmucl::connect_complete\
		$arg(host) $arg(port) $arg(login)]
    }
    
    return
}

# try to complete a connection

proc mmucl::connect_complete {host port login} {
    variable Mmucl

    after cancel $Mmucl(timeout_id)
    array set Mmucl [list connect 1 host $host port $port \
	    login $login attempt 0]
    
    if {[catch {fconfigure $Mmucl(sock) -peername}]} {
	report error "connection refused"
	MCdisconnect
    	return
    }

    report connect
    fileevent $Mmucl(sock) readable mmucl::read_mud

    if {$Mmucl(connect) && [llength $login]} {
	MCwrite [join $login \n]
    }

    return
}

# handle a maybe timeout on a connection

proc mmucl::connect_timeout {host port login} {
    variable Mmucl

    if {!$Mmucl(connect)} {
	report timeout
	catch {close $Mmucl(sock)}
	
	if {$Mmucl(attempt) < $Mmucl(cfg,reconnect)} {
	    incr Mmucl(attempt)
	    report reconnect
	    after 2000 [list mmucl::MCconnect $host $port $login]
	} else {
	    set Mmucl(attempt) 0
	}
    }

    return
}

proc mmucl::MCdisconnect {} {
    variable Mmucl

    if {!$Mmucl(connect)} {
	if {[catch {after cancel $Mmucl(timeout_id)}] == 0} {
	    report stop_attempt
	    return
	} 
	error "not connected"
    }
    
    catch {close $Mmucl(sock)}
    set Mmucl(connect) 0
    report closed

    return
}

proc mmucl::MCreconnect {} {
    variable Mmucl
    
    if {[string equal $Mmucl(host) ""]} {
	error "no previous connection"
    }
    
    MCconnect $Mmucl(host) $Mmucl(port) $Mmucl(login)
    
    return
}

proc mmucl::MCconfig {args} {
    variable Mmucl
    
    set syntax {
	set    {{+ option} {? value}}
	names  {{? pattern *}}
	print  {{? pattern *}}
    }

    switch -exact -- [check config $syntax $args 1] {
	set {
	    if {![info exists Mmucl(cfg,$arg(option))]} {
		error "no such option"
	    } elseif {![info exists arg(value)]} {
		return $Mmucl(cfg,$arg(option))
	    } else {
		if {[string match *_char $arg(option)]} {
		    if {[string length $arg(value)] != 1} {
			error "value must be a char"
		    }
		} elseif {[string match *_color $arg(option)]} {
		    if {[catch {concat $arg(value)}]} {
			error "value must be a list"
		    }
		} elseif {![string is integer -strict $arg(value)]} {
		    error "value must be a number"
		}
		
		set Mmucl(cfg,$arg(option)) $arg(value)
	    }
	} names {
	    return [ltrimleft [array names Mmucl cfg,$arg(pattern)] 4]
	} print {
	    foreach name [lsort [MCconfig names $arg(pattern)]] {
		print "$name: $Mmucl(cfg,$name)"
	    }
	}
    }
    
    return
}

proc mmucl::MCwrite {args} {
    variable Mmucl
    
    if {!$Mmucl(connect)} {
	error "not connected"
    }

    foreach str $args {
	puts $Mmucl(sock) $str
    }
    flush $Mmucl(sock)
    
    return
}

proc mmucl::MCalias {args} {
    variable Mmucl

    set syntax {
	set    {{+ name} {? script}}
	names  {{? pattern *}}
	print  {{? pattern *}}
	delete {{- exact} {+ pattern}}
    }

    switch -exact -- [check alias $syntax $args 1] {
	set {
	    if {[info exists arg(script)]} {
		if {[regexp -- {\s} $arg(name)]} {
		    error "alias name cannot white space"
		}

		hid_proc __al_$arg(name) {0 1 2 3} $arg(script)
		set Mmucl(al_$arg(name)) ""
	    } elseif {![info exists Mmucl(al_$arg(name))]} {
		error "no such alias"
	    } else {
		return [hid_body __al_$arg(name)]
	    }
	} names {	
	    return [ltrimleft [array names Mmucl al_$arg(pattern)] 3]
	} delete {
	    if {$arg(exact)} {
		hid_del __al_$arg(pattern)
		catch {unset Mmucl(al_$arg(pattern))}
	    } else {
		foreach name [array names Mmucl al_$arg(pattern)] {
		    hid_del __$name
		    catch {unset Mmucl($name)}
		}
	    }
	} print {
	    foreach name [lsort [MCalias names $arg(pattern)]] {
		print "\"$name\" set to {[MCalias set $name]}"
	    }
	}
    }
    
    return
}

proc mmucl::MCaction {args} {
    variable Mmucl

    set syntax {
	set    {{+ pattern} {? script} {? priority 0}}
	names  {{? pattern *}}
	print  {{? pattern *}}
	delete {{- exact} {+ pattern}}
	priority {{+ pattern} {? priority}}
    }

    array set action $Mmucl(actions)

    switch -exact -- [check action $syntax $args 1] {
	set {
	    if {[info exists arg(script)]} {
		set action(f_$arg(pattern)) [fmt2rxp $arg(pattern)]
		set Mmucl(pri,f_$arg(pattern)) [incr arg(priority) 0]

		hid_proc __ac_f_$arg(pattern)\
			{0 1 2 3 4 5 6 7 8 9} $arg(script)
	    } elseif {![info exists action(f_$arg(pattern))]} {
		error "no such action"
	    } else {
		return [hid_body __ac_f_$arg(pattern)]
	    }
	    action_sort action
	} names {
	    return [ltrimleft [array names action f_$arg(pattern)] 2]
	} delete {
	    if {$arg(exact)} {
		hid_del __ac_f_$arg(pattern)
		catch {
		    unset action(f_$arg(pattern))
		    unset Mmucl(pri,f_$arg(pattern))
		}
	    } else {
		foreach name [array names action f_$arg(pattern)] {
		    hid_del __ac_$name
		    catch {
			unset action($name)
			unset Mmucl(pri,$name)
		    }
		}
	    }
	    action_sort action
	} print {
	    foreach name [lsort [MCaction names $arg(pattern)]] {
		print "($Mmucl(pri,f_$name)) {$name} triggers\
			{[hid_body __ac_f_$name]}"
	    }
	} priority {
	    if {![info exists action(f_$arg(pattern))]} {
		error "no such action"
	    }

	    if {[info exists arg(priority)]} {
		set Mmucl(pri,f_$arg(pattern)) [incr arg(priority) 0]	
	    } else {
		return $Mmucl(pri,f_$arg(pattern))
	    }
	    action_sort action
	}
    }

    return
}

proc mmucl::action_sort {array_var} {
    variable Mmucl
    upvar 1 $array_var action

    set Mmucl(actions) [list]
    foreach id [lsort -command mmucl::pri_sort [array names action]] {
	lappend Mmucl(actions) $id $action($id)
    }

    return
}

proc mmucl::pri_sort {pri1 pri2} {
    variable Mmucl

    if {$Mmucl(pri,$pri1) == $Mmucl(pri,$pri2)} {
	return 0
    } elseif {$Mmucl(pri,$pri1) > $Mmucl(pri,$pri2)} {
	return -1
    } else {
	return 1
    }
}

proc mmucl::MCrxp_action {args} {
    variable Mmucl

    set syntax {
	set    {{+ pattern} {? script} {? priority 0}}
	names  {{? pattern *}}
	print  {{? pattern *}}
	delete {{- exact} {+ pattern}}
	priority {{+ pattern} {? priority}}
    }

    array set action $Mmucl(actions)

    switch -exact -- [check rxp_action $syntax $args 1] {
	set {
	    if {[info exists arg(script)]} {
		regexp -- $arg(pattern) ""
		set action(r_$arg(pattern)) $arg(pattern)
		set Mmucl(pri,r_$arg(pattern)) [incr arg(priority) 0]
		hid_proc __ac_r_$arg(pattern)\
			{0 1 2 3 4 5 6 7 8 9} $arg(script)
	    } elseif {![info exists action(r_$arg(pattern))]} {
		error "no such action"
	    } else {
		return [hid_body __ac_r_$arg(pattern)]
	    }
	    
	    action_sort action
	} names {
	    return [ltrimleft [array names action r_$arg(pattern)] 2]
	} delete {
	    if {$arg(exact)} {
		hid_del __ac_r_$arg(pattern)
		catch {
		    unset action(r_$arg(pattern))
		    unset Mmucl(pri,r_$arg(pattern))
		}
	    } else {
		foreach name [array names action r_$arg(pattern)] {
		    hid_del __ac_$name
		    catch {
			unset action($name)
			unset Mmucl(pri,$name)
		    }
		}
	    }

	    action_sort action
	} print {
	    foreach name [lsort [MCrxp_action names $arg(pattern)]] {
		print "($Mmucl(pri,r_$name)) {$name} triggers \
			{[MCrxp_action set $name]}"
	    }
	} priority {
	    if {![info exists action(r_$arg(pattern))]} {
		error "no such action"
	    }

	    if {[info exists arg(priority)]} {
		set Mmucl(pri,r_$arg(pattern)) [incr arg(priority) 0]
	    } else {
		return $Mmucl(pri,r_$arg(pattern))
	    }

	    action_sort action
	}
    }

    return
}

# 

proc mmucl::MCsub {args} {
    variable Mmucl

    set syntax {
	set    {{+ pattern} {? subspec}}
	names  {{? pattern *}}
	print  {{? pattern *}}
	delete {{- exact} {+ pattern}}
    }

    array set sub $Mmucl(subs)

    switch -exact -- [check sub $syntax $args 1] {
	set {
	    if {[info exists arg(subspec)]} {
		set sub(f_$arg(pattern)) [fmt2rxp $arg(pattern)]
		set Mmucl(spec,f_$arg(pattern)) $arg(subspec)
	    } elseif {![info exists Mmucl(spec,f_$arg(pattern))]} {
		error "no such sub"
	    } else {
		return $Mmucl(spec,f_$arg(pattern))
	    }
	} names {
	    return [ltrimleft [array names sub f_$arg(pattern)] 2]
	} delete {
	    if {$arg(exact)} {
		catch {unset sub(f_$arg(pattern)) Mmucl(spec,f_$arg(pattern))}
	    } else {
		foreach name [array names sub f_$arg(pattern)] {
		    unset sub($name) Mmucl(spec,$name)
		}
	    }
	} print {
	    foreach name [MCsub names $arg(pattern)] {
		print "{$name} changed to {$Mmucl(spec,f_$name)}"
	    }
	}
    }

    set Mmucl(subs) [array get sub]
    return
}

proc mmucl::MCrxp_sub {args} {
    variable Mmucl

    set syntax {
	set    {{+ pattern} {? subspec}}
	names  {{? pattern *}}
	print  {{? pattern *}}
	delete {{- exact} {+ pattern}}
    }

    array set sub $Mmucl(subs)

    switch -exact -- [check sub $syntax $args 1] {
	set {
	    if {[info exists arg(subspec)]} {
		regexp -- $arg(pattern) ""
		set sub(r_$arg(pattern)) $arg(pattern)
		set Mmucl(spec,r_$arg(pattern)) $arg(subspec)
	    } elseif {![info exists Mmucl(spec,r_$arg(pattern))]} {
		error "no such sub"
	    } else {
		return $Mmucl(spec,r_$arg(pattern))
	    }
	} names {
	    return [ltrimleft [array names sub r_$arg(pattern)] 2]
	} delete {
	    if {$arg(exact)} {
		catch {unset sub(r_$arg(pattern)) Mmucl(spec,r_$arg(pattern))}
	    } else {
		foreach name [array names sub r_$arg(pattern)] {
		    unset sub($name) Mmucl(spec,$name)
		}
	    }
	} print {
	    foreach name [MCsub names $arg(pattern)] {
		print "{$name} changed to {$Mmucl(spec,r_$name)}"
	    }
	}
    }

    set Mmucl(subs) [array get sub]
    return
}

proc mmucl::MCchar {args} {
    variable Mmucl
    global config

    set syntax {
	set    {{+ name} {? info}}
	names  {{? pattern *}}
	print  {{? pattern *}}
	delete {{- exact} {+ pattern}}
	load   {{+ name}}
    }
    
    array set char $Mmucl(chars)
    
    switch -exact -- [check char $syntax $args 1] {
	set {
	    if {[info exists arg(info)]} {
		set n [llength $arg(info)]

		if {$n < 2 || $n > 3} {
		    error "info is list of form: {host port ?login?}"
		}
		
		catch {close [open \
			[file join $config(rc_dir) chars $arg(name)] a+]}

		set char($arg(name)) $arg(info)
	    } elseif {![info exists char($arg(name))]} {
		error "no such char"
	    } else {
		return $char($arg(name))
	    }
	} names {	
	    return [array names char $arg(pattern)]
	} delete {
	    if {$arg(exact)} {
		catch {unset char($arg(pattern))}
	    } else {
		foreach name [array names char $arg(pattern)] {
		    unset char($name)
		}
	    }
	} load {
	    if {![info exists char($arg(name))]} {
		error "no such char"
	    }
	    
	    foreach {host port login} $char($arg(name)) break
	    
	    set init [file join $config(rc_dir) chars $arg(name)]
	    if {[file exists $init]} {
		print "Loading $init..."
		mmucl invokehidden source $init
	    }
	    MCconnect $host $port $login
	} print {
	    foreach name [array names char $arg(pattern)] {
		print $name
		print "  Host: [lindex $char($name) 0]:[lindex $char($name) 1]"
		print "  Login: [lindex $char($name) 2]"
	    }
	}
    }
    
    set Mmucl(chars) [array get char]
    return
}

proc mmucl::MCdump {args} {
    variable Mmucl
    
    check dump "{- append all $Mmucl(dump)} {+ file}" $args
    
    set fd [open $arg(file) [expr {$arg(append) ? "a+" : "w"}]]
    
    foreach cmd $Mmucl(dump) {
	if {$arg(all) || $arg($cmd)} {
	    foreach name [MC$cmd names] {
		puts $fd [list $cmd set $name [MC$cmd set $name]]
	    }
	}
    }
    
    close $fd
    return
}

proc mmucl::MCtextin {args} {
    variable Mmucl

    check textin {{+ file}} $args

    if {!$Mmucl(connect)} {
	error "not connected"
    }
    
    set fd [open $arg(file) r]
    fcopy $fd $Mmucl(sock)
    close $fd
   
    return
}

# Provide a reasonable default bgerror to user.

proc mmucl::MCbgerror {msg} {
    report error "background: $msg"
    return
}

proc mmucl::MCexit {} {
    global config
    
    foreach cmd {char config} {
	if {[catch {MCdump -$cmd -- \
		[file join $config(rc_dir) .$cmd]} error]} {
	    puts stderr "error writing .$cmd: $error"
	}
    }
    
    exit
}
