#
# $Source: /home/nlfm/Working/Zircon/Released/lib/RCS/initial.tcl,v $
# $Date: 2001/07/12 15:35:51 $
# $Revision: 1.18.1.184 $
#
# ----------------------------------------------------------------------
#   AUTHOR:  Lindsay Marshall <lindsay.marshall@newcastle.ac.uk>
# ----------------------------------------------------------------------
# Copyright 1993-2000 The University of Newcastle upon Tyne (see COPYRIGHT)
# ======================================================================
#
package provide zircon 1.18
#
proc preferences {op val} {}
#
proc dispAd {msg} {
    catch {.ad.info conf -text $msg ; update }
}
#
proc net {var val} {
    global currentNet DEBUG
    switch -glob -- $var {
    trust*  {
	    regsub {\(} $var "\($currentNet," var
	    uplevel #0 set $var "{$val}"
	}
    DEBUG { set DEBUG $val }
    zircon(ping) { $currentNet configure -ping [expr {$val * 1000}] }
    zircon(multion) -
    zircon(beep) -
    zircon(autochat) -
    zircon(busymsg) -
    zircon(autoget) -
    zircon(images) -
    zircon(raw) -
    zircon(command) -
    zircon(nicksize) -
    zircon(antiflood) -
    zircon(ircIImode) -
    zircon(nosplit) -
    zircon(reconnect) {
	    regexp {.*\((.*)\)} $var m op
	    $currentNet configure -$op $val
	}
    zircon(wavpath) -
    wavpath { $currentNet addWP $val }
    zircon(wavplayer) -
    wavplayer { $currentNet addWPl $val }
    meta { set zircon(meta) $val }
    autoAway -
    ping -
    monitorTime -
    quittime -
    dccTime -
    notifyInterval {$currentNet configure -$var [expr {$val * 1000}]}
    closeTime - testTime {# dont let users change these }
    zircon* { uplevel #0 set $var "{$val}" }
    default { $currentNet configure -$var $val }
    }
}
#
proc away {args} { global currentNet ; $currentNet configure +aways [join $args] }
#
proc nick {args} {
    global currentNet
    switch {} [set foo [join $args]] return
    $currentNet configure +nicks $foo
}
#
proc ircname {args} {
   global currentNet
   switch {} [set foo [join $args]] return
   $currentNet configure +ircnames $foo
}
#
proc action {args} { global currentNet ; $currentNet configure +actions [join $args] }
#
proc leave {args} { global currentNet ; $currentNet configure +leaves [join $args] }
#
proc signoff {args} { global currentNet ; $currentNet configure +signoffs [join $args] }
#
proc zbind {a1 a2 args} {
    global currentNet
    switch {} $args {
	set chan {}
	set sequence $a1
	set action $a2
    } default {
	set chan $a1
	set sequence $a2
	set action [lindex $args 0]
    }
    if {![regexp {^<.*>$} $sequence]} {
        set sequence <$sequence>
    }
    switch {} $chan {
	$currentNet configure +bindings [list $sequence $action]
    } default {
	[Channel :: make $chan $currentNet] configure +bindings [list $sequence $action]
    }
}
#
proc srvName {srv net} {
    if {[regexp {(.*):(.*)} $srv m hst prt]} {
	switch nil [set sid [Server :: make $net $hst]] {
	    set sid [Server $hst -port $prt]
	} default {
	    switch [$sid port] $prt {} default {
		set sid [Server [newName srv] -host $hst -port $prt]
	    }
	}
    } {
	set sid [Server :: make $net $srv]
    }
    return $sid
}
#
proc setCE {var val evar} {
    upvar $var dv
    switch {} $val {
	global env
	if {[info exists env($evar)]} {
	    set dv $env($evar)
	    return 1
	}
    } default {
	set dv $val
	return 1
    }
    return 0
}
#
proc envCheck {arg evar op dflt} {
    global currentNet
    set lst [$currentNet $op]
    if {[setCE v $arg $evar]} {
        # PRAGMA : set v
	if {[set x [lsearch $lst $v]] > 0} { listdel lst $x }
	$currentNet configure -$op [linsert $lst 0 $v]
    } \
    elseif {[string match {} $lst]} {$currentNet configure -$op $dflt}
}
#
proc layout {net window geom} {
    uplevel #0 set zlayout($net,$window) $geom
}
#
proc checkRE {exp} { return [expr {![catch {regexp -- $exp a}]}] }
#
proc helper {ptn cmd args} {
    global currentNet
    if {![checkRE $ptn]} {
	tellError {} Error "Bad helper file regular expression \"$ptn\""
    } {
	set usr [lindex $args 0]
	switch {} $usr { set usr .* } default {
	    if {![checkRE $usr]} {
		tellError {} Error "Bad helper user regular expression \"$usr\""
		return
	    }
	}
	$currentNet configure +helpers [list $ptn $cmd ]
    }
}
#
proc srcit {file what} {
    if {[file exists $file]} {
	if {[catch {uplevel #0 source [list $file]} msg]} {
	    tellError {} Error "**** Error in the $what file - $msg"
	    exit 1
	}
	return 1
    }
    return 0
}
#
proc setupImages {} {
    global zircon button1 bbc fbc
    set d [file join $zircon(lib) gifs button.gif]
    set button1 [image create photo -file $d]
    set bbc [eval format {#%02x%02x%02x} [$button1 get 44 20]]
    set fbc [eval format {#%02x%02x%02x} [$button1 get 0 0]]
}
#
proc InitImages {} {
    dispAd {Initialising Images...}
    global zircon DIms
    set f [file join $zircon(lib) gifs]
    foreach x {arc none polygon text line oval rectangle} {
	set DIms($x) [image create photo -file [file join $f $x.gif]]
    }
    global zDIOff zDIOn zDIOff1 zDIOn1 zKeyGif zSpkGif zNSpkGif zII \
      zNOII zLock zUnlock zLogo zLog
    set zDIOff [image create photo -file [file join $f off.gif]]
    set zDIOn  [image create photo -file [file join $f on.gif]]
    set zDIOff1 [image create photo -file [file join $f off1.gif]]
    set zDIOn1  [image create photo -file [file join $f on1.gif]]
    set zKeyGif [image create photo -file [file join $f key.gif]]
    set zSpkGif [image create photo -file [file join $f speak.gif]]
    set zNSpkGif [image create photo -file [file join $f nospeak.gif]]
    set zII [image create photo -file [file join $f ii.gif]]
    set zNOII [image create photo -file [file join $f noii.gif]]
    set zLock [image create photo -file [file join $f lock.gif]]
    set zUnlock [image create photo -file [file join $f unlock.gif]]
    set zLog [image create photo -file [file join $f log.gif]]
    set zLogo [image create photo -file [file join $f zlogo.gif]]
    setupImages
}
#
proc InitPlugins {} {
    global zircon auto_path
    foreach x [glob -nocomplain [file join $zircon(lib) plugins *]] {
	if {[file isdirectory $x]} {
	    set auto_path [linsert $auto_path 0 $x]
	    set pname [file tail $x]
	    dispAd "Initialising plugin $pname..."
	    if {[file exists [set f [file join $x setup.tcl]]]} {
		if {[catch {source $f} msg]} {
		    tellError {} Plugins "Error setting up plugin $pname - \"$msg\""
		}
	    } {
		package require $pname
	    }
	}
    }
}
#
proc InitLang {args} {
    global zircon
    switch english $zircon(language) {} default {
	srcit [file join $zircon(lib) lang $zircon(language).tcl] \
	  "system Zircon $zircon(language) message"
    }
    srcit [file join $zircon(prefdir) lang $zircon(language).tcl] \
      "your Zircon $zircon(language) message"
}
#
proc Initialise {} {
    global argv zircon defaults DEBUG currentNet defaultNet inexp1 \
      inexp2 userFlags zWList zWClose zWInc ztrans zInfo
#
    set zWList {}
    set zWClose {}
    set zWInc 30000
    set zInfo nil
#
    array set zircon [set zbase {
	nameCount	0
	idle		0
	nsignore	{RCS CVS *.bak *.tmp}
	C		0
	j		0
	o		0
	z		0
	i		{}
	N		{}
	S		{}
	p		{}
    }]
    wm withdraw .
    set h [winfo screenheight .]
    set w [winfo screenwidth .]
    if {[string match {*#*} [winfo name .]]} {
	if {![askUser {} Duplicate {You have another copy of zircon\
running. This may cause some problems with the appearance of this run.

Continue?}]} {
	    exit
	}
    }
    image create photo advert -file [file join $zircon(lib) gifs zircon.gif]
    set iw [expr {[image width advert] + 10}]
    set ih [expr {[image height advert] + 30}]
    toplevel .ad
    set zircon(fg) [[label .ad.f] cget -foreground]
    set zircon(bg) [.ad.f cget -background]
    destroy .ad.f
    wm overrideredirect .ad 1
    wm geometry .ad ${iw}x${ih}+[expr {($w -$ih) /2}]+[expr {($h - $ih )/2}]
    grid [label .ad.l -image advert -borderwidth 5 -relief ridge]
    grid [label .ad.info -bg black -fg white -text {}] -sticky ew
    update
#
# Hack to hide tk grab errors... (may have to be cleverer!!!)
#
    rename grab sys_grab
    proc grab {args} {
        if {![catch {eval sys_grab $args} res]} { return $res }
	return {}
    }
#
# Must initialise classes *before* consts as some initialisation
# currently depends on some Class values.
#
    InitClasses
    InitConsts
#
    set inexp1 {^([^ ]*) ([^ ]*)(( ([^:][^ ]*))*)( :(.*))?$}
    set inexp2 {^([^ ]*) ([^ ]*)(.*)?$}
    array set ztrans {ok OK cancel Cancel}
    dispAd "Initialising bindings..."
    foreach ty {Entry Text Button} {
	foreach x [bind $ty] { bind $ty $x {+ notIdle %W} }
    }
    if {[file exists [file join $zircon(lib) zircon.ad]]} {
	option readfile [file join $zircon(lib) zircon.ad] startupFile
    }
    option add *Checkbutton*relief flat widgetDefault
    option add *Checkbutton*borderwidth 0 widgetDefault
    option add *CheckButton*padX 5 widgetDefault
    option add *CheckButton*padY 4 widgetDefault
    option add *CheckButton*highlightThickness 0 widgetDefault
    option add *Button*padX 5 widgetDefault
    option add *Button*padY 4 widgetDefault
    option add *Button*highlightThickness 0 widgetDefault
    option add *Menubutton*padX 5 widgetDefault
    option add *Menubutton*pady 4 widgetDefault
    option add *Menubutton*relief raised widgetDefault
    option add *Frame*borderWidth 2 widgetDefault
    option add *Scrollbar*relief raised widgetDefault
    option add *Listbox*relief raised widgetDefault
    option add *Entry*relief raised widgetDefault
    option add *Entry*highlighThickness 1 widgetDefault
    option add *Text*setGrid 1 widgetDefault
    option add *Text*wrap word widgetDefault
    option add *Text*relief raised widgetDefault
    option add *Text*exportSelection 1 widgetDefault
    option add *Canvas*relief raised widgetDefault
    
    foreach x [bind Button] { bind ButtonMenu $x [bind Button $x] }
    bind ButtonMenu <Destroy> {
	catch {rename %W {}}
	catch {rename mb%W {}}
    }
    bind ButtonMenu <Enter> "[bind Menubutton <Enter>] ; [bind Button <Enter>]"
    bind ButtonMenu <Leave> "[bind Menubutton <Leave>] ; [bind Button <Leave>]"
    bind ButtonMenu <Button-2> [bind Menubutton <Button-1>]
    bind ButtonMenu <ButtonRelease-2> [bind Menubutton <ButtonRelease-1>]
    bind ButtonMenu <Button2-Motion> [bind Menubutton <Button1-Motion>]
    bind ButtonMenu <Motion> [bind MenuButton <Motion>]
    bind ButtonMenu <FocusIn> [bind MenuButton <FocusIn>]

    foreach x [bind Text] { bind ROText $x [bind Text $x] }
    foreach x {<KeyPress-F20> <KeyPress-F18> <Tab> <Control-i> <Return>
      <Delete> <BackSpace> <Insert> <KeyPress> <Control-d> <Control-k>
      <Control-o> <Control-t> <Meta-BackSpace> <Meta-Delete>
      <Control-h> <ButtonRelease-2>} {
	bind ROText $x {}
    }
    foreach x [bind Entry] { bind NEntry $x [bind Entry $x] }
    bind NEntry <Key> {
	notIdle %W
	switch -glob -- %A { [0-9+-] { tkEntryInsert %W %A } }
	break
    }
    array set zircon "
	meta		Meta
	bellcmd		bell
	envnick		IRCNICK
	envname		IRCNAME
	envserver	IRCSERVER
	envport		IRCPORT
	prefdir		[list [prefdir]]
	language	english
	look		standard
	action		Shift-Return
	sepColor	red
	ignore		{Msgs Notices Public Invites Wallops Notes CTCP Others}
	scriptpath	[list [file join $zircon(lib) scripts]]
	pluginpath	[list [file join $zircon(lib) plugins]]
	serversStyle	pulldown
	usersStyle	pulldown
    "
    array set defaults [array get zircon]
    foreach {x y} $zbase { unset defaults($x) }
    zVersion
#
    array set userFlags {
	o	gircop
	O	ircop
	w	wallops
	s	srvmsg
	i	invisible
	r	restricted
    }
    dispAd "Processing arguments..."
# Process args
    set DEBUG 0
    set opts {}
    foreach arg $argv {
	if {[string match {-*} $arg]} {
	    foreach bit [split [string range $arg 1 end] {}] {
		switch $bit {
		C - j - o - z { set zircon($bit) 1 }
		d - r - i - l - N - S - p { lappend opts $bit}
		D { set DEBUG 1 }
		default { puts stderr "Unknown option -$bit" }
		}
	    }
	} {
	    set opt [lindex $opts 0]
	    set opts [lrange $opts 1 end]
	    switch $opt {
	    i - N - S - r - p { set zircon($opt) $arg }
	    l { set zircon(language) $arg }
	    d { set zircon(prefdir) $arg }
	    default { }
	    }
	}
    }
    if {$DEBUG} { package require Tracing } { package require Notrace }
    set defaultNet [set currentNet [Net default]]
    dispAd "Initialising Look..."
    InitLook
    InitImages
    InitPlugins
    after 600000 schedGC
    set zWClose [after $zWInc closeWindows]
    InitGlobals
    if {$DEBUG} zDBGControl
    set ops 1
    foreach x {Font Foreground Background} {
        switch {} [option get . operator$x Operator$x] {} default {
	    set ops 0
	    break
	}
    }
    if {$ops} {
        foreach x [Net :: list] { $x configure -ircIIops 1 }
    }
    destroy .ad
    checkHeight [MainControl]
    bind [MainControl] <Configure> {checkHeight [winfo toplevel %W]}
}
#
proc makeDefaults {net} {
    global defChan defChat defMsg defNotice
    set defChan($net) [Channel *default*]
    set defChat($net) [Chat *default* -height 10]
    set defMsg($net) [Message *default* -height 10]
    set defNotice($net) [Notice *default* -height 10]
}
#
proc InitGlobals {} {
    dispAd "Initialising Globals..."
    global env zircon defaults user trust
    upvar #0 currentNet net
    getOption smiley ":-\)"
    getOption scowl ":-\("
    getOption wink ";-\)"
#
    array set trust {
	eval	{}
	draw	.+
	interp	{}
    }
    makeDefaults $net
#
# Array variables
#
    makeArray TFg TBg TAF TAB MkOp Host Shost Share
#
    set user [username]
#
# Source the system and then the user's rc file if they exist. The -z
# flag turns off reading rc files. First source the English language
# in case of errors.
#
    dispAd {Initialising messages...}
    srcit [file join $zircon(lib) lang english.tcl] "the system Zircon english message"
    global DEBUG hostIPaddress
    catch {set hostIPaddress $env(HOSTIPADDR)}
    dispAd {Initialising system look...}
    if {![srcit [file join $zircon(prefdir) look $zircon(look).tcl] \
      "your Zircon $zircon(look) look"]} {
	srcit [file join $zircon(lib) look $zircon(look).tcl] \
	  "the system Zircon $zircon(look)"
    }
    dispAd "Initialising $zircon(language) messages..."
    InitLang
    trace variable zircon(language) w InitLang
    dispAd {Initialising layout...}
    srcit [file join $zircon(prefdir) layout] "your Zircon layout"
    versionCheck
    dispAd {Reading your preferences...}
    catch {set zircon(prefdir) $env(ZIRCONPREFDIR)}
    if {[info exists zircon(d)]} { set zircon(prefdir) $zircon(d) }
    if {!$zircon(z)} {
	if {[info exists zircon(r)]} {
	    srcit $zircon(r) "your $zircon(r)"
	} {
	    set sp $zircon(prefdir)
	    if {[srcit [file join $zircon(lib) rc] {the system rc}]} {
		foreach sv [$net servers] { $sv configure -sys 1 }
		foreach sv [$net services] { $sv configure -sys 1 }
		foreach sv [$net channels] { $sv configure -sys 1 }
		uplevel #0 \$defChan($net) configure -sys 0
		oldCheck $net
	    }
	    set zircon(prefdir) $sp
	    if {![srcit [file join $zircon(prefdir) preferences] \
		"your [file join $zircon(prefdir) preferences]"]} {
		if {[srcit [file join ~ .zirconrc] {your .zirconrc}]} { upgradeRC }
	    }
	}
    }
    envCheck $zircon(N) $zircon(envnick) nicks $user
    envCheck $zircon(i) $zircon(envname) ircnames %u@%h
    InitNet $net
    trace vdelete zircon(language) w InitLang
    set nets [Net :: list]
    if {[llength $nets] <= 2} {
	set dnet [lindex $nets end]
#    setCE v $zircon(p) $zircon(envport)
	set srv nil
	if {![string match {} $zircon(S)]} { set srv [srvName $zircon(S) $dnet]}\
	elseif {[info exists env($zircon(envserver))]} {
	    foreach v [split $env($zircon(envserver))] {
		lappend sid [srvName $v $dnet]
	    }
	    set srv [lindex $sid 0]
	} \
	elseif {![string compare nil [$dnet hostid]]} {
	    if {![string compare nil [set srv [Server :: find default $dnet]]]} {
		set zircon(C) 2
	    }
	}
	switch nil $srv {} default {$dnet configure -hostid $srv}
    }
}
#
proc InitNet {net} {
    dispAd "Initialising netspace [$net name]..."
    global zircon trust defaultNet cfgv defChan user host
    set notdf [string compare $net $defaultNet]
    foreach x {eval draw} {
	if {![info exists trust($net,$x)]} {
	    if {[info exists trust($defaultNet,$x)]} {
		set trust($net,$x) $trust($defaultNet,$x)
	    } {
		set trust($net,$x) $trust($x)
	    }
	}
    }
#
# Set up all the defaults from the default net (if any)
#
    if {[$net raw]} {$net configure -command 1}
    if {$notdf} {	
	global Net currentNet
	set sc $currentNet
	set currentNet $net
	foreach x {nick ircname away action leave signoff} {
	    foreach y [$defaultNet ${x}s] {$x $y}
	}
	set currentNet $sc
	array set ndefs $Net
	foreach x [array names ndefs] {
	    set v [$net $x]
	    set dv [$defaultNet $x]
	    if {[string compare $v $dv] && ![string compare $v $ndefs($x)]} {
		$net configure -$x $dv
	    }
	}
	switch {} [$net nicks] { $net configure -nicks $user }
	switch {} [$net ircnames] {$net configure -ircnames %u@%h}

    }
#
# Flag channels that are created in the rc file. This makes sure they
# dont get thrown away when the channel is closed
#
    foreach x [$net channels] { $x configure -keep 1 }
    foreach x [$net messages] { $x configure -keep 1 }
    oldCheck $net
}
#
proc oldCheck1 {net} {}
#
proc oldCheck {net} {
    global cfgv
    set alert 0
    dispAd {Checking for old format...}
    foreach x $cfgv {
	switch {} [info globals $x] continue
	if {!$alert} {
	    bell
	    tk_dialog .@wa Warning "The preferences file format \
has changed - please re-save your preferences" warning 0 ok
	    set alert 1
	}
	$net configure -$x [uplevel #0 set $x]
    }
}
#
proc versionCheck {} {
    global zircon
    set f [file join $zircon(prefdir) version]
    if {[file exists $f]}  {
	catch { rename oldCheck {} ; rename oldCheck1 oldCheck}
    }
    if {[catch {source $f}] ||
      ![info exists currentVersion] ||
      [string compare $currentVersion $zircon(version).$zircon(patchlevel)]} {
	displayAlert
	if {![file exists $zircon(prefdir)]} {
	    if {[catch {filemkdir $zircon(prefdir)} msg]} {
		tellError {} Version "Cannot create preferences directory - $msg"
		return
	    }
	}
	if {[catch {open $f w} fd]} {
	    tellError {} Version "Cannot write version file - $fd"
	} {
	    puts $fd "set currentVersion $zircon(version).$zircon(patchlevel)"
	    close $fd
	}
    }
}
#
proc displayAlert {} {
   global zircon
   set warn {}
   switch -glob -- [info patchlevel] 7* - 8.0a* - 8.0b* - 8.0 - 8.0p1 {
	set warn {

You should upgrade to the latest release of tcl which is tcl8.0p2.}
    }
    tellInfo {} {New Version} "This is Zircon $zircon(version) patchlevel $zircon(patchlevel)$warn

See CHANGES for what has altered.

L."
}
#
proc schedGC {} { after idle garbageCollect }
#
proc garbageCollect {} {
    foreach net [Net :: list] {
	foreach usr [$net users] {
	   if {[$usr refcount] <= 0} { $usr delete }
	}
    }
    after 600000 schedGC
}
#
proc closeWindows {} {
    global zWList zWClose zWInc
    foreach x $zWList {$x inactive -$zWInc}
    set zWClose [after $zWInc closeWindows]
}
#
proc checkMainClose {} {
    global zWClose zWInc zWList
    set val 0
    foreach x $zWList {
        catch {if {[set ct [$x closetime]] != 0} {
	    if {$val == 0 || $ct < $val} {
	        set val $ct
	    }
	}}
    }
    if {$val <= 0} {
        set zWInc 30000
    } {
        set zWInc [expr {$val - 2000}]
    }
}

