#
# $Source: /home/nlfm/Working/Zircon/Released/lib/RCS/Look.tcl,v $
# $Date: 1997/01/31 08:41:35 $
# $Revision: 1.18.1.10 $
#
# ----------------------------------------------------------------------
#   AUTHOR:  Lindsay Marshall <lindsay.marshall@newcastle.ac.uk>
# ----------------------------------------------------------------------
# Copyright 1995 The University of Newcastle upon Tyne (see COPYRIGHT)
# ======================================================================
#
package provide zircon 1.18
#
proc getType {arg var} {
    upvar $var type
    set type {}
    while {![string match {} $arg]} {
	switch -glob -- [set opt [lindex $arg 0]] {
	-channel -
	-chat -
	-message -
	-notice {
		switch {} $type {} default {append type |}
		append type [string range $opt 1 end]
	    }
	-- { set arg [lrange $arg 1 end] ; break  }
	-* { error "Invalid type specifier - \"$opt\"" }
	default break
	}
	set arg [lrange $arg 1 end]
    }
    switch {} $type {set type .+}
    return $arg


}
#
proc getNet {ptn} {
    switch {} $ptn {
	if [notDefault] {
	    global currentNet
	    regsub -all {[][+*\^$()|?]} [$currentNet name] {\\&} nn
	    set ptn "^$nn\$"
	} {
	    set ptn .+
	}
    }
    return [string tolower $ptn]
}
#
proc look {args} {
    global Look currentNet
    set args [getType $args type]
    set cptn [string tolower [lindex $args 0]]
    switch [llength $args] {
    2 { set net [getNet {}] ; set desc [lindex $args 1]}
    3 { set net [getNet [lindex $args 1]] ; set desc [lindex $args 2] }
    default { error "Invalid look statement" }
    }
    set Look([newName Look]) [list $currentNet $type $cptn $net $desc]
}
#
proc merge {args} {
    global Share currentNet
    set args [getType $args t]
    set Share([newName Share]) \
      [list $currentNet $t [string tolower [lindex $args 0]] [getNet [lindex $args 1]] 1]
}
#
proc share {args} {
    global Share currentNet
    set args [getType $args t]
    set Share([newName Share]) \
      [list $currentNet $t [string tolower [lindex $args 0]] [getNet [lindex $args 1]] 0]
}
#
proc InitLook {} {
    global Look DLook
    look -channel {^\\+.*$} {.*} {
	        Info
	        {{Control {Mode Info Action Users Quit Clear}}}
	        {Text Users}
	        Entry
	    }
    look -channel {^\\&.*$} {.*} {
	        Info
	        {{Control {Mode Info Action Users Quit Clear}}}
	        {Text {Users off}}
	        Entry
	    }
    look -channel {.*} {.*} {
		Topic
	        Info
	        {{Control {Mode Info Action Users Quit Clear}}}
	        {Text Users}
	        Entry
	    }
    look -message -chat -notice -- {.*} {.*} {
		{{Control {Mode Info Action Users Quit Clear}}}
		{Text {Users off}}
		Entry
	}
    array set DLook [array get Look]
    unset Look
}
#
proc findLook {id name net} {
    global Look DLook OType
    foreach x [array names Look] {
	set type [lindex $Look($x) 1]
	set cptn [lindex $Look($x) 2]
	set nptn [lindex $Look($x) 3]
	if {[regexp -nocase $type $OType($id)] &&
	  [regexp -nocase $cptn $name] && [regexp -nocase $nptn $net]} {
	    return [lindex $Look($x) 4]
	}
    }
    foreach x [array names DLook] {
	set type [lindex $DLook($x) 1]
	set cptn [lindex $DLook($x) 2]
	set nptn [lindex $DLook($x) 3]
	if {[regexp -nocase $type $OType($id)] &&
	  [regexp -nocase $cptn $name] && [regexp -nocase $nptn $net]} {
	    return [lindex $DLook($x) 4]
	}
    }
    error "Look matching failure!!"
}
#
proc findStyle {id name net} {
    global Share OType
    set wnm {}
    set style original
    if ![$id noshare] {
	foreach x [array names Share] {
	    set type [lindex $Share($x) 1]
	    set cptn [lindex $Share($x) 2]
	    set nptn [lindex $Share($x) 3]
	    if {[regexp -nocase $type $OType($id)] &&
	      [regexp -nocase $cptn $name] && [regexp -nocase $nptn $net]} {
	        if [lindex $Share($x) 4] { set style hicaffiene } {set style diet}
	        set wnm $x
	        break
	    }
	}
    }
    return [list $style $wnm]
}
#
proc cnvType {desc ty} {
    switch .+ $ty return
    foreach x [split $ty |] { puts -nonewline $desc " -$x" }
}
#
proc saveLook {desc net} {
    global Look
    set cm 1
    foreach x [lsort [array names Look]] {
	switch -- [lindex $Look($x) 0] $net {
	    set type [lindex $Look($x) 1]
	    set cptn [lindex $Look($x) 2]
	    set nptn [lindex $Look($x) 3]
	    if $cm { puts $desc "#\n# Layout control\n#" ; set cm 0 }
	    puts -nonewline $desc look
	    cnvType $desc $type
	    if [string match -* $cptn] { puts -nonewline $desc -- }
	    puts -nonewline $desc " {$cptn}"
	    switch -- [subst $nptn] [$net name] {} default {
		puts -nonewline " $nptn"
	    }
	    puts $desc " [lindex $x 4]"
	}
    }

}
#
proc saveShare {desc net} {
    global Share
    set cm 1
    foreach x [lsort [array names Share]] {
	switch -- [lindex $Share($x) 0] $net {
	    set type [lindex $Share($x) 1]
	    set cptn [lindex $Share($x) 2]
	    set nptn [lindex $Share($x) 3]
	    if [lindex $Share($x) 4] { set pc merge } { set pc share }
	    if $cm { puts $desc "#\n# Window Sharing\n#" ; set cm 0 }
	    puts -nonewline $desc $pc
	    cnvType $desc $type
	    if [string match -* $cptn] { puts -nonewline $desc -- }
	    puts -nonewline $desc " {$cptn}"
	    switch [subst $nptn] [$net name] {} default {
		puts -nonewline $desc " $nptn"
	    }
	    puts $desc {}
	}
    }
}

