"SfR Fresh" - the SfR Freeware/Shareware Archive 
Member "OpenVerse/lib/Objects.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 Objects 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 - Objects Module
8 # Current Maintainter - Cruise <cruise@openverse.org>
9 # Sourced By - Command Line
10 #
11 # Copyright (C) 1999 David Gale <cruise@openverse.org>
12 # For more information visit http://OpenVerse.org/
13 #
14 # This program is free software; you can redistribute it and/or
15 # modify it under the terms of the GNU General Public License
16 # as published by the Free Software Foundation; either version 2
17 # of the License, or (at your option) any later version.
18 #
19 # This program is distributed in the hope that it will be useful,
20 # but WITHOUT ANY WARRANTY; without even the implied warranty of
21 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
22 # GNU General Public License for more details.
23 #
24 # You should have received a copy of the GNU General Public License
25 # along with this program; if not, write to the Free Software
26 # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
27 # USA.
28
29 # Performance enhancements using string compare
30
31
32 proc NewObject {} {
33 }
34
35 proc DrawBox {name x1 y1 x2 y2 fill outline duration} {
36 global MV
37
38 if {[TestNum $x1] || [TestNum $y1] || [TestNum $x2] || [TestNum $y2] || [TestNum $duration]} {
39 DebugIt "DrawBox: Invalid Parameters" other
40 return
41 }
42
43 if {[lsearch -exact $MV(server_objects) $name] != -1} {
44 #
45 # Let's update the one we already have.
46 #
47 .top.c itemconfigure $MV(server_objects.$name.id) -fill $fill -outline $outline
48 set id $MV(server_objects.$name.id)
49 } else {
50 lappend MV(server_objects) $name
51 set id [.top.c create rectangle $x1 $y1 $x2 $y2 \
52 -fill $fill -outline $outline]
53
54 set MV(server_objects.$id.name) $name
55 set MV(server_objects.$name.image) "NOT_IMAGE_COMPATABLE"
56 set MV(server_objects.$name.image2) "NOT_IMAGE_COMPATABLE"
57 set MV(server_objects.$name.id) $id
58 set MV(server_objects.$name.type) "BOX"
59 set MV(server_objects.$name.text) "BOX"
60 }
61 if $duration {
62 after $duration "KillServerObject $id"
63 } else {
64 update idletasks
65 }
66 }
67
68 proc DrawImage {name x1 y1 image size duration} {
69 global MV
70
71 if {[TestNum $x1] || [TestNum $y1] || [TestNum $size] || [TestNum $duration]} {
72 DebugIt "DrawImage: Invalid Parameters" other
73 return
74 }
75
76 if {[lsearch -exact $MV(server_objects) $name] != -1} {
77 set MV(server_objects.$name.image) $image
78 if ![file exists "$MV(objects)/$image"] {
79 if {[lsearch -exact $MV(downloads) $image] == -1} {
80 SendToServer "DCCSENDOB $image"
81 image create photo server_object_$name -file "$MV(icondir)/unknown.gif"
82 } else {
83 image create photo server_object_$name -file "$MV(icondir)/unknown.gif"
84 }
85 } else {
86 if {$size != [file size "$MV(objects)/$image"]} {
87 if {[lsearch -exact $MV(downloads) $image] == -1} {
88 SendToServer "DCCSENDOB $image"
89 image create photo server_object_$name -file "$MV(icondir)/unknown.gif"
90 } else {
91 image create photo server_object_$name -file "$MV(icondir)/unknown.gif"
92 }
93 } else {
94 image create photo server_object_$name -file "$MV(objects)/$image"
95 }
96 }
97 if $duration {
98 after $duration "KillServerObject $MV(server_objects.$name.id)"
99 } else {
100 update idletasks
101 }
102 return
103 }
104 lappend MV(server_objects) $name
105
106 if ![file exists "$MV(objects)/$image"] {
107 if {[lsearch -exact $MV(downloads) $image] == -1} {
108 SendToServer "DCCSENDOB $image"
109 image create photo server_object_$name -file "$MV(icondir)/unknown.gif"
110 } else {
111 image create photo server_object_$name -file "$MV(icondir)/unknown.gif"
112 }
113 } else {
114 if {$size != [file size "$MV(objects)/$image"]} {
115 if {[lsearch -exact $MV(downloads) $image] == -1} {
116 SendToServer "DCCSENDOB $image"
117 image create photo server_object_$name -file "$MV(icondir)/unknown.gif"
118 } else {
119 image create photo server_object_$name -file "$MV(icondir)/unknown.gif"
120 }
121 } else {
122 image create photo server_object_$name -file "$MV(objects)/$image"
123 }
124 }
125
126 set id [.top.c create image $x1 $y1 -image server_object_$name]
127
128 set MV(server_objects.$id.name) $name
129 set MV(server_objects.$name.image) $image
130 set MV(server_objects.$name.image2) "NOT_IMAGE_COMPATABLE"
131 set MV(server_objects.$name.id) $id
132 set MV(server_objects.$name.type) "IMAGE"
133 set MV(server_objects.$name.text) "IMAGE"
134
135 if $duration {
136 after $duration "KillServerObject $id"
137 } else {
138 update idletasks
139 }
140 }
141
142 proc DrawMouseOver {name x1 y1 image1 size1 image2 size2 duration} {
143 global MV
144
145 if {[TestNum $x1] || [TestNum $y1] || [TestNum $size1] || [TestNum $size2] || [TestNum $duration]} {
146 DebugIt "DrawMouseOver: Invalid Parameters" other
147 return
148 }
149
150 if {[lsearch -exact $MV(server_objects) $name] != -1} {
151 if ![file exists "$MV(objects)/$image1"] {
152 if {[lsearch -exact $MV(downloads) $image1] == -1} {
153 SendToServer "DCCSENDOB $image1"
154 image create photo server_object_$name -file "$MV(icondir)/unknown.gif"
155 } else {
156 image create photo server_object_$name -file "$MV(icondir)/unknown.gif"
157 }
158 } else {
159 if {$size1 != [file size "$MV(objects)/$image1"]} {
160 if {[lsearch -exact $MV(downloads) $image1] == -1} {
161 SendToServer "DCCSENDOB $image1"
162 image create photo server_object_$name -file "$MV(icondir)/unknown.gif"
163 } else {
164 image create photo server_object_$name -file "$MV(icondir)/unknown.gif"
165 }
166 } else {
167 image create photo server_object_$name -file "$MV(objects)/$image1"
168 }
169 }
170
171 if ![file exists "$MV(objects)/$image2"] {
172 if {[lsearch -exact $MV(downloads) $image2] == -1} {
173 SendToServer "DCCSENDOB $image2"
174 }
175 } else {
176 if {$size2 != [file size "$MV(objects)/$image2"]} {
177 if {[lsearch -exact $MV(downloads) $image2] == -1} {
178 SendToServer "DCCSENDOB $image2"
179 }
180 }
181 }
182 if $duration {
183 after $duration "KillServerObject $MV(server_objects.$name.id)"
184 } else {
185 update idletasks
186 }
187 set MV(server_objects.$name.image) $image1
188 set MV(server_objects.$name.image2) $image2
189 return
190 }
191 lappend MV(server_objects) $name
192
193 if ![file exists "$MV(objects)/$image1"] {
194 if {[lsearch -exact $MV(downloads) $image1] == -1} {
195 SendToServer "DCCSENDOB $image1"
196 image create photo server_object_$name -file "$MV(icondir)/unknown.gif"
197 } else {
198 image create photo server_object_$name -file "$MV(icondir)/unknown.gif"
199 }
200 } else {
201 if {$size1 != [file size "$MV(objects)/$image1"]} {
202 if {[lsearch -exact $MV(downloads) $image1] == -1} {
203 SendToServer "DCCSENDOB $image1"
204 image create photo server_object_$name -file "$MV(icondir)/unknown.gif"
205 } else {
206 image create photo server_object_$name -file "$MV(icondir)/unknown.gif"
207 }
208 } else {
209 image create photo server_object_$name -file "$MV(objects)/$image1"
210 }
211 }
212
213 if ![file exists "$MV(objects)/$image2"] {
214 if {[lsearch -exact $MV(downloads) $image2] == -1} {
215 SendToServer "DCCSENDOB $image2"
216 }
217 } else {
218 if {$size2 != [file size "$MV(objects)/$image2"]} {
219 if {[lsearch -exact $MV(downloads) $image2] == -1} {
220 SendToServer "DCCSENDOB $image2"
221 }
222 }
223 }
224
225 set id [.top.c create image $x1 $y1 -image server_object_$name]
226 .top.c bind $id <Enter> "MouseOverEvent 1 $id"
227 .top.c bind $id <Leave> "MouseOverEvent 0 $id"
228
229 set MV(server_objects.$id.name) $name
230 set MV(server_objects.$name.image) $image1
231 set MV(server_objects.$name.image2) $image2
232 set MV(server_objects.$name.id) $id
233 set MV(server_objects.$name.type) "MOUSEOVER"
234 set MV(server_objects.$name.text) "MOUSEOVER"
235
236 if $duration {
237 after $duration "KillServerObject $id"
238 } else {
239 update idletasks
240 }
241 }
242
243 proc DrawText {name x1 y1 color size duration text} {
244 global MV
245
246 if {[TestNum $x1] || [TestNum $y1] || [TestNum $size] || [TestNum $duration]} {
247 DebugIt "DrawText: Invalid Parameters" other
248 return
249 }
250
251 set font(1) -*-Helvetica-Medium-R-Normal-*-8-*
252 set font(2) -*-Helvetica-Medium-R-Normal-*-12-*
253 set font(3) -*-Helvetica-Medium-R-Normal-*-14-*
254 set font(4) -*-Helvetica-Medium-R-Normal-*-18-*
255 set font(5) -*-Helvetica-Medium-R-Normal-*-24-*
256
257 if {[lsearch -exact $MV(server_objects) $name] != -1} {
258 .top.c itemconfigure $MV(server_objects.$name.id) -fill $color -text $text -font $font($size)
259 if $duration {
260 after $duration "KillServerObject $MV(server_objects.$name.id)"
261 } else {
262 update idletasks
263 }
264 return
265 }
266 lappend MV(server_objects) $name
267
268 set id [.top.c create text $x1 $y1 -fill $color -text $text -font $font($size)]
269 set MV(server_objects.$name.id) $id
270 set MV(server_objects.$id.name) $name
271 set MV(server_objects.$name.image) "NOT_IMAGE_COMPATABLE"
272 set MV(server_objects.$name.image2) "NOT_IMAGE_COMPATABLE"
273 set MV(server_objects.$name.type) "TEXT"
274 set MV(server_objects.$name.text) $text
275
276 if $duration {
277 after $duration "KillServerObject $id"
278 } else {
279 update idletasks
280 }
281 }
282
283 proc DrawWText {name x1 y1 color size duration width text} {
284 global MV
285
286 if {[TestNum $x1] || [TestNum $y1] || [TestNum $size] || [TestNum $duration] || [TestNum $width]} {
287 DebugIt "DrawText: Invalid Parameters" other
288 return
289 }
290
291 set font(1) -*-Helvetica-Medium-R-Normal-*-8-*
292 set font(2) -*-Helvetica-Medium-R-Normal-*-12-*
293 set font(3) -*-Helvetica-Medium-R-Normal-*-14-*
294 set font(4) -*-Helvetica-Medium-R-Normal-*-18-*
295 set font(5) -*-Helvetica-Medium-R-Normal-*-24-*
296
297 if {[lsearch -exact $MV(server_objects) $name] != -1} {
298 .top.c itemconfigure $MV(server_objects.$name.id) -fill $color -text $text -font $font($size) -width $width
299 if $duration {
300 after $duration "KillServerObject $MV(server_objects.$name.id)"
301 } else {
302 update idletasks
303 }
304 return
305 }
306 lappend MV(server_objects) $name
307
308 set id [.top.c create text $x1 $y1 -fill $color -text $text -font $font($size) -width $width]
309 set MV(server_objects.$name.id) $id
310 set MV(server_objects.$id.name) $name
311 set MV(server_objects.$name.image) "NOT_IMAGE_COMPATABLE"
312 set MV(server_objects.$name.image2) "NOT_IMAGE_COMPATABLE"
313 set MV(server_objects.$name.type) "WTEXT"
314 set MV(server_objects.$name.text) $text
315
316 if $duration {
317 after $duration "KillServerObject $id"
318 } else {
319 update idletasks
320 }
321 }
322
323 proc DrawEntry {name x1 y1 length color text_color duration text} {
324 global MV
325
326 if {[TestNum $x1] || [TestNum $y1] || [TestNum $length] || [TestNum $duration]} {
327 DebugIt "DrawEntry: Invalid Parameters" other
328 return
329 }
330
331 if {[lsearch -exact $MV(server_objects) $name] != -1} {
332 KillServerObject $MV(server_objects.$name.id)
333 }
334 lappend MV(server_objects) $name
335
336 set MV(server_objects.$name.text) "$text"
337 entry .top.c.$name -width $length -bg $color \
338 -fg $text_color -textvariable MV(server_objects.$name.text)
339
340 set id [.top.c create window $x1 $y1 -window .top.c.$name]
341 set MV(server_objects.$name.id) $id
342 set MV(server_objects.$id.name) $name
343 set MV(server_objects.$name.image) "NOT_IMAGE_COMPATABLE"
344 set MV(server_objects.$name.image2) "NOT_IMAGE_COMPATABLE"
345 set MV(server_objects.$name.type) "ENTRY"
346 set MV(server_objects.$name.text) $text
347
348 if $duration {
349 after $duration "KillServerObject $id"
350 } else {
351 update idletasks
352 }
353 }
354
355 proc DrawSubmit {name x1 y1 color text_color duration text} {
356 global MV
357
358 if {[TestNum $x1] || [TestNum $y1] || [TestNum $duration]} {
359 DebugIt "DrawSubmit: Invalid Parameters" other
360 return
361 }
362
363 if {[lsearch -exact $MV(server_objects) $name] != -1} {
364 KillServerObject $MV(server_objects.$name.id)
365 }
366 lappend MV(server_objects) $name
367
368 set MV(server_objects.$name.text) "$text"
369 button .top.c.$name -bg $color -fg $text_color \
370 -activebackground $color \
371 -text $MV(server_objects.$name.text)
372
373 set id [.top.c create window $x1 $y1 -window .top.c.$name]
374 set MV(server_objects.$name.id) $id
375 .top.c.$name configure -command "ObjectSubmit $id"
376 set MV(server_objects.$id.name) $name
377 set MV(server_objects.$name.image) "NOT_IMAGE_COMPATABLE"
378 set MV(server_objects.$name.image2) "NOT_IMAGE_COMPATABLE"
379 set MV(server_objects.$name.type) "SUBMIT"
380 set MV(server_objects.$name.text) $text
381
382 if $duration {
383 after $duration "KillServerObject $id"
384 } else {
385 update idletasks
386 }
387 }
388
389 proc DrawLink {name x1 y1 x2 y2 duration url} {
390 global MV
391
392 if {[TestNum $x1] || [TestNum $y1] || [TestNum $x2] || [TestNum $y2] || [TestNum $duration]} {
393 DebugIt "DrawLink: Invalid Parameters" other
394 return
395 }
396
397 if {[lsearch -exact $MV(server_links) $name] != -1} {
398 KillServerLink $MV(server_links.$name.id)
399 }
400 lappend MV(server_links) $name
401
402 set id [incr MV(current_link_id)]
403 set MV(server_links.$name.x1) $x1
404 set MV(server_links.$name.y1) $y1
405 set MV(server_links.$name.x2) $x2
406 set MV(server_links.$name.y2) $y2
407 set MV(server_links.$name.url) $url
408 set MV(server_links.$id.name) $name
409 set MV(server_links.$name.id) $id
410 if $duration {
411 after $duration "KillServerLink $id"
412 } else {
413 update idletasks
414 }
415 }
416
417 # TELL NAME x1 y1 x2 y2 duration
418 proc DrawTell {name x1 y1 x2 y2 duration} {
419 global MV
420
421 if {[TestNum $x1] || [TestNum $y1] || [TestNum $x2] || [TestNum $y2] || [TestNum $duration]} {
422 DebugIt "DrawTell: Invalid Parameters" other
423 return
424 }
425
426 if {[lsearch -exact $MV(server_tells) $name] != -1} {
427 KillServerTell $MV(server_tells.$name.id)
428 }
429 lappend MV(server_tells) $name
430
431 set id [incr MV(current_tell_id)]
432 set MV(server_tells.$name.x1) $x1
433 set MV(server_tells.$name.y1) $y1
434 set MV(server_tells.$name.x2) $x2
435 set MV(server_tells.$name.y2) $y2
436 set MV(server_tells.$name.url) "NOT URL COMPATABLE"
437 set MV(server_tells.$id.name) $name
438 set MV(server_tells.$name.id) $id
439 if $duration {
440 after $duration "KillServerTell $id"
441 } else {
442 update idletasks
443 }
444 }
445
446 proc DrawExit {name x1 y1 x2 y2 duration host port} {
447 global MV
448
449 if {[TestNum $x1] || [TestNum $y1] || [TestNum $x2] || [TestNum $y2] || [TestNum $duration] || [TestNum $port]} {
450 DebugIt "DrawExit: Invalid Parameters" other
451 return
452 }
453
454 if {[lsearch -exact $MV(server_exits) $name] != -1} {
455 KillServerExit $MV(server_exits.$name.id)
456 }
457 lappend MV(server_exits) $name
458
459 set id [incr MV(current_exits_id)]
460 set MV(server_exits.$name.x1) $x1
461 set MV(server_exits.$name.y1) $y1
462 set MV(server_exits.$name.x2) $x2
463 set MV(server_exits.$name.y2) $y2
464 set MV(server_exits.$name.host) $host
465 set MV(server_exits.$name.port) $port
466 set MV(server_exits.$id.name) $name
467 set MV(server_exits.$name.id) $id
468 if $duration {
469 after $duration "KillServerExit $id"
470 } else {
471 update idletasks
472 }
473 }
474
475 proc KillServerExit {id} {
476 global MV
477
478 if {[catch {set MV(server_exits.$id.name)}]} {return}
479
480 set idx [lsearch -exact $MV(server_exits) $MV(server_exits.$id.name)]
481 set name [lindex $MV(server_exits) $idx]
482 set MV(server_exits) [lreplace $MV(server_exits) $idx $idx]
483 #
484 # Clean up the memory this object uses.
485 #
486 catch {unset MV(server_exits.$id.name)}
487 catch {unset MV(server_exits.$name.host)}
488 catch {unset MV(server_exits.$name.id)}
489 catch {unset MV(server_exits.$name.port)}
490 catch {unset MV(server_exits.$name.x1)}
491 catch {unset MV(server_exits.$name.x2)}
492 catch {unset MV(server_exits.$name.y1)}
493 catch {unset MV(server_exits.$name.y2)}
494 }
495
496 proc KillServerLink {id} {
497 global MV
498
499 if {[catch {set MV(server_links.$id.name)}]} {return}
500
501 set name $MV(server_links.$id.name)
502 set idx [lsearch -exact $MV(server_links) $MV(server_links.$id.name)]
503 set MV(server_links) [lreplace $MV(server_links) $idx $idx]
504 #
505 # Clean up the memory this object used.
506 #
507 catch {unset MV(server_links.$id.name)}
508 catch {unset MV(server_links.$name.id)}
509 catch {unset MV(server_links.$name.x1)}
510 catch {unset MV(server_links.$name.y1)}
511 catch {unset MV(server_links.$name.x2)}
512 catch {unset MV(server_links.$name.y2)}
513 catch {unset MV(server_links.$name.url)}
514 }
515
516 proc KillServerTell {id} {
517 global MV
518
519 if {[catch {set MV(server_tells.$id.name)}]} {return}
520
521 set idx [lsearch -exact $MV(server_tells) $MV(server_tells.$id.name)]
522 set name [lindex $MV(server_tells) $idx]
523 set MV(server_tells) [lreplace $MV(server_tells) $idx $idx]
524 #
525 # Clean up memory this object used.
526 #
527 catch {unset MV(server_tells.$id.name)}
528 catch {unset MV(server_tells.$name.id)}
529 catch {unset MV(server_tells.$name.x1)}
530 catch {unset MV(server_tells.$name.y1)}
531 catch {unset MV(server_tells.$name.x2)}
532 catch {unset MV(server_tells.$name.y2)}
533 catch {unset MV(server_tells.$name.url)}
534 }
535
536 proc KillServerObject {id} {
537 global MV
538
539 if {[catch {set MV(server_objects.$id.name)}]} {return}
540
541 if {[lsearch $MV(server_objects) $MV(server_objects.$id.name)] == -1} {return}
542
543 if {[string compare $MV(server_objects.$MV(server_objects.$id.name).image) "NOT_IMAGE_COMPATABLE"]} {
544 image delete server_object_$MV(server_objects.$id.name)
545 }
546 if {[string compare $MV(server_objects.$MV(server_objects.$id.name).image2) "NOT_IMAGE_COMPATABLE"]} {
547 image delete server_object_$MV(server_objects.$id.name)
548 }
549 set idx [lsearch -exact $MV(server_objects) $MV(server_objects.$id.name)]
550 set name [lindex $MV(server_objects) $idx]
551 set MV(server_objects) [lreplace $MV(server_objects) $idx $idx]
552 .top.c delete $id
553 switch $MV(server_objects.$MV(server_objects.$id.name).type) {
554 "ENTRY" {
555 destroy .top.c.$MV(server_objects.$id.name)
556 }
557 "SUBMIT" {
558 destroy .top.c.$MV(server_objects.$id.name)
559 }
560 }
561 catch {unset MV(server_objects.$id.name)}
562 catch {unset MV(server_objects.$name.id)}
563 catch {unset MV(server_objects.$name.image)}
564 catch {unset MV(server_objects.$name.image2)}
565 catch {unset MV(server_objects.$name.type)}
566 catch {unset MV(server_objects.$name.text)}
567 }
568
569 proc MouseOverEvent {onoff id} {
570 global MV
571
572 if $onoff {
573 catch {image create photo server_object_$MV(server_objects.$id.name) -file "$MV(objects)/$MV(server_objects.$MV(server_objects.$id.name).image2)"} err
574 } else {
575 catch {image create photo server_object_$MV(server_objects.$id.name) -file "$MV(objects)/$MV(server_objects.$MV(server_objects.$id.name).image)"}
576 }
577 }
578
579 proc ObjectSubmit {id} {
580 global MV
581 foreach object $MV(server_objects) {
582 # Performance Enhancement DRG
583 if {![string compare $MV(server_objects.$object.type) "ENTRY"]} {
584 SendToServer "ENTRY $object $MV(server_objects.$object.text)"
585 }
586 }
587 SendToServer "SUBMIT $MV(server_objects.$id.name)"
588 }
589
590 #
591 # This function will move an object which is already existing.
592 #
593 # MOVE_OBJ NAME x_offset y_offset type speed
594 #
595 # Moveable objects include....
596 #
597 # BOX TEXT WTEXT
598 # IMAGE MOUSEOVER ENTRY
599 # SUBMIT
600 #
601 # Type is movement type Supported types are...
602 # 0 Instant move.
603 #
604 # Speed will be used later as other move types are added.
605 # For non speed types (like type 0) use a speed of 0
606 #
607 proc MoveObject {name x y type speed} {
608 global MV
609
610 if {[TestNum $x] || [TestNum $y] || [TestPosNum $type] || [TestPosNum $speed]} {
611 DebugIt "MoveObject: Invalid Parameters" other
612 return
613 }
614 if {[lsearch -exact $MV(server_objects) $name] == -1} {
615 DebugIt "MoveObject: Object $name does not exist in MV(server_objects)." other
616 return;
617 }
618
619 .top.c move $MV(server_objects.$name.id) $x $y
620 update idletasks
621 }