#
# $Source: /home/nlfm/Working/Zircon/Released/lib/RCS/Look.tcl,v $
# $Date: 2001/07/10 15:36:11 $
# $Revision: 1.18.1.26 $
#
# ----------------------------------------------------------------------
#   AUTHOR:  Lindsay Marshall <lindsay.marshall@newcastle.ac.uk>
# ----------------------------------------------------------------------
# Copyright 2000 The University of Newcastle upon Tyne (see COPYRIGHT)
# ======================================================================
#
package provide zircon 1.18
#
proc getType {arg} {
    set type {}
    while {![string match {} $arg]} {
	switch -glob -- [set opt [lindex $arg 0]] {
	-friends -
	-dcclist -
	-monitor -
	-list -
	-info -
	-control -
	-debug -
	-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 [list $arg $type]


}
#
proc getNet {ptn} {
    switch {} $ptn {
	if {[notDefaultNet]} {
	    global currentNet
	    regsub -all {[][+*\^$()|?]} [$currentNet name] {\\&} nn
	    set ptn "^$nn\$"
	}  {
	    set ptn .+
	}
    } default {
	if {![checkRE $ptn]} {
	    tellError {} Error "Bad net regular expression for share or merge - \"$nn\""
	    set ptn .+
	}
    }
    return [string tolower $ptn]
}
#
proc look {args} {
    global Look currentNet
    foreach {args type} [getType $args] break
    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" }
    }
    if {[checkRE $cptn]} {
 	set Look([newName Look]) [list $currentNet $type $cptn $net $desc]
    } {
	tellError {} Error "Bad look regular expression \"$cptn\""
    }
}
#
proc merge {args} {
    global Share currentNet
    foreach {args t} [getType $args] break
    if {![checkRE [set cptn [string tolower [lindex $args 0]]]]} {
        tellError {} Error "Bad pattern for merge command - \"$cptn\""
    } {
	set Share([newName Share]) \
	  [list $currentNet $t $cptn [getNet [lindex $args 1]] 1 1]
    }
}
#
proc share {args} {
    global Share currentNet
    foreach {args t} [getType $args] break
    set cols 1
    if {[regexp {^\*([0-9]+)$} [lindex $args 0] m cols]} {
        set args [lrange $args 1 end]
    }
    if {![checkRE [set cptn [string tolower [lindex $args 0]]]]} {
        tellError {} Error "Bad pattern for share command - \"$cptn\""
    } {
	set Share([newName Share]) \
	  [list $currentNet $t $cptn [getNet [lindex $args 1]] 0 $cols]
    }
}
#
proc InitLook {} {
    dispAd {Initialising look...}
    global Look DLook
    look -channel {^\\+.*$} {.*} [list \
	        [list [list Popper] [list Info [list limit create url topic]] [list Flags [list key mod log]]] \
	        [list [list Popper] [list Control [list Mode Info Action Users Quit Clear]]] \
	        [list [list Text] [list Users]] \
	        [list [list Entry scroll]] \
	    ]
    look -channel {^\\&.*$} {.*} [list \
	        [list [list Popper] [list Info [list limit create url topic]] [list Flags [list key mod log]]] \
	        [list [list Popper] [list Control [list Mode Info Action Users Quit Clear]]]\
	        [list [list Text] [list Users off]]\
	        [list [list Entry scroll]]\
	    ]
    look -channel {.*} {.*} [list \
		[list [list Popper] [list Topic]] \
	        [list [list Popper] [list Info [list limit create url topic]] [list Flags [list key mod log]]] \
	        [list [list Popper] [list Control [list Mode Info Action Users Quit Clear]]] \
	        [list [list Text] [list Users]] \
	        [list [list Entry scroll]] \
	    ]
    look -message -chat -notice -- {.*} {.*} [list \
		[list [list Popper] [list Control [list Mode Info Action Users Quit Clear]]] \
		[list [list Text] [list Users off]]\
		[list [list Entry scroll]]\
	]
    array set DLook [array get Look]
    unset Look
}
#
proc findLook {id name net} {
    global Look DLook
    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 [$id type]] &&
	  [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 [$id type]] &&
	  [regexp -nocase -- $cptn $name] && [regexp -nocase -- $nptn $net]} {
	    return [lindex $DLook($x) 4]
	}
    }
    error "Look matching failure!!"
}
#
proc findStyle {id name net} {
    global Share
    set style original
    if {![$id noshare]} {
	foreach x [array names Share] {
	    foreach {nt type cptn nptn mrg col} $Share($x) break
	    if {[regexp -nocase -- $type [$id type]] &&
	      [regexp -nocase -- $cptn $name] && [regexp -nocase -- $nptn [$net name]]} {
	        if {$mrg} { set style hicaffiene } {set style diet}
	        return [list $style .$x $col]
	    }
	}
    }
    return [list $style .$id 1]
}
#
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]] {
        foreach {nt type cptn nptn val} $Look($x) break
	switch -- $nt $net {
	    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 " [list $cptn]"
	    switch -- [subst $nptn] [$net name] {} default {
		puts -nonewline " [list $nptn]"
	    }
	    puts $desc " $val"
	}
    }

}
#
proc saveShare {desc net} {
    global Share
    set cm 1
    foreach x [lsort [array names Share]] {
        foreach {nt type cptn nptn mrg cols} $Share($x) break
	switch -- $nt $net {
	    if {$mrg} { 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 -- }
	    if {!$mrg && $cols > 1} { puts -nonewline $desc " *$cols" }
	    puts -nonewline $desc " [list $cptn]"
	    switch [subst $nptn] [$net name] {} default {
		puts -nonewline $desc " [list $nptn]"
	    }
	    puts $desc {}
	}
    }
}
#
proc remShareLook {net} {
    foreach var {Share Look} {
        upvar #0 $var gv
	foreach {x y} [array get gv] {
	    switch -- $net [lindex $y 0] {
	        unset gv($x)
	    }
	}
    }
    
}

