"SfR Fresh" - the SfR Freeware/Shareware Archive 
Member "OpenVerse/plugins/Query/PlugInit.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 # Query Users OpenVerse Plugin
2 #
3 # Copyright (C) 1999 David Gale <cruise@openverse.org>
4 # For more information visit http://OpenVerse.org/
5 #
6 #
7 # This program is free software; you can redistribute it and/or
8 # modify it under the terms of the GNU General Public License
9 # as published by the Free Software Foundation; either version 2
10 # of the License, or (at your option) any later version.
11 #
12 # This program is distributed in the hope that it will be useful,
13 # but WITHOUT ANY WARRANTY; without even the implied warranty of
14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 # GNU General Public License for more details.
16 #
17 # You should have received a copy of the GNU General Public License
18 # along with this program; if not, write to the Free Software
19 # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
20 # USA.
21 # -----------------------------------------------------------------------
22 # This plugin will allow users to click on the names of other users
23 # and have them in "Query" mode. It makes use of several available traps
24 # within Metaverse.
25 #
26 # Written by Cruise <cruise@drunkenbastards.org>
27 #
28 # This was to be included as a feature but I decided to make it a seperate
29 # plugin to being working on plugins in general. This can be used as an
30 # example of how to make a plugin, there will be others as I make more
31 # plugin support available.
32 #
33 # SEE THE Plugins.tcl FILE FOR MORE INFORMATION ON CREATING PLUGINS!
34 #
35 # It is a good idea to put all of your variables into one container.
36 # This will ensure that "your" variables do not conflict with variables
37 # from another plugin. You should have one global variable which is an
38 # array of all the variables which your plugin will need. You should name
39 # this variable the same as your directory name.
40
41 global Query
42
43 set Query(users) {}
44 set Query(OnOff) 0
45
46 #
47 # You must register your plugin with all the traps you intend to use.
48 # The arguments for the register command are....
49 #
50 # The name of your plugin's Directory (Case Counts)
51 # Trap Name (see lib/Global.tcl for a list)
52 # Your function to call when this trap is executed.
53 #
54 # NOTE!! Your function must return 1 or 0 indicating to the parent
55 # function that it should continue(1) processing normally or that it
56 # should stop(0) normal processing.
57 #
58 RegisterPlugin Query MoveTo.Pre Query_CheckClick
59 RegisterPlugin Query NewPerson Query_NewPerson
60 RegisterPlugin Query PersonLeft Query_PersonLeft
61 RegisterPlugin Query ChangeAvatar Query_ChangeAvatar
62 RegisterPlugin Query ChangeUserAvatar Query_ChangeUserAvatar
63 RegisterPlugin Query SendText Query_SendText
64 RegisterPlugin Query Disconnect Query_Disconnect
65 RegisterPlugin Query DoNames Query_DoNames
66 RegisterPlugin Query ShowName Query_ShowName
67 RegisterPlugin Qyery Debug_memory Query_Debug_memory
68
69 proc Query_NewPerson {who x y image xx yy size bx by} {
70 global Query
71 set Query($who) 0
72 return 1
73 }
74
75 proc Query_PersonLeft {who} {
76 global Query MV
77
78 set Query($who) 0
79 set idx [lsearch -exact $Query(users) $who]
80 set Query(users) [lreplace $Query(users) $idx $idx]
81 if ![llength $Query(users)] {
82 if $MV(names) {.top.c itemconfigure $MV($MV(nick).nameplate) -fill "black"}
83 set Query(OnOff) 0
84 }
85 #
86 # Clean up the memory this user was using.
87 #
88 catch {unset Query($who)}
89
90 return 1
91 }
92
93 proc Query_CheckClick {x y} {
94 global Query MV
95
96 #
97 # If we are not displaying names, Don't bother checking.
98 # This plugin requires names be displayed.
99 # They can be shut off after you select a user for query.
100 #
101 if !$MV(names) {return 1}
102
103 #
104 # Check and see if the user is within the space of a name
105 # tag on the screen. If they are, don't move.. query the
106 # user and color their nametag blue (and your's!)
107 # No, You cannot query yourself.
108 # Clicking yourself will cancel all queries. (KaosBeetl 11/27/2000)
109 #
110 if {$x >= $MV($MV(nick).name_tl_x) &&
111 $x <= $MV($MV(nick).name_br_x) &&
112 $y >= $MV($MV(nick).name_tl_y) &&
113 $y <= $MV($MV(nick).name_br_y)} {
114 if {$Query(OnOff) == 0} {
115 return 0
116 }
117
118 while {[llength $Query(users)]} {
119 set who [lindex $Query(users) 0]
120 if $MV(names) {.top.c itemconfigure $MV($who.nameplate) -fill "black"}
121 set Query($who) 0
122 set Query(users) [lreplace $Query(users) 0 0]
123 }
124
125 if $MV(names) {.top.c itemconfigure $MV($MV(nick).nameplate) -fill "black"}
126 set Query(OnOff) 0
127
128 DoNames
129 return 0
130 }
131
132 foreach who $MV(people) {
133 if {$x >= $MV($who.name_tl_x) &&
134 $x <= $MV($who.name_br_x) &&
135 $y >= $MV($who.name_tl_y) &&
136 $y <= $MV($who.name_br_y)} {
137 if $Query($who) {
138 if $MV(names) {.top.c itemconfigure $MV($who.nameplate) -fill "black"}
139 set Query($who) 0
140 set idx [lsearch -exact $Query(users) $who]
141 set Query(users) [lreplace $Query(users) $idx $idx]
142 if ![llength $Query(users)] {
143 if $MV(names) {.top.c itemconfigure $MV($MV(nick).nameplate) -fill "black"}
144 set Query(OnOff) 0
145 }
146 } else {
147 if $MV(names) {.top.c itemconfigure $MV($who.nameplate) -fill "blue"}
148 if $MV(names) {.top.c itemconfigure $MV($MV(nick).nameplate) -fill "blue"}
149 lappend Query(users) "$who"
150 set Query($who) 1
151 if !$Query(OnOff) {
152 set Query(OnOff) 1
153 }
154 }
155 DoNames
156 return 0
157 }
158 }
159 return 1
160 }
161
162 proc Query_ChangeAvatar {notused} {
163 global Query MV
164
165 if $Query(OnOff) {
166 if $MV(names) {.top.c itemconfigure $MV($MV(nick).nameplate) -fill "blue"}
167 }
168 return 1
169 }
170
171 proc Query_ChangeUserAvatar {who what x y size bx by} {
172 global Query MV
173
174 if $Query($who) {
175 if $MV(names) {.top.c itemconfigure $MV($who.nameplate) -fill "blue"}
176 }
177 return 1
178 }
179
180 proc Query_ColorLocal {x y} {
181 global Query MV
182
183 if $Query(OnOff) {
184 if $MV(names) {.top.c itemconfigure $MV($MV(nick).nameplate) -fill "blue"}
185 }
186 return 1
187 }
188
189 proc Query_ColorRemote {who x y speed} {
190 global Query MV
191
192 if $Query($who) {
193 if $MV(names) {.top.c itemconfigure $MV($who.nameplate) -fill "blue"}
194 }
195 return 1
196 }
197
198 proc Query_ShowName {who} {
199 global Query MV
200
201 if {![string compare $MV(nick) $who]} {
202 Query_ColorLocal -1 -1
203 } else {
204 Query_ColorRemote $who -1 -1 -1
205 }
206
207 return 1
208 }
209
210 #
211 # Bug FIX - CRUISE - 11/02/2001 - Will now put <!> around YOUR name when sending private messages.
212 #
213 proc Query_SendText {stuff} {
214 global Query MV
215
216 if !$Query(OnOff) {return 1}
217 if {[string range $stuff 0 0] == "/"} {return 1}
218
219 ProcChat $MV(nick) "$stuff" 0 2 $MV(colors.privmsg.baloon)
220 foreach who $Query(users) {
221 if $MV(rot13) {set stuff [Rot13 $stuff]}
222 SendToServer "PRIVMSG $who $stuff"
223 }
224 return 0
225 }
226
227 proc Query_Disconnect {} {
228 global Query MV
229
230 set Query(users) {}
231 set Query(OnOff) 0
232 if $MV(names) {.top.c itemconfigure $MV($MV(nick).nameplate) -fill "black"}
233 return 1
234 }
235
236 proc Query_DoNames {win who idx} {
237 global Query
238
239 if $Query($who) {
240 $win add command -label "UnQuery" -command "Query_ByNumber $idx"
241 } else {
242 $win add command -label "Query" -command "Query_ByNumber $idx"
243 }
244 return 1
245 }
246
247 proc Query_ByNumber {idx} {
248 global Query MV
249
250 if !$Query($MV(whois.$idx)) {
251 if $MV(names) {
252 .top.c itemconfigure $MV($MV(whois.$idx).nameplate) -fill "blue"
253 if !$Query(OnOff) {
254 .top.c itemconfigure $MV($MV(nick).nameplate) -fill "blue"
255 }
256 }
257 lappend Query(users) "$MV(whois.$idx)"
258 set Query($MV(whois.$idx)) 1
259 set Query(OnOff) 1
260 } else {
261 if $MV(names) {.top.c itemconfigure $MV($MV(whois.$idx).nameplate) -fill "black"}
262 set Query($MV(whois.$idx)) 0
263 set id [lsearch -exact $Query(users) $MV(whois.$idx)]
264 set Query(users) [lreplace $Query(users) $id $id]
265 if ![llength $Query(users)] {
266 if $MV(names) {.top.c itemconfigure $MV($MV(nick).nameplate) -fill "black"}
267 set Query(OnOff) 0
268 }
269 }
270 DoNames
271 return 1
272 }
273
274 proc Query_Debug_memory {outfile} {
275 global Query
276
277
278 set arrays [list Query]
279 #
280 # debug all the arrays.
281 #
282 foreach ar $arrays {
283 puts $outfile "------------------------------------------------------------------------------"
284 puts $outfile " Query - THIS IS THE $ar\() ARRAY"
285 puts $outfile "------------------------------------------------------------------------------"
286 set toggle 0
287 set values {}
288 set keys {}
289 foreach var [array get $ar] {
290 if {!$toggle} {
291 lappend keys $var
292 set toggle 1
293 } else {
294 set toggle 0
295 }
296 }
297 set keys [lsort $keys]
298 foreach key $keys {
299 puts $outfile [format "%-39.39s %-39.39s" $key [set $ar\($key)]]
300 }
301 }
302 return 1
303 }
304
305 if $MV(debug) {puts "Query Plugin Initalized!"}
306