# # $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) } } } }