"SfR Fresh" - the SfR Freeware/Shareware Archive 
Member "OpenVerse/lib/Passage.tcl" of archive OpenVerse-0.8-7.tar.gz:
As a special service "SfR Fresh" has tried to format the requested source page into HTML format using (guessed) Tcl/Tk source code syntax highlighting with prefixed line numbers.
Alternatively you can here view or download the uninterpreted source code file.
That can be also achieved for any archive member file by clicking within an archive contents listing on the first character of the file(path) respectively on the according byte size field.
1 # OpenVerse Passageways Module
2 #
3 # this file initalizes the program and does any
4 # platform specific things/setup. It will then source
5 # supporting modules.
6 #
7 # Module Name - Passageways Module
8 # Current Maintainter - Cruise <cruise@openverse.org>
9 # Sourced By - Init Main Window
10 #
11 # Modifications by KaosBeetl:
12 # Room History, 01/16/2000, revised 02/07/2000, 02/09/2000, 02/12/2000
13 #
14 # Copyright (C) 1999 David Gale <cruise@openverse.org>
15 # For more information visit http://OpenVerse.org/
16 #
17 # This program is free software; you can redistribute it and/or
18 # modify it under the terms of the GNU General Public License
19 # as published by the Free Software Foundation; either version 2
20 # of the License, or (at your option) any later version.
21 #
22 # This program is distributed in the hope that it will be useful,
23 # but WITHOUT ANY WARRANTY; without even the implied warranty of
24 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
25 # GNU General Public License for more details.
26 #
27 # You should have received a copy of the GNU General Public License
28 # along with this program; if not, write to the Free Software
29 # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
30 # USA.
31
32 #Performance enhancements using string compare
33 # Now using curley braces to increase performance
34
35
36 proc DoBookmarks {} {
37 global MV
38
39 destroy $MV(passageways_menu).m
40
41 if {!$MV(use_windowmanager_colors)} {
42 menu $MV(passageways_menu).m -bg $MV(colors.pw.bg) \
43 -fg $MV(colors.pw.fg) -activeforeground $MV(colors.pw.afg) \
44 -activebackground $MV(colors.pw.abg)
45 } else {
46 menu $MV(passageways_menu).m
47 }
48
49 $MV(passageways_menu).m add command -label [Trns add_current_room] \
50 -command "AddBookmark"
51 $MV(passageways_menu).m add command -label [Trns refresh_list] \
52 -command "QueryServers 1"
53 $MV(passageways_menu).m add command -label [Trns edit_list] \
54 -command "PassagewayEditor"
55
56 set MV(pwq.queries) 0
57 set server 0
58
59 # History and Passageways menu code merged; KaosBeetl 02/07/2000
60 foreach filename [list $MV(history) $MV(bookmarks)] \
61 menudef [list [Trns history] [Trns passageways]] \
62 getsdepth [list 0 1] {
63 set depth 0
64 set marks 0
65 if {[file exists "$filename"]} {
66 set depth 0
67 set infile [open "$filename" r]
68 while {[eof $infile] != 1} {
69 gets $infile input
70 set bm [split $input "|"]
71 set serv [split [lindex $bm 1] ":"]
72 if {[string first "|" $input] != -1} {
73 if {!$depth} {
74 incr depth
75 if {$getsdepth} {
76 set menulabel "$menudef $depth"
77 } else {
78 set menulabel "$menudef"
79 }
80 $MV(passageways_menu).m add cascade -menu \
81 $MV(passageways_menu).m.m$menudef$depth -label "$menulabel"
82 if {!$MV(use_windowmanager_colors)} {
83 menu $MV(passageways_menu).m.m$menudef$depth -bg $MV(colors.pw.bg) \
84 -fg $MV(colors.pw.fg) -activeforeground $MV(colors.pw.afg) \
85 -activebackground $MV(colors.pw.abg)
86 } else {
87 menu $MV(passageways_menu).m.m$menudef$depth
88 }
89 }
90 set prepend ""
91 if {[info exists MV(pwq.$server.users)]} {
92 append prepend "($MV(pwq.$server.users)) ($MV(pwq.$server.users)) "
93 }
94 set name_label "$prepend [lindex $bm 0] [HistoryAge [lindex $bm 2]]"
95 set MV(pwq.queries) "$server"
96 set MV(pwq.$server.name) "$name_label"
97 set MV(pwq.$server.short_name) "[lindex $bm 0] [HistoryAge [lindex $bm 2]]"
98 set MV(pwq.$server.host) "[lindex $serv 0]"
99 set MV(pwq.$server.port) "[lindex $serv 1]"
100 set MV(pwq.$server.menu) "$MV(passageways_menu).m.m$menudef$depth"
101 $MV(passageways_menu).m.m$menudef$depth add command -label "$name_label" \
102 -command "ConnectToRoom [lindex $serv 0] [lindex $serv 1]"
103 if {[info exists MV(pwq.$server.users)]} {
104 $MV(pwq.$server.menu) entryconfigure $MV(pwq.$server.name) -label "$name_label" -foreground $MV(pwq.$server.color) -activeforeground $MV(pwq.$server.color)
105 }
106 if {$getsdepth} {
107 incr marks
108 }
109 incr server
110 if {$marks > 19} {
111 # this will only happen if $getsdepth is set
112 incr depth
113 $MV(passageways_menu).m add cascade -menu \
114 $MV(passageways_menu).m.m$menudef$depth -label "$menudef $depth"
115 if !$MV(use_windowmanager_colors) {
116 menu $MV(passageways_menu).m.m$menudef$depth -bg $MV(colors.pw.bg) \
117 -fg $MV(colors.pw.fg) -activeforeground $MV(colors.pw.afg) \
118 -activebackground $MV(colors.pw.abg)
119 } else {
120 menu $MV(passageways_menu).m.m$menudef$depth
121 }
122 set marks 0
123 }
124 }
125 }
126 close $infile
127 }
128 }
129 }
130
131 proc AddBookmark {} {
132 global MV
133
134 set outfile [open "$MV(bookmarks)" a+]
135 puts $outfile "$MV(roomname)|$MV(roomhost):$MV(roomport)|[clock seconds]"
136 close $outfile
137 DoBookmarks
138 }
139
140 #
141 # Will query all servers in the passageways list
142 # and retrieve a number of users on each server.
143 # It will also note the time it took to respond to the query.
144 #
145 # This information will be stored into an array for future use when
146 # updating the history information when changing rooms.
147 #
148 proc QueryServers {BookMark} {
149 global MV
150
151 if {[llength $MV(server_queries)] > 0} {return}
152 set MV(nosort) 1
153 if $BookMark {
154 DoBookmarks
155 }
156 set time 500
157 for {set c 0} {$c <= $MV(pwq.queries)} {incr c} {
158 lappend MV(server_queries) $c
159 after $time "PWQueryServer $c"
160 incr time 500
161 update idletasks
162 }
163 }
164
165 proc PWQueryServer {idx} {
166 global MV
167
168 set MV(pwq.$idx.sock) -1
169 set sck -1
170 catch {set sck [socket -async $MV(pwq.$idx.host) $MV(pwq.$idx.port)]}
171 catch {fconfigure $sck -blocking 0}
172 set MV(pwq.$idx.sock) $sck
173 set MV(pwq.$idx.time) [clock seconds]
174 after 30000 "PWKillRequestSocket $idx"
175 catch {puts $MV(pwq.$idx.sock) "USERS"}
176 catch {flush $MV(pwq.$idx.sock)}
177 update idletasks
178 catch {fileevent $MV(pwq.$idx.sock) readable "PWGetUsers $idx"}
179 }
180
181 proc PWGetUsers {idx} {
182 global MV
183
184 set input "AUTH REQD"
185 catch {gets $MV(pwq.$idx.sock) input}
186 if {[eof $MV(pwq.$idx.sock)]} {
187 set MV(pwq.$idx.time) 0
188 set id [lsearch -exact $MV(server_queries) $idx]
189 set MV(server_queries) [lreplace $MV(server_queries) $id $id]
190 catch {close $MV(pwq.$idx.sock)}
191 return
192 }
193 DebugIt "<-(P) [eof $MV(pwq.$idx.sock)] $MV(pwq.$idx.sock) $input" prot
194 set parms [split $input]
195 set users [lindex $parms 1]
196 set tme [expr [clock seconds] - $MV(pwq.$idx.time)]
197 switch -exact -- [lindex $parms 0] {
198 "PING" {
199 return
200 }
201 "AUTH" {
202 $MV(pwq.$idx.menu) entryconfigure $MV(pwq.$idx.name) -label "(??) ($tme S) $MV(pwq.$idx.short_name)" -foreground red -activeforeground red
203 set MV(pwq.$idx.users) "??"
204 set MV(pwq.$idx.time) $tme
205 set MV(pwq.$idx.color) "red"
206 }
207 "USERS" {
208 # Performance Enhancement
209 if {[string compare $users ""] && $users > 0} {
210 $MV(pwq.$idx.menu) entryconfigure $MV(pwq.$idx.name) -label "($users) ($tme S) $MV(pwq.$idx.short_name)" -foreground blue -activeforeground blue
211 set MV(pwq.$idx.color) "blue"
212 } else {
213 $MV(pwq.$idx.menu) entryconfigure $MV(pwq.$idx.name) -label "($users) ($tme S) $MV(pwq.$idx.short_name)" -foreground "dark green" -activeforeground "dark green"
214 set MV(pwq.$idx.color) "dark green"
215 }
216 set MV(pwq.$idx.users) "$users"
217 set MV(pwq.$idx.time) $tme
218 }
219 default {return}
220 }
221 set MV(pwq.$idx.time) 0
222 set id [lsearch -exact $MV(server_queries) $idx]
223 set MV(server_queries) [lreplace $MV(server_queries) $id $id]
224 catch {close $MV(pwq.$idx.sock)}
225 update idletasks
226 }
227
228 proc PWKillRequestSocket {idx} {
229 global MV
230
231 if !$MV(pwq.$idx.time) {
232 set id [lsearch -exact $MV(server_queries) $idx]
233 set MV(server_queries) [lreplace $MV(server_queries) $id $id]
234 return
235 }
236 catch {close $MV(pwq.$idx.sock)}
237 $MV(pwq.$idx.menu) entryconfigure $MV(pwq.$idx.name) -label "(--) (TO) $MV(pwq.$idx.short_name)" -foreground red -activeforeground red
238 set MV(pwq.$idx.users) "--"
239 set MV(pwq.$idx.time) 0
240 set MV(pwq.$idx.color) "red"
241 set id [lsearch -exact $MV(server_queries) $idx]
242 set MV(server_queries) [lreplace $MV(server_queries) $id $id]
243 }
244
245 # Returns a human-readable form of the difference between $time and
246 # current time, in seconds, minutes, hours, days, or "long time"
247 # KaosBeetl 02/07/2000
248 proc HistoryAge {time} {
249 if {![string compare $time ""] || ($time == 0)} {
250 return "(unknown)"
251 }
252
253 set age [ expr [clock seconds] - $time ]
254
255 if { $age < 60 } {
256 if { $age > 0 } {
257 set age_val $age
258 } else {
259 set age_val 0
260 }
261 set age_unit "sec"
262 } elseif { $age < 3600 } {
263 set age_val [ expr $age / 60 ]
264 set age_unit "min"
265 } elseif { $age < 86400 } {
266 set age_val [ expr $age / 3600 ]
267 set age_unit "hour"
268 } elseif { $age > 31536000 } {
269 # more than 365 days (86400 * 365)
270 return "(long time)"
271 } else {
272 set age_val [ expr $age / 86400 ]
273 set age_unit "day"
274 }
275
276 if { $age_val == 0 } {
277 return ""
278 }
279
280 if { $age_val == 1 } {
281 return "($age_val $age_unit)"
282 }
283
284 # note the added s
285 return "($age_val ${age_unit}s)"
286 }
287
288 # Updates history and passageways file, setting the last use time for the
289 # current server to the current time. Sorts history, and optionally sorts
290 # passageways.
291 # KaosBeetl 02/07/2000
292 proc UpdatePassageways {} {
293 global MV
294
295 foreach filename [list $MV(bookmarks) $MV(history)] \
296 getssort [list $MV(sort_bookmarks) 1] \
297 max [list 9999 $MV(history_max)] {
298 set found 0
299 set cur_list [list]
300 DebugIt "Processing $filename" other
301 if [file exists "$filename"] {
302 set infile [open "$filename" r]
303 while {[eof $infile] != 1} {
304 gets $infile input
305 set bm [split $input "|"]
306
307 if {[string first "|" $input] != -1} {
308 set cur_entry [list]
309 set name "[lindex $bm 0]"
310 set thisserv "[split [lindex $bm 1] ":"]"
311 set host "[lindex $thisserv 0]"
312 set port [lindex $thisserv 1]
313 set time [lindex $bm 2]
314
315 if {![string compare $time ""]} {
316 set time 0
317 }
318
319 # see if this is the current server
320 if {![string compare $MV(roomhost) $host] && \
321 ![string compare $MV(roomport) $port]} {
322 if {!$found} {
323 # update name and time
324 set name "$MV(roomname)"
325 set time [clock seconds]
326 set found 1
327 } else {
328 set host ""
329 }
330 }
331
332 if {[string compare $host ""]} {
333 set cur_entry [list $name $host $port $time]
334 lappend cur_list $cur_entry
335 }
336 }
337 }
338 }
339
340 if {![string compare $filename $MV(history)]} {
341 # for history pass, make sure current room is in
342 if {!$found} {
343 set cur_entry [list $MV(roomname) $MV(roomhost) $MV(roomport) [clock seconds]]
344 lappend cur_list $cur_entry
345 set found 1
346 }
347 }
348
349 if {$getssort && !$MV(nosort)} {
350 # sort by visiting time
351 set cur_list [lsort -integer -decreasing -index 3 $cur_list]
352 }
353
354 # write them back out, if necessary
355 if {$found} {
356 set outfile [open "$filename" w]
357 set ct 1
358
359 foreach cur_entry $cur_list {
360 if {$ct > $max} {
361 break
362 } else {
363 incr ct
364 }
365 puts $outfile "[lindex $cur_entry 0]|[lindex $cur_entry 1]:[lindex $cur_entry 2]|[lindex $cur_entry 3]"
366 }
367
368 close $outfile
369 }
370 }
371 DoBookmarks
372 }
373
374
375 #
376 # PassEdWriteOut
377 #
378 # Write the list of passageways.
379 proc PassEdWriteOut {} {
380 global PASSED MV
381 set outfile [open "$MV(bookmarks)" w]
382 foreach pass $PASSED(bms) {
383 puts $outfile "$pass"
384 }
385 close $outfile
386 DoBookmarks
387 }
388
389 #
390 # PassagewayEdDisplay
391 #
392 # This function displays a selected passageway in the editor.
393 #
394 global PASSED
395 proc PassagewayEdDisplay {} {
396 global PASSED
397
398 if {[catch {set idx [lindex [split [selection get -displayof .pas_ed.list.list]] 0]}]} {return}
399
400 set input [lindex $PASSED(bms) $idx]
401 set bm [split $input "|"]
402 set hp [split [lindex $bm 1] ":"]
403 set PASSED(name) [lindex $bm 0]
404 set PASSED(host) [lindex $hp 0]
405 set PASSED(port) [lindex $hp 1]
406 set PASSED(idx) $idx
407 update idletasks
408 }
409
410
411 #
412 # PassEdSaveNew
413 #
414 # Saves a new passageway
415 #
416 proc PassEdSaveNew {} {
417 global PASSED
418
419 set input "$PASSED(name_new)|$PASSED(host_new):$PASSED(port_new)|0"
420 set idx [llength $PASSED(bms)]
421 lappend PASSED(bms) "$input"
422 lappend PASSED(list) "$idx $PASSED(name_new)"
423 destroy .pas_ed_new
424 catch {unset PASSED(name_new)}
425 catch {unset PASSED(host_new)}
426 catch {unset PASSED(port_new)}
427 .pas_ed.list.list selection set end
428 update idletasks
429 PassEdWriteOut
430 PassagewayEdDisplay
431 }
432
433 #
434 # PassEdSave
435 #
436 # Saves the currently displayed passageway.
437 #
438 #
439 proc PassEdSave {} {
440 global PASSED
441
442 if {$PASSED(idx) == -1} {return}
443 set input "$PASSED(name)|$PASSED(host):$PASSED(port)|0"
444 set idx $PASSED(idx)
445 set PASSED(bms) [lreplace $PASSED(bms) $idx $idx "$input"]
446 set PASSED(list) [lreplace $PASSED(list) $idx $idx "$idx $PASSED(name)"]
447 update idletasks
448 PassEdWriteOut
449 }
450
451 #
452 # PassEdDelete
453 #
454 # Deletes the selected item.
455 #
456 proc PassEdDelete {} {
457 global PASSED
458 if {[catch {set idx [lindex [split [selection get -displayof .pas_ed.list.list]] 0]}]} {return}
459 set PASSED(list) [lreplace $PASSED(list) $idx $idx]
460 set PASSED(bms) [lreplace $PASSED(bms) $idx $idx]
461 update idletasks
462 PassEdWriteOut
463 .pas_ed.list.list selection set 0
464 PassagewayEdDisplay
465 }
466
467 #
468 # PassEdNewRoom
469 #
470 # A popup to add a new room.
471 #
472 proc PassEdNewRoom {} {
473 global PASSED
474
475 if {[winfo exists .pas_ed_new]} {
476 destroy .pas_ed_new
477 }
478
479 toplevel .pas_ed_new
480 wm title .pas_ed_new [Trns new_room]
481
482 frame .pas_ed_new.name
483 label .pas_ed_new.name.l -text [Trns name] -width 10
484 entry .pas_ed_new.name.e -textvariable PASSED(name_new)
485 pack .pas_ed_new.name -fill both
486 pack .pas_ed_new.name.l -side left
487 pack .pas_ed_new.name.e -side left -fill x -expand y
488
489 frame .pas_ed_new.host
490 label .pas_ed_new.host.l -text [Trns host] -width 10
491 entry .pas_ed_new.host.e -textvariable PASSED(host_new)
492 label .pas_ed_new.host.pl -text [Trns port] -width 10
493 entry .pas_ed_new.host.pe -textvariable PASSED(port_new)
494 pack .pas_ed_new.host -fill both
495 pack .pas_ed_new.host.l -side left
496 pack .pas_ed_new.host.e -side left -fill x -expand y
497 pack .pas_ed_new.host.pl -side left
498 pack .pas_ed_new.host.pe -side left -fill x -expand y
499
500 frame .pas_ed_new.buttons -relief sunken -borderwidth 2
501 button .pas_ed_new.buttons.quit -text [Trns close] -command "destroy .pas_ed_new"
502 button .pas_ed_new.buttons.save -text [Trns save] -command PassEdSaveNew
503 pack .pas_ed_new.buttons -fill both
504 pack .pas_ed_new.buttons.quit .pas_ed_new.buttons.save -side left -fill x -expand y
505
506 }
507
508 #
509 # This is the passageway editor. Add, delete, etc.
510 #
511 proc PassagewayEditor {} {
512 global MV PASSED
513
514 if {[winfo exists .pas_ed]} {
515 destroy .pas_ed
516 }
517
518 toplevel .pas_ed
519 wm title .pas_ed [Trns passageway_editor]
520
521 frame .pas_ed.name
522 label .pas_ed.name.l -text [Trns name] -width 10
523 entry .pas_ed.name.e -textvariable PASSED(name)
524 pack .pas_ed.name -fill both
525 pack .pas_ed.name.l -side left
526 pack .pas_ed.name.e -side left -fill x -expand y
527
528 frame .pas_ed.host
529 label .pas_ed.host.l -text [Trns host] -width 10
530 entry .pas_ed.host.e -textvariable PASSED(host)
531 label .pas_ed.host.pl -text [Trns port] -width 10
532 entry .pas_ed.host.pe -textvariable PASSED(port)
533 pack .pas_ed.host -fill both
534 pack .pas_ed.host.l -side left
535 pack .pas_ed.host.e -side left -fill x -expand y
536 pack .pas_ed.host.pl -side left
537 pack .pas_ed.host.pe -side left -fill x -expand y
538
539 frame .pas_ed.buttons -relief sunken -borderwidth 2
540 button .pas_ed.buttons.quit -text [Trns close] -command "destroy .pas_ed"
541 button .pas_ed.buttons.save -text [Trns save] -command "PassEdSave"
542 button .pas_ed.buttons.del -text [Trns delete_selected] -command "PassEdDelete"
543 button .pas_ed.buttons.new -text [Trns new_room] -command PassEdNewRoom
544 pack .pas_ed.buttons -fill both
545 pack .pas_ed.buttons.quit .pas_ed.buttons.save .pas_ed.buttons.del .pas_ed.buttons.new -side left \
546 -fill x -expand y
547
548
549 frame .pas_ed.list -relief sunken -borderwidth 2
550 listbox .pas_ed.list.list -width 80 -height 20 -xscrollcommand ".pas_ed.list.scrollx set" \
551 -yscrollcommand ".pas_ed.list.scrolly set" -listvar PASSED(list)
552 scrollbar .pas_ed.list.scrolly -command ".pas_ed.list.list yview"
553 scrollbar .pas_ed.list.scrollx -orient horizontal -command ".pas_ed.list.list xview"
554 pack .pas_ed.list -fill both -expand y
555 pack .pas_ed.list.scrollx -side top -fill x
556 pack .pas_ed.list.list -side left -fill both -expand y
557 pack .pas_ed.list.scrolly -side left -fill y
558 update idletasks
559
560 set PASSED(bms) {}
561 set PASSED(list) {}
562 set PASSED(idx) -1
563 set idx -1
564 if {[file exists "$MV(bookmarks)"]} {
565 set infile [open "$MV(bookmarks)" r]
566 while {[eof $infile] != 1} {
567 gets $infile input
568 if {[string first "|" $input] != -1} {
569 incr idx
570 set bm [split $input "|"]
571 set hp [split [lindex $bm 1] ":"]
572 set name [lindex $bm 0]
573 set host [lindex $hp 0]
574 set port [lindex $hp 1]
575 lappend PASSED(list) "$idx $name"
576 lappend PASSED(bms) $input
577 }
578 }
579 close $infile
580 }
581 bind .pas_ed.list.list <ButtonRelease> "PassagewayEdDisplay"
582 }