1 | ############################################################################## |
---|
2 | # |
---|
3 | # This library is free software; you can redistribute it and/or |
---|
4 | # modify it under the terms of the GNU Library General Public |
---|
5 | # License as published by the Free Software Foundation; either |
---|
6 | # version 2 of the License, or (at your option) any later version. |
---|
7 | # |
---|
8 | # This library is distributed in the hope that it will be useful, |
---|
9 | # but WITHOUT ANY WARRANTY; without even the implied warranty of |
---|
10 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
---|
11 | # Library General Public License for more details. |
---|
12 | # |
---|
13 | # You should have received a copy of the GNU Library General Public |
---|
14 | # License along with this library; if not, write to the |
---|
15 | # Free Software Foundation, Inc., 59 Temple Place - Suite 330, |
---|
16 | # Boston, MA 02111-1307, USA. |
---|
17 | # |
---|
18 | # Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/ |
---|
19 | # |
---|
20 | ############################################################################## |
---|
21 | |
---|
22 | package Net::XMPP::Protocol; |
---|
23 | |
---|
24 | =head1 NAME |
---|
25 | |
---|
26 | Net::XMPP::Protocol - XMPP Protocol Module |
---|
27 | |
---|
28 | =head1 SYNOPSIS |
---|
29 | |
---|
30 | Net::XMPP::Protocol is a module that provides a developer easy |
---|
31 | access to the XMPP Instant Messaging protocol. It provides high |
---|
32 | level functions to the Net::XMPP Client object. These functions are |
---|
33 | inherited by that modules. |
---|
34 | |
---|
35 | =head1 DESCRIPTION |
---|
36 | |
---|
37 | Protocol.pm seeks to provide enough high level APIs and automation of |
---|
38 | the low level APIs that writing a XMPP Client in Perl is trivial. For |
---|
39 | those that wish to work with the low level you can do that too, but |
---|
40 | those functions are covered in the documentation for each module. |
---|
41 | |
---|
42 | Net::XMPP::Protocol provides functions to login, send and receive |
---|
43 | messages, set personal information, create a new user account, manage |
---|
44 | the roster, and disconnect. You can use all or none of the functions, |
---|
45 | there is no requirement. |
---|
46 | |
---|
47 | For more information on how the details for how Net::XMPP is written |
---|
48 | please see the help for Net::XMPP itself. |
---|
49 | |
---|
50 | For more information on writing a Client see Net::XMPP::Client. |
---|
51 | |
---|
52 | =head2 Modes |
---|
53 | |
---|
54 | Several of the functions take a mode argument that let you specify how |
---|
55 | the function should behave: |
---|
56 | |
---|
57 | block - send the packet with an ID, and then block until an answer |
---|
58 | comes back. You can optionally specify a timeout so that |
---|
59 | you do not block forever. |
---|
60 | |
---|
61 | nonblock - send the packet with an ID, but then return that id and |
---|
62 | control to the master program. Net::XMPP is still |
---|
63 | tracking this packet, so you must use the CheckID function |
---|
64 | to tell when it comes in. (This might not be very |
---|
65 | useful...) |
---|
66 | |
---|
67 | passthru - send the packet with an ID, but do NOT register it with |
---|
68 | Net::XMPP, then return the ID. This is useful when |
---|
69 | combined with the XPath function because you can register |
---|
70 | a one shot function tied to the id you get back. |
---|
71 | |
---|
72 | |
---|
73 | =head2 Basic Functions |
---|
74 | |
---|
75 | use Net::XMPP qw( Client ); |
---|
76 | $Con = Net::XMPP::Client->new(); # From |
---|
77 | $status = $Con->Connect(hostname=>"jabber.org"); # Net::XMPP::Client |
---|
78 | |
---|
79 | $Con->SetCallBacks(send=>\&sendCallBack, |
---|
80 | receive=>\&receiveCallBack, |
---|
81 | message=>\&messageCallBack, |
---|
82 | iq=>\&handleTheIQTag); |
---|
83 | |
---|
84 | $Con->SetMessageCallBacks(normal=>\&messageNormalCB, |
---|
85 | chat=>\&messageChatCB); |
---|
86 | |
---|
87 | $Con->SetPresenceCallBacks(available=>\&presenceAvailableCB, |
---|
88 | unavailable=>\&presenceUnavailableCB); |
---|
89 | |
---|
90 | $Con->SetIQCallBacks("custom-namespace"=> |
---|
91 | { |
---|
92 | get=>\&iqCustomGetCB, |
---|
93 | set=>\&iqCustomSetCB, |
---|
94 | result=>\&iqCustomResultCB, |
---|
95 | }, |
---|
96 | etc... |
---|
97 | ); |
---|
98 | |
---|
99 | $Con->SetXPathCallBacks("/message[@type='chat']"=>&messageChatCB, |
---|
100 | "/message[@type='chat']"=>&otherMessageChatCB, |
---|
101 | ... |
---|
102 | ); |
---|
103 | |
---|
104 | $Con->RemoveXPathCallBacks("/message[@type='chat']"=>&otherMessageChatCB); |
---|
105 | |
---|
106 | $error = $Con->GetErrorCode(); |
---|
107 | $Con->SetErrorCode("Timeout limit reached"); |
---|
108 | |
---|
109 | $status = $Con->Process(); |
---|
110 | $status = $Con->Process(5); |
---|
111 | |
---|
112 | $Con->Send($object); |
---|
113 | $Con->Send("<tag>XML</tag>"); |
---|
114 | |
---|
115 | $Con->Send($object,1); |
---|
116 | $Con->Send("<tag>XML</tag>",1); |
---|
117 | |
---|
118 | $Con->Disconnect(); |
---|
119 | |
---|
120 | =head2 ID Functions |
---|
121 | |
---|
122 | $id = $Con->SendWithID($sendObj); |
---|
123 | $id = $Con->SendWithID("<tag>XML</tag>"); |
---|
124 | $receiveObj = $Con->SendAndReceiveWithID($sendObj); |
---|
125 | $receiveObj = $Con->SendAndReceiveWithID($sendObj, |
---|
126 | 10); |
---|
127 | $receiveObj = $Con->SendAndReceiveWithID("<tag>XML</tag>"); |
---|
128 | $receiveObj = $Con->SendAndReceiveWithID("<tag>XML</tag>", |
---|
129 | 5); |
---|
130 | $yesno = $Con->ReceivedID($id); |
---|
131 | $receiveObj = $Con->GetID($id); |
---|
132 | $receiveObj = $Con->WaitForID($id); |
---|
133 | $receiveObj = $Con->WaitForID($id, |
---|
134 | 20); |
---|
135 | |
---|
136 | =head2 Namespace Functions |
---|
137 | |
---|
138 | $Con->AddNamespace(ns=>"foo:bar", |
---|
139 | tag=>"myfoo", |
---|
140 | xpath=>{Foo=>{ path=> "foo/text()" }, |
---|
141 | Bar=>{ path=> "bar/text()" }, |
---|
142 | FooBar=>{ type=> "master" }, |
---|
143 | } |
---|
144 | ); |
---|
145 | |
---|
146 | =head2 Message Functions |
---|
147 | |
---|
148 | $Con->MessageSend(to=>"bob@jabber.org", |
---|
149 | subject=>"Lunch", |
---|
150 | body=>"Let's go grab some...\n", |
---|
151 | thread=>"ABC123", |
---|
152 | priority=>10); |
---|
153 | |
---|
154 | =head2 Presence Functions |
---|
155 | |
---|
156 | $Con->PresenceSend(); |
---|
157 | $Con->PresenceSend(type=>"unavailable"); |
---|
158 | $Con->PresenceSend(show=>"away"); |
---|
159 | $Con->PresenceSend(signature=>...signature...); |
---|
160 | |
---|
161 | =head2 Subscription Functions |
---|
162 | |
---|
163 | $Con->Subscription(type=>"subscribe", |
---|
164 | to=>"bob@jabber.org"); |
---|
165 | |
---|
166 | $Con->Subscription(type=>"unsubscribe", |
---|
167 | to=>"bob@jabber.org"); |
---|
168 | |
---|
169 | $Con->Subscription(type=>"subscribed", |
---|
170 | to=>"bob@jabber.org"); |
---|
171 | |
---|
172 | $Con->Subscription(type=>"unsubscribed", |
---|
173 | to=>"bob@jabber.org"); |
---|
174 | |
---|
175 | =head2 Presence DB Functions |
---|
176 | |
---|
177 | $Con->PresenceDB(); |
---|
178 | |
---|
179 | $Con->PresenceDBParse(Net::XMPP::Presence); |
---|
180 | |
---|
181 | $Con->PresenceDBDelete("bob\@jabber.org"); |
---|
182 | $Con->PresenceDBDelete(Net::XMPP::JID); |
---|
183 | |
---|
184 | $Con->PresenceDBClear(); |
---|
185 | |
---|
186 | $presence = $Con->PresenceDBQuery("bob\@jabber.org"); |
---|
187 | $presence = $Con->PresenceDBQuery(Net::XMPP::JID); |
---|
188 | |
---|
189 | @resources = $Con->PresenceDBResources("bob\@jabber.org"); |
---|
190 | @resources = $Con->PresenceDBResources(Net::XMPP::JID); |
---|
191 | |
---|
192 | =head2 IQ Functions |
---|
193 | |
---|
194 | =head2 Auth Functions |
---|
195 | |
---|
196 | @result = $Con->AuthSend(); |
---|
197 | @result = $Con->AuthSend(username=>"bob", |
---|
198 | password=>"bobrulez", |
---|
199 | resource=>"Bob"); |
---|
200 | |
---|
201 | =head2 Register Functions |
---|
202 | |
---|
203 | %hash = $Con->RegisterRequest(); |
---|
204 | %hash = $Con->RegisterRequest(to=>"transport.jabber.org"); |
---|
205 | %hash = $Con->RegisterRequest(to=>"transport.jabber.org", |
---|
206 | timeout=>10); |
---|
207 | |
---|
208 | @result = $Con->RegisterSend(to=>"somewhere", |
---|
209 | username=>"newuser", |
---|
210 | resource=>"New User", |
---|
211 | password=>"imanewbie", |
---|
212 | email=>"newguy@new.com", |
---|
213 | key=>"some key"); |
---|
214 | |
---|
215 | =head2 Roster Functions |
---|
216 | |
---|
217 | $Roster = $Con->Roster(); |
---|
218 | |
---|
219 | %roster = $Con->RosterParse($iq); |
---|
220 | %roster = $Con->RosterGet(); |
---|
221 | $Con->RosterRequest(); |
---|
222 | $Con->RosterAdd(jid=>"bob\@jabber.org", |
---|
223 | name=>"Bob"); |
---|
224 | $Con->RosterRemove(jid=>"bob@jabber.org"); |
---|
225 | |
---|
226 | =head2 Roster DB Functions |
---|
227 | |
---|
228 | $Con->RosterDB(); |
---|
229 | |
---|
230 | $Con->RosterDBParse(Net::XMPP::IQ); |
---|
231 | |
---|
232 | $Con->RosterDBAdd("bob\@jabber.org", |
---|
233 | name=>"Bob", |
---|
234 | groups=>["foo"] |
---|
235 | ); |
---|
236 | |
---|
237 | $Con->RosterDBRemove("bob\@jabber.org"); |
---|
238 | $Con->RosterDBRemove(Net::XMPP::JID); |
---|
239 | |
---|
240 | $Con->RosterDBClear(); |
---|
241 | |
---|
242 | if ($Con->RosterDBExists("bob\@jabber.org")) { ... |
---|
243 | if ($Con->RosterDBExists(Net::XMPP::JID)) { ... |
---|
244 | |
---|
245 | @jids = $Con->RosterDBJIDs(); |
---|
246 | |
---|
247 | if ($Con->RosterDBGroupExists("foo")) { ... |
---|
248 | |
---|
249 | @groups = $Con->RosterDBGroups(); |
---|
250 | |
---|
251 | @jids = $Con->RosterDBGroupJIDs("foo"); |
---|
252 | |
---|
253 | @jids = $Con->RosterDBNonGroupJIDs(); |
---|
254 | |
---|
255 | %hash = $Con->RosterDBQuery("bob\@jabber.org"); |
---|
256 | %hash = $Con->RosterDBQuery(Net::XMPP::JID); |
---|
257 | |
---|
258 | $value = $Con->RosterDBQuery("bob\@jabber.org","name"); |
---|
259 | $value = $Con->RosterDBQuery(Net::XMPP::JID,"groups"); |
---|
260 | |
---|
261 | |
---|
262 | =head1 METHODS |
---|
263 | |
---|
264 | =head2 Basic Functions |
---|
265 | |
---|
266 | GetErrorCode() - returns a string that will hopefully contain some |
---|
267 | useful information about why a function returned |
---|
268 | an undef to you. |
---|
269 | |
---|
270 | SetErrorCode(string) - set a useful error message before you return |
---|
271 | an undef to the caller. |
---|
272 | |
---|
273 | SetCallBacks(message=>function, - sets the callback functions for |
---|
274 | presence=>function, the top level tags listed. The |
---|
275 | iq=>function, available tags to look for are |
---|
276 | send=>function, <message/>, <presence/>, and |
---|
277 | receive=>function, <iq/>. If a packet is received |
---|
278 | update=>function) with an ID which is found in the |
---|
279 | registerd ID list (see RegisterID |
---|
280 | below) then it is not sent to |
---|
281 | these functions, instead it |
---|
282 | is inserted into a LIST and can |
---|
283 | be retrieved by some functions |
---|
284 | we will mention later. |
---|
285 | |
---|
286 | send and receive are used to |
---|
287 | log what XML is sent and received. |
---|
288 | update is used as way to update |
---|
289 | your program while waiting for |
---|
290 | a packet with an ID to be |
---|
291 | returned (useful for GUI apps). |
---|
292 | |
---|
293 | A major change that came with |
---|
294 | the last release is that the |
---|
295 | session id is passed to the |
---|
296 | callback as the first argument. |
---|
297 | This was done to facilitate |
---|
298 | the Server module. |
---|
299 | |
---|
300 | The next argument depends on |
---|
301 | which callback you are talking |
---|
302 | about. message, presence, and iq |
---|
303 | all get passed in Net::XMPP |
---|
304 | objects that match those types. |
---|
305 | send and receive get passed in |
---|
306 | strings. update gets passed |
---|
307 | nothing, not even the session id. |
---|
308 | |
---|
309 | If you set the function to undef, |
---|
310 | then the callback is removed from |
---|
311 | the list. |
---|
312 | |
---|
313 | SetPresenceCallBacks(type=>function - sets the callback functions for |
---|
314 | etc...) the specified presence type. |
---|
315 | The function takes types as the |
---|
316 | main key, and lets you specify |
---|
317 | a function for each type of |
---|
318 | packet you can get. |
---|
319 | "available" |
---|
320 | "unavailable" |
---|
321 | "subscribe" |
---|
322 | "unsubscribe" |
---|
323 | "subscribed" |
---|
324 | "unsubscribed" |
---|
325 | "probe" |
---|
326 | "error" |
---|
327 | When it gets a <presence/> |
---|
328 | packet it checks the type='' |
---|
329 | for a defined callback. If |
---|
330 | there is one then it calls the |
---|
331 | function with two arguments: |
---|
332 | the session ID, and the |
---|
333 | Net::XMPP::Presence object. |
---|
334 | |
---|
335 | If you set the function to |
---|
336 | undef, then the callback is |
---|
337 | removed from the list. |
---|
338 | |
---|
339 | NOTE: If you use this, which is a cleaner method, |
---|
340 | then you must *NOT* specify a callback for |
---|
341 | presence in the SetCallBacks function. |
---|
342 | |
---|
343 | Net::XMPP defines a few default |
---|
344 | callbacks for various types: |
---|
345 | |
---|
346 | "subscribe" - |
---|
347 | replies with subscribed |
---|
348 | |
---|
349 | "unsubscribe" - |
---|
350 | replies with unsubscribed |
---|
351 | |
---|
352 | "subscribed" - |
---|
353 | replies with subscribed |
---|
354 | |
---|
355 | "unsubscribed" - |
---|
356 | replies with unsubscribed |
---|
357 | |
---|
358 | |
---|
359 | SetMessageCallBacks(type=>function, - sets the callback functions for |
---|
360 | etc...) the specified message type. The |
---|
361 | function takes types as the |
---|
362 | main key, and lets you specify |
---|
363 | a function for each type of |
---|
364 | packet you can get. |
---|
365 | "normal" |
---|
366 | "chat" |
---|
367 | "groupchat" |
---|
368 | "headline" |
---|
369 | "error" |
---|
370 | When it gets a <message/> packet |
---|
371 | it checks the type='' for a |
---|
372 | defined callback. If there is |
---|
373 | one then it calls the function |
---|
374 | with two arguments: |
---|
375 | the session ID, and the |
---|
376 | Net::XMPP::Message object. |
---|
377 | |
---|
378 | If you set the function to |
---|
379 | undef, then the callback is |
---|
380 | removed from the list. |
---|
381 | |
---|
382 | NOTE: If you use this, which is a cleaner method, |
---|
383 | then you must *NOT* specify a callback for |
---|
384 | message in the SetCallBacks function. |
---|
385 | |
---|
386 | |
---|
387 | SetIQCallBacks(namespace=>{ - sets the callback functions for |
---|
388 | get=>function, the specified namespace. The |
---|
389 | set=>function, function takes namespaces as the |
---|
390 | result=>function main key, and lets you specify a |
---|
391 | }, function for each type of packet |
---|
392 | etc...) you can get. |
---|
393 | "get" |
---|
394 | "set" |
---|
395 | "result" |
---|
396 | When it gets an <iq/> packet it |
---|
397 | checks the type='' and the |
---|
398 | xmlns='' for a defined callback. |
---|
399 | If there is one then it calls |
---|
400 | the function with two arguments: |
---|
401 | the session ID, and the |
---|
402 | Net::XMPP::xxxx object. |
---|
403 | |
---|
404 | If you set the function to undef, |
---|
405 | then the callback is removed from |
---|
406 | the list. |
---|
407 | |
---|
408 | NOTE: If you use this, which is a cleaner method, |
---|
409 | then you must *NOT* specify a callback for |
---|
410 | iq in the SetCallBacks function. |
---|
411 | |
---|
412 | SetXPathCallBacks(xpath=>function, - registers a callback function |
---|
413 | etc...) for each xpath specified. If |
---|
414 | Net::XMPP matches the xpath, |
---|
415 | then it calls the function with |
---|
416 | two arguments: |
---|
417 | the session ID, and the |
---|
418 | Net::XMPP::Message object. |
---|
419 | |
---|
420 | Xpaths are rooted at each |
---|
421 | packet: |
---|
422 | /message[@type="chat"] |
---|
423 | /iq/*[xmlns="jabber:iq:roster"][1] |
---|
424 | ... |
---|
425 | |
---|
426 | RemoveXPathCallBacks(xpath=>function, - unregisters a callback |
---|
427 | etc...) function for each xpath |
---|
428 | specified. |
---|
429 | |
---|
430 | Process(integer) - takes the timeout period as an argument. If no |
---|
431 | timeout is listed then the function blocks until |
---|
432 | a packet is received. Otherwise it waits that |
---|
433 | number of seconds and then exits so your program |
---|
434 | can continue doing useful things. NOTE: This is |
---|
435 | important for GUIs. You need to leave time to |
---|
436 | process GUI commands even if you are waiting for |
---|
437 | packets. The following are the possible return |
---|
438 | values, and what they mean: |
---|
439 | |
---|
440 | 1 - Status ok, data received. |
---|
441 | 0 - Status ok, no data received. |
---|
442 | undef - Status not ok, stop processing. |
---|
443 | |
---|
444 | IMPORTANT: You need to check the output of every |
---|
445 | Process. If you get an undef then the connection |
---|
446 | died and you should behave accordingly. |
---|
447 | |
---|
448 | Send(object, - takes either a Net::XMPP::xxxxx object or |
---|
449 | ignoreActivity) an XML string as an argument and sends it to |
---|
450 | Send(string, the server. If you set ignoreActivty to 1, |
---|
451 | ignoreActivity) then the XML::Stream module will not record |
---|
452 | this packet as couting towards user activity. |
---|
453 | =head2 ID Functions |
---|
454 | |
---|
455 | SendWithID(object) - takes either a Net::XMPP::xxxxx object or an |
---|
456 | SendWithID(string) XML string as an argument, adds the next |
---|
457 | available ID number and sends that packet to |
---|
458 | the server. Returns the ID number assigned. |
---|
459 | |
---|
460 | SendAndReceiveWithID(object, - uses SendWithID and WaitForID to |
---|
461 | timeout) provide a complete way to send and |
---|
462 | SendAndReceiveWithID(string, receive packets with IDs. Can take |
---|
463 | timeout) either a Net::XMPP::xxxxx object |
---|
464 | or an XML string. Returns the |
---|
465 | proper Net::XMPP::xxxxx object |
---|
466 | based on the type of packet |
---|
467 | received. The timeout is passed |
---|
468 | on to WaitForID, see that function |
---|
469 | for how the timeout works. |
---|
470 | |
---|
471 | ReceivedID(integer) - returns 1 if a packet has been received with |
---|
472 | specified ID, 0 otherwise. |
---|
473 | |
---|
474 | GetID(integer) - returns the proper Net::XMPP::xxxxx object based |
---|
475 | on the type of packet received with the specified |
---|
476 | ID. If the ID has been received the GetID returns |
---|
477 | 0. |
---|
478 | |
---|
479 | WaitForID(integer, - blocks until a packet with the ID is received. |
---|
480 | timeout) Returns the proper Net::XMPP::xxxxx object |
---|
481 | based on the type of packet received. If the |
---|
482 | timeout limit is reached then if the packet |
---|
483 | does come in, it will be discarded. |
---|
484 | |
---|
485 | |
---|
486 | NOTE: Only <iq/> officially support ids, so sending a <message/>, or |
---|
487 | <presence/> with an id is a risk. The server will ignore the |
---|
488 | id tag and pass it through, so both clients must support the |
---|
489 | id tag for these functions to be useful. |
---|
490 | |
---|
491 | =head2 Namespace Functions |
---|
492 | |
---|
493 | AddNamespace(ns=>string, - This function is very complex. |
---|
494 | tag=>string, It is a little too complex to |
---|
495 | xpath=>hash) discuss within the confines of |
---|
496 | this small paragraph. Please |
---|
497 | refer to the man page for |
---|
498 | Net::XMPP::Namespaces for the |
---|
499 | full documentation on this |
---|
500 | subject. |
---|
501 | |
---|
502 | =head2 Message Functions |
---|
503 | |
---|
504 | MessageSend(hash) - takes the hash and passes it to SetMessage in |
---|
505 | Net::XMPP::Message (refer there for valid |
---|
506 | settings). Then it sends the message to the |
---|
507 | server. |
---|
508 | |
---|
509 | =head2 Presence Functions |
---|
510 | |
---|
511 | PresenceSend() - no arguments will send an empty |
---|
512 | PresenceSend(hash, Presence to the server to tell it |
---|
513 | signature=>string) that you are available. If you |
---|
514 | provide a hash, then it will pass |
---|
515 | that hash to the SetPresence() |
---|
516 | function as defined in the |
---|
517 | Net::XMPP::Presence module. |
---|
518 | Optionally, you can specify a |
---|
519 | signature and a jabber:x:signed |
---|
520 | will be placed in the <presence/>. |
---|
521 | |
---|
522 | =head2 Subscription Functions |
---|
523 | |
---|
524 | Subscription(hash) - taks the hash and passes it to SetPresence in |
---|
525 | Net::XMPP::Presence (refer there for valid |
---|
526 | settings). Then it sends the subscription to |
---|
527 | server. |
---|
528 | |
---|
529 | The valid types of subscription are: |
---|
530 | |
---|
531 | subscribe - subscribe to JID's presence |
---|
532 | unsubscribe - unsubscribe from JID's presence |
---|
533 | subscribed - response to a subscribe |
---|
534 | unsubscribed - response to an unsubscribe |
---|
535 | |
---|
536 | =head2 Presence DB Functions |
---|
537 | |
---|
538 | PresenceDB() - Tell the object to initialize the callbacks to |
---|
539 | automatically populate the Presence DB. |
---|
540 | |
---|
541 | PresenceDBParse(Net::XMPP::Presence) - for every presence that you |
---|
542 | receive pass the Presence |
---|
543 | object to the DB so that |
---|
544 | it can track the resources |
---|
545 | and priorities for you. |
---|
546 | Returns either the presence |
---|
547 | passed in, if it not able |
---|
548 | to parsed for the DB, or the |
---|
549 | current presence as found by |
---|
550 | the PresenceDBQuery |
---|
551 | function. |
---|
552 | |
---|
553 | PresenceDBDelete(string|Net::XMPP::JID) - delete thes JID entry |
---|
554 | from the DB. |
---|
555 | |
---|
556 | PresenceDBClear() - delete all entries in the database. |
---|
557 | |
---|
558 | PresenceDBQuery(string|Net::XMPP::JID) - returns the NJ::Presence |
---|
559 | that was last received for |
---|
560 | the highest priority of |
---|
561 | this JID. You can pass |
---|
562 | it a string or a NJ::JID |
---|
563 | object. |
---|
564 | |
---|
565 | PresenceDBResources(string|Net::XMPP::JID) - returns an array of |
---|
566 | resources in order |
---|
567 | from highest priority |
---|
568 | to lowest. |
---|
569 | |
---|
570 | =head2 IQ Functions |
---|
571 | |
---|
572 | =head2 Auth Functions |
---|
573 | |
---|
574 | AuthSend(username=>string, - takes all of the information and |
---|
575 | password=>string, builds a Net::XMPP::IQ::Auth packet. |
---|
576 | resource=>string) It then sends that packet to the |
---|
577 | server with an ID and waits for that |
---|
578 | ID to return. Then it looks in |
---|
579 | resulting packet and determines if |
---|
580 | authentication was successful for not. |
---|
581 | The array returned from AuthSend looks |
---|
582 | like this: |
---|
583 | [ type , message ] |
---|
584 | If type is "ok" then authentication |
---|
585 | was successful, otherwise message |
---|
586 | contains a little more detail about the |
---|
587 | error. |
---|
588 | |
---|
589 | =head2 IQ::Register Functions |
---|
590 | |
---|
591 | RegisterRequest(to=>string, - send an <iq/> request to the specified |
---|
592 | timeout=>int) server/transport, if not specified it |
---|
593 | RegisterRequest() sends to the current active server. |
---|
594 | The function returns a hash that |
---|
595 | contains the required fields. Here |
---|
596 | is an example of the hash: |
---|
597 | |
---|
598 | $hash{fields} - The raw fields from |
---|
599 | the iq:register. |
---|
600 | To be used if there |
---|
601 | is no x:data in the |
---|
602 | packet. |
---|
603 | $hash{instructions} - How to fill out |
---|
604 | the form. |
---|
605 | $hash{form} - The new dynamic forms. |
---|
606 | |
---|
607 | In $hash{form}, the fields that are |
---|
608 | present are the required fields the |
---|
609 | server needs. |
---|
610 | |
---|
611 | RegisterSend(hash) - takes the contents of the hash and passes it |
---|
612 | to the SetRegister function in the module |
---|
613 | Net::XMPP::Query jabber:iq:register namespace. |
---|
614 | This function returns an array that looks like |
---|
615 | this: |
---|
616 | |
---|
617 | [ type , message ] |
---|
618 | |
---|
619 | If type is "ok" then registration was |
---|
620 | successful, otherwise message contains a |
---|
621 | little more detail about the error. |
---|
622 | |
---|
623 | =head2 Roster Functions |
---|
624 | |
---|
625 | Roster() - returns a Net::XMPP::Roster object. This will automatically |
---|
626 | intercept all of the roster and presence packets sent from |
---|
627 | the server and give you an accurate Roster. For more |
---|
628 | information please read the man page for Net::XMPP::Roster. |
---|
629 | |
---|
630 | RosterParse(IQ object) - returns a hash that contains the roster |
---|
631 | parsed into the following data structure: |
---|
632 | |
---|
633 | $roster{'bob@jabber.org'}->{name} |
---|
634 | - Name you stored in the roster |
---|
635 | |
---|
636 | $roster{'bob@jabber.org'}->{subscription} |
---|
637 | - Subscription status |
---|
638 | (to, from, both, none) |
---|
639 | |
---|
640 | $roster{'bob@jabber.org'}->{ask} |
---|
641 | - The ask status from this user |
---|
642 | (subscribe, unsubscribe) |
---|
643 | |
---|
644 | $roster{'bob@jabber.org'}->{groups} |
---|
645 | - Array of groups that |
---|
646 | bob@jabber.org is in |
---|
647 | |
---|
648 | RosterGet() - sends an empty Net::XMPP::IQ::Roster tag to the |
---|
649 | server so the server will send the Roster to the |
---|
650 | client. Returns the above hash from RosterParse. |
---|
651 | |
---|
652 | RosterRequest() - sends an empty Net::XMPP::IQ::Roster tag to the |
---|
653 | server so the server will send the Roster to the |
---|
654 | client. |
---|
655 | |
---|
656 | RosterAdd(hash) - sends a packet asking that the jid be |
---|
657 | added to the roster. The hash format |
---|
658 | is defined in the SetItem function |
---|
659 | in the Net::XMPP::Query jabber:iq:roster |
---|
660 | namespace. |
---|
661 | |
---|
662 | RosterRemove(hash) - sends a packet asking that the jid be |
---|
663 | removed from the roster. The hash |
---|
664 | format is defined in the SetItem function |
---|
665 | in the Net::XMPP::Query jabber:iq:roster |
---|
666 | namespace. |
---|
667 | |
---|
668 | =head2 Roster DB Functions |
---|
669 | |
---|
670 | RosterDB() - Tell the object to initialize the callbacks to |
---|
671 | automatically populate the Roster DB. If you do this, |
---|
672 | then make sure that you call RosterRequest() instead of |
---|
673 | RosterGet() so that the callbacks can catch it and |
---|
674 | parse it. |
---|
675 | |
---|
676 | RosterDBParse(IQ object) - If you want to manually control the |
---|
677 | database, then you can pass in all iq |
---|
678 | packets with jabber:iq:roster queries to |
---|
679 | this function. |
---|
680 | |
---|
681 | RosterDBAdd(jid,hash) - Add a new JID into the roster DB. The JID |
---|
682 | is either a string, or a Net::XMPP::JID |
---|
683 | object. The hash must be the same format as |
---|
684 | the has returned by RosterParse above, and |
---|
685 | is the actual hash, not a reference. |
---|
686 | |
---|
687 | RosterDBRemove(jid) - Remove a JID from the roster DB. The JID is |
---|
688 | either a string, or a Net::XMPP::JID object. |
---|
689 | |
---|
690 | RosterDBClear() - Remove all JIDs from the roster DB. |
---|
691 | |
---|
692 | RosterDBExists(jid) - return 1 if the JID exists in the roster DB, |
---|
693 | undef otherwise. The JID is either a string, |
---|
694 | or a Net::XMPP::JID object. |
---|
695 | |
---|
696 | RosterDBJIDs() - returns a list of Net::XMPP::JID objects that |
---|
697 | represents all of the JIDs in the DB. |
---|
698 | |
---|
699 | RosterDBGroups() - returns the complete list of roster groups in the |
---|
700 | roster. |
---|
701 | |
---|
702 | RosterDBGroupExists(group) - return 1 if the group is a group in the |
---|
703 | roster DB, undef otherwise. |
---|
704 | |
---|
705 | RosterDBGroupJIDs(group) - returns a list of Net::XMPP::JID objects |
---|
706 | that represents all of the JIDs in the |
---|
707 | specified roster group. |
---|
708 | |
---|
709 | RosterDBNonGroupJIDs() - returns a list of Net::XMPP::JID objects |
---|
710 | that represents all of the JIDs not in a |
---|
711 | roster group. |
---|
712 | |
---|
713 | RosterDBQuery(jid) - returns a hash containing the data from the |
---|
714 | roster DB for the specified JID. The JID is |
---|
715 | either a string, or a Net::XMPP::JID object. |
---|
716 | The hash format the same as in RosterParse |
---|
717 | above. |
---|
718 | |
---|
719 | RosterDBQuery(jid,key) - returns the entry from the above hash for |
---|
720 | the given key. The available keys are: |
---|
721 | name, ask, subsrcription and groups |
---|
722 | The JID is either a string, or a |
---|
723 | Net::XMPP::JID object. |
---|
724 | |
---|
725 | |
---|
726 | =head1 AUTHOR |
---|
727 | |
---|
728 | Ryan Eatmon |
---|
729 | |
---|
730 | =head1 COPYRIGHT |
---|
731 | |
---|
732 | This module is free software; you can redistribute it and/or modify |
---|
733 | it under the same terms as Perl itself. |
---|
734 | |
---|
735 | =cut |
---|
736 | |
---|
737 | use Net::XMPP::Roster; |
---|
738 | use Net::XMPP::PrivacyLists; |
---|
739 | use strict; |
---|
740 | use Carp; |
---|
741 | use vars qw( %XMLNS %NEWOBJECT $SASL_CALLBACK $TLS_CALLBACK ); |
---|
742 | |
---|
743 | ############################################################################## |
---|
744 | # Define the namespaces in an easy/constant manner. |
---|
745 | #----------------------------------------------------------------------------- |
---|
746 | # 1.0 |
---|
747 | #----------------------------------------------------------------------------- |
---|
748 | $XMLNS{'xmppstreams'} = "urn:ietf:params:xml:ns:xmpp-streams"; |
---|
749 | $XMLNS{'xmpp-bind'} = "urn:ietf:params:xml:ns:xmpp-bind"; |
---|
750 | $XMLNS{'xmpp-sasl'} = "urn:ietf:params:xml:ns:xmpp-sasl"; |
---|
751 | $XMLNS{'xmpp-session'} = "urn:ietf:params:xml:ns:xmpp-session"; |
---|
752 | $XMLNS{'xmpp-tls'} = "urn:ietf:params:xml:ns:xmpp-tls"; |
---|
753 | ############################################################################## |
---|
754 | |
---|
755 | ############################################################################## |
---|
756 | # BuildObject takes a root tag and builds the correct object. NEWOBJECT is |
---|
757 | # the table that maps tag to package. Override these, or provide new ones. |
---|
758 | #----------------------------------------------------------------------------- |
---|
759 | $NEWOBJECT{'iq'} = "Net::XMPP::IQ"; |
---|
760 | $NEWOBJECT{'message'} = "Net::XMPP::Message"; |
---|
761 | $NEWOBJECT{'presence'} = "Net::XMPP::Presence"; |
---|
762 | $NEWOBJECT{'jid'} = "Net::XMPP::JID"; |
---|
763 | ############################################################################## |
---|
764 | |
---|
765 | sub _message { shift; my $o; eval "\$o = new $NEWOBJECT{'message'}(\@_);"; return $o; } |
---|
766 | sub _presence { shift; my $o; eval "\$o = new $NEWOBJECT{'presence'}(\@_);"; return $o; } |
---|
767 | sub _iq { shift; my $o; eval "\$o = new $NEWOBJECT{'iq'}(\@_);"; return $o; } |
---|
768 | sub _jid { shift; my $o; eval "\$o = new $NEWOBJECT{'jid'}(\@_);"; return $o; } |
---|
769 | |
---|
770 | ############################################################################### |
---|
771 | #+----------------------------------------------------------------------------- |
---|
772 | #| |
---|
773 | #| Base API |
---|
774 | #| |
---|
775 | #+----------------------------------------------------------------------------- |
---|
776 | ############################################################################### |
---|
777 | |
---|
778 | ############################################################################### |
---|
779 | # |
---|
780 | # GetErrorCode - if you are returned an undef, you can call this function |
---|
781 | # and hopefully learn more information about the problem. |
---|
782 | # |
---|
783 | ############################################################################### |
---|
784 | sub GetErrorCode |
---|
785 | { |
---|
786 | my $self = shift; |
---|
787 | return ((exists($self->{ERRORCODE}) && ($self->{ERRORCODE} ne "")) ? |
---|
788 | $self->{ERRORCODE} : |
---|
789 | $! |
---|
790 | ); |
---|
791 | } |
---|
792 | |
---|
793 | |
---|
794 | ############################################################################### |
---|
795 | # |
---|
796 | # SetErrorCode - sets the error code so that the caller can find out more |
---|
797 | # information about the problem |
---|
798 | # |
---|
799 | ############################################################################### |
---|
800 | sub SetErrorCode |
---|
801 | { |
---|
802 | my $self = shift; |
---|
803 | my ($errorcode) = @_; |
---|
804 | $self->{ERRORCODE} = $errorcode; |
---|
805 | } |
---|
806 | |
---|
807 | |
---|
808 | ############################################################################### |
---|
809 | # |
---|
810 | # CallBack - Central callback function. If a packet comes back with an ID |
---|
811 | # and the tag and ID have been registered then the packet is not |
---|
812 | # returned as normal, instead it is inserted in the LIST and |
---|
813 | # stored until the user wants to fetch it. If the tag and ID |
---|
814 | # are not registered the function checks if a callback exists |
---|
815 | # for this tag, if it does then that callback is called, |
---|
816 | # otherwise the function drops the packet since it does not know |
---|
817 | # how to handle it. |
---|
818 | # |
---|
819 | ############################################################################### |
---|
820 | sub CallBack |
---|
821 | { |
---|
822 | my $self = shift; |
---|
823 | my $sid = shift; |
---|
824 | my ($object) = @_; |
---|
825 | |
---|
826 | my $tag; |
---|
827 | my $id; |
---|
828 | my $tree; |
---|
829 | |
---|
830 | if (ref($object) !~ /^Net::XMPP/) |
---|
831 | { |
---|
832 | if ($self->{DEBUG}->GetLevel() >= 1 || exists($self->{CB}->{receive})) |
---|
833 | { |
---|
834 | my $xml = $object->GetXML(); |
---|
835 | $self->{DEBUG}->Log1("CallBack: sid($sid) received($xml)"); |
---|
836 | &{$self->{CB}->{receive}}($sid,$xml) if exists($self->{CB}->{receive}); |
---|
837 | } |
---|
838 | |
---|
839 | $tag = $object->get_tag(); |
---|
840 | $id = ""; |
---|
841 | $id = $object->get_attrib("id") |
---|
842 | if defined($object->get_attrib("id")); |
---|
843 | $tree = $object; |
---|
844 | } |
---|
845 | else |
---|
846 | { |
---|
847 | $tag = $object->GetTag(); |
---|
848 | $id = $object->GetID(); |
---|
849 | $tree = $object->GetTree(); |
---|
850 | } |
---|
851 | |
---|
852 | $self->{DEBUG}->Log1("CallBack: tag($tag)"); |
---|
853 | $self->{DEBUG}->Log1("CallBack: id($id)") if ($id ne ""); |
---|
854 | |
---|
855 | my $pass = 1; |
---|
856 | $pass = 0 |
---|
857 | if (!exists($self->{CB}->{$tag}) && |
---|
858 | !exists($self->{CB}->{XPath}) && |
---|
859 | !exists($self->{CB}->{DirectXPath}) && |
---|
860 | !$self->CheckID($tag,$id) |
---|
861 | ); |
---|
862 | |
---|
863 | if ($pass) |
---|
864 | { |
---|
865 | $self->{DEBUG}->Log1("CallBack: we either want it or were waiting for it."); |
---|
866 | |
---|
867 | if (exists($self->{CB}->{DirectXPath})) |
---|
868 | { |
---|
869 | $self->{DEBUG}->Log1("CallBack: check directxpath"); |
---|
870 | |
---|
871 | my $direct_pass = 0; |
---|
872 | |
---|
873 | foreach my $xpath (keys(%{$self->{CB}->{DirectXPath}})) |
---|
874 | { |
---|
875 | $self->{DEBUG}->Log1("CallBack: check directxpath($xpath)"); |
---|
876 | if ($object->XPathCheck($xpath)) |
---|
877 | { |
---|
878 | foreach my $func (keys(%{$self->{CB}->{DirectXPath}->{$xpath}})) |
---|
879 | { |
---|
880 | $self->{DEBUG}->Log1("CallBack: goto directxpath($xpath) function($func)"); |
---|
881 | &{$self->{CB}->{DirectXPath}->{$xpath}->{$func}}($sid,$object); |
---|
882 | $direct_pass = 1; |
---|
883 | } |
---|
884 | } |
---|
885 | } |
---|
886 | |
---|
887 | return if $direct_pass; |
---|
888 | } |
---|
889 | |
---|
890 | my $NJObject; |
---|
891 | if (ref($object) !~ /^Net::XMPP/) |
---|
892 | { |
---|
893 | $NJObject = $self->BuildObject($tag,$object); |
---|
894 | } |
---|
895 | else |
---|
896 | { |
---|
897 | $NJObject = $object; |
---|
898 | } |
---|
899 | |
---|
900 | if ($NJObject == -1) |
---|
901 | { |
---|
902 | $self->{DEBUG}->Log1("CallBack: DANGER!! DANGER!! We didn't build a packet! We're all gonna die!!"); |
---|
903 | } |
---|
904 | else |
---|
905 | { |
---|
906 | if ($self->CheckID($tag,$id)) |
---|
907 | { |
---|
908 | $self->{DEBUG}->Log1("CallBack: found registry entry: tag($tag) id($id)"); |
---|
909 | $self->DeregisterID($tag,$id); |
---|
910 | if ($self->TimedOutID($id)) |
---|
911 | { |
---|
912 | $self->{DEBUG}->Log1("CallBack: dropping packet due to timeout"); |
---|
913 | $self->CleanID($id); |
---|
914 | } |
---|
915 | else |
---|
916 | { |
---|
917 | $self->{DEBUG}->Log1("CallBack: they still want it... we still got it..."); |
---|
918 | $self->GotID($id,$NJObject); |
---|
919 | } |
---|
920 | } |
---|
921 | else |
---|
922 | { |
---|
923 | $self->{DEBUG}->Log1("CallBack: no registry entry"); |
---|
924 | |
---|
925 | if (exists($self->{CB}->{XPath})) |
---|
926 | { |
---|
927 | $self->{DEBUG}->Log1("CallBack: check xpath"); |
---|
928 | |
---|
929 | foreach my $xpath (keys(%{$self->{CB}->{XPath}})) |
---|
930 | { |
---|
931 | if ($NJObject->GetTree()->XPathCheck($xpath)) |
---|
932 | { |
---|
933 | foreach my $func (keys(%{$self->{CB}->{XPath}->{$xpath}})) |
---|
934 | { |
---|
935 | $self->{DEBUG}->Log1("CallBack: goto xpath($xpath) function($func)"); |
---|
936 | &{$self->{CB}->{XPath}->{$xpath}->{$func}}($sid,$NJObject); |
---|
937 | } |
---|
938 | } |
---|
939 | } |
---|
940 | } |
---|
941 | |
---|
942 | if (exists($self->{CB}->{$tag})) |
---|
943 | { |
---|
944 | $self->{DEBUG}->Log1("CallBack: goto user function($self->{CB}->{$tag})"); |
---|
945 | &{$self->{CB}->{$tag}}($sid,$NJObject); |
---|
946 | } |
---|
947 | else |
---|
948 | { |
---|
949 | $self->{DEBUG}->Log1("CallBack: no defined function. Dropping packet."); |
---|
950 | } |
---|
951 | } |
---|
952 | } |
---|
953 | } |
---|
954 | else |
---|
955 | { |
---|
956 | $self->{DEBUG}->Log1("CallBack: a packet that no one wants... how sad. =("); |
---|
957 | } |
---|
958 | } |
---|
959 | |
---|
960 | |
---|
961 | ############################################################################### |
---|
962 | # |
---|
963 | # BuildObject - turn the packet into an object. |
---|
964 | # |
---|
965 | ############################################################################### |
---|
966 | sub BuildObject |
---|
967 | { |
---|
968 | my $self = shift; |
---|
969 | my ($tag,$tree) = @_; |
---|
970 | |
---|
971 | my $obj = -1; |
---|
972 | |
---|
973 | if (exists($NEWOBJECT{$tag})) |
---|
974 | { |
---|
975 | $self->{DEBUG}->Log1("BuildObject: tag($tag) package($NEWOBJECT{$tag})"); |
---|
976 | eval "\$obj = new $NEWOBJECT{$tag}(\$tree);"; |
---|
977 | } |
---|
978 | |
---|
979 | return $obj; |
---|
980 | } |
---|
981 | |
---|
982 | |
---|
983 | ############################################################################### |
---|
984 | # |
---|
985 | # SetCallBacks - Takes a hash with top level tags to look for as the keys |
---|
986 | # and pointers to functions as the values. The functions |
---|
987 | # are called and passed the XML::Parser::Tree objects |
---|
988 | # generated by XML::Stream. |
---|
989 | # |
---|
990 | ############################################################################### |
---|
991 | sub SetCallBacks |
---|
992 | { |
---|
993 | my $self = shift; |
---|
994 | while($#_ >= 0) |
---|
995 | { |
---|
996 | my $func = pop(@_); |
---|
997 | my $tag = pop(@_); |
---|
998 | $self->{DEBUG}->Log1("SetCallBacks: tag($tag) func($func)"); |
---|
999 | if (defined($func)) |
---|
1000 | { |
---|
1001 | $self->{CB}->{$tag} = $func; |
---|
1002 | } |
---|
1003 | else |
---|
1004 | { |
---|
1005 | delete($self->{CB}->{$tag}); |
---|
1006 | } |
---|
1007 | $self->{STREAM}->SetCallBacks(update=>$func) if ($tag eq "update"); |
---|
1008 | } |
---|
1009 | } |
---|
1010 | |
---|
1011 | |
---|
1012 | ############################################################################### |
---|
1013 | # |
---|
1014 | # SetIQCallBacks - define callbacks for the namespaces inside an iq. |
---|
1015 | # |
---|
1016 | ############################################################################### |
---|
1017 | sub SetIQCallBacks |
---|
1018 | { |
---|
1019 | my $self = shift; |
---|
1020 | |
---|
1021 | while($#_ >= 0) |
---|
1022 | { |
---|
1023 | my $hash = pop(@_); |
---|
1024 | my $namespace = pop(@_); |
---|
1025 | |
---|
1026 | foreach my $type (keys(%{$hash})) |
---|
1027 | { |
---|
1028 | if (defined($hash->{$type})) |
---|
1029 | { |
---|
1030 | $self->{CB}->{IQns}->{$namespace}->{$type} = $hash->{$type}; |
---|
1031 | } |
---|
1032 | else |
---|
1033 | { |
---|
1034 | delete($self->{CB}->{IQns}->{$namespace}->{$type}); |
---|
1035 | } |
---|
1036 | } |
---|
1037 | } |
---|
1038 | } |
---|
1039 | |
---|
1040 | |
---|
1041 | ############################################################################### |
---|
1042 | # |
---|
1043 | # SetPresenceCallBacks - define callbacks for the different presence packets. |
---|
1044 | # |
---|
1045 | ############################################################################### |
---|
1046 | sub SetPresenceCallBacks |
---|
1047 | { |
---|
1048 | my $self = shift; |
---|
1049 | my (%types) = @_; |
---|
1050 | |
---|
1051 | foreach my $type (keys(%types)) |
---|
1052 | { |
---|
1053 | if (defined($types{$type})) |
---|
1054 | { |
---|
1055 | $self->{CB}->{Pres}->{$type} = $types{$type}; |
---|
1056 | } |
---|
1057 | else |
---|
1058 | { |
---|
1059 | delete($self->{CB}->{Pres}->{$type}); |
---|
1060 | } |
---|
1061 | } |
---|
1062 | } |
---|
1063 | |
---|
1064 | |
---|
1065 | ############################################################################### |
---|
1066 | # |
---|
1067 | # SetMessageCallBacks - define callbacks for the different message packets. |
---|
1068 | # |
---|
1069 | ############################################################################### |
---|
1070 | sub SetMessageCallBacks |
---|
1071 | { |
---|
1072 | my $self = shift; |
---|
1073 | my (%types) = @_; |
---|
1074 | |
---|
1075 | foreach my $type (keys(%types)) |
---|
1076 | { |
---|
1077 | if (defined($types{$type})) |
---|
1078 | { |
---|
1079 | $self->{CB}->{Mess}->{$type} = $types{$type}; |
---|
1080 | } |
---|
1081 | else |
---|
1082 | { |
---|
1083 | delete($self->{CB}->{Mess}->{$type}); |
---|
1084 | } |
---|
1085 | } |
---|
1086 | } |
---|
1087 | |
---|
1088 | |
---|
1089 | ############################################################################### |
---|
1090 | # |
---|
1091 | # SetXPathCallBacks - define callbacks for packets based on XPath. |
---|
1092 | # |
---|
1093 | ############################################################################### |
---|
1094 | sub SetXPathCallBacks |
---|
1095 | { |
---|
1096 | my $self = shift; |
---|
1097 | my (%xpaths) = @_; |
---|
1098 | |
---|
1099 | foreach my $xpath (keys(%xpaths)) |
---|
1100 | { |
---|
1101 | $self->{DEBUG}->Log1("SetXPathCallBacks: xpath($xpath) func($xpaths{$xpath})"); |
---|
1102 | $self->{CB}->{XPath}->{$xpath}->{$xpaths{$xpath}} = $xpaths{$xpath}; |
---|
1103 | } |
---|
1104 | } |
---|
1105 | |
---|
1106 | |
---|
1107 | ############################################################################### |
---|
1108 | # |
---|
1109 | # RemoveXPathCallBacks - remove callbacks for packets based on XPath. |
---|
1110 | # |
---|
1111 | ############################################################################### |
---|
1112 | sub RemoveXPathCallBacks |
---|
1113 | { |
---|
1114 | my $self = shift; |
---|
1115 | my (%xpaths) = @_; |
---|
1116 | |
---|
1117 | foreach my $xpath (keys(%xpaths)) |
---|
1118 | { |
---|
1119 | $self->{DEBUG}->Log1("RemoveXPathCallBacks: xpath($xpath) func($xpaths{$xpath})"); |
---|
1120 | delete($self->{CB}->{XPath}->{$xpath}->{$xpaths{$xpath}}); |
---|
1121 | delete($self->{CB}->{XPath}->{$xpath}) |
---|
1122 | if (scalar(keys(%{$self->{CB}->{XPath}->{$xpath}})) == 0); |
---|
1123 | delete($self->{CB}->{XPath}) |
---|
1124 | if (scalar(keys(%{$self->{CB}->{XPath}})) == 0); |
---|
1125 | } |
---|
1126 | } |
---|
1127 | |
---|
1128 | |
---|
1129 | ############################################################################### |
---|
1130 | # |
---|
1131 | # SetDirectXPathCallBacks - define callbacks for packets based on XPath. |
---|
1132 | # |
---|
1133 | ############################################################################### |
---|
1134 | sub SetDirectXPathCallBacks |
---|
1135 | { |
---|
1136 | my $self = shift; |
---|
1137 | my (%xpaths) = @_; |
---|
1138 | |
---|
1139 | foreach my $xpath (keys(%xpaths)) |
---|
1140 | { |
---|
1141 | $self->{DEBUG}->Log1("SetDirectXPathCallBacks: xpath($xpath) func($xpaths{$xpath})"); |
---|
1142 | $self->{CB}->{DirectXPath}->{$xpath}->{$xpaths{$xpath}} = $xpaths{$xpath}; |
---|
1143 | } |
---|
1144 | } |
---|
1145 | |
---|
1146 | |
---|
1147 | ############################################################################### |
---|
1148 | # |
---|
1149 | # RemoveDirectXPathCallBacks - remove callbacks for packets based on XPath. |
---|
1150 | # |
---|
1151 | ############################################################################### |
---|
1152 | sub RemoveDirectXPathCallBacks |
---|
1153 | { |
---|
1154 | my $self = shift; |
---|
1155 | my (%xpaths) = @_; |
---|
1156 | |
---|
1157 | foreach my $xpath (keys(%xpaths)) |
---|
1158 | { |
---|
1159 | $self->{DEBUG}->Log1("RemoveDirectXPathCallBacks: xpath($xpath) func($xpaths{$xpath})"); |
---|
1160 | delete($self->{CB}->{DirectXPath}->{$xpath}->{$xpaths{$xpath}}); |
---|
1161 | delete($self->{CB}->{DirectXPath}->{$xpath}) |
---|
1162 | if (scalar(keys(%{$self->{CB}->{DirectXPath}->{$xpath}})) == 0); |
---|
1163 | delete($self->{CB}->{DirectXPath}) |
---|
1164 | if (scalar(keys(%{$self->{CB}->{DirectXPath}})) == 0); |
---|
1165 | } |
---|
1166 | } |
---|
1167 | |
---|
1168 | |
---|
1169 | ############################################################################### |
---|
1170 | # |
---|
1171 | # Send - Takes either XML or a Net::XMPP::xxxx object and sends that |
---|
1172 | # packet to the server. |
---|
1173 | # |
---|
1174 | ############################################################################### |
---|
1175 | sub Send |
---|
1176 | { |
---|
1177 | my $self = shift; |
---|
1178 | my $object = shift; |
---|
1179 | my $ignoreActivity = shift; |
---|
1180 | $ignoreActivity = 0 unless defined($ignoreActivity); |
---|
1181 | |
---|
1182 | if (ref($object) eq "") |
---|
1183 | { |
---|
1184 | $self->SendXML($object,$ignoreActivity); |
---|
1185 | } |
---|
1186 | else |
---|
1187 | { |
---|
1188 | $self->SendXML($object->GetXML(),$ignoreActivity); |
---|
1189 | } |
---|
1190 | } |
---|
1191 | |
---|
1192 | |
---|
1193 | ############################################################################### |
---|
1194 | # |
---|
1195 | # SendXML - Sends the XML packet to the server |
---|
1196 | # |
---|
1197 | ############################################################################### |
---|
1198 | sub SendXML |
---|
1199 | { |
---|
1200 | my $self = shift; |
---|
1201 | my $xml = shift; |
---|
1202 | my $ignoreActivity = shift; |
---|
1203 | $ignoreActivity = 0 unless defined($ignoreActivity); |
---|
1204 | |
---|
1205 | $self->{DEBUG}->Log1("SendXML: sent($xml)"); |
---|
1206 | &{$self->{CB}->{send}}($self->GetStreamID(),$xml) if exists($self->{CB}->{send}); |
---|
1207 | $self->{STREAM}->IgnoreActivity($self->GetStreamID(),$ignoreActivity); |
---|
1208 | $self->{STREAM}->Send($self->GetStreamID(),$xml); |
---|
1209 | $self->{STREAM}->IgnoreActivity($self->GetStreamID(),0); |
---|
1210 | } |
---|
1211 | |
---|
1212 | |
---|
1213 | ############################################################################### |
---|
1214 | # |
---|
1215 | # SendWithID - Take either XML or a Net::XMPP::xxxx object and send it |
---|
1216 | # with the next available ID number. Then return that ID so |
---|
1217 | # the client can track it. |
---|
1218 | # |
---|
1219 | ############################################################################### |
---|
1220 | sub SendWithID |
---|
1221 | { |
---|
1222 | my $self = shift; |
---|
1223 | my ($object) = @_; |
---|
1224 | |
---|
1225 | #-------------------------------------------------------------------------- |
---|
1226 | # Take the current XML stream and insert an id attrib at the top level. |
---|
1227 | #-------------------------------------------------------------------------- |
---|
1228 | my $id = $self->UniqueID(); |
---|
1229 | |
---|
1230 | $self->{DEBUG}->Log1("SendWithID: id($id)"); |
---|
1231 | |
---|
1232 | my $xml; |
---|
1233 | if (ref($object) eq "") |
---|
1234 | { |
---|
1235 | $self->{DEBUG}->Log1("SendWithID: in($object)"); |
---|
1236 | $xml = $object; |
---|
1237 | $xml =~ s/^(\<[^\>]+)(\>)/$1 id\=\'$id\'$2/; |
---|
1238 | my ($tag) = ($xml =~ /^\<(\S+)\s/); |
---|
1239 | $self->RegisterID($tag,$id); |
---|
1240 | } |
---|
1241 | else |
---|
1242 | { |
---|
1243 | $self->{DEBUG}->Log1("SendWithID: in(",$object->GetXML(),")"); |
---|
1244 | $object->SetID($id); |
---|
1245 | $xml = $object->GetXML(); |
---|
1246 | $self->RegisterID($object->GetTag(),$id); |
---|
1247 | } |
---|
1248 | $self->{DEBUG}->Log1("SendWithID: out($xml)"); |
---|
1249 | |
---|
1250 | #-------------------------------------------------------------------------- |
---|
1251 | # Send the new XML string. |
---|
1252 | #-------------------------------------------------------------------------- |
---|
1253 | $self->SendXML($xml); |
---|
1254 | |
---|
1255 | #-------------------------------------------------------------------------- |
---|
1256 | # Return the ID number we just assigned. |
---|
1257 | #-------------------------------------------------------------------------- |
---|
1258 | return $id; |
---|
1259 | } |
---|
1260 | |
---|
1261 | |
---|
1262 | ############################################################################### |
---|
1263 | # |
---|
1264 | # UniqueID - Increment and return a new unique ID. |
---|
1265 | # |
---|
1266 | ############################################################################### |
---|
1267 | sub UniqueID |
---|
1268 | { |
---|
1269 | my $self = shift; |
---|
1270 | |
---|
1271 | my $id_num = $self->{RCVDB}->{currentID}; |
---|
1272 | |
---|
1273 | $self->{RCVDB}->{currentID}++; |
---|
1274 | |
---|
1275 | return "netjabber-$id_num"; |
---|
1276 | } |
---|
1277 | |
---|
1278 | |
---|
1279 | ############################################################################### |
---|
1280 | # |
---|
1281 | # SendAndReceiveWithID - Take either XML or a Net::XMPP::xxxxx object and |
---|
1282 | # send it with the next ID. Then wait for that ID |
---|
1283 | # to come back and return the response in a |
---|
1284 | # Net::XMPP::xxxx object. |
---|
1285 | # |
---|
1286 | ############################################################################### |
---|
1287 | sub SendAndReceiveWithID |
---|
1288 | { |
---|
1289 | my $self = shift; |
---|
1290 | my ($object,$timeout) = @_; |
---|
1291 | &{$self->{CB}->{startwait}}() if exists($self->{CB}->{startwait}); |
---|
1292 | $self->{DEBUG}->Log1("SendAndReceiveWithID: object($object)"); |
---|
1293 | my $id = $self->SendWithID($object); |
---|
1294 | $self->{DEBUG}->Log1("SendAndReceiveWithID: sent with id($id)"); |
---|
1295 | my $packet = $self->WaitForID($id,$timeout); |
---|
1296 | &{$self->{CB}->{endwait}}() if exists($self->{CB}->{endwait}); |
---|
1297 | return $packet; |
---|
1298 | } |
---|
1299 | |
---|
1300 | |
---|
1301 | ############################################################################### |
---|
1302 | # |
---|
1303 | # ReceivedID - returns 1 if a packet with the ID has been received, or 0 |
---|
1304 | # if it has not. |
---|
1305 | # |
---|
1306 | ############################################################################### |
---|
1307 | sub ReceivedID |
---|
1308 | { |
---|
1309 | my $self = shift; |
---|
1310 | my ($id) = @_; |
---|
1311 | |
---|
1312 | $self->{DEBUG}->Log1("ReceivedID: id($id)"); |
---|
1313 | return 1 if exists($self->{RCVDB}->{$id}); |
---|
1314 | $self->{DEBUG}->Log1("ReceivedID: nope..."); |
---|
1315 | return 0; |
---|
1316 | } |
---|
1317 | |
---|
1318 | |
---|
1319 | ############################################################################### |
---|
1320 | # |
---|
1321 | # GetID - Return the Net::XMPP::xxxxx object that is stored in the LIST |
---|
1322 | # that matches the ID if that ID exists. Otherwise return 0. |
---|
1323 | # |
---|
1324 | ############################################################################### |
---|
1325 | sub GetID |
---|
1326 | { |
---|
1327 | my $self = shift; |
---|
1328 | my ($id) = @_; |
---|
1329 | |
---|
1330 | $self->{DEBUG}->Log1("GetID: id($id)"); |
---|
1331 | return $self->{RCVDB}->{$id} if $self->ReceivedID($id); |
---|
1332 | $self->{DEBUG}->Log1("GetID: haven't gotten that id yet..."); |
---|
1333 | return 0; |
---|
1334 | } |
---|
1335 | |
---|
1336 | |
---|
1337 | ############################################################################### |
---|
1338 | # |
---|
1339 | # CleanID - Delete the list entry for this id since we don't want a leak. |
---|
1340 | # |
---|
1341 | ############################################################################### |
---|
1342 | sub CleanID |
---|
1343 | { |
---|
1344 | my $self = shift; |
---|
1345 | my ($id) = @_; |
---|
1346 | |
---|
1347 | $self->{DEBUG}->Log1("CleanID: id($id)"); |
---|
1348 | delete($self->{RCVDB}->{$id}); |
---|
1349 | } |
---|
1350 | |
---|
1351 | |
---|
1352 | ############################################################################### |
---|
1353 | # |
---|
1354 | # WaitForID - Keep looping and calling Process(1) to poll every second |
---|
1355 | # until the response from the server occurs. |
---|
1356 | # |
---|
1357 | ############################################################################### |
---|
1358 | sub WaitForID |
---|
1359 | { |
---|
1360 | my $self = shift; |
---|
1361 | my ($id,$timeout) = @_; |
---|
1362 | $timeout = "300" unless defined($timeout); |
---|
1363 | |
---|
1364 | $self->{DEBUG}->Log1("WaitForID: id($id)"); |
---|
1365 | my $endTime = time + $timeout; |
---|
1366 | while(!$self->ReceivedID($id) && ($endTime >= time)) |
---|
1367 | { |
---|
1368 | $self->{DEBUG}->Log1("WaitForID: haven't gotten it yet... let's wait for more packets"); |
---|
1369 | return unless (defined($self->Process(1))); |
---|
1370 | &{$self->{CB}->{update}}() if exists($self->{CB}->{update}); |
---|
1371 | } |
---|
1372 | if (!$self->ReceivedID($id)) |
---|
1373 | { |
---|
1374 | $self->TimeoutID($id); |
---|
1375 | $self->{DEBUG}->Log1("WaitForID: timed out..."); |
---|
1376 | return; |
---|
1377 | } |
---|
1378 | else |
---|
1379 | { |
---|
1380 | $self->{DEBUG}->Log1("WaitForID: we got it!"); |
---|
1381 | my $packet = $self->GetID($id); |
---|
1382 | $self->CleanID($id); |
---|
1383 | return $packet; |
---|
1384 | } |
---|
1385 | } |
---|
1386 | |
---|
1387 | |
---|
1388 | ############################################################################### |
---|
1389 | # |
---|
1390 | # GotID - Callback to store the Net::XMPP::xxxxx object in the LIST at |
---|
1391 | # the ID index. This is a private helper function. |
---|
1392 | # |
---|
1393 | ############################################################################### |
---|
1394 | sub GotID |
---|
1395 | { |
---|
1396 | my $self = shift; |
---|
1397 | my ($id,$object) = @_; |
---|
1398 | |
---|
1399 | $self->{DEBUG}->Log1("GotID: id($id) xml(",$object->GetXML(),")"); |
---|
1400 | $self->{RCVDB}->{$id} = $object; |
---|
1401 | } |
---|
1402 | |
---|
1403 | |
---|
1404 | ############################################################################### |
---|
1405 | # |
---|
1406 | # CheckID - Checks the ID registry if this tag and ID have been registered. |
---|
1407 | # 0 = no, 1 = yes |
---|
1408 | # |
---|
1409 | ############################################################################### |
---|
1410 | sub CheckID |
---|
1411 | { |
---|
1412 | my $self = shift; |
---|
1413 | my ($tag,$id) = @_; |
---|
1414 | $id = "" unless defined($id); |
---|
1415 | |
---|
1416 | $self->{DEBUG}->Log1("CheckID: tag($tag) id($id)"); |
---|
1417 | return 0 if ($id eq ""); |
---|
1418 | $self->{DEBUG}->Log1("CheckID: we have that here somewhere..."); |
---|
1419 | return exists($self->{IDRegistry}->{$tag}->{$id}); |
---|
1420 | } |
---|
1421 | |
---|
1422 | |
---|
1423 | ############################################################################### |
---|
1424 | # |
---|
1425 | # TimeoutID - Timeout the tag and ID in the registry so that the CallBack |
---|
1426 | # can know what to put in the ID list and what to pass on. |
---|
1427 | # |
---|
1428 | ############################################################################### |
---|
1429 | sub TimeoutID |
---|
1430 | { |
---|
1431 | my $self = shift; |
---|
1432 | my ($id) = @_; |
---|
1433 | |
---|
1434 | $self->{DEBUG}->Log1("TimeoutID: id($id)"); |
---|
1435 | $self->{RCVDB}->{$id} = 0; |
---|
1436 | } |
---|
1437 | |
---|
1438 | |
---|
1439 | ############################################################################### |
---|
1440 | # |
---|
1441 | # TimedOutID - Timeout the tag and ID in the registry so that the CallBack |
---|
1442 | # can know what to put in the ID list and what to pass on. |
---|
1443 | # |
---|
1444 | ############################################################################### |
---|
1445 | sub TimedOutID |
---|
1446 | { |
---|
1447 | my $self = shift; |
---|
1448 | my ($id) = @_; |
---|
1449 | |
---|
1450 | return (exists($self->{RCVDB}->{$id}) && ($self->{RCVDB}->{$id} == 0)); |
---|
1451 | } |
---|
1452 | |
---|
1453 | |
---|
1454 | ############################################################################### |
---|
1455 | # |
---|
1456 | # RegisterID - Register the tag and ID in the registry so that the CallBack |
---|
1457 | # can know what to put in the ID list and what to pass on. |
---|
1458 | # |
---|
1459 | ############################################################################### |
---|
1460 | sub RegisterID |
---|
1461 | { |
---|
1462 | my $self = shift; |
---|
1463 | my ($tag,$id) = @_; |
---|
1464 | |
---|
1465 | $self->{DEBUG}->Log1("RegisterID: tag($tag) id($id)"); |
---|
1466 | $self->{IDRegistry}->{$tag}->{$id} = 1; |
---|
1467 | } |
---|
1468 | |
---|
1469 | |
---|
1470 | ############################################################################### |
---|
1471 | # |
---|
1472 | # DeregisterID - Delete the tag and ID in the registry so that the CallBack |
---|
1473 | # can knows that it has been received. |
---|
1474 | # |
---|
1475 | ############################################################################### |
---|
1476 | sub DeregisterID |
---|
1477 | { |
---|
1478 | my $self = shift; |
---|
1479 | my ($tag,$id) = @_; |
---|
1480 | |
---|
1481 | $self->{DEBUG}->Log1("DeregisterID: tag($tag) id($id)"); |
---|
1482 | delete($self->{IDRegistry}->{$tag}->{$id}); |
---|
1483 | } |
---|
1484 | |
---|
1485 | |
---|
1486 | ############################################################################### |
---|
1487 | # |
---|
1488 | # AddNamespace - Add a custom namespace into the mix. |
---|
1489 | # |
---|
1490 | ############################################################################### |
---|
1491 | sub AddNamespace |
---|
1492 | { |
---|
1493 | my $self = shift; |
---|
1494 | &Net::XMPP::Namespaces::add_ns(@_); |
---|
1495 | } |
---|
1496 | |
---|
1497 | |
---|
1498 | ############################################################################### |
---|
1499 | # |
---|
1500 | # MessageSend - Takes the same hash that Net::XMPP::Message->SetMessage |
---|
1501 | # takes and sends the message to the server. |
---|
1502 | # |
---|
1503 | ############################################################################### |
---|
1504 | sub MessageSend |
---|
1505 | { |
---|
1506 | my $self = shift; |
---|
1507 | |
---|
1508 | my $mess = $self->_message(); |
---|
1509 | $mess->SetMessage(@_); |
---|
1510 | $self->Send($mess); |
---|
1511 | } |
---|
1512 | |
---|
1513 | |
---|
1514 | ############################################################################## |
---|
1515 | # |
---|
1516 | # PresenceDB - initialize the module to use the presence database |
---|
1517 | # |
---|
1518 | ############################################################################## |
---|
1519 | sub PresenceDB |
---|
1520 | { |
---|
1521 | my $self = shift; |
---|
1522 | |
---|
1523 | $self->SetXPathCallBacks('/presence'=>sub{ shift; $self->PresenceDBParse(@_) }); |
---|
1524 | } |
---|
1525 | |
---|
1526 | |
---|
1527 | ############################################################################### |
---|
1528 | # |
---|
1529 | # PresenceDBParse - adds the presence information to the Presence DB so |
---|
1530 | # you can keep track of the current state of the JID and |
---|
1531 | # all of it's resources. |
---|
1532 | # |
---|
1533 | ############################################################################### |
---|
1534 | sub PresenceDBParse |
---|
1535 | { |
---|
1536 | my $self = shift; |
---|
1537 | my ($presence) = @_; |
---|
1538 | |
---|
1539 | $self->{DEBUG}->Log4("PresenceDBParse: pres(",$presence->GetXML(),")"); |
---|
1540 | |
---|
1541 | my $type = $presence->GetType(); |
---|
1542 | $type = "" unless defined($type); |
---|
1543 | return $presence unless (($type eq "") || |
---|
1544 | ($type eq "available") || |
---|
1545 | ($type eq "unavailable")); |
---|
1546 | |
---|
1547 | my $fromJID = $presence->GetFrom("jid"); |
---|
1548 | my $fromID = $fromJID->GetJID(); |
---|
1549 | $fromID = "" unless defined($fromID); |
---|
1550 | my $resource = $fromJID->GetResource(); |
---|
1551 | $resource = " " unless ($resource ne ""); |
---|
1552 | my $priority = $presence->GetPriority(); |
---|
1553 | $priority = 0 unless defined($priority); |
---|
1554 | |
---|
1555 | $self->{DEBUG}->Log1("PresenceDBParse: fromJID(",$fromJID->GetJID("full"),") resource($resource) priority($priority) type($type)"); |
---|
1556 | $self->{DEBUG}->Log2("PresenceDBParse: xml(",$presence->GetXML(),")"); |
---|
1557 | |
---|
1558 | if (exists($self->{PRESENCEDB}->{$fromID})) |
---|
1559 | { |
---|
1560 | my $oldPriority = $self->{PRESENCEDB}->{$fromID}->{resources}->{$resource}; |
---|
1561 | $oldPriority = "" unless defined($oldPriority); |
---|
1562 | |
---|
1563 | my $loc = 0; |
---|
1564 | foreach my $index (0..$#{$self->{PRESENCEDB}->{$fromID}->{priorities}->{$oldPriority}}) |
---|
1565 | { |
---|
1566 | $loc = $index |
---|
1567 | if ($self->{PRESENCEDB}->{$fromID}->{priorities}->{$oldPriority}->[$index]->{resource} eq $resource); |
---|
1568 | } |
---|
1569 | splice(@{$self->{PRESENCEDB}->{$fromID}->{priorities}->{$oldPriority}},$loc,1); |
---|
1570 | delete($self->{PRESENCEDB}->{$fromID}->{resources}->{$resource}); |
---|
1571 | delete($self->{PRESENCEDB}->{$fromID}->{priorities}->{$oldPriority}) |
---|
1572 | if (exists($self->{PRESENCEDB}->{$fromID}->{priorities}->{$oldPriority}) && |
---|
1573 | ($#{$self->{PRESENCEDB}->{$fromID}->{priorities}->{$oldPriority}} == -1)); |
---|
1574 | delete($self->{PRESENCEDB}->{$fromID}) |
---|
1575 | if (scalar(keys(%{$self->{PRESENCEDB}->{$fromID}})) == 0); |
---|
1576 | |
---|
1577 | $self->{DEBUG}->Log1("PresenceDBParse: remove ",$fromJID->GetJID("full")," from the DB"); |
---|
1578 | } |
---|
1579 | |
---|
1580 | if (($type eq "") || ($type eq "available")) |
---|
1581 | { |
---|
1582 | my $loc = -1; |
---|
1583 | foreach my $index (0..$#{$self->{PRESENCEDB}->{$fromID}->{priorities}->{$priority}}) { |
---|
1584 | $loc = $index |
---|
1585 | if ($self->{PRESENCEDB}->{$fromID}->{priorities}->{$priority}->[$index]->{resource} eq $resource); |
---|
1586 | } |
---|
1587 | $loc = $#{$self->{PRESENCEDB}->{$fromID}->{priorities}->{$priority}}+1 |
---|
1588 | if ($loc == -1); |
---|
1589 | $self->{PRESENCEDB}->{$fromID}->{resources}->{$resource} = $priority; |
---|
1590 | $self->{PRESENCEDB}->{$fromID}->{priorities}->{$priority}->[$loc]->{presence} = |
---|
1591 | $presence; |
---|
1592 | $self->{PRESENCEDB}->{$fromID}->{priorities}->{$priority}->[$loc]->{resource} = |
---|
1593 | $resource; |
---|
1594 | |
---|
1595 | $self->{DEBUG}->Log1("PresenceDBParse: add ",$fromJID->GetJID("full")," to the DB"); |
---|
1596 | } |
---|
1597 | |
---|
1598 | my $currentPresence = $self->PresenceDBQuery($fromJID); |
---|
1599 | return (defined($currentPresence) ? $currentPresence : $presence); |
---|
1600 | } |
---|
1601 | |
---|
1602 | |
---|
1603 | ############################################################################### |
---|
1604 | # |
---|
1605 | # PresenceDBDelete - delete the JID from the DB completely. |
---|
1606 | # |
---|
1607 | ############################################################################### |
---|
1608 | sub PresenceDBDelete |
---|
1609 | { |
---|
1610 | my $self = shift; |
---|
1611 | my ($jid) = @_; |
---|
1612 | |
---|
1613 | my $indexJID = $jid; |
---|
1614 | $indexJID = $jid->GetJID() if $jid->isa("Net::XMPP::JID"); |
---|
1615 | |
---|
1616 | return if !exists($self->{PRESENCEDB}->{$indexJID}); |
---|
1617 | delete($self->{PRESENCEDB}->{$indexJID}); |
---|
1618 | $self->{DEBUG}->Log1("PresenceDBDelete: delete ",$indexJID," from the DB"); |
---|
1619 | } |
---|
1620 | |
---|
1621 | |
---|
1622 | ############################################################################### |
---|
1623 | # |
---|
1624 | # PresenceDBClear - delete all of the JIDs from the DB completely. |
---|
1625 | # |
---|
1626 | ############################################################################### |
---|
1627 | sub PresenceDBClear |
---|
1628 | { |
---|
1629 | my $self = shift; |
---|
1630 | |
---|
1631 | $self->{DEBUG}->Log1("PresenceDBClear: clearing the database"); |
---|
1632 | foreach my $indexJID (keys(%{$self->{PRESENCEDB}})) |
---|
1633 | { |
---|
1634 | $self->{DEBUG}->Log3("PresenceDBClear: deleting ",$indexJID," from the DB"); |
---|
1635 | delete($self->{PRESENCEDB}->{$indexJID}); |
---|
1636 | } |
---|
1637 | $self->{DEBUG}->Log3("PresenceDBClear: database is empty"); |
---|
1638 | } |
---|
1639 | |
---|
1640 | |
---|
1641 | ############################################################################### |
---|
1642 | # |
---|
1643 | # PresenceDBQuery - retrieve the last Net::XMPP::Presence received with |
---|
1644 | # the highest priority. |
---|
1645 | # |
---|
1646 | ############################################################################### |
---|
1647 | sub PresenceDBQuery |
---|
1648 | { |
---|
1649 | my $self = shift; |
---|
1650 | my ($jid) = @_; |
---|
1651 | |
---|
1652 | my $indexJID = $jid; |
---|
1653 | $indexJID = $jid->GetJID() if $jid->isa("Net::XMPP::JID"); |
---|
1654 | |
---|
1655 | return if !exists($self->{PRESENCEDB}->{$indexJID}); |
---|
1656 | return if (scalar(keys(%{$self->{PRESENCEDB}->{$indexJID}->{priorities}})) == 0); |
---|
1657 | |
---|
1658 | my $highPriority = |
---|
1659 | (sort {$b cmp $a} keys(%{$self->{PRESENCEDB}->{$indexJID}->{priorities}}))[0]; |
---|
1660 | |
---|
1661 | return $self->{PRESENCEDB}->{$indexJID}->{priorities}->{$highPriority}->[0]->{presence}; |
---|
1662 | } |
---|
1663 | |
---|
1664 | |
---|
1665 | ############################################################################### |
---|
1666 | # |
---|
1667 | # PresenceDBResources - returns a list of the resources from highest |
---|
1668 | # priority to lowest. |
---|
1669 | # |
---|
1670 | ############################################################################### |
---|
1671 | sub PresenceDBResources |
---|
1672 | { |
---|
1673 | my $self = shift; |
---|
1674 | my ($jid) = @_; |
---|
1675 | |
---|
1676 | my $indexJID = $jid; |
---|
1677 | $indexJID = $jid->GetJID() if $jid->isa("Net::XMPP::JID"); |
---|
1678 | |
---|
1679 | my @resources; |
---|
1680 | |
---|
1681 | return if !exists($self->{PRESENCEDB}->{$indexJID}); |
---|
1682 | |
---|
1683 | foreach my $priority (sort {$b cmp $a} keys(%{$self->{PRESENCEDB}->{$indexJID}->{priorities}})) |
---|
1684 | { |
---|
1685 | foreach my $index (0..$#{$self->{PRESENCEDB}->{$indexJID}->{priorities}->{$priority}}) |
---|
1686 | { |
---|
1687 | next if ($self->{PRESENCEDB}->{$indexJID}->{priorities}->{$priority}->[$index]->{resource} eq " "); |
---|
1688 | push(@resources,$self->{PRESENCEDB}->{$indexJID}->{priorities}->{$priority}->[$index]->{resource}); |
---|
1689 | } |
---|
1690 | } |
---|
1691 | return @resources; |
---|
1692 | } |
---|
1693 | |
---|
1694 | |
---|
1695 | ############################################################################### |
---|
1696 | # |
---|
1697 | # PresenceSend - Sends a presence tag to announce your availability |
---|
1698 | # |
---|
1699 | ############################################################################### |
---|
1700 | sub PresenceSend |
---|
1701 | { |
---|
1702 | my $self = shift; |
---|
1703 | my %args; |
---|
1704 | while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
---|
1705 | |
---|
1706 | $args{ignoreactivity} = 0 unless exists($args{ignoreactivity}); |
---|
1707 | my $ignoreActivity = delete($args{ignoreactivity}); |
---|
1708 | |
---|
1709 | my $presence = $self->_presence(); |
---|
1710 | |
---|
1711 | $presence->SetPresence(%args); |
---|
1712 | $self->Send($presence,$ignoreActivity); |
---|
1713 | return $presence; |
---|
1714 | } |
---|
1715 | |
---|
1716 | |
---|
1717 | ############################################################################### |
---|
1718 | # |
---|
1719 | # PresenceProbe - Sends a presence probe to the server |
---|
1720 | # |
---|
1721 | ############################################################################### |
---|
1722 | sub PresenceProbe |
---|
1723 | { |
---|
1724 | my $self = shift; |
---|
1725 | my %args; |
---|
1726 | while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
---|
1727 | delete($args{type}); |
---|
1728 | |
---|
1729 | my $presence = $self->_presence(); |
---|
1730 | $presence->SetPresence(type=>"probe", |
---|
1731 | %args); |
---|
1732 | $self->Send($presence); |
---|
1733 | } |
---|
1734 | |
---|
1735 | |
---|
1736 | ############################################################################### |
---|
1737 | # |
---|
1738 | # Subscription - Sends a presence tag to perform the subscription on the |
---|
1739 | # specified JID. |
---|
1740 | # |
---|
1741 | ############################################################################### |
---|
1742 | sub Subscription |
---|
1743 | { |
---|
1744 | my $self = shift; |
---|
1745 | |
---|
1746 | my $presence = $self->_presence(); |
---|
1747 | $presence->SetPresence(@_); |
---|
1748 | $self->Send($presence); |
---|
1749 | } |
---|
1750 | |
---|
1751 | |
---|
1752 | ############################################################################### |
---|
1753 | # |
---|
1754 | # AuthSend - This is a self contained function to send a login iq tag with |
---|
1755 | # an id. Then wait for a reply what the same id to come back |
---|
1756 | # and tell the caller what the result was. |
---|
1757 | # |
---|
1758 | ############################################################################### |
---|
1759 | sub AuthSend |
---|
1760 | { |
---|
1761 | my $self = shift; |
---|
1762 | my %args; |
---|
1763 | while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
---|
1764 | |
---|
1765 | carp("AuthSend requires a username arguement") |
---|
1766 | unless exists($args{username}); |
---|
1767 | carp("AuthSend requires a password arguement") |
---|
1768 | unless exists($args{password}); |
---|
1769 | |
---|
1770 | if($self->{STREAM}->GetStreamFeature($self->GetStreamID(),"xmpp-sasl")) |
---|
1771 | { |
---|
1772 | return $self->AuthSASL(%args); |
---|
1773 | } |
---|
1774 | |
---|
1775 | return $self->AuthIQAuth(%args); |
---|
1776 | } |
---|
1777 | |
---|
1778 | |
---|
1779 | ############################################################################### |
---|
1780 | # |
---|
1781 | # AuthIQAuth - Try and auth using jabber:iq:auth, the old Jabber way of |
---|
1782 | # authenticating. |
---|
1783 | # |
---|
1784 | ############################################################################### |
---|
1785 | sub AuthIQAuth |
---|
1786 | { |
---|
1787 | my $self = shift; |
---|
1788 | my %args; |
---|
1789 | while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
---|
1790 | |
---|
1791 | $self->{DEBUG}->Log1("AuthIQAuth: old school auth"); |
---|
1792 | |
---|
1793 | carp("AuthIQAuth requires a resource arguement") |
---|
1794 | unless exists($args{resource}); |
---|
1795 | |
---|
1796 | my $authType = "digest"; |
---|
1797 | my $token; |
---|
1798 | my $sequence; |
---|
1799 | |
---|
1800 | #-------------------------------------------------------------------------- |
---|
1801 | # First let's ask the sever what all is available in terms of auth types. |
---|
1802 | # If we get an error, then all we can do is digest or plain. |
---|
1803 | #-------------------------------------------------------------------------- |
---|
1804 | my $iqAuth = $self->_iq(); |
---|
1805 | $iqAuth->SetIQ(type=>"get"); |
---|
1806 | my $iqAuthQuery = $iqAuth->NewChild("jabber:iq:auth"); |
---|
1807 | $iqAuthQuery->SetUsername($args{username}); |
---|
1808 | $iqAuth = $self->SendAndReceiveWithID($iqAuth); |
---|
1809 | |
---|
1810 | return unless defined($iqAuth); |
---|
1811 | return ( $iqAuth->GetErrorCode() , $iqAuth->GetError() ) |
---|
1812 | if ($iqAuth->GetType() eq "error"); |
---|
1813 | |
---|
1814 | if ($iqAuth->GetType() eq "error") |
---|
1815 | { |
---|
1816 | $authType = "digest"; |
---|
1817 | } |
---|
1818 | else |
---|
1819 | { |
---|
1820 | $iqAuthQuery = $iqAuth->GetChild(); |
---|
1821 | $authType = "plain" if $iqAuthQuery->DefinedPassword(); |
---|
1822 | $authType = "digest" if $iqAuthQuery->DefinedDigest(); |
---|
1823 | $authType = "zerok" if ($iqAuthQuery->DefinedSequence() && |
---|
1824 | $iqAuthQuery->DefinedToken()); |
---|
1825 | $token = $iqAuthQuery->GetToken() if ($authType eq "zerok"); |
---|
1826 | $sequence = $iqAuthQuery->GetSequence() if ($authType eq "zerok"); |
---|
1827 | } |
---|
1828 | |
---|
1829 | $self->{DEBUG}->Log1("AuthIQAuth: authType($authType)"); |
---|
1830 | |
---|
1831 | delete($args{digest}); |
---|
1832 | delete($args{type}); |
---|
1833 | my $password = delete $args{password}; |
---|
1834 | if (ref($password) eq 'CODE') |
---|
1835 | { |
---|
1836 | $password = $password->(); |
---|
1837 | } |
---|
1838 | |
---|
1839 | #-------------------------------------------------------------------------- |
---|
1840 | # 0k authenticaion (http://core.jabber.org/0k.html) |
---|
1841 | # |
---|
1842 | # Tell the server that we want to connect this way, the server sends back |
---|
1843 | # a token and a sequence number. We take that token + the password and |
---|
1844 | # SHA1 it. Then we SHA1 it sequence number more times and send that hash. |
---|
1845 | # The server SHA1s that hash one more time and compares it to the hash it |
---|
1846 | # stored last time. IF they match, we are in and it stores the hash we sent |
---|
1847 | # for the next time and decreases the sequence number, else, no go. |
---|
1848 | #-------------------------------------------------------------------------- |
---|
1849 | if ($authType eq "zerok") |
---|
1850 | { |
---|
1851 | my $hashA = Digest::SHA1::sha1_hex($password); |
---|
1852 | $args{hash} = Digest::SHA1::sha1_hex($hashA.$token); |
---|
1853 | |
---|
1854 | for (1..$sequence) |
---|
1855 | { |
---|
1856 | $args{hash} = Digest::SHA1::sha1_hex($args{hash}); |
---|
1857 | } |
---|
1858 | } |
---|
1859 | |
---|
1860 | #-------------------------------------------------------------------------- |
---|
1861 | # If we have access to the SHA-1 digest algorithm then let's use it. |
---|
1862 | # Remove the password from the hash, create the digest, and put the |
---|
1863 | # digest in the hash instead. |
---|
1864 | # |
---|
1865 | # Note: Concat the Session ID and the password and then digest that |
---|
1866 | # string to get the server to accept the digest. |
---|
1867 | #-------------------------------------------------------------------------- |
---|
1868 | if ($authType eq "digest") |
---|
1869 | { |
---|
1870 | $args{digest} = Digest::SHA1::sha1_hex($self->GetStreamID().$password); |
---|
1871 | } |
---|
1872 | |
---|
1873 | #-------------------------------------------------------------------------- |
---|
1874 | # Create a Net::XMPP::IQ object to send to the server |
---|
1875 | #-------------------------------------------------------------------------- |
---|
1876 | my $iqLogin = $self->_iq(); |
---|
1877 | $iqLogin->SetIQ(type=>"set"); |
---|
1878 | my $iqLoginQuery = $iqLogin->NewChild("jabber:iq:auth"); |
---|
1879 | $iqLoginQuery->SetAuth(%args); |
---|
1880 | |
---|
1881 | #-------------------------------------------------------------------------- |
---|
1882 | # Send the IQ with the next available ID and wait for a reply with that |
---|
1883 | # id to be received. Then grab the IQ reply. |
---|
1884 | #-------------------------------------------------------------------------- |
---|
1885 | $iqLogin = $self->SendAndReceiveWithID($iqLogin); |
---|
1886 | |
---|
1887 | #-------------------------------------------------------------------------- |
---|
1888 | # From the reply IQ determine if we were successful or not. If yes then |
---|
1889 | # return "". If no then return error string from the reply. |
---|
1890 | #-------------------------------------------------------------------------- |
---|
1891 | $password =~ tr/\0-\377/x/; |
---|
1892 | return unless defined($iqLogin); |
---|
1893 | return ( $iqLogin->GetErrorCode() , $iqLogin->GetError() ) |
---|
1894 | if ($iqLogin->GetType() eq "error"); |
---|
1895 | |
---|
1896 | $self->{DEBUG}->Log1("AuthIQAuth: we authed!"); |
---|
1897 | |
---|
1898 | return ("ok",""); |
---|
1899 | } |
---|
1900 | |
---|
1901 | |
---|
1902 | ############################################################################### |
---|
1903 | # |
---|
1904 | # AuthSASL - Try and auth using SASL, the XMPP preferred way of authenticating. |
---|
1905 | # |
---|
1906 | ############################################################################### |
---|
1907 | sub AuthSASL |
---|
1908 | { |
---|
1909 | my $self = shift; |
---|
1910 | my %args; |
---|
1911 | while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
---|
1912 | |
---|
1913 | $self->{DEBUG}->Log1("AuthSASL: shiney new auth"); |
---|
1914 | |
---|
1915 | carp("AuthSASL requires a username arguement") |
---|
1916 | unless exists($args{username}); |
---|
1917 | carp("AuthSASL requires a password arguement") |
---|
1918 | unless exists($args{password}); |
---|
1919 | |
---|
1920 | $args{resource} = "" unless exists($args{resource}); |
---|
1921 | |
---|
1922 | #------------------------------------------------------------------------- |
---|
1923 | # Create the SASLClient on our end |
---|
1924 | #------------------------------------------------------------------------- |
---|
1925 | my $sid = $self->{SESSION}->{id}; |
---|
1926 | my $status = |
---|
1927 | $self->{STREAM}->SASLClient($sid, |
---|
1928 | $args{username}, |
---|
1929 | $args{password} |
---|
1930 | ); |
---|
1931 | |
---|
1932 | $args{timeout} = "120" unless exists($args{timeout}); |
---|
1933 | |
---|
1934 | #------------------------------------------------------------------------- |
---|
1935 | # While we haven't timed out, keep waiting for the SASLClient to finish |
---|
1936 | #------------------------------------------------------------------------- |
---|
1937 | my $endTime = time + $args{timeout}; |
---|
1938 | while(!$self->{STREAM}->SASLClientDone($sid) && ($endTime >= time)) |
---|
1939 | { |
---|
1940 | $self->{DEBUG}->Log1("AuthSASL: haven't authed yet... let's wait."); |
---|
1941 | return unless (defined($self->Process(1))); |
---|
1942 | &{$self->{CB}->{update}}() if exists($self->{CB}->{update}); |
---|
1943 | } |
---|
1944 | |
---|
1945 | #------------------------------------------------------------------------- |
---|
1946 | # The loop finished... but was it done? |
---|
1947 | #------------------------------------------------------------------------- |
---|
1948 | if (!$self->{STREAM}->SASLClientDone($sid)) |
---|
1949 | { |
---|
1950 | $self->{DEBUG}->Log1("AuthSASL: timed out..."); |
---|
1951 | return( "system","SASL timed out authenticating"); |
---|
1952 | } |
---|
1953 | |
---|
1954 | #------------------------------------------------------------------------- |
---|
1955 | # Ok, it was done... but did we auth? |
---|
1956 | #------------------------------------------------------------------------- |
---|
1957 | if (!$self->{STREAM}->SASLClientAuthed($sid)) |
---|
1958 | { |
---|
1959 | $self->{DEBUG}->Log1("AuthSASL: Authentication failed."); |
---|
1960 | return ( "error", $self->{STREAM}->SASLClientError($sid)); |
---|
1961 | } |
---|
1962 | |
---|
1963 | #------------------------------------------------------------------------- |
---|
1964 | # Phew... Restart the <stream:stream> per XMPP |
---|
1965 | #------------------------------------------------------------------------- |
---|
1966 | $self->{DEBUG}->Log1("AuthSASL: We authed!"); |
---|
1967 | $self->{SESSION} = $self->{STREAM}->OpenStream($sid); |
---|
1968 | $sid = $self->{SESSION}->{id}; |
---|
1969 | |
---|
1970 | $self->{DEBUG}->Log1("AuthSASL: We got a new session. sid($sid)"); |
---|
1971 | |
---|
1972 | #------------------------------------------------------------------------- |
---|
1973 | # Look in the new set of <stream:feature/>s and see if xmpp-bind was |
---|
1974 | # offered. |
---|
1975 | #------------------------------------------------------------------------- |
---|
1976 | my $bind = $self->{STREAM}->GetStreamFeature($sid,"xmpp-bind"); |
---|
1977 | if ($bind) |
---|
1978 | { |
---|
1979 | $self->{DEBUG}->Log1("AuthSASL: Binding to resource"); |
---|
1980 | $self->BindResource($args{resource}); |
---|
1981 | } |
---|
1982 | |
---|
1983 | #------------------------------------------------------------------------- |
---|
1984 | # Look in the new set of <stream:feature/>s and see if xmpp-session was |
---|
1985 | # offered. |
---|
1986 | #------------------------------------------------------------------------- |
---|
1987 | my $session = $self->{STREAM}->GetStreamFeature($sid,"xmpp-session"); |
---|
1988 | if ($session) |
---|
1989 | { |
---|
1990 | $self->{DEBUG}->Log1("AuthSASL: Starting session"); |
---|
1991 | $self->StartSession(); |
---|
1992 | } |
---|
1993 | |
---|
1994 | return ("ok",""); |
---|
1995 | } |
---|
1996 | |
---|
1997 | |
---|
1998 | ############################################################################## |
---|
1999 | # |
---|
2000 | # BindResource - bind to a resource |
---|
2001 | # |
---|
2002 | ############################################################################## |
---|
2003 | sub BindResource |
---|
2004 | { |
---|
2005 | my $self = shift; |
---|
2006 | my $resource = shift; |
---|
2007 | |
---|
2008 | $self->{DEBUG}->Log2("BindResource: Binding to resource"); |
---|
2009 | my $iq = $self->_iq(); |
---|
2010 | |
---|
2011 | $iq->SetIQ(type=>"set"); |
---|
2012 | my $bind = $iq->NewChild(&ConstXMLNS("xmpp-bind")); |
---|
2013 | |
---|
2014 | if (defined($resource) && ($resource ne "")) |
---|
2015 | { |
---|
2016 | $self->{DEBUG}->Log2("BindResource: resource($resource)"); |
---|
2017 | $bind->SetBind(resource=>$resource); |
---|
2018 | } |
---|
2019 | |
---|
2020 | my $result = $self->SendAndReceiveWithID($iq); |
---|
2021 | } |
---|
2022 | |
---|
2023 | |
---|
2024 | ############################################################################## |
---|
2025 | # |
---|
2026 | # StartSession - Initialize a session |
---|
2027 | # |
---|
2028 | ############################################################################## |
---|
2029 | sub StartSession |
---|
2030 | { |
---|
2031 | my $self = shift; |
---|
2032 | |
---|
2033 | my $iq = $self->_iq(); |
---|
2034 | |
---|
2035 | $iq->SetIQ(type=>"set"); |
---|
2036 | my $session = $iq->NewChild(&ConstXMLNS("xmpp-session")); |
---|
2037 | |
---|
2038 | my $result = $self->SendAndReceiveWithID($iq); |
---|
2039 | } |
---|
2040 | |
---|
2041 | |
---|
2042 | ############################################################################## |
---|
2043 | # |
---|
2044 | # PrivacyLists - Initialize a Net::XMPP::PrivacyLists object and return it. |
---|
2045 | # |
---|
2046 | ############################################################################## |
---|
2047 | sub PrivacyLists |
---|
2048 | { |
---|
2049 | my $self = shift; |
---|
2050 | |
---|
2051 | return Net::XMPP::PrivacyLists->new(connection=>$self); |
---|
2052 | } |
---|
2053 | |
---|
2054 | |
---|
2055 | ############################################################################## |
---|
2056 | # |
---|
2057 | # PrivacyListsGet - Sends an empty IQ to the server to request that the user's |
---|
2058 | # Privacy Lists be sent to them. Returns the iq packet |
---|
2059 | # of the result. |
---|
2060 | # |
---|
2061 | ############################################################################## |
---|
2062 | sub PrivacyListsGet |
---|
2063 | { |
---|
2064 | my $self = shift; |
---|
2065 | my %args; |
---|
2066 | while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
---|
2067 | |
---|
2068 | my $iq = $self->_iq(); |
---|
2069 | $iq->SetIQ(type=>"get"); |
---|
2070 | my $query = $iq->NewChild("jabber:iq:privacy"); |
---|
2071 | |
---|
2072 | if (exists($args{list})) |
---|
2073 | { |
---|
2074 | $query->AddList(name=>$args{list}); |
---|
2075 | } |
---|
2076 | |
---|
2077 | $iq = $self->SendAndReceiveWithID($iq); |
---|
2078 | return unless defined($iq); |
---|
2079 | |
---|
2080 | return $iq; |
---|
2081 | } |
---|
2082 | |
---|
2083 | |
---|
2084 | ############################################################################## |
---|
2085 | # |
---|
2086 | # PrivacyListsRequest - Sends an empty IQ to the server to request that the |
---|
2087 | # user's privacy lists be sent to them, and return to |
---|
2088 | # let the user's program handle parsing the return packet. |
---|
2089 | # |
---|
2090 | ############################################################################## |
---|
2091 | sub PrivacyListsRequest |
---|
2092 | { |
---|
2093 | my $self = shift; |
---|
2094 | my %args; |
---|
2095 | while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
---|
2096 | |
---|
2097 | my $iq = $self->_iq(); |
---|
2098 | $iq->SetIQ(type=>"get"); |
---|
2099 | my $query = $iq->NewChild("jabber:iq:privacy"); |
---|
2100 | |
---|
2101 | if (exists($args{list})) |
---|
2102 | { |
---|
2103 | $query->AddList(name=>$args{list}); |
---|
2104 | } |
---|
2105 | |
---|
2106 | $self->Send($iq); |
---|
2107 | } |
---|
2108 | |
---|
2109 | |
---|
2110 | ############################################################################## |
---|
2111 | # |
---|
2112 | # PrivacyListsSet - Sends an empty IQ to the server to request that the |
---|
2113 | # user's privacy lists be sent to them, and return to |
---|
2114 | # let the user's program handle parsing the return packet. |
---|
2115 | # |
---|
2116 | ############################################################################## |
---|
2117 | sub PrivacyListsSet |
---|
2118 | { |
---|
2119 | my $self = shift; |
---|
2120 | my %args; |
---|
2121 | while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
---|
2122 | |
---|
2123 | my $iq = $self->_iq(); |
---|
2124 | $iq->SetIQ(type=>"set"); |
---|
2125 | my $query = $iq->NewChild("jabber:iq:privacy"); |
---|
2126 | |
---|
2127 | #XXX error check that there is a list |
---|
2128 | my $list = $query->AddList(name=>$args{list}); |
---|
2129 | |
---|
2130 | foreach my $item (@{$args{items}}) |
---|
2131 | { |
---|
2132 | $list->AddItem(%{$item}); |
---|
2133 | } |
---|
2134 | |
---|
2135 | $iq = $self->SendAndReceiveWithID($iq); |
---|
2136 | return unless defined($iq); |
---|
2137 | |
---|
2138 | return if $iq->DefinedError(); |
---|
2139 | |
---|
2140 | return 1; |
---|
2141 | } |
---|
2142 | |
---|
2143 | |
---|
2144 | ############################################################################### |
---|
2145 | # |
---|
2146 | # RegisterRequest - This is a self contained function to send an iq tag |
---|
2147 | # an id that requests the target address to send back |
---|
2148 | # the required fields. It waits for a reply what the |
---|
2149 | # same id to come back and tell the caller what the |
---|
2150 | # fields are. |
---|
2151 | # |
---|
2152 | ############################################################################### |
---|
2153 | sub RegisterRequest |
---|
2154 | { |
---|
2155 | my $self = shift; |
---|
2156 | my %args; |
---|
2157 | $args{mode} = "block"; |
---|
2158 | while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
---|
2159 | |
---|
2160 | my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef; |
---|
2161 | |
---|
2162 | #-------------------------------------------------------------------------- |
---|
2163 | # Create a Net::XMPP::IQ object to send to the server |
---|
2164 | #-------------------------------------------------------------------------- |
---|
2165 | my $iq = $self->_iq(); |
---|
2166 | $iq->SetIQ(to=>delete($args{to})) if exists($args{to}); |
---|
2167 | $iq->SetIQ(type=>"get"); |
---|
2168 | my $query = $iq->NewChild("jabber:iq:register"); |
---|
2169 | |
---|
2170 | #-------------------------------------------------------------------------- |
---|
2171 | # Send the IQ with the next available ID and wait for a reply with that |
---|
2172 | # id to be received. Then grab the IQ reply. |
---|
2173 | #-------------------------------------------------------------------------- |
---|
2174 | if ($args{mode} eq "passthru") |
---|
2175 | { |
---|
2176 | my $id = $self->UniqueID(); |
---|
2177 | $iq->SetIQ(id=>$id); |
---|
2178 | $self->Send($iq); |
---|
2179 | return $id; |
---|
2180 | } |
---|
2181 | |
---|
2182 | return $self->SendWithID($iq) if ($args{mode} eq "nonblock"); |
---|
2183 | |
---|
2184 | $iq = $self->SendAndReceiveWithID($iq,$timeout); |
---|
2185 | |
---|
2186 | #-------------------------------------------------------------------------- |
---|
2187 | # Check if there was an error. |
---|
2188 | #-------------------------------------------------------------------------- |
---|
2189 | return unless defined($iq); |
---|
2190 | if ($iq->GetType() eq "error") |
---|
2191 | { |
---|
2192 | $self->SetErrorCode($iq->GetErrorCode().": ".$iq->GetError()); |
---|
2193 | return; |
---|
2194 | } |
---|
2195 | |
---|
2196 | my %register; |
---|
2197 | #-------------------------------------------------------------------------- |
---|
2198 | # From the reply IQ determine what fields are required and send a hash |
---|
2199 | # back with the fields and any values that are already defined (like key) |
---|
2200 | #-------------------------------------------------------------------------- |
---|
2201 | $query = $iq->GetChild(); |
---|
2202 | $register{fields} = { $query->GetRegister() }; |
---|
2203 | |
---|
2204 | return %register; |
---|
2205 | } |
---|
2206 | |
---|
2207 | |
---|
2208 | ############################################################################### |
---|
2209 | # |
---|
2210 | # RegisterSend - This is a self contained function to send a registration |
---|
2211 | # iq tag with an id. Then wait for a reply what the same |
---|
2212 | # id to come back and tell the caller what the result was. |
---|
2213 | # |
---|
2214 | ############################################################################### |
---|
2215 | sub RegisterSend |
---|
2216 | { |
---|
2217 | my $self = shift; |
---|
2218 | my %args; |
---|
2219 | while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
---|
2220 | |
---|
2221 | #-------------------------------------------------------------------------- |
---|
2222 | # Create a Net::XMPP::IQ object to send to the server |
---|
2223 | #-------------------------------------------------------------------------- |
---|
2224 | my $iq = $self->_iq(); |
---|
2225 | $iq->SetIQ(to=>delete($args{to})) if exists($args{to}); |
---|
2226 | $iq->SetIQ(type=>"set"); |
---|
2227 | my $iqRegister = $iq->NewChild("jabber:iq:register"); |
---|
2228 | $iqRegister->SetRegister(%args); |
---|
2229 | |
---|
2230 | #-------------------------------------------------------------------------- |
---|
2231 | # Send the IQ with the next available ID and wait for a reply with that |
---|
2232 | # id to be received. Then grab the IQ reply. |
---|
2233 | #-------------------------------------------------------------------------- |
---|
2234 | $iq = $self->SendAndReceiveWithID($iq); |
---|
2235 | |
---|
2236 | #-------------------------------------------------------------------------- |
---|
2237 | # From the reply IQ determine if we were successful or not. If yes then |
---|
2238 | # return "". If no then return error string from the reply. |
---|
2239 | #-------------------------------------------------------------------------- |
---|
2240 | return unless defined($iq); |
---|
2241 | return ( $iq->GetErrorCode() , $iq->GetError() ) |
---|
2242 | if ($iq->GetType() eq "error"); |
---|
2243 | return ("ok",""); |
---|
2244 | } |
---|
2245 | |
---|
2246 | |
---|
2247 | ############################################################################## |
---|
2248 | # |
---|
2249 | # RosterAdd - Takes the Jabber ID of the user to add to their Roster and |
---|
2250 | # sends the IQ packet to the server. |
---|
2251 | # |
---|
2252 | ############################################################################## |
---|
2253 | sub RosterAdd |
---|
2254 | { |
---|
2255 | my $self = shift; |
---|
2256 | my %args; |
---|
2257 | while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
---|
2258 | |
---|
2259 | my $iq = $self->_iq(); |
---|
2260 | $iq->SetIQ(type=>"set"); |
---|
2261 | my $roster = $iq->NewChild("jabber:iq:roster"); |
---|
2262 | my $item = $roster->AddItem(); |
---|
2263 | $item->SetItem(%args); |
---|
2264 | |
---|
2265 | $self->{DEBUG}->Log1("RosterAdd: xml(",$iq->GetXML(),")"); |
---|
2266 | $self->Send($iq); |
---|
2267 | } |
---|
2268 | |
---|
2269 | |
---|
2270 | ############################################################################## |
---|
2271 | # |
---|
2272 | # RosterAdd - Takes the Jabber ID of the user to remove from their Roster |
---|
2273 | # and sends the IQ packet to the server. |
---|
2274 | # |
---|
2275 | ############################################################################## |
---|
2276 | sub RosterRemove |
---|
2277 | { |
---|
2278 | my $self = shift; |
---|
2279 | my %args; |
---|
2280 | while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
---|
2281 | delete($args{subscription}); |
---|
2282 | |
---|
2283 | my $iq = $self->_iq(); |
---|
2284 | $iq->SetIQ(type=>"set"); |
---|
2285 | my $roster = $iq->NewChild("jabber:iq:roster"); |
---|
2286 | my $item = $roster->AddItem(); |
---|
2287 | $item->SetItem(%args, |
---|
2288 | subscription=>"remove"); |
---|
2289 | $self->Send($iq); |
---|
2290 | } |
---|
2291 | |
---|
2292 | |
---|
2293 | ############################################################################## |
---|
2294 | # |
---|
2295 | # RosterParse - Returns a hash of roster items. |
---|
2296 | # |
---|
2297 | ############################################################################## |
---|
2298 | sub RosterParse |
---|
2299 | { |
---|
2300 | my $self = shift; |
---|
2301 | my($iq) = @_; |
---|
2302 | |
---|
2303 | my %roster; |
---|
2304 | my $query = $iq->GetChild("jabber:iq:roster"); |
---|
2305 | |
---|
2306 | if (defined($query)) #$query->GetXMLNS() eq "jabber:iq:roster") |
---|
2307 | { |
---|
2308 | my @items = $query->GetItems(); |
---|
2309 | |
---|
2310 | foreach my $item (@items) |
---|
2311 | { |
---|
2312 | my $jid = $item->GetJID(); |
---|
2313 | $roster{$jid}->{name} = $item->GetName(); |
---|
2314 | $roster{$jid}->{subscription} = $item->GetSubscription(); |
---|
2315 | $roster{$jid}->{ask} = $item->GetAsk(); |
---|
2316 | $roster{$jid}->{groups} = [ $item->GetGroup() ]; |
---|
2317 | } |
---|
2318 | } |
---|
2319 | |
---|
2320 | return %roster; |
---|
2321 | } |
---|
2322 | |
---|
2323 | |
---|
2324 | ############################################################################## |
---|
2325 | # |
---|
2326 | # RosterGet - Sends an empty IQ to the server to request that the user's |
---|
2327 | # Roster be sent to them. Returns a hash of roster items. |
---|
2328 | # |
---|
2329 | ############################################################################## |
---|
2330 | sub RosterGet |
---|
2331 | { |
---|
2332 | my $self = shift; |
---|
2333 | |
---|
2334 | my $iq = $self->_iq(); |
---|
2335 | $iq->SetIQ(type=>"get"); |
---|
2336 | my $query = $iq->NewChild("jabber:iq:roster"); |
---|
2337 | |
---|
2338 | $iq = $self->SendAndReceiveWithID($iq); |
---|
2339 | |
---|
2340 | return unless defined($iq); |
---|
2341 | |
---|
2342 | return $self->RosterParse($iq); |
---|
2343 | } |
---|
2344 | |
---|
2345 | |
---|
2346 | ############################################################################## |
---|
2347 | # |
---|
2348 | # RosterRequest - Sends an empty IQ to the server to request that the user's |
---|
2349 | # Roster be sent to them, and return to let the user's program |
---|
2350 | # handle parsing the return packet. |
---|
2351 | # |
---|
2352 | ############################################################################## |
---|
2353 | sub RosterRequest |
---|
2354 | { |
---|
2355 | my $self = shift; |
---|
2356 | |
---|
2357 | my $iq = $self->_iq(); |
---|
2358 | $iq->SetIQ(type=>"get"); |
---|
2359 | my $query = $iq->NewChild("jabber:iq:roster"); |
---|
2360 | |
---|
2361 | $self->Send($iq); |
---|
2362 | } |
---|
2363 | |
---|
2364 | |
---|
2365 | ############################################################################## |
---|
2366 | # |
---|
2367 | # Roster - Initialize a Net::XMPP::Roster object and return it. |
---|
2368 | # |
---|
2369 | ############################################################################## |
---|
2370 | sub Roster |
---|
2371 | { |
---|
2372 | my $self = shift; |
---|
2373 | |
---|
2374 | return Net::XMPP::Roster->new(connection=>$self); |
---|
2375 | } |
---|
2376 | |
---|
2377 | |
---|
2378 | ############################################################################## |
---|
2379 | # |
---|
2380 | # RosterDB - initialize the module to use the roster database |
---|
2381 | # |
---|
2382 | ############################################################################## |
---|
2383 | sub RosterDB |
---|
2384 | { |
---|
2385 | my $self = shift; |
---|
2386 | |
---|
2387 | $self->SetXPathCallBacks('/iq[@type="result" or @type="set"]/query[@xmlns="jabber:iq:roster"]'=>sub{ shift; $self->RosterDBParse(@_) }); |
---|
2388 | } |
---|
2389 | |
---|
2390 | |
---|
2391 | ############################################################################## |
---|
2392 | # |
---|
2393 | # RosterDBAdd - adds the entry to the Roster DB. |
---|
2394 | # |
---|
2395 | ############################################################################## |
---|
2396 | sub RosterDBAdd |
---|
2397 | { |
---|
2398 | my $self = shift; |
---|
2399 | my ($jid,%item) = @_; |
---|
2400 | |
---|
2401 | $self->{ROSTERDB}->{JIDS}->{$jid} = \%item; |
---|
2402 | |
---|
2403 | foreach my $group (@{$item{groups}}) |
---|
2404 | { |
---|
2405 | $self->{ROSTERDB}->{GROUPS}->{$group}->{$jid} = 1; |
---|
2406 | } |
---|
2407 | } |
---|
2408 | |
---|
2409 | |
---|
2410 | ############################################################################### |
---|
2411 | # |
---|
2412 | # RosterDBClear - delete all of the JIDs from the DB completely. |
---|
2413 | # |
---|
2414 | ############################################################################### |
---|
2415 | sub RosterDBClear |
---|
2416 | { |
---|
2417 | my $self = shift; |
---|
2418 | |
---|
2419 | $self->{DEBUG}->Log1("RosterDBClear: clearing the database"); |
---|
2420 | foreach my $jid ($self->RosterDBJIDs()) |
---|
2421 | { |
---|
2422 | $self->{DEBUG}->Log3("RosterDBClear: deleting ",$jid->GetJID()," from the DB"); |
---|
2423 | $self->RosterDBRemove($jid); |
---|
2424 | } |
---|
2425 | $self->{DEBUG}->Log3("RosterDBClear: database is empty"); |
---|
2426 | } |
---|
2427 | |
---|
2428 | |
---|
2429 | ############################################################################## |
---|
2430 | # |
---|
2431 | # RosterDBExists - allows you to query if the JID exists in the Roster DB. |
---|
2432 | # |
---|
2433 | ############################################################################## |
---|
2434 | sub RosterDBExists |
---|
2435 | { |
---|
2436 | my $self = shift; |
---|
2437 | my ($jid) = @_; |
---|
2438 | |
---|
2439 | if ($jid->isa("Net::XMPP::JID")) |
---|
2440 | { |
---|
2441 | $jid = $jid->GetJID(); |
---|
2442 | } |
---|
2443 | |
---|
2444 | return unless exists($self->{ROSTERDB}); |
---|
2445 | return unless exists($self->{ROSTERDB}->{JIDS}); |
---|
2446 | return unless exists($self->{ROSTERDB}->{JIDS}->{$jid}); |
---|
2447 | return 1; |
---|
2448 | } |
---|
2449 | |
---|
2450 | |
---|
2451 | ############################################################################## |
---|
2452 | # |
---|
2453 | # RosterDBGroupExists - allows you to query if the group exists in the Roster |
---|
2454 | # DB. |
---|
2455 | # |
---|
2456 | ############################################################################## |
---|
2457 | sub RosterDBGroupExists |
---|
2458 | { |
---|
2459 | my $self = shift; |
---|
2460 | my ($group) = @_; |
---|
2461 | |
---|
2462 | return unless exists($self->{ROSTERDB}); |
---|
2463 | return unless exists($self->{ROSTERDB}->{GROUPS}); |
---|
2464 | return unless exists($self->{ROSTERDB}->{GROUPS}->{$group}); |
---|
2465 | return 1; |
---|
2466 | } |
---|
2467 | |
---|
2468 | |
---|
2469 | ############################################################################## |
---|
2470 | # |
---|
2471 | # RosterDBGroupJIDs - returns a list of the current groups in your roster. |
---|
2472 | # |
---|
2473 | ############################################################################## |
---|
2474 | sub RosterDBGroupJIDs |
---|
2475 | { |
---|
2476 | my $self = shift; |
---|
2477 | my $group = shift; |
---|
2478 | |
---|
2479 | return unless $self->RosterDBGroupExists($group); |
---|
2480 | my @jids; |
---|
2481 | foreach my $jid (keys(%{$self->{ROSTERDB}->{GROUPS}->{$group}})) |
---|
2482 | { |
---|
2483 | push(@jids,$self->_jid($jid)); |
---|
2484 | } |
---|
2485 | return @jids; |
---|
2486 | } |
---|
2487 | |
---|
2488 | |
---|
2489 | ############################################################################## |
---|
2490 | # |
---|
2491 | # RosterDBGroups - returns a list of the current groups in your roster. |
---|
2492 | # |
---|
2493 | ############################################################################## |
---|
2494 | sub RosterDBGroups |
---|
2495 | { |
---|
2496 | my $self = shift; |
---|
2497 | |
---|
2498 | return () unless exists($self->{ROSTERDB}->{GROUPS}); |
---|
2499 | return () if (scalar(keys(%{$self->{ROSTERDB}->{GROUPS}})) == 0); |
---|
2500 | return keys(%{$self->{ROSTERDB}->{GROUPS}}); |
---|
2501 | } |
---|
2502 | |
---|
2503 | |
---|
2504 | ############################################################################## |
---|
2505 | # |
---|
2506 | # RosterDBJIDs - returns a list of all of the JIDs in your roster. |
---|
2507 | # |
---|
2508 | ############################################################################## |
---|
2509 | sub RosterDBJIDs |
---|
2510 | { |
---|
2511 | my $self = shift; |
---|
2512 | my $group = shift; |
---|
2513 | |
---|
2514 | my @jids; |
---|
2515 | |
---|
2516 | return () unless exists($self->{ROSTERDB}); |
---|
2517 | return () unless exists($self->{ROSTERDB}->{JIDS}); |
---|
2518 | foreach my $jid (keys(%{$self->{ROSTERDB}->{JIDS}})) |
---|
2519 | { |
---|
2520 | push(@jids,$self->_jid($jid)); |
---|
2521 | } |
---|
2522 | return @jids; |
---|
2523 | } |
---|
2524 | |
---|
2525 | |
---|
2526 | ############################################################################## |
---|
2527 | # |
---|
2528 | # RosterDBNonGroupJIDs - returns a list of the JIDs not in a group. |
---|
2529 | # |
---|
2530 | ############################################################################## |
---|
2531 | sub RosterDBNonGroupJIDs |
---|
2532 | { |
---|
2533 | my $self = shift; |
---|
2534 | my $group = shift; |
---|
2535 | |
---|
2536 | my @jids; |
---|
2537 | |
---|
2538 | return () unless exists($self->{ROSTERDB}); |
---|
2539 | return () unless exists($self->{ROSTERDB}->{JIDS}); |
---|
2540 | foreach my $jid (keys(%{$self->{ROSTERDB}->{JIDS}})) |
---|
2541 | { |
---|
2542 | next if (exists($self->{ROSTERDB}->{JIDS}->{$jid}->{groups}) && |
---|
2543 | ($#{$self->{ROSTERDB}->{JIDS}->{$jid}->{groups}} > -1)); |
---|
2544 | |
---|
2545 | push(@jids,$self->_jid($jid)); |
---|
2546 | } |
---|
2547 | return @jids; |
---|
2548 | } |
---|
2549 | |
---|
2550 | |
---|
2551 | ############################################################################## |
---|
2552 | # |
---|
2553 | # RosterDBParse - takes an iq packet that containsa roster, parses it, and puts |
---|
2554 | # the roster into the Roster DB. |
---|
2555 | # |
---|
2556 | ############################################################################## |
---|
2557 | sub RosterDBParse |
---|
2558 | { |
---|
2559 | my $self = shift; |
---|
2560 | my ($iq) = @_; |
---|
2561 | |
---|
2562 | #print "RosterDBParse: iq(",$iq->GetXML(),")\n"; |
---|
2563 | |
---|
2564 | my $type = $iq->GetType(); |
---|
2565 | return unless (($type eq "set") || ($type eq "result")); |
---|
2566 | |
---|
2567 | my %newroster = $self->RosterParse($iq); |
---|
2568 | |
---|
2569 | $self->RosterDBProcessParsed(%newroster); |
---|
2570 | } |
---|
2571 | |
---|
2572 | |
---|
2573 | ############################################################################## |
---|
2574 | # |
---|
2575 | # RosterDBProcessParsed - takes a parsed roster and puts it into the Roster DB. |
---|
2576 | # |
---|
2577 | ############################################################################## |
---|
2578 | sub RosterDBProcessParsed |
---|
2579 | { |
---|
2580 | my $self = shift; |
---|
2581 | my (%roster) = @_; |
---|
2582 | |
---|
2583 | foreach my $jid (keys(%roster)) |
---|
2584 | { |
---|
2585 | $self->RosterDBRemove($jid); |
---|
2586 | |
---|
2587 | if ($roster{$jid}->{subscription} ne "remove") |
---|
2588 | { |
---|
2589 | $self->RosterDBAdd($jid, %{$roster{$jid}} ); |
---|
2590 | } |
---|
2591 | } |
---|
2592 | } |
---|
2593 | |
---|
2594 | |
---|
2595 | ############################################################################## |
---|
2596 | # |
---|
2597 | # RosterDBQuery - allows you to get one of the pieces of info from the |
---|
2598 | # Roster DB. |
---|
2599 | # |
---|
2600 | ############################################################################## |
---|
2601 | sub RosterDBQuery |
---|
2602 | { |
---|
2603 | my $self = shift; |
---|
2604 | my $jid = shift; |
---|
2605 | my $key = shift; |
---|
2606 | |
---|
2607 | if ($jid->isa("Net::XMPP::JID")) |
---|
2608 | { |
---|
2609 | $jid = $jid->GetJID(); |
---|
2610 | } |
---|
2611 | |
---|
2612 | return unless $self->RosterDBExists($jid); |
---|
2613 | if (defined($key)) |
---|
2614 | { |
---|
2615 | return unless exists($self->{ROSTERDB}->{JIDS}->{$jid}->{$key}); |
---|
2616 | return $self->{ROSTERDB}->{JIDS}->{$jid}->{$key}; |
---|
2617 | } |
---|
2618 | return %{$self->{ROSTERDB}->{JIDS}->{$jid}}; |
---|
2619 | } |
---|
2620 | |
---|
2621 | |
---|
2622 | ############################################################################## |
---|
2623 | # |
---|
2624 | # RosterDBRemove - removes the JID from the Roster DB. |
---|
2625 | # |
---|
2626 | ############################################################################## |
---|
2627 | sub RosterDBRemove |
---|
2628 | { |
---|
2629 | my $self = shift; |
---|
2630 | my ($jid) = @_; |
---|
2631 | |
---|
2632 | if ($self->RosterDBExists($jid)) |
---|
2633 | { |
---|
2634 | if (defined($self->RosterDBQuery($jid,"groups"))) |
---|
2635 | { |
---|
2636 | foreach my $group (@{$self->RosterDBQuery($jid,"groups")}) |
---|
2637 | { |
---|
2638 | delete($self->{ROSTERDB}->{GROUPS}->{$group}->{$jid}); |
---|
2639 | delete($self->{ROSTERDB}->{GROUPS}->{$group}) |
---|
2640 | if (scalar(keys(%{$self->{ROSTERDB}->{GROUPS}->{$group}})) == 0); |
---|
2641 | delete($self->{ROSTERDB}->{GROUPS}) |
---|
2642 | if (scalar(keys(%{$self->{ROSTERDB}->{GROUPS}})) == 0); |
---|
2643 | } |
---|
2644 | } |
---|
2645 | |
---|
2646 | delete($self->{ROSTERDB}->{JIDS}->{$jid}); |
---|
2647 | } |
---|
2648 | } |
---|
2649 | |
---|
2650 | |
---|
2651 | |
---|
2652 | |
---|
2653 | ############################################################################## |
---|
2654 | #+---------------------------------------------------------------------------- |
---|
2655 | #| |
---|
2656 | #| TLS Functions |
---|
2657 | #| |
---|
2658 | #+---------------------------------------------------------------------------- |
---|
2659 | ############################################################################## |
---|
2660 | |
---|
2661 | ############################################################################## |
---|
2662 | # |
---|
2663 | # TLSInit - Initialize the connection for TLS. |
---|
2664 | # |
---|
2665 | ############################################################################## |
---|
2666 | sub TLSInit |
---|
2667 | { |
---|
2668 | my $self = shift; |
---|
2669 | |
---|
2670 | $TLS_CALLBACK = sub{ $self->ProcessTLSStanza( @_ ) }; |
---|
2671 | $self->SetDirectXPathCallBacks('/[@xmlns="'.&ConstXMLNS("xmpp-tls").'"]'=>$TLS_CALLBACK); |
---|
2672 | } |
---|
2673 | |
---|
2674 | |
---|
2675 | ############################################################################## |
---|
2676 | # |
---|
2677 | # ProcessTLSStanza - process a TLS based packet. |
---|
2678 | # |
---|
2679 | ############################################################################## |
---|
2680 | sub ProcessTLSStanza |
---|
2681 | { |
---|
2682 | my $self = shift; |
---|
2683 | my $sid = shift; |
---|
2684 | my $node = shift; |
---|
2685 | |
---|
2686 | my $tag = &XML::Stream::XPath($node,"name()"); |
---|
2687 | |
---|
2688 | if ($tag eq "failure") |
---|
2689 | { |
---|
2690 | $self->TLSClientFailure($node); |
---|
2691 | } |
---|
2692 | |
---|
2693 | if ($tag eq "proceed") |
---|
2694 | { |
---|
2695 | $self->TLSClientProceed($node); |
---|
2696 | } |
---|
2697 | } |
---|
2698 | |
---|
2699 | |
---|
2700 | ############################################################################## |
---|
2701 | # |
---|
2702 | # TLSStart - client function to have the socket start TLS. |
---|
2703 | # |
---|
2704 | ############################################################################## |
---|
2705 | sub TLSStart |
---|
2706 | { |
---|
2707 | my $self = shift; |
---|
2708 | my $timeout = shift; |
---|
2709 | $timeout = 120 unless defined($timeout); |
---|
2710 | $timeout = 120 if ($timeout eq ""); |
---|
2711 | |
---|
2712 | $self->TLSSendStartTLS(); |
---|
2713 | |
---|
2714 | my $endTime = time + $timeout; |
---|
2715 | while(!$self->TLSClientDone() && ($endTime >= time)) |
---|
2716 | { |
---|
2717 | $self->Process(); |
---|
2718 | } |
---|
2719 | |
---|
2720 | if (!$self->TLSClientSecure()) |
---|
2721 | { |
---|
2722 | return; |
---|
2723 | } |
---|
2724 | |
---|
2725 | $self->RestartStream($timeout); |
---|
2726 | } |
---|
2727 | |
---|
2728 | |
---|
2729 | ############################################################################## |
---|
2730 | # |
---|
2731 | # TLSClientProceed - handle a <proceed/> packet. |
---|
2732 | # |
---|
2733 | ############################################################################## |
---|
2734 | sub TLSClientProceed |
---|
2735 | { |
---|
2736 | my $self = shift; |
---|
2737 | my $node = shift; |
---|
2738 | |
---|
2739 | my ($status,$message) = $self->{STREAM}->StartTLS($self->GetStreamID()); |
---|
2740 | |
---|
2741 | if ($status) |
---|
2742 | { |
---|
2743 | $self->{TLS}->{done} = 1; |
---|
2744 | $self->{TLS}->{secure} = 1; |
---|
2745 | } |
---|
2746 | else |
---|
2747 | { |
---|
2748 | $self->{TLS}->{done} = 1; |
---|
2749 | $self->{TLS}->{error} = $message; |
---|
2750 | } |
---|
2751 | |
---|
2752 | $self->RemoveDirectXPathCallBacks('/[@xmlns="'.&ConstXMLNS("xmpp-tls").'"]'=>$TLS_CALLBACK); |
---|
2753 | } |
---|
2754 | |
---|
2755 | |
---|
2756 | ############################################################################## |
---|
2757 | # |
---|
2758 | # TLSClientSecure - return 1 if the socket is secure, 0 otherwise. |
---|
2759 | # |
---|
2760 | ############################################################################## |
---|
2761 | sub TLSClientSecure |
---|
2762 | { |
---|
2763 | my $self = shift; |
---|
2764 | |
---|
2765 | return $self->{TLS}->{secure}; |
---|
2766 | } |
---|
2767 | |
---|
2768 | |
---|
2769 | ############################################################################## |
---|
2770 | # |
---|
2771 | # TLSClientDone - return 1 if the TLS process is done |
---|
2772 | # |
---|
2773 | ############################################################################## |
---|
2774 | sub TLSClientDone |
---|
2775 | { |
---|
2776 | my $self = shift; |
---|
2777 | |
---|
2778 | return $self->{TLS}->{done}; |
---|
2779 | } |
---|
2780 | |
---|
2781 | |
---|
2782 | ############################################################################## |
---|
2783 | # |
---|
2784 | # TLSClientError - return the TLS error if any |
---|
2785 | # |
---|
2786 | ############################################################################## |
---|
2787 | sub TLSClientError |
---|
2788 | { |
---|
2789 | my $self = shift; |
---|
2790 | |
---|
2791 | return $self->{TLS}->{error}; |
---|
2792 | } |
---|
2793 | |
---|
2794 | |
---|
2795 | ############################################################################## |
---|
2796 | # |
---|
2797 | # TLSClientFailure - handle a <failure/> |
---|
2798 | # |
---|
2799 | ############################################################################## |
---|
2800 | sub TLSClientFailure |
---|
2801 | { |
---|
2802 | my $self = shift; |
---|
2803 | my $node = shift; |
---|
2804 | |
---|
2805 | my $type = &XML::Stream::XPath($node,"*/name()"); |
---|
2806 | |
---|
2807 | $self->{TLS}->{error} = $type; |
---|
2808 | $self->{TLS}->{done} = 1; |
---|
2809 | } |
---|
2810 | |
---|
2811 | |
---|
2812 | ############################################################################## |
---|
2813 | # |
---|
2814 | # TLSSendFailure - Send a <failure/> in the TLS namespace |
---|
2815 | # |
---|
2816 | ############################################################################## |
---|
2817 | sub TLSSendFailure |
---|
2818 | { |
---|
2819 | my $self = shift; |
---|
2820 | my $type = shift; |
---|
2821 | |
---|
2822 | $self->Send("<failure xmlns='".&ConstXMLNS('xmpp-tls')."'><${type}/></failure>"); |
---|
2823 | } |
---|
2824 | |
---|
2825 | |
---|
2826 | ############################################################################## |
---|
2827 | # |
---|
2828 | # TLSSendStartTLS - send a <starttls/> in the TLS namespace. |
---|
2829 | # |
---|
2830 | ############################################################################## |
---|
2831 | sub TLSSendStartTLS |
---|
2832 | { |
---|
2833 | my $self = shift; |
---|
2834 | |
---|
2835 | $self->Send("<starttls xmlns='".&ConstXMLNS('xmpp-tls')."'/>"); |
---|
2836 | } |
---|
2837 | |
---|
2838 | |
---|
2839 | |
---|
2840 | |
---|
2841 | ############################################################################## |
---|
2842 | #+---------------------------------------------------------------------------- |
---|
2843 | #| |
---|
2844 | #| SASL Functions |
---|
2845 | #| |
---|
2846 | #+---------------------------------------------------------------------------- |
---|
2847 | ############################################################################## |
---|
2848 | |
---|
2849 | ############################################################################## |
---|
2850 | # |
---|
2851 | # SASLInit - Initialize the connection for SASL. |
---|
2852 | # |
---|
2853 | ############################################################################## |
---|
2854 | sub SASLInit |
---|
2855 | { |
---|
2856 | my $self = shift; |
---|
2857 | |
---|
2858 | $SASL_CALLBACK = sub{ $self->ProcessSASLStanza( @_ ) }; |
---|
2859 | $self->SetDirectXPathCallBacks('/[@xmlns="'.&ConstXMLNS("xmpp-sasl").'"]'=> $SASL_CALLBACK); |
---|
2860 | } |
---|
2861 | |
---|
2862 | |
---|
2863 | ############################################################################## |
---|
2864 | # |
---|
2865 | # ProcessSASLStanza - process a SASL based packet. |
---|
2866 | # |
---|
2867 | ############################################################################## |
---|
2868 | sub ProcessSASLStanza |
---|
2869 | { |
---|
2870 | my $self = shift; |
---|
2871 | my $sid = shift; |
---|
2872 | my $node = shift; |
---|
2873 | |
---|
2874 | my $tag = &XML::Stream::XPath($node,"name()"); |
---|
2875 | |
---|
2876 | if ($tag eq "challenge") |
---|
2877 | { |
---|
2878 | $self->SASLAnswerChallenge($node); |
---|
2879 | } |
---|
2880 | |
---|
2881 | if ($tag eq "failure") |
---|
2882 | { |
---|
2883 | $self->SASLClientFailure($node); |
---|
2884 | } |
---|
2885 | |
---|
2886 | if ($tag eq "success") |
---|
2887 | { |
---|
2888 | $self->SASLClientSuccess($node); |
---|
2889 | } |
---|
2890 | } |
---|
2891 | |
---|
2892 | |
---|
2893 | ############################################################################## |
---|
2894 | # |
---|
2895 | # SASLAnswerChallenge - when we get a <challenge/> we need to do the grunt |
---|
2896 | # work to return a <response/>. |
---|
2897 | # |
---|
2898 | ############################################################################## |
---|
2899 | sub SASLAnswerChallenge |
---|
2900 | { |
---|
2901 | my $self = shift; |
---|
2902 | my $node = shift; |
---|
2903 | |
---|
2904 | my $challenge64 = &XML::Stream::XPath($node,"text()"); |
---|
2905 | my $challenge = MIME::Base64::decode_base64($challenge64); |
---|
2906 | |
---|
2907 | my $response = $self->SASLGetClient()->client_step($challenge); |
---|
2908 | |
---|
2909 | my $response64 = MIME::Base64::encode_base64($response,""); |
---|
2910 | $self->SASLSendResponse($response64); |
---|
2911 | } |
---|
2912 | |
---|
2913 | |
---|
2914 | ############################################################################### |
---|
2915 | # |
---|
2916 | # SASLClient - This is a helper function to perform all of the required steps |
---|
2917 | # for doing SASL with the server. |
---|
2918 | # |
---|
2919 | ############################################################################### |
---|
2920 | sub SASLClient |
---|
2921 | { |
---|
2922 | my $self = shift; |
---|
2923 | my $username = shift; |
---|
2924 | my $password = shift; |
---|
2925 | |
---|
2926 | my $mechanisms = $self->GetStreamFeature("xmpp-sasl"); |
---|
2927 | |
---|
2928 | return unless defined($mechanisms); |
---|
2929 | |
---|
2930 | my $sasl = new Authen::SASL(mechanism=>join(" ",@{$mechanisms}), |
---|
2931 | callback=>{ user => $username, |
---|
2932 | pass => $password |
---|
2933 | } |
---|
2934 | ); |
---|
2935 | |
---|
2936 | $self->{SASL}->{client} = $sasl->client_new(); |
---|
2937 | $self->{SASL}->{username} = $username; |
---|
2938 | $self->{SASL}->{password} = $password; |
---|
2939 | $self->{SASL}->{authed} = 0; |
---|
2940 | $self->{SASL}->{done} = 0; |
---|
2941 | |
---|
2942 | $self->SASLSendAuth(); |
---|
2943 | } |
---|
2944 | |
---|
2945 | |
---|
2946 | ############################################################################## |
---|
2947 | # |
---|
2948 | # SASLClientAuthed - return 1 if we authed via SASL, 0 otherwise |
---|
2949 | # |
---|
2950 | ############################################################################## |
---|
2951 | sub SASLClientAuthed |
---|
2952 | { |
---|
2953 | my $self = shift; |
---|
2954 | |
---|
2955 | return $self->{SASL}->{authed}; |
---|
2956 | } |
---|
2957 | |
---|
2958 | |
---|
2959 | ############################################################################## |
---|
2960 | # |
---|
2961 | # SASLClientDone - return 1 if the SASL process is finished |
---|
2962 | # |
---|
2963 | ############################################################################## |
---|
2964 | sub SASLClientDone |
---|
2965 | { |
---|
2966 | my $self = shift; |
---|
2967 | |
---|
2968 | return $self->{SASL}->{done}; |
---|
2969 | } |
---|
2970 | |
---|
2971 | |
---|
2972 | ############################################################################## |
---|
2973 | # |
---|
2974 | # SASLClientError - return the error if any |
---|
2975 | # |
---|
2976 | ############################################################################## |
---|
2977 | sub SASLClientError |
---|
2978 | { |
---|
2979 | my $self = shift; |
---|
2980 | |
---|
2981 | return $self->{SASL}->{error}; |
---|
2982 | } |
---|
2983 | |
---|
2984 | |
---|
2985 | ############################################################################## |
---|
2986 | # |
---|
2987 | # SASLClientFailure - handle a received <failure/> |
---|
2988 | # |
---|
2989 | ############################################################################## |
---|
2990 | sub SASLClientFailure |
---|
2991 | { |
---|
2992 | my $self = shift; |
---|
2993 | my $node = shift; |
---|
2994 | |
---|
2995 | my $type = &XML::Stream::XPath($node,"*/name()"); |
---|
2996 | |
---|
2997 | $self->{SASL}->{error} = $type; |
---|
2998 | $self->{SASL}->{done} = 1; |
---|
2999 | } |
---|
3000 | |
---|
3001 | |
---|
3002 | ############################################################################## |
---|
3003 | # |
---|
3004 | # SASLClientSuccess - handle a received <success/> |
---|
3005 | # |
---|
3006 | ############################################################################## |
---|
3007 | sub SASLClientSuccess |
---|
3008 | { |
---|
3009 | my $self = shift; |
---|
3010 | my $node = shift; |
---|
3011 | |
---|
3012 | $self->{SASL}->{authed} = 1; |
---|
3013 | $self->{SASL}->{done} = 1; |
---|
3014 | |
---|
3015 | $self->RemoveDirectXPathCallBacks('/[@xmlns="'.&ConstXMLNS("xmpp-sasl").'"]'=>$SASL_CALLBACK); |
---|
3016 | } |
---|
3017 | |
---|
3018 | |
---|
3019 | ############################################################################### |
---|
3020 | # |
---|
3021 | # SASLGetClient - This is a helper function to return the SASL client object. |
---|
3022 | # |
---|
3023 | ############################################################################### |
---|
3024 | sub SASLGetClient |
---|
3025 | { |
---|
3026 | my $self = shift; |
---|
3027 | |
---|
3028 | return $self->{SASL}->{client}; |
---|
3029 | } |
---|
3030 | |
---|
3031 | |
---|
3032 | ############################################################################## |
---|
3033 | # |
---|
3034 | # SASLSendAuth - send an <auth/> in the SASL namespace |
---|
3035 | # |
---|
3036 | ############################################################################## |
---|
3037 | sub SASLSendAuth |
---|
3038 | { |
---|
3039 | my $self = shift; |
---|
3040 | |
---|
3041 | $self->Send("<auth xmlns='".&ConstXMLNS('xmpp-sasl')."' mechanism='".$self->SASLGetClient()->mechanism()."'/>"); |
---|
3042 | } |
---|
3043 | |
---|
3044 | |
---|
3045 | ############################################################################## |
---|
3046 | # |
---|
3047 | # SASLSendChallenge - Send a <challenge/> in the SASL namespace |
---|
3048 | # |
---|
3049 | ############################################################################## |
---|
3050 | sub SASLSendChallenge |
---|
3051 | { |
---|
3052 | my $self = shift; |
---|
3053 | my $challenge = shift; |
---|
3054 | |
---|
3055 | $self->Send("<challenge xmlns='".&ConstXMLNS('xmpp-sasl')."'>${challenge}</challenge>"); |
---|
3056 | } |
---|
3057 | |
---|
3058 | |
---|
3059 | ############################################################################## |
---|
3060 | # |
---|
3061 | # SASLSendFailure - Send a <failure/> tag in the SASL namespace |
---|
3062 | # |
---|
3063 | ############################################################################## |
---|
3064 | sub SASLSendFailure |
---|
3065 | { |
---|
3066 | my $self = shift; |
---|
3067 | my $type = shift; |
---|
3068 | |
---|
3069 | $self->Send("<failure xmlns='".&ConstXMLNS('xmpp-sasl')."'><${type}/></failure>"); |
---|
3070 | } |
---|
3071 | |
---|
3072 | |
---|
3073 | ############################################################################## |
---|
3074 | # |
---|
3075 | # SASLSendResponse - Send a <response/> tag in the SASL namespace |
---|
3076 | # |
---|
3077 | ############################################################################## |
---|
3078 | sub SASLSendResponse |
---|
3079 | { |
---|
3080 | my $self = shift; |
---|
3081 | my $response = shift; |
---|
3082 | |
---|
3083 | $self->Send("<response xmlns='".&ConstXMLNS('xmpp-sasl')."'>${response}</response>"); |
---|
3084 | } |
---|
3085 | |
---|
3086 | |
---|
3087 | |
---|
3088 | |
---|
3089 | ############################################################################## |
---|
3090 | #+---------------------------------------------------------------------------- |
---|
3091 | #| |
---|
3092 | #| Default CallBacks |
---|
3093 | #| |
---|
3094 | #+---------------------------------------------------------------------------- |
---|
3095 | ############################################################################## |
---|
3096 | |
---|
3097 | |
---|
3098 | ############################################################################## |
---|
3099 | # |
---|
3100 | # callbackInit - initialize the default callbacks |
---|
3101 | # |
---|
3102 | ############################################################################## |
---|
3103 | sub callbackInit |
---|
3104 | { |
---|
3105 | my $self = shift; |
---|
3106 | |
---|
3107 | $self->SetCallBacks(iq=>sub{ $self->callbackIQ(@_) }, |
---|
3108 | presence=>sub{ $self->callbackPresence(@_) }, |
---|
3109 | message=>sub{ $self->callbackMessage(@_) }, |
---|
3110 | ); |
---|
3111 | |
---|
3112 | $self->SetPresenceCallBacks(subscribe=>sub{ $self->callbackPresenceSubscribe(@_) }, |
---|
3113 | unsubscribe=>sub{ $self->callbackPresenceUnsubscribe(@_) }, |
---|
3114 | subscribed=>sub{ $self->callbackPresenceSubscribed(@_) }, |
---|
3115 | unsubscribed=>sub{ $self->callbackPresenceUnsubscribed(@_) }, |
---|
3116 | ); |
---|
3117 | |
---|
3118 | $self->TLSInit(); |
---|
3119 | $self->SASLInit(); |
---|
3120 | } |
---|
3121 | |
---|
3122 | |
---|
3123 | ############################################################################## |
---|
3124 | # |
---|
3125 | # callbackMessage - default callback for <message/> packets. |
---|
3126 | # |
---|
3127 | ############################################################################## |
---|
3128 | sub callbackMessage |
---|
3129 | { |
---|
3130 | my $self = shift; |
---|
3131 | my $sid = shift; |
---|
3132 | my $message = shift; |
---|
3133 | |
---|
3134 | my $type = "normal"; |
---|
3135 | $type = $message->GetType() if $message->DefinedType(); |
---|
3136 | |
---|
3137 | if (exists($self->{CB}->{Mess}->{$type}) && |
---|
3138 | (ref($self->{CB}->{Mess}->{$type}) eq "CODE")) |
---|
3139 | { |
---|
3140 | &{$self->{CB}->{Mess}->{$type}}($sid,$message); |
---|
3141 | } |
---|
3142 | } |
---|
3143 | |
---|
3144 | |
---|
3145 | ############################################################################## |
---|
3146 | # |
---|
3147 | # callbackPresence - default callback for <presence/> packets. |
---|
3148 | # |
---|
3149 | ############################################################################## |
---|
3150 | sub callbackPresence |
---|
3151 | { |
---|
3152 | my $self = shift; |
---|
3153 | my $sid = shift; |
---|
3154 | my $presence = shift; |
---|
3155 | |
---|
3156 | my $type = "available"; |
---|
3157 | $type = $presence->GetType() if $presence->DefinedType(); |
---|
3158 | |
---|
3159 | if (exists($self->{CB}->{Pres}->{$type}) && |
---|
3160 | (ref($self->{CB}->{Pres}->{$type}) eq "CODE")) |
---|
3161 | { |
---|
3162 | &{$self->{CB}->{Pres}->{$type}}($sid,$presence); |
---|
3163 | } |
---|
3164 | } |
---|
3165 | |
---|
3166 | |
---|
3167 | ############################################################################## |
---|
3168 | # |
---|
3169 | # callbackIQ - default callback for <iq/> packets. |
---|
3170 | # |
---|
3171 | ############################################################################## |
---|
3172 | sub callbackIQ |
---|
3173 | { |
---|
3174 | my $self = shift; |
---|
3175 | my $sid = shift; |
---|
3176 | my $iq = shift; |
---|
3177 | |
---|
3178 | return unless $iq->DefinedChild(); |
---|
3179 | my $query = $iq->GetChild(); |
---|
3180 | return unless defined($query); |
---|
3181 | |
---|
3182 | my $type = $iq->GetType(); |
---|
3183 | my $ns = $query->GetXMLNS(); |
---|
3184 | |
---|
3185 | if (exists($self->{CB}->{IQns}->{$ns}) && |
---|
3186 | (ref($self->{CB}->{IQns}->{$ns}) eq "CODE")) |
---|
3187 | { |
---|
3188 | &{$self->{CB}->{IQns}->{$ns}}($sid,$iq); |
---|
3189 | |
---|
3190 | } |
---|
3191 | elsif (exists($self->{CB}->{IQns}->{$ns}->{$type}) && |
---|
3192 | (ref($self->{CB}->{IQns}->{$ns}->{$type}) eq "CODE")) |
---|
3193 | { |
---|
3194 | &{$self->{CB}->{IQns}->{$ns}->{$type}}($sid,$iq); |
---|
3195 | } |
---|
3196 | } |
---|
3197 | |
---|
3198 | |
---|
3199 | ############################################################################## |
---|
3200 | # |
---|
3201 | # callbackPresenceSubscribe - default callback for subscribe packets. |
---|
3202 | # |
---|
3203 | ############################################################################## |
---|
3204 | sub callbackPresenceSubscribe |
---|
3205 | { |
---|
3206 | my $self = shift; |
---|
3207 | my $sid = shift; |
---|
3208 | my $presence = shift; |
---|
3209 | |
---|
3210 | my $reply = $presence->Reply(type=>"subscribed"); |
---|
3211 | $self->Send($reply,1); |
---|
3212 | $reply->SetType("subscribe"); |
---|
3213 | $self->Send($reply,1); |
---|
3214 | } |
---|
3215 | |
---|
3216 | |
---|
3217 | ############################################################################## |
---|
3218 | # |
---|
3219 | # callbackPresenceUnsubscribe - default callback for unsubscribe packets. |
---|
3220 | # |
---|
3221 | ############################################################################## |
---|
3222 | sub callbackPresenceUnsubscribe |
---|
3223 | { |
---|
3224 | my $self = shift; |
---|
3225 | my $sid = shift; |
---|
3226 | my $presence = shift; |
---|
3227 | |
---|
3228 | my $reply = $presence->Reply(type=>"unsubscribed"); |
---|
3229 | $self->Send($reply,1); |
---|
3230 | } |
---|
3231 | |
---|
3232 | |
---|
3233 | ############################################################################## |
---|
3234 | # |
---|
3235 | # callbackPresenceSubscribed - default callback for subscribed packets. |
---|
3236 | # |
---|
3237 | ############################################################################## |
---|
3238 | sub callbackPresenceSubscribed |
---|
3239 | { |
---|
3240 | my $self = shift; |
---|
3241 | my $sid = shift; |
---|
3242 | my $presence = shift; |
---|
3243 | |
---|
3244 | my $reply = $presence->Reply(type=>"subscribed"); |
---|
3245 | $self->Send($reply,1); |
---|
3246 | } |
---|
3247 | |
---|
3248 | |
---|
3249 | ############################################################################## |
---|
3250 | # |
---|
3251 | # callbackPresenceUnsubscribed - default callback for unsubscribed packets. |
---|
3252 | # |
---|
3253 | ############################################################################## |
---|
3254 | sub callbackPresenceUnsubscribed |
---|
3255 | { |
---|
3256 | my $self = shift; |
---|
3257 | my $sid = shift; |
---|
3258 | my $presence = shift; |
---|
3259 | |
---|
3260 | my $reply = $presence->Reply(type=>"unsubscribed"); |
---|
3261 | $self->Send($reply,1); |
---|
3262 | } |
---|
3263 | |
---|
3264 | |
---|
3265 | |
---|
3266 | ############################################################################## |
---|
3267 | #+---------------------------------------------------------------------------- |
---|
3268 | #| |
---|
3269 | #| Stream functions |
---|
3270 | #| |
---|
3271 | #+---------------------------------------------------------------------------- |
---|
3272 | ############################################################################## |
---|
3273 | sub GetStreamID |
---|
3274 | { |
---|
3275 | my $self = shift; |
---|
3276 | |
---|
3277 | return $self->{SESSION}->{id}; |
---|
3278 | } |
---|
3279 | |
---|
3280 | |
---|
3281 | sub GetStreamFeature |
---|
3282 | { |
---|
3283 | my $self = shift; |
---|
3284 | my $feature = shift; |
---|
3285 | |
---|
3286 | return $self->{STREAM}->GetStreamFeature($self->GetStreamID(),$feature); |
---|
3287 | } |
---|
3288 | |
---|
3289 | |
---|
3290 | sub RestartStream |
---|
3291 | { |
---|
3292 | my $self = shift; |
---|
3293 | my $timeout = shift; |
---|
3294 | |
---|
3295 | $self->{SESSION} = |
---|
3296 | $self->{STREAM}->OpenStream($self->GetStreamID(),$timeout); |
---|
3297 | return $self->GetStreamID(); |
---|
3298 | } |
---|
3299 | |
---|
3300 | |
---|
3301 | ############################################################################## |
---|
3302 | # |
---|
3303 | # ConstXMLNS - Return the namespace from the constant string. |
---|
3304 | # |
---|
3305 | ############################################################################## |
---|
3306 | sub ConstXMLNS |
---|
3307 | { |
---|
3308 | my $const = shift; |
---|
3309 | |
---|
3310 | return $XMLNS{$const}; |
---|
3311 | } |
---|
3312 | |
---|
3313 | |
---|
3314 | 1; |
---|