line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
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::Jabber::Protocol; |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
=head1 NAME |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
Net::Jabber::Protocol - Jabber Protocol Library |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
=head1 SYNOPSIS |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
Net::Jabber::Protocol is a module that provides a developer easy |
31
|
|
|
|
|
|
|
access to the Jabber Instant Messaging protocol. It provides high |
32
|
|
|
|
|
|
|
level functions to the Net::Jabber Client, Component, and Server |
33
|
|
|
|
|
|
|
objects. These functions are automatically indluded in those modules |
34
|
|
|
|
|
|
|
through AUTOLOAD and delegates. |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
=head1 DESCRIPTION |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
Protocol.pm seeks to provide enough high level APIs and automation of |
39
|
|
|
|
|
|
|
the low level APIs that writing a Jabber Client/Transport in Perl is |
40
|
|
|
|
|
|
|
trivial. For those that wish to work with the low level you can do |
41
|
|
|
|
|
|
|
that too, but those functions are covered in the documentation for |
42
|
|
|
|
|
|
|
each module. |
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
Net::Jabber::Protocol provides functions to login, send and receive |
45
|
|
|
|
|
|
|
messages, set personal information, create a new user account, manage |
46
|
|
|
|
|
|
|
the roster, and disconnect. You can use all or none of the functions, |
47
|
|
|
|
|
|
|
there is no requirement. |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
For more information on how the details for how Net::Jabber is written |
50
|
|
|
|
|
|
|
please see the help for Net::Jabber itself. |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
For more information on writing a Client see Net::Jabber::Client. |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
For more information on writing a Transport see Net::Jabber::Transport. |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
=head2 Modes |
57
|
|
|
|
|
|
|
|
58
|
|
|
|
|
|
|
Several of the functions take a mode argument that let you specify how |
59
|
|
|
|
|
|
|
the function should behave: |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
block - send the packet with an ID, and then block until an answer |
62
|
|
|
|
|
|
|
comes back. You can optionally specify a timeout so that |
63
|
|
|
|
|
|
|
you do not block forever. |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
nonblock - send the packet with an ID, but then return that id and |
66
|
|
|
|
|
|
|
control to the master program. Net::Jabber is still |
67
|
|
|
|
|
|
|
tracking this packet, so you must use the CheckID function |
68
|
|
|
|
|
|
|
to tell when it comes in. (This might not be very |
69
|
|
|
|
|
|
|
useful...) |
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
passthru - send the packet with an ID, but do NOT register it with |
72
|
|
|
|
|
|
|
Net::Jabber, then return the ID. This is useful when |
73
|
|
|
|
|
|
|
combined with the XPath function because you can register |
74
|
|
|
|
|
|
|
a one shot function tied to the id you get back. |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
=head2 Basic Functions |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
use Net::Jabber qw( Client ); |
80
|
|
|
|
|
|
|
$Con = new Net::Jabber::Client(); # From |
81
|
|
|
|
|
|
|
$status = $Con->Connect(hostname=>"jabber.org"); # Net::Jabber::Client |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
or |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
use Net::Jabber qw( Component ); |
86
|
|
|
|
|
|
|
$Con = new Net::Jabber::Component(); # |
87
|
|
|
|
|
|
|
$status = $Con->Connect(hostname=>"jabber.org", # From |
88
|
|
|
|
|
|
|
secret=>"bob"); # Net::Jabber::Component |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
# |
92
|
|
|
|
|
|
|
# For callback setup, see Net::XMPP::Protocol |
93
|
|
|
|
|
|
|
# |
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
$Con->Info(name=>"Jarl", |
96
|
|
|
|
|
|
|
version=>"v0.6000"); |
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
=head2 ID Functions |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
$id = $Con->SendWithID($sendObj); |
101
|
|
|
|
|
|
|
$id = $Con->SendWithID("XML"); |
102
|
|
|
|
|
|
|
$receiveObj = $Con->SendAndReceiveWithID($sendObj); |
103
|
|
|
|
|
|
|
$receiveObj = $Con->SendAndReceiveWithID($sendObj, |
104
|
|
|
|
|
|
|
10); |
105
|
|
|
|
|
|
|
$receiveObj = $Con->SendAndReceiveWithID("XML"); |
106
|
|
|
|
|
|
|
$receiveObj = $Con->SendAndReceiveWithID("XML", |
107
|
|
|
|
|
|
|
5); |
108
|
|
|
|
|
|
|
$yesno = $Con->ReceivedID($id); |
109
|
|
|
|
|
|
|
$receiveObj = $Con->GetID($id); |
110
|
|
|
|
|
|
|
$receiveObj = $Con->WaitForID($id); |
111
|
|
|
|
|
|
|
$receiveObj = $Con->WaitForID($id, |
112
|
|
|
|
|
|
|
20); |
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
=head2 IQ Functions |
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
=head2 Agents Functions |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
%agents = $Con->AgentsGet(); |
119
|
|
|
|
|
|
|
%agents = $Con->AgentsGet(to=>"transport.jabber.org"); |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
=head2 Browse Functions |
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
%hash = $Con->BrowseRequest(jid=>"jabber.org"); |
124
|
|
|
|
|
|
|
%hash = $Con->BrowseRequest(jid=>"jabber.org", |
125
|
|
|
|
|
|
|
timeout=>10); |
126
|
|
|
|
|
|
|
|
127
|
|
|
|
|
|
|
$id = $Con->BrowseRequest(jid=>"jabber.org", |
128
|
|
|
|
|
|
|
mode=>"nonblock"); |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
$id = $Con->BrowseRequest(jid=>"jabber.org", |
131
|
|
|
|
|
|
|
mode=>"passthru"); |
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
=head2 Browse DB Functions |
134
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
$Con->BrowseDBDelete("jabber.org"); |
136
|
|
|
|
|
|
|
$Con->BrowseDBDelete(Net::Jabber::JID); |
137
|
|
|
|
|
|
|
|
138
|
|
|
|
|
|
|
$presence = $Con->BrowseDBQuery(jid=>"bob\@jabber.org"); |
139
|
|
|
|
|
|
|
$presence = $Con->BrowseDBQuery(jid=>Net::Jabber::JID); |
140
|
|
|
|
|
|
|
$presence = $Con->BrowseDBQuery(jid=>"users.jabber.org", |
141
|
|
|
|
|
|
|
timeout=>10); |
142
|
|
|
|
|
|
|
$presence = $Con->BrowseDBQuery(jid=>"conference.jabber.org", |
143
|
|
|
|
|
|
|
refresh=>1); |
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
=head2 Bystreams Functions |
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
%hash = $Con->ByteStreamsProxyRequest(jid=>"proxy.server"); |
148
|
|
|
|
|
|
|
%hash = $Con->ByteStreamsProxyRequest(jid=>"proxy.server", |
149
|
|
|
|
|
|
|
timeout=>10); |
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
$id = $Con->ByteStreamsProxyRequest(jid=>"proxy.server", |
152
|
|
|
|
|
|
|
mode=>"nonblock"); |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
$id = $Con->ByteStreamsProxyRequest(jid=>"proxy.server", |
155
|
|
|
|
|
|
|
mode=>"passthru"); |
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
%hash = $Con->ByteStreamsProxyParse($query); |
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
$status = $Con->ByteStreamsProxyActivate(sid=>"stream_id", |
162
|
|
|
|
|
|
|
jid=>"proxy.server"); |
163
|
|
|
|
|
|
|
$status = $Con->ByteStreamsProxyActivate(sid=>"stream_id", |
164
|
|
|
|
|
|
|
jid=>"proxy.server", |
165
|
|
|
|
|
|
|
timeout=>10); |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
$id = $Con->ByteStreamsProxyActivate(sid=>"stream_id", |
168
|
|
|
|
|
|
|
jid=>"proxy.server", |
169
|
|
|
|
|
|
|
mode=>"nonblock"); |
170
|
|
|
|
|
|
|
|
171
|
|
|
|
|
|
|
$id = $Con->ByteStreamsProxyActivate(sid=>"stream_id", |
172
|
|
|
|
|
|
|
jid=>"proxy.server", |
173
|
|
|
|
|
|
|
mode=>"passthru"); |
174
|
|
|
|
|
|
|
|
175
|
|
|
|
|
|
|
|
176
|
|
|
|
|
|
|
$jid = $Con->ByteStreamsOffer(sid=>"stream_id", |
177
|
|
|
|
|
|
|
streamhosts=>[{jid=>"jid", |
178
|
|
|
|
|
|
|
host=>"host", |
179
|
|
|
|
|
|
|
port=>"port", |
180
|
|
|
|
|
|
|
zeroconf=>"zero", |
181
|
|
|
|
|
|
|
}, |
182
|
|
|
|
|
|
|
... |
183
|
|
|
|
|
|
|
], |
184
|
|
|
|
|
|
|
jid=>"bob\@jabber.org"); |
185
|
|
|
|
|
|
|
$jid = $Con->ByteStreamsOffer(sid=>"stream_id", |
186
|
|
|
|
|
|
|
streamhosts=>[{},{},...], |
187
|
|
|
|
|
|
|
jid=>"bob\@jabber.org", |
188
|
|
|
|
|
|
|
timeout=>10); |
189
|
|
|
|
|
|
|
|
190
|
|
|
|
|
|
|
$id = $Con->ByteStreamsOffer(sid=>"stream_id", |
191
|
|
|
|
|
|
|
streamhosts=>[{},{},...], |
192
|
|
|
|
|
|
|
jid=>"bob\@jabber.org", |
193
|
|
|
|
|
|
|
mode=>"nonblock"); |
194
|
|
|
|
|
|
|
|
195
|
|
|
|
|
|
|
$id = $Con->ByteStreamsOffer(sid=>"stream_id", |
196
|
|
|
|
|
|
|
streamhosts=>[{},{},...], |
197
|
|
|
|
|
|
|
jid=>"bob\@jabber.org", |
198
|
|
|
|
|
|
|
mode=>"passthru"); |
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
=head2 Disco Functions |
201
|
|
|
|
|
|
|
|
202
|
|
|
|
|
|
|
%hash = $Con->DiscoInfoRequest(jid=>"jabber.org"); |
203
|
|
|
|
|
|
|
%hash = $Con->DiscoInfoRequest(jid=>"jabber.org", |
204
|
|
|
|
|
|
|
node=>"node..."); |
205
|
|
|
|
|
|
|
%hash = $Con->DiscoInfoRequest(jid=>"jabber.org", |
206
|
|
|
|
|
|
|
node=>"node...", |
207
|
|
|
|
|
|
|
timeout=>10); |
208
|
|
|
|
|
|
|
|
209
|
|
|
|
|
|
|
$id = $Con->DiscoInfoRequest(jid=>"jabber.org", |
210
|
|
|
|
|
|
|
mode=>"nonblock"); |
211
|
|
|
|
|
|
|
$id = $Con->DiscoInfoRequest(jid=>"jabber.org", |
212
|
|
|
|
|
|
|
node=>"node...", |
213
|
|
|
|
|
|
|
mode=>"nonblock"); |
214
|
|
|
|
|
|
|
|
215
|
|
|
|
|
|
|
$id = $Con->DiscoInfoRequest(jid=>"jabber.org", |
216
|
|
|
|
|
|
|
mode=>"passthru"); |
217
|
|
|
|
|
|
|
$id = $Con->DiscoInfoRequest(jid=>"jabber.org", |
218
|
|
|
|
|
|
|
node=>"node...", |
219
|
|
|
|
|
|
|
mode=>"passthru"); |
220
|
|
|
|
|
|
|
|
221
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
%hash = $Con->DiscoInfoParse($query); |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
|
225
|
|
|
|
|
|
|
%hash = $Con->DiscoItemsRequest(jid=>"jabber.org"); |
226
|
|
|
|
|
|
|
%hash = $Con->DiscoItemsRequest(jid=>"jabber.org", |
227
|
|
|
|
|
|
|
timeout=>10); |
228
|
|
|
|
|
|
|
|
229
|
|
|
|
|
|
|
$id = $Con->DiscoItemsRequest(jid=>"jabber.org", |
230
|
|
|
|
|
|
|
mode=>"nonblock"); |
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
$id = $Con->DiscoItemsRequest(jid=>"jabber.org", |
233
|
|
|
|
|
|
|
mode=>"passthru"); |
234
|
|
|
|
|
|
|
|
235
|
|
|
|
|
|
|
|
236
|
|
|
|
|
|
|
%hash = $Con->DiscoItemsParse($query); |
237
|
|
|
|
|
|
|
|
238
|
|
|
|
|
|
|
=head2 Feature Negotiation Functions |
239
|
|
|
|
|
|
|
|
240
|
|
|
|
|
|
|
|
241
|
|
|
|
|
|
|
%hash = $Con->FeatureNegRequest(jid=>"jabber.org", |
242
|
|
|
|
|
|
|
features=>{ feat1=>["opt1","opt2",...], |
243
|
|
|
|
|
|
|
feat2=>["optA","optB",...] |
244
|
|
|
|
|
|
|
} |
245
|
|
|
|
|
|
|
); |
246
|
|
|
|
|
|
|
%hash = $Con->FeatureNegRequest(jid=>"jabber.org", |
247
|
|
|
|
|
|
|
features=>{ ... }, |
248
|
|
|
|
|
|
|
timeout=>10); |
249
|
|
|
|
|
|
|
|
250
|
|
|
|
|
|
|
$id = $Con->FeatureNegRequest(jid=>"jabber.org", |
251
|
|
|
|
|
|
|
features=>{ ... }, |
252
|
|
|
|
|
|
|
mode=>"nonblock"); |
253
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
$id = $Con->FeatureNegRequest(jid=>"jabber.org", |
255
|
|
|
|
|
|
|
features=>{ ... }, |
256
|
|
|
|
|
|
|
mode=>"passthru"); |
257
|
|
|
|
|
|
|
|
258
|
|
|
|
|
|
|
my $query = $self->FeatureNegQuery(\{ ... }); |
259
|
|
|
|
|
|
|
$iq->AddQuery($query); |
260
|
|
|
|
|
|
|
|
261
|
|
|
|
|
|
|
%hash = $Con->FeatureNegParse($query); |
262
|
|
|
|
|
|
|
|
263
|
|
|
|
|
|
|
=head2 File Transfer Functions |
264
|
|
|
|
|
|
|
|
265
|
|
|
|
|
|
|
$method = $Con->FileTransferOffer(jid=>"bob\@jabber.org", |
266
|
|
|
|
|
|
|
sid=>"stream_id", |
267
|
|
|
|
|
|
|
filename=>"/path/to/file", |
268
|
|
|
|
|
|
|
methods=>["http://jabber.org/protocol/si/profile/bytestreams", |
269
|
|
|
|
|
|
|
"jabber:iq:oob", |
270
|
|
|
|
|
|
|
... |
271
|
|
|
|
|
|
|
] |
272
|
|
|
|
|
|
|
); |
273
|
|
|
|
|
|
|
$method = $Con->FileTransferOffer(jid=>"bob\@jabber.org", |
274
|
|
|
|
|
|
|
sid=>"stream_id", |
275
|
|
|
|
|
|
|
filename=>"/path/to/file", |
276
|
|
|
|
|
|
|
methods=>\@methods, |
277
|
|
|
|
|
|
|
timeout=>"10"); |
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
$id = $Con->FileTransferOffer(jid=>"bob\@jabber.org", |
280
|
|
|
|
|
|
|
sid=>"stream_id", |
281
|
|
|
|
|
|
|
filename=>"/path/to/file", |
282
|
|
|
|
|
|
|
methods=>\@methods, |
283
|
|
|
|
|
|
|
mode=>"nonblock"); |
284
|
|
|
|
|
|
|
|
285
|
|
|
|
|
|
|
$id = $Con->FileTransferOffer(jid=>"bob\@jabber.org", |
286
|
|
|
|
|
|
|
sid=>"stream_id", |
287
|
|
|
|
|
|
|
filename=>"/path/to/file", |
288
|
|
|
|
|
|
|
methods=>\@methods, |
289
|
|
|
|
|
|
|
mode=>"passthru"); |
290
|
|
|
|
|
|
|
|
291
|
|
|
|
|
|
|
=head2 Last Functions |
292
|
|
|
|
|
|
|
|
293
|
|
|
|
|
|
|
$Con->LastQuery(); |
294
|
|
|
|
|
|
|
$Con->LastQuery(to=>"bob@jabber.org"); |
295
|
|
|
|
|
|
|
|
296
|
|
|
|
|
|
|
%result = $Con->LastQuery(mode=>"block"); |
297
|
|
|
|
|
|
|
%result = $Con->LastQuery(to=>"bob@jabber.org", |
298
|
|
|
|
|
|
|
mode=>"block"); |
299
|
|
|
|
|
|
|
|
300
|
|
|
|
|
|
|
%result = $Con->LastQuery(to=>"bob@jabber.org", |
301
|
|
|
|
|
|
|
mode=>"block", |
302
|
|
|
|
|
|
|
timeout=>10); |
303
|
|
|
|
|
|
|
%result = $Con->LastQuery(mode=>"block", |
304
|
|
|
|
|
|
|
timeout=>10); |
305
|
|
|
|
|
|
|
|
306
|
|
|
|
|
|
|
$Con->LastSend(to=>"bob@jabber.org"); |
307
|
|
|
|
|
|
|
|
308
|
|
|
|
|
|
|
$seconds = $Con->LastActivity(); |
309
|
|
|
|
|
|
|
|
310
|
|
|
|
|
|
|
=head2 Multi-User Chat Functions |
311
|
|
|
|
|
|
|
|
312
|
|
|
|
|
|
|
$Con->MUCJoin(room=>"jabber", |
313
|
|
|
|
|
|
|
server=>"conference.jabber.org", |
314
|
|
|
|
|
|
|
nick=>"nick"); |
315
|
|
|
|
|
|
|
|
316
|
|
|
|
|
|
|
$Con->MUCJoin(room=>"jabber", |
317
|
|
|
|
|
|
|
server=>"conference.jabber.org", |
318
|
|
|
|
|
|
|
nick=>"nick", |
319
|
|
|
|
|
|
|
password=>"secret"); |
320
|
|
|
|
|
|
|
|
321
|
|
|
|
|
|
|
=head2 Register Functions |
322
|
|
|
|
|
|
|
|
323
|
|
|
|
|
|
|
@result = $Con->RegisterSendData("users.jabber.org", |
324
|
|
|
|
|
|
|
first=>"Bob", |
325
|
|
|
|
|
|
|
last=>"Smith", |
326
|
|
|
|
|
|
|
nick=>"bob", |
327
|
|
|
|
|
|
|
email=>"foo@bar.net"); |
328
|
|
|
|
|
|
|
|
329
|
|
|
|
|
|
|
|
330
|
|
|
|
|
|
|
=head2 RPC Functions |
331
|
|
|
|
|
|
|
|
332
|
|
|
|
|
|
|
$query = $Con->RPCEncode(type=>"methodCall", |
333
|
|
|
|
|
|
|
methodName=>"methodName", |
334
|
|
|
|
|
|
|
params=>[param,param,...]); |
335
|
|
|
|
|
|
|
$query = $Con->RPCEncode(type=>"methodResponse", |
336
|
|
|
|
|
|
|
params=>[param,param,...]); |
337
|
|
|
|
|
|
|
$query = $Con->RPCEncode(type=>"methodResponse", |
338
|
|
|
|
|
|
|
faultCode=>4, |
339
|
|
|
|
|
|
|
faultString=>"Too many params"); |
340
|
|
|
|
|
|
|
|
341
|
|
|
|
|
|
|
@response = $Con->RPCParse($iq); |
342
|
|
|
|
|
|
|
|
343
|
|
|
|
|
|
|
@response = $Con->RPCCall(to=>"dataHouse.jabber.org", |
344
|
|
|
|
|
|
|
methodname=>"numUsers", |
345
|
|
|
|
|
|
|
params=>[ param,param,... ] |
346
|
|
|
|
|
|
|
); |
347
|
|
|
|
|
|
|
|
348
|
|
|
|
|
|
|
$Con->RPCResponse(to=>"you\@jabber.org", |
349
|
|
|
|
|
|
|
params=>[ param,param,... ]); |
350
|
|
|
|
|
|
|
|
351
|
|
|
|
|
|
|
$Con->RPCResponse(to=>"you\@jabber.org", |
352
|
|
|
|
|
|
|
faultCode=>"4", |
353
|
|
|
|
|
|
|
faultString=>"Too many parameters" |
354
|
|
|
|
|
|
|
); |
355
|
|
|
|
|
|
|
|
356
|
|
|
|
|
|
|
$Con->RPCSetCallBacks(myMethodA=>\&methoda, |
357
|
|
|
|
|
|
|
myMethodB=>\&do_somthing, |
358
|
|
|
|
|
|
|
etc... |
359
|
|
|
|
|
|
|
); |
360
|
|
|
|
|
|
|
|
361
|
|
|
|
|
|
|
=head2 Search Functions |
362
|
|
|
|
|
|
|
|
363
|
|
|
|
|
|
|
%fields = $Con->SearchRequest(); |
364
|
|
|
|
|
|
|
%fields = $Con->SearchRequest(to=>"users.jabber.org"); |
365
|
|
|
|
|
|
|
%fields = $Con->SearchRequest(to=>"users.jabber.org", |
366
|
|
|
|
|
|
|
timeout=>10); |
367
|
|
|
|
|
|
|
|
368
|
|
|
|
|
|
|
$Con->SearchSend(to=>"somewhere", |
369
|
|
|
|
|
|
|
name=>"", |
370
|
|
|
|
|
|
|
first=>"Bob", |
371
|
|
|
|
|
|
|
last=>"", |
372
|
|
|
|
|
|
|
nick=>"bob", |
373
|
|
|
|
|
|
|
email=>"", |
374
|
|
|
|
|
|
|
key=>"some key"); |
375
|
|
|
|
|
|
|
|
376
|
|
|
|
|
|
|
$Con->SearchSendData("users.jabber.org", |
377
|
|
|
|
|
|
|
first=>"Bob", |
378
|
|
|
|
|
|
|
last=>"", |
379
|
|
|
|
|
|
|
nick=>"bob", |
380
|
|
|
|
|
|
|
email=>""); |
381
|
|
|
|
|
|
|
|
382
|
|
|
|
|
|
|
=head2 Time Functions |
383
|
|
|
|
|
|
|
|
384
|
|
|
|
|
|
|
$Con->TimeQuery(); |
385
|
|
|
|
|
|
|
$Con->TimeQuery(to=>"bob@jabber.org"); |
386
|
|
|
|
|
|
|
|
387
|
|
|
|
|
|
|
%result = $Con->TimeQuery(mode=>"block"); |
388
|
|
|
|
|
|
|
%result = $Con->TimeQuery(to=>"bob@jabber.org", |
389
|
|
|
|
|
|
|
mode=>"block"); |
390
|
|
|
|
|
|
|
|
391
|
|
|
|
|
|
|
$Con->TimeSend(to=>"bob@jabber.org"); |
392
|
|
|
|
|
|
|
|
393
|
|
|
|
|
|
|
=head2 Version Functions |
394
|
|
|
|
|
|
|
|
395
|
|
|
|
|
|
|
$Con->VersionQuery(); |
396
|
|
|
|
|
|
|
$Con->VersionQuery(to=>"bob@jabber.org"); |
397
|
|
|
|
|
|
|
|
398
|
|
|
|
|
|
|
%result = $Con->VersionQuery(mode=>"block"); |
399
|
|
|
|
|
|
|
%result = $Con->VersionQuery(to=>"bob@jabber.org", |
400
|
|
|
|
|
|
|
mode=>"block"); |
401
|
|
|
|
|
|
|
|
402
|
|
|
|
|
|
|
$Con->VersionSend(to=>"bob@jabber.org", |
403
|
|
|
|
|
|
|
name=>"Net::Jabber", |
404
|
|
|
|
|
|
|
ver=>"1.0a", |
405
|
|
|
|
|
|
|
os=>"Perl"); |
406
|
|
|
|
|
|
|
|
407
|
|
|
|
|
|
|
=head1 METHODS |
408
|
|
|
|
|
|
|
|
409
|
|
|
|
|
|
|
=head2 Basic Functions |
410
|
|
|
|
|
|
|
|
411
|
|
|
|
|
|
|
Info(name=>string, - Set some information so that Net::Jabber |
412
|
|
|
|
|
|
|
version=>string) can auto-reply to some packets for you to |
413
|
|
|
|
|
|
|
reduce the work you have to do. |
414
|
|
|
|
|
|
|
|
415
|
|
|
|
|
|
|
NOTE: This requires that you use the |
416
|
|
|
|
|
|
|
SetIQCallBacks methodology and not the |
417
|
|
|
|
|
|
|
SetCallBacks for packets. |
418
|
|
|
|
|
|
|
|
419
|
|
|
|
|
|
|
=head2 IQ Functions |
420
|
|
|
|
|
|
|
|
421
|
|
|
|
|
|
|
=head2 Agents Functions |
422
|
|
|
|
|
|
|
|
423
|
|
|
|
|
|
|
******************************** |
424
|
|
|
|
|
|
|
* * |
425
|
|
|
|
|
|
|
* Deprecated in favor of Disco * |
426
|
|
|
|
|
|
|
* * |
427
|
|
|
|
|
|
|
******************************** |
428
|
|
|
|
|
|
|
|
429
|
|
|
|
|
|
|
AgentsGet(to=>string, - takes all of the information and |
430
|
|
|
|
|
|
|
AgentsGet() builds a Net::Jabber::IQ::Agents packet. |
431
|
|
|
|
|
|
|
It then sends that packet either to the |
432
|
|
|
|
|
|
|
server, or to the specified transport, |
433
|
|
|
|
|
|
|
with an ID and waits for that ID to return. |
434
|
|
|
|
|
|
|
Then it looks in the resulting packet and |
435
|
|
|
|
|
|
|
builds a hash that contains the values |
436
|
|
|
|
|
|
|
of the agent list. The hash is layed out |
437
|
|
|
|
|
|
|
like this: (NOTE: the jid is the key to |
438
|
|
|
|
|
|
|
distinguish the various agents) |
439
|
|
|
|
|
|
|
|
440
|
|
|
|
|
|
|
$hash{}->{order} = 4 |
441
|
|
|
|
|
|
|
->{name} = "ICQ Transport" |
442
|
|
|
|
|
|
|
->{transport} = "ICQ #" |
443
|
|
|
|
|
|
|
->{description} = "ICQ..blah.." |
444
|
|
|
|
|
|
|
->{service} = "icq" |
445
|
|
|
|
|
|
|
->{register} = 1 |
446
|
|
|
|
|
|
|
->{search} = 1 |
447
|
|
|
|
|
|
|
etc... |
448
|
|
|
|
|
|
|
|
449
|
|
|
|
|
|
|
The order field determines the order that |
450
|
|
|
|
|
|
|
it came from the server in... in case you |
451
|
|
|
|
|
|
|
care. For more info on the valid fields |
452
|
|
|
|
|
|
|
see the Net::Jabber::Query jabber:iq:agent |
453
|
|
|
|
|
|
|
namespace. |
454
|
|
|
|
|
|
|
|
455
|
|
|
|
|
|
|
=head2 Browse Functions |
456
|
|
|
|
|
|
|
|
457
|
|
|
|
|
|
|
******************************** |
458
|
|
|
|
|
|
|
* * |
459
|
|
|
|
|
|
|
* Deprecated in favor of Disco * |
460
|
|
|
|
|
|
|
* * |
461
|
|
|
|
|
|
|
******************************** |
462
|
|
|
|
|
|
|
|
463
|
|
|
|
|
|
|
BrowseRequest(jid=>string, - sends a jabber:iq:browse request to |
464
|
|
|
|
|
|
|
mode=>string, the jid passed as an argument. |
465
|
|
|
|
|
|
|
timeout=>int) Returns a hash with the resulting |
466
|
|
|
|
|
|
|
tree if mode is set to "block": |
467
|
|
|
|
|
|
|
|
468
|
|
|
|
|
|
|
$browse{'category'} = "conference" |
469
|
|
|
|
|
|
|
$browse{'children'}->[0] |
470
|
|
|
|
|
|
|
$browse{'children'}->[1] |
471
|
|
|
|
|
|
|
$browse{'children'}->[11] |
472
|
|
|
|
|
|
|
$browse{'jid'} = "conference.jabber.org" |
473
|
|
|
|
|
|
|
$browse{'name'} = "Jabber.org Conferencing Center" |
474
|
|
|
|
|
|
|
$browse{'ns'}->[0] |
475
|
|
|
|
|
|
|
$browse{'ns'}->[1] |
476
|
|
|
|
|
|
|
$browse{'type'} = "public" |
477
|
|
|
|
|
|
|
|
478
|
|
|
|
|
|
|
The ns array is an array of the |
479
|
|
|
|
|
|
|
namespaces that this jid supports. |
480
|
|
|
|
|
|
|
The children array points to hashs |
481
|
|
|
|
|
|
|
of this form, and represent the fact |
482
|
|
|
|
|
|
|
that they can be browsed to. |
483
|
|
|
|
|
|
|
|
484
|
|
|
|
|
|
|
See MODES above for using the mode |
485
|
|
|
|
|
|
|
and timeout. |
486
|
|
|
|
|
|
|
|
487
|
|
|
|
|
|
|
=head2 Browse DB Functions |
488
|
|
|
|
|
|
|
|
489
|
|
|
|
|
|
|
BrowseDBDelete(string|Net::Jabber::JID) - delete thes JID browse |
490
|
|
|
|
|
|
|
data from the DB. |
491
|
|
|
|
|
|
|
|
492
|
|
|
|
|
|
|
BrowseDBQuery(jid=>string | NJ::JID, - returns the browse data |
493
|
|
|
|
|
|
|
timeout=>integer, for the requested JID. If |
494
|
|
|
|
|
|
|
refresh=>0|1) the DB does not contain |
495
|
|
|
|
|
|
|
the data for the JID, then |
496
|
|
|
|
|
|
|
it attempts to fetch the |
497
|
|
|
|
|
|
|
data via BrowseRequest(). |
498
|
|
|
|
|
|
|
The timeout is passed to |
499
|
|
|
|
|
|
|
the BrowseRequest() call, |
500
|
|
|
|
|
|
|
and refresh tells the DB |
501
|
|
|
|
|
|
|
to request the data, even |
502
|
|
|
|
|
|
|
if it already has some. |
503
|
|
|
|
|
|
|
|
504
|
|
|
|
|
|
|
=head2 Bytestreams Functions |
505
|
|
|
|
|
|
|
|
506
|
|
|
|
|
|
|
ByteStreamsProxyRequest(jid=>string, - sends a bytestreams request |
507
|
|
|
|
|
|
|
mode=>string, to the jid passed as an |
508
|
|
|
|
|
|
|
timeout=>int) argument. Returns an array |
509
|
|
|
|
|
|
|
ref with the resulting tree |
510
|
|
|
|
|
|
|
if mode is set to "block". |
511
|
|
|
|
|
|
|
|
512
|
|
|
|
|
|
|
See ByteStreamsProxyParse |
513
|
|
|
|
|
|
|
for the format of the |
514
|
|
|
|
|
|
|
resulting tree. |
515
|
|
|
|
|
|
|
|
516
|
|
|
|
|
|
|
See MODES above for using |
517
|
|
|
|
|
|
|
the mode and timeout. |
518
|
|
|
|
|
|
|
|
519
|
|
|
|
|
|
|
ByteStreamsProxyParse(Net::Jabber::Query) - parses the query and |
520
|
|
|
|
|
|
|
returns an array ref |
521
|
|
|
|
|
|
|
to the resulting tree: |
522
|
|
|
|
|
|
|
|
523
|
|
|
|
|
|
|
$host[0]->{jid} = "bytestreams1.proxy.server"; |
524
|
|
|
|
|
|
|
$host[0]->{host} = "proxy1.server"; |
525
|
|
|
|
|
|
|
$host[0]->{port} = "5006"; |
526
|
|
|
|
|
|
|
$host[1]->{jid} = "bytestreams2.proxy.server"; |
527
|
|
|
|
|
|
|
$host[1]->{host} = "proxy2.server"; |
528
|
|
|
|
|
|
|
$host[1]->{port} = "5007"; |
529
|
|
|
|
|
|
|
... |
530
|
|
|
|
|
|
|
|
531
|
|
|
|
|
|
|
ByteStreamsProxyActivate(jid=>string, - sends a bytestreams activate |
532
|
|
|
|
|
|
|
sid=>string, to the jid passed as an |
533
|
|
|
|
|
|
|
mode=>string, argument. Returns 1 if the |
534
|
|
|
|
|
|
|
timeout=>int) proxy activated (undef if |
535
|
|
|
|
|
|
|
it did not) if mode is set |
536
|
|
|
|
|
|
|
to "block". |
537
|
|
|
|
|
|
|
|
538
|
|
|
|
|
|
|
sid is the stream id that |
539
|
|
|
|
|
|
|
is being used to talk about |
540
|
|
|
|
|
|
|
this stream. |
541
|
|
|
|
|
|
|
|
542
|
|
|
|
|
|
|
See MODES above for using |
543
|
|
|
|
|
|
|
the mode and timeout. |
544
|
|
|
|
|
|
|
|
545
|
|
|
|
|
|
|
ByteStreamsOffer(jid=>string, - sends a bytestreams offer |
546
|
|
|
|
|
|
|
sid=>string, to the jid passed as an |
547
|
|
|
|
|
|
|
streamhosts=>arrayref argument. Returns the jid |
548
|
|
|
|
|
|
|
mode=>string, of the streamhost that the |
549
|
|
|
|
|
|
|
timeout=>int) user selected if mode is set |
550
|
|
|
|
|
|
|
to "block". |
551
|
|
|
|
|
|
|
|
552
|
|
|
|
|
|
|
streamhosts is the same |
553
|
|
|
|
|
|
|
format as the array ref |
554
|
|
|
|
|
|
|
returned from |
555
|
|
|
|
|
|
|
ByteStreamsProxyParse. |
556
|
|
|
|
|
|
|
|
557
|
|
|
|
|
|
|
See MODES above for using |
558
|
|
|
|
|
|
|
the mode and timeout. |
559
|
|
|
|
|
|
|
|
560
|
|
|
|
|
|
|
=head2 Disco Functions |
561
|
|
|
|
|
|
|
|
562
|
|
|
|
|
|
|
DiscoInfoRequest(jid=>string, - sends a disco#info request to |
563
|
|
|
|
|
|
|
node=>string, the jid passed as an argument, |
564
|
|
|
|
|
|
|
mode=>string, and the node if specified. |
565
|
|
|
|
|
|
|
timeout=>int) Returns a hash with the resulting |
566
|
|
|
|
|
|
|
tree if mode is set to "block". |
567
|
|
|
|
|
|
|
|
568
|
|
|
|
|
|
|
See DiscoInfoParse for the format |
569
|
|
|
|
|
|
|
of the resulting tree. |
570
|
|
|
|
|
|
|
|
571
|
|
|
|
|
|
|
See MODES above for using the mode |
572
|
|
|
|
|
|
|
and timeout. |
573
|
|
|
|
|
|
|
|
574
|
|
|
|
|
|
|
DiscoInfoParse(Net::Jabber::Query) - parses the query and |
575
|
|
|
|
|
|
|
returns a hash ref |
576
|
|
|
|
|
|
|
to the resulting tree: |
577
|
|
|
|
|
|
|
|
578
|
|
|
|
|
|
|
$info{identity}->[0]->{category} = "groupchat"; |
579
|
|
|
|
|
|
|
$info{identity}->[0]->{name} = "Public Chatrooms"; |
580
|
|
|
|
|
|
|
$info{identity}->[0]->{type} = "public"; |
581
|
|
|
|
|
|
|
|
582
|
|
|
|
|
|
|
$info{identity}->[1]->{category} = "groupchat"; |
583
|
|
|
|
|
|
|
$info{identity}->[1]->{name} = "Private Chatrooms"; |
584
|
|
|
|
|
|
|
$info{identity}->[1]->{type} = "private"; |
585
|
|
|
|
|
|
|
|
586
|
|
|
|
|
|
|
$info{feature}->{http://jabber.org/protocol/disco#info} = 1; |
587
|
|
|
|
|
|
|
$info{feature}->{http://jabber.org/protocol/muc#admin} = 1; |
588
|
|
|
|
|
|
|
|
589
|
|
|
|
|
|
|
DiscoItemsRequest(jid=>string, - sends a disco#items request to |
590
|
|
|
|
|
|
|
mode=>string, the jid passed as an argument. |
591
|
|
|
|
|
|
|
timeout=>int) Returns a hash with the resulting |
592
|
|
|
|
|
|
|
tree if mode is set to "block". |
593
|
|
|
|
|
|
|
|
594
|
|
|
|
|
|
|
See DiscoItemsParse for the format |
595
|
|
|
|
|
|
|
of the resulting tree. |
596
|
|
|
|
|
|
|
|
597
|
|
|
|
|
|
|
See MODES above for using the mode |
598
|
|
|
|
|
|
|
and timeout. |
599
|
|
|
|
|
|
|
|
600
|
|
|
|
|
|
|
DiscoItemsParse(Net::Jabber::Query) - parses the query and |
601
|
|
|
|
|
|
|
returns a hash ref |
602
|
|
|
|
|
|
|
to the resulting tree: |
603
|
|
|
|
|
|
|
|
604
|
|
|
|
|
|
|
$items{jid}->{node} = name; |
605
|
|
|
|
|
|
|
|
606
|
|
|
|
|
|
|
$items{"proxy.server"}->{""} = "Bytestream Proxy Server"; |
607
|
|
|
|
|
|
|
$items{"conf.server"}->{"public"} = "Public Chatrooms"; |
608
|
|
|
|
|
|
|
$items{"conf.server"}->{"private"} = "Private Chatrooms"; |
609
|
|
|
|
|
|
|
|
610
|
|
|
|
|
|
|
=head2 Feature Negotiation Functions |
611
|
|
|
|
|
|
|
|
612
|
|
|
|
|
|
|
FeatureNegRequest(jid=>string, - sends a feature negotiation to |
613
|
|
|
|
|
|
|
features=>hash ref, the jid passed as an argument, |
614
|
|
|
|
|
|
|
mode=>string, using the features specified. |
615
|
|
|
|
|
|
|
timeout=>int) Returns a hash with the resulting |
616
|
|
|
|
|
|
|
tree if mode is set to "block". |
617
|
|
|
|
|
|
|
|
618
|
|
|
|
|
|
|
See DiscoInfoQuery for the format |
619
|
|
|
|
|
|
|
of the features hash ref. |
620
|
|
|
|
|
|
|
|
621
|
|
|
|
|
|
|
See DiscoInfoParse for the format |
622
|
|
|
|
|
|
|
of the resulting tree. |
623
|
|
|
|
|
|
|
|
624
|
|
|
|
|
|
|
See MODES above for using the mode |
625
|
|
|
|
|
|
|
and timeout. |
626
|
|
|
|
|
|
|
|
627
|
|
|
|
|
|
|
FeatureNegParse(Net::Jabber::Query) - parses the query and |
628
|
|
|
|
|
|
|
returns a hash ref |
629
|
|
|
|
|
|
|
to the resulting tree: |
630
|
|
|
|
|
|
|
|
631
|
|
|
|
|
|
|
$features->{feat1} = ["opt1","opt2",...]; |
632
|
|
|
|
|
|
|
$features->{feat2} = ["optA","optB",...]; |
633
|
|
|
|
|
|
|
.... |
634
|
|
|
|
|
|
|
|
635
|
|
|
|
|
|
|
If this is a result: |
636
|
|
|
|
|
|
|
|
637
|
|
|
|
|
|
|
$features->{feat1} = "opt2"; |
638
|
|
|
|
|
|
|
$features->{feat2} = "optA"; |
639
|
|
|
|
|
|
|
.... |
640
|
|
|
|
|
|
|
|
641
|
|
|
|
|
|
|
FeatureNeqQuery(hash ref) - takes a hash ref and turns it into a |
642
|
|
|
|
|
|
|
feature negotiation query that you can |
643
|
|
|
|
|
|
|
AddQuery into your packaet. The format |
644
|
|
|
|
|
|
|
of the hash ref is as follows: |
645
|
|
|
|
|
|
|
|
646
|
|
|
|
|
|
|
$features->{feat1} = ["opt1","opt2",...]; |
647
|
|
|
|
|
|
|
$features->{feat2} = ["optA","optB",...]; |
648
|
|
|
|
|
|
|
.... |
649
|
|
|
|
|
|
|
|
650
|
|
|
|
|
|
|
=head2 File Transfer Functions |
651
|
|
|
|
|
|
|
|
652
|
|
|
|
|
|
|
FileTransferOffer(jid=>string, - sends a file transfer stream |
653
|
|
|
|
|
|
|
sid=>string, initiation to the jid passed |
654
|
|
|
|
|
|
|
filename=>string, as an argument. Returns the |
655
|
|
|
|
|
|
|
mode=>string, method (if the users accepts), |
656
|
|
|
|
|
|
|
timeout=>int) undef (if the user declines), |
657
|
|
|
|
|
|
|
if the mode is set to "block". |
658
|
|
|
|
|
|
|
|
659
|
|
|
|
|
|
|
See MODES above for using |
660
|
|
|
|
|
|
|
the mode and timeout. |
661
|
|
|
|
|
|
|
|
662
|
|
|
|
|
|
|
=head2 Last Functions |
663
|
|
|
|
|
|
|
|
664
|
|
|
|
|
|
|
LastQuery(to=>string, - asks the jid specified for its last |
665
|
|
|
|
|
|
|
mode=>string, activity. If the to is blank, then it |
666
|
|
|
|
|
|
|
timeout=>int) queries the server. Returns a hash with |
667
|
|
|
|
|
|
|
LastQuery() the various items set if mode is set to |
668
|
|
|
|
|
|
|
"block": |
669
|
|
|
|
|
|
|
|
670
|
|
|
|
|
|
|
$last{seconds} - Seconds since activity |
671
|
|
|
|
|
|
|
$last{message} - Message for activity |
672
|
|
|
|
|
|
|
|
673
|
|
|
|
|
|
|
See MODES above for using the mode |
674
|
|
|
|
|
|
|
and timeout. |
675
|
|
|
|
|
|
|
|
676
|
|
|
|
|
|
|
LastSend(to=>string, - sends the specified last to the specified jid. |
677
|
|
|
|
|
|
|
hash) the hash is the seconds and message as shown |
678
|
|
|
|
|
|
|
in the Net::Jabber::Query man page. |
679
|
|
|
|
|
|
|
|
680
|
|
|
|
|
|
|
LastActivity() - returns the number of seconds since the last activity |
681
|
|
|
|
|
|
|
by the user. |
682
|
|
|
|
|
|
|
|
683
|
|
|
|
|
|
|
=head2 Multi-User Chat Functions |
684
|
|
|
|
|
|
|
|
685
|
|
|
|
|
|
|
MUCJoin(room=>string, - Sends the appropriate MUC protocol to join |
686
|
|
|
|
|
|
|
server=>string, the specified room with the specified nick. |
687
|
|
|
|
|
|
|
nick=>string, |
688
|
|
|
|
|
|
|
password=>string) |
689
|
|
|
|
|
|
|
|
690
|
|
|
|
|
|
|
=head2 Register Functions |
691
|
|
|
|
|
|
|
|
692
|
|
|
|
|
|
|
RegisterSendData(string|JID, - takes the contents of the hash and |
693
|
|
|
|
|
|
|
hash) builds a jabebr:x:data return packet |
694
|
|
|
|
|
|
|
which it sends in a Net::Jabber::Query |
695
|
|
|
|
|
|
|
jabber:iq:register namespace packet. |
696
|
|
|
|
|
|
|
The first argument is the JID to send |
697
|
|
|
|
|
|
|
the packet to. This function returns |
698
|
|
|
|
|
|
|
an array that looks like this: |
699
|
|
|
|
|
|
|
|
700
|
|
|
|
|
|
|
[ type , message ] |
701
|
|
|
|
|
|
|
|
702
|
|
|
|
|
|
|
If type is "ok" then registration was |
703
|
|
|
|
|
|
|
successful, otherwise message contains |
704
|
|
|
|
|
|
|
a little more detail about the error. |
705
|
|
|
|
|
|
|
|
706
|
|
|
|
|
|
|
=head2 RPC Functions |
707
|
|
|
|
|
|
|
|
708
|
|
|
|
|
|
|
RPCParse(IQ object) - returns an array. The first argument tells |
709
|
|
|
|
|
|
|
the status "ok" or "fault". The second |
710
|
|
|
|
|
|
|
argument is an array if "ok", or a hash if |
711
|
|
|
|
|
|
|
"fault". |
712
|
|
|
|
|
|
|
|
713
|
|
|
|
|
|
|
RPCCall(to=>jid|string, - takes the methodName and params, |
714
|
|
|
|
|
|
|
methodName=>string, builds the RPC calls and sends it |
715
|
|
|
|
|
|
|
params=>array, to the specified address. Returns |
716
|
|
|
|
|
|
|
mode=>string, the above data from RPCParse. |
717
|
|
|
|
|
|
|
timeout=>int) |
718
|
|
|
|
|
|
|
See MODES above for using the mode |
719
|
|
|
|
|
|
|
and timeout. |
720
|
|
|
|
|
|
|
|
721
|
|
|
|
|
|
|
RPCResponse(to=>jid|string, - generates a response back to |
722
|
|
|
|
|
|
|
params=>array, the caller. If any part of |
723
|
|
|
|
|
|
|
faultCode=>int, fault is specified, then it |
724
|
|
|
|
|
|
|
faultString=>string) wins. |
725
|
|
|
|
|
|
|
|
726
|
|
|
|
|
|
|
|
727
|
|
|
|
|
|
|
Note: To ensure that you get the correct type for a param sent |
728
|
|
|
|
|
|
|
back, you can specify the type by prepending the type to |
729
|
|
|
|
|
|
|
the value: |
730
|
|
|
|
|
|
|
|
731
|
|
|
|
|
|
|
"i4:5" or "int:5" |
732
|
|
|
|
|
|
|
"boolean:0" |
733
|
|
|
|
|
|
|
"string:56" |
734
|
|
|
|
|
|
|
"double:5.0" |
735
|
|
|
|
|
|
|
"datetime:20020415T11:11:11" |
736
|
|
|
|
|
|
|
"base64:...." |
737
|
|
|
|
|
|
|
|
738
|
|
|
|
|
|
|
RPCSetCallBacks(method=>function, - sets the callback functions |
739
|
|
|
|
|
|
|
method=>function, for the specified methods. |
740
|
|
|
|
|
|
|
etc...) The method comes from the |
741
|
|
|
|
|
|
|
and is case |
742
|
|
|
|
|
|
|
sensitive. The single |
743
|
|
|
|
|
|
|
arguemnt is a ref to an |
744
|
|
|
|
|
|
|
array that contains the |
745
|
|
|
|
|
|
|
. The function you |
746
|
|
|
|
|
|
|
write should return one of two |
747
|
|
|
|
|
|
|
things: |
748
|
|
|
|
|
|
|
|
749
|
|
|
|
|
|
|
["ok", [...] ] |
750
|
|
|
|
|
|
|
|
751
|
|
|
|
|
|
|
The [...] is a list of the |
752
|
|
|
|
|
|
|
you want to return. |
753
|
|
|
|
|
|
|
|
754
|
|
|
|
|
|
|
["fault", {faultCode=>1, |
755
|
|
|
|
|
|
|
faultString=>...} ] |
756
|
|
|
|
|
|
|
|
757
|
|
|
|
|
|
|
If you set the function to undef, |
758
|
|
|
|
|
|
|
then the method is removed from |
759
|
|
|
|
|
|
|
the list. |
760
|
|
|
|
|
|
|
|
761
|
|
|
|
|
|
|
=head2 Search Functions |
762
|
|
|
|
|
|
|
|
763
|
|
|
|
|
|
|
SearchRequest(to=>string, - send an request to the specified |
764
|
|
|
|
|
|
|
mode=>string, server/transport, if not specified it |
765
|
|
|
|
|
|
|
timeout=>int) sends to the current active server. |
766
|
|
|
|
|
|
|
SearchRequest() The function returns a hash that |
767
|
|
|
|
|
|
|
contains the required fields. Here |
768
|
|
|
|
|
|
|
is an example of the hash: |
769
|
|
|
|
|
|
|
|
770
|
|
|
|
|
|
|
$hash{fields} - The raw fields from |
771
|
|
|
|
|
|
|
the iq:register. To |
772
|
|
|
|
|
|
|
be used if there is |
773
|
|
|
|
|
|
|
no x:data in the |
774
|
|
|
|
|
|
|
packet. |
775
|
|
|
|
|
|
|
$hash{instructions} - How to fill out |
776
|
|
|
|
|
|
|
the form. |
777
|
|
|
|
|
|
|
$hash{form} - The new dynamic forms. |
778
|
|
|
|
|
|
|
|
779
|
|
|
|
|
|
|
In $hash{form}, the fields that are |
780
|
|
|
|
|
|
|
present are the required fields the |
781
|
|
|
|
|
|
|
server needs. |
782
|
|
|
|
|
|
|
|
783
|
|
|
|
|
|
|
See MODES above for using the mode |
784
|
|
|
|
|
|
|
and timeout. |
785
|
|
|
|
|
|
|
|
786
|
|
|
|
|
|
|
SearchSend(to=>string|JID, - takes the contents of the hash and |
787
|
|
|
|
|
|
|
hash) passes it to the SetSearch function |
788
|
|
|
|
|
|
|
in the Net::Jabber::Query |
789
|
|
|
|
|
|
|
jabber:iq:search namespace. And then |
790
|
|
|
|
|
|
|
sends the packet. |
791
|
|
|
|
|
|
|
|
792
|
|
|
|
|
|
|
SearchSendData(string|JID, - takes the contents of the hash and |
793
|
|
|
|
|
|
|
hash) builds a jabebr:x:data return packet |
794
|
|
|
|
|
|
|
which it sends in a Net::Jabber::Query |
795
|
|
|
|
|
|
|
jabber:iq:search namespace packet. |
796
|
|
|
|
|
|
|
The first argument is the JID to send |
797
|
|
|
|
|
|
|
the packet to. |
798
|
|
|
|
|
|
|
|
799
|
|
|
|
|
|
|
=head2 Time Functions |
800
|
|
|
|
|
|
|
|
801
|
|
|
|
|
|
|
TimeQuery(to=>string, - asks the jid specified for its localtime. |
802
|
|
|
|
|
|
|
mode=>string, If the to is blank, then it queries the |
803
|
|
|
|
|
|
|
timeout=>int) server. Returns a hash with the various |
804
|
|
|
|
|
|
|
TimeQuery() items set if mode is set to "block": |
805
|
|
|
|
|
|
|
|
806
|
|
|
|
|
|
|
$time{utc} - Time in UTC |
807
|
|
|
|
|
|
|
$time{tz} - Timezone |
808
|
|
|
|
|
|
|
$time{display} - Display string |
809
|
|
|
|
|
|
|
|
810
|
|
|
|
|
|
|
See MODES above for using the mode |
811
|
|
|
|
|
|
|
and timeout. |
812
|
|
|
|
|
|
|
|
813
|
|
|
|
|
|
|
TimeSend(to=>string) - sends the current UTC time to the specified |
814
|
|
|
|
|
|
|
jid. |
815
|
|
|
|
|
|
|
|
816
|
|
|
|
|
|
|
=head2 Version Functions |
817
|
|
|
|
|
|
|
|
818
|
|
|
|
|
|
|
VersionQuery(to=>string, - asks the jid specified for its |
819
|
|
|
|
|
|
|
mode=>string, client version information. If the |
820
|
|
|
|
|
|
|
timeout=>int) to is blank, then it queries the |
821
|
|
|
|
|
|
|
VersionQuery() server. Returns ahash with the |
822
|
|
|
|
|
|
|
various items set if mode is set to |
823
|
|
|
|
|
|
|
"block": |
824
|
|
|
|
|
|
|
|
825
|
|
|
|
|
|
|
$version{name} - Name |
826
|
|
|
|
|
|
|
$version{ver} - Version |
827
|
|
|
|
|
|
|
$version{os} - Operating System/ |
828
|
|
|
|
|
|
|
Platform |
829
|
|
|
|
|
|
|
|
830
|
|
|
|
|
|
|
See MODES above for using the mode |
831
|
|
|
|
|
|
|
and timeout. |
832
|
|
|
|
|
|
|
|
833
|
|
|
|
|
|
|
VersionSend(to=>string, - sends the specified version information |
834
|
|
|
|
|
|
|
name=>string, to the jid specified in the to. |
835
|
|
|
|
|
|
|
ver=>string, |
836
|
|
|
|
|
|
|
os=>string) |
837
|
|
|
|
|
|
|
|
838
|
|
|
|
|
|
|
=head1 AUTHOR |
839
|
|
|
|
|
|
|
|
840
|
|
|
|
|
|
|
Ryan Eatmon |
841
|
|
|
|
|
|
|
|
842
|
|
|
|
|
|
|
=head1 COPYRIGHT |
843
|
|
|
|
|
|
|
|
844
|
|
|
|
|
|
|
This module is free software; you can redistribute it and/or modify |
845
|
|
|
|
|
|
|
it under the same terms as Perl itself. |
846
|
|
|
|
|
|
|
|
847
|
|
|
|
|
|
|
=cut |
848
|
|
|
|
|
|
|
|
849
|
49
|
|
|
49
|
|
299
|
use strict; |
|
49
|
|
|
|
|
96
|
|
|
49
|
|
|
|
|
2101
|
|
850
|
49
|
|
|
49
|
|
276
|
use Carp; |
|
49
|
|
|
|
|
104
|
|
|
49
|
|
|
|
|
3425
|
|
851
|
49
|
|
|
49
|
|
284
|
use vars qw($VERSION); |
|
49
|
|
|
|
|
97
|
|
|
49
|
|
|
|
|
627823
|
|
852
|
|
|
|
|
|
|
|
853
|
|
|
|
|
|
|
$VERSION = "2.0"; |
854
|
|
|
|
|
|
|
|
855
|
|
|
|
|
|
|
############################################################################## |
856
|
|
|
|
|
|
|
# BuildObject takes a root tag and builds the correct object. NEWOBJECT is |
857
|
|
|
|
|
|
|
# the table that maps tag to package. Override these, or provide new ones. |
858
|
|
|
|
|
|
|
#----------------------------------------------------------------------------- |
859
|
|
|
|
|
|
|
$Net::XMPP::Protocol::NEWOBJECT{'iq'} = "Net::Jabber::IQ"; |
860
|
|
|
|
|
|
|
$Net::XMPP::Protocol::NEWOBJECT{'message'} = "Net::Jabber::Message"; |
861
|
|
|
|
|
|
|
$Net::XMPP::Protocol::NEWOBJECT{'presence'} = "Net::Jabber::Presence"; |
862
|
|
|
|
|
|
|
$Net::XMPP::Protocol::NEWOBJECT{'jid'} = "Net::Jabber::JID"; |
863
|
|
|
|
|
|
|
############################################################################## |
864
|
|
|
|
|
|
|
|
865
|
|
|
|
|
|
|
############################################################################### |
866
|
|
|
|
|
|
|
#+----------------------------------------------------------------------------- |
867
|
|
|
|
|
|
|
#| |
868
|
|
|
|
|
|
|
#| Base API |
869
|
|
|
|
|
|
|
#| |
870
|
|
|
|
|
|
|
#+----------------------------------------------------------------------------- |
871
|
|
|
|
|
|
|
############################################################################### |
872
|
|
|
|
|
|
|
|
873
|
|
|
|
|
|
|
############################################################################### |
874
|
|
|
|
|
|
|
# |
875
|
|
|
|
|
|
|
# Info - set the base information about this Jabber Client/Component for |
876
|
|
|
|
|
|
|
# use in a default response. |
877
|
|
|
|
|
|
|
# |
878
|
|
|
|
|
|
|
############################################################################### |
879
|
|
|
|
|
|
|
sub Info |
880
|
|
|
|
|
|
|
{ |
881
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
882
|
0
|
|
|
|
|
0
|
my %args; |
883
|
0
|
|
|
|
|
0
|
while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
|
0
|
|
|
|
|
0
|
|
884
|
|
|
|
|
|
|
|
885
|
0
|
|
|
|
|
0
|
foreach my $arg (keys(%args)) |
886
|
|
|
|
|
|
|
{ |
887
|
0
|
|
|
|
|
0
|
$self->{INFO}->{$arg} = $args{$arg}; |
888
|
|
|
|
|
|
|
} |
889
|
|
|
|
|
|
|
} |
890
|
|
|
|
|
|
|
|
891
|
|
|
|
|
|
|
|
892
|
|
|
|
|
|
|
############################################################################### |
893
|
|
|
|
|
|
|
# |
894
|
|
|
|
|
|
|
# DefineNamespace - adds the namespace and corresponding functions onto the |
895
|
|
|
|
|
|
|
# of available functions based on namespace. |
896
|
|
|
|
|
|
|
# |
897
|
|
|
|
|
|
|
# Deprecated in favor of AddNamespace |
898
|
|
|
|
|
|
|
# |
899
|
|
|
|
|
|
|
############################################################################### |
900
|
|
|
|
|
|
|
sub DefineNamespace |
901
|
|
|
|
|
|
|
{ |
902
|
5
|
|
|
5
|
0
|
76247
|
my $self = shift; |
903
|
5
|
|
|
|
|
7
|
my %args; |
904
|
5
|
|
|
|
|
20
|
while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
|
15
|
|
|
|
|
53
|
|
905
|
|
|
|
|
|
|
|
906
|
5
|
50
|
|
|
|
15
|
croak("You must specify xmlns=>'' for the function call to DefineNamespace") |
907
|
|
|
|
|
|
|
if !exists($args{xmlns}); |
908
|
5
|
50
|
|
|
|
20
|
croak("You must specify type=>'' for the function call to DefineNamespace") |
909
|
|
|
|
|
|
|
if !exists($args{type}); |
910
|
5
|
50
|
|
|
|
14
|
croak("You must specify functions=>'' for the function call to DefineNamespace") |
911
|
|
|
|
|
|
|
if !exists($args{functions}); |
912
|
|
|
|
|
|
|
|
913
|
5
|
|
|
|
|
8
|
my %xpath; |
914
|
|
|
|
|
|
|
|
915
|
|
|
|
|
|
|
my $tag; |
916
|
5
|
50
|
|
|
|
20
|
if (exists($args{tag})) |
917
|
|
|
|
|
|
|
{ |
918
|
0
|
|
|
|
|
0
|
$tag = $args{tag}; |
919
|
|
|
|
|
|
|
} |
920
|
|
|
|
|
|
|
else |
921
|
|
|
|
|
|
|
{ |
922
|
5
|
50
|
|
|
|
19
|
$tag = "x" if ($args{type} eq "X"); |
923
|
5
|
50
|
|
|
|
23
|
$tag = "query" if ($args{type} eq "Query"); |
924
|
|
|
|
|
|
|
} |
925
|
|
|
|
|
|
|
|
926
|
5
|
|
|
|
|
8
|
foreach my $function (@{$args{functions}}) |
|
5
|
|
|
|
|
13
|
|
927
|
|
|
|
|
|
|
{ |
928
|
29
|
|
|
|
|
34
|
my %tempHash = %{$function}; |
|
29
|
|
|
|
|
105
|
|
929
|
29
|
|
|
|
|
40
|
my %funcHash; |
930
|
29
|
|
|
|
|
55
|
foreach my $func (keys(%tempHash)) |
931
|
|
|
|
|
|
|
{ |
932
|
100
|
|
|
|
|
175
|
$funcHash{lc($func)} = $tempHash{$func}; |
933
|
|
|
|
|
|
|
} |
934
|
|
|
|
|
|
|
|
935
|
29
|
50
|
|
|
|
82
|
croak("You must specify name=>'' for each function in call to DefineNamespace") |
936
|
|
|
|
|
|
|
if !exists($funcHash{name}); |
937
|
|
|
|
|
|
|
|
938
|
29
|
|
|
|
|
47
|
my $name = delete($funcHash{name}); |
939
|
|
|
|
|
|
|
|
940
|
29
|
100
|
100
|
|
|
101
|
if (!exists($funcHash{set}) && exists($funcHash{get})) |
941
|
|
|
|
|
|
|
{ |
942
|
1
|
|
|
|
|
177
|
croak("The DefineNamespace arugments have changed, and I cannot determine the\nnew values automatically for name($name). Please read the man page\nfor Net::Jabber::Namespaces. I apologize for this incompatability.\n"); |
943
|
|
|
|
|
|
|
} |
944
|
|
|
|
|
|
|
|
945
|
28
|
50
|
100
|
|
|
158
|
if (exists($funcHash{type}) || exists($funcHash{path}) || |
|
|
|
66
|
|
|
|
|
|
|
|
66
|
|
|
|
|
946
|
|
|
|
|
|
|
exists($funcHash{child}) || exists($funcHash{calls})) |
947
|
|
|
|
|
|
|
{ |
948
|
|
|
|
|
|
|
|
949
|
16
|
|
|
|
|
28
|
foreach my $type (keys(%funcHash)) |
950
|
|
|
|
|
|
|
{ |
951
|
23
|
100
|
|
|
|
39
|
if ($type eq "child") |
952
|
|
|
|
|
|
|
{ |
953
|
2
|
|
|
|
|
7
|
$xpath{$name}->{$type}->{ns} = $funcHash{$type}->[1]; |
954
|
2
|
|
|
|
|
3
|
my $i = 2; |
955
|
2
|
|
|
|
|
3
|
while( $i <= $#{$funcHash{$type}} ) |
|
2
|
|
|
|
|
10
|
|
956
|
|
|
|
|
|
|
{ |
957
|
0
|
0
|
|
|
|
0
|
if ($funcHash{$type}->[$i] eq "__netjabber__:skip_xmlns") |
958
|
|
|
|
|
|
|
{ |
959
|
0
|
|
|
|
|
0
|
$xpath{$name}->{$type}->{skip_xmlns} = 1; |
960
|
|
|
|
|
|
|
} |
961
|
|
|
|
|
|
|
|
962
|
0
|
0
|
|
|
|
0
|
if ($funcHash{$type}->[$i] eq "__netjabber__:specifyname") |
963
|
|
|
|
|
|
|
{ |
964
|
0
|
|
|
|
|
0
|
$xpath{$name}->{$type}->{specify_name} = 1; |
965
|
0
|
|
|
|
|
0
|
$i++; |
966
|
0
|
|
|
|
|
0
|
$xpath{$name}->{$type}->{tag} = $funcHash{$type}->[$i+1]; |
967
|
|
|
|
|
|
|
} |
968
|
|
|
|
|
|
|
|
969
|
0
|
|
|
|
|
0
|
$i++; |
970
|
|
|
|
|
|
|
} |
971
|
|
|
|
|
|
|
} |
972
|
|
|
|
|
|
|
else |
973
|
|
|
|
|
|
|
{ |
974
|
21
|
|
|
|
|
70
|
$xpath{$name}->{$type} = $funcHash{$type}; |
975
|
|
|
|
|
|
|
} |
976
|
|
|
|
|
|
|
} |
977
|
16
|
|
|
|
|
123
|
next; |
978
|
|
|
|
|
|
|
} |
979
|
|
|
|
|
|
|
|
980
|
12
|
|
|
|
|
25
|
my $type = $funcHash{set}->[0]; |
981
|
12
|
|
|
|
|
17
|
my $xpath = $funcHash{set}->[1]; |
982
|
12
|
100
|
|
|
|
26
|
if (exists($funcHash{hash})) |
983
|
|
|
|
|
|
|
{ |
984
|
11
|
100
|
|
|
|
22
|
$xpath = "text()" if ($funcHash{hash} eq "data"); |
985
|
11
|
100
|
|
|
|
23
|
$xpath .= "/text()" if ($funcHash{hash} eq "child-data"); |
986
|
11
|
100
|
|
|
|
31
|
$xpath = "\@$xpath" if ($funcHash{hash} eq "att"); |
987
|
11
|
100
|
|
|
|
45
|
$xpath = "$1/\@$2" if ($funcHash{hash} =~ /^att-(\S+)-(.+)$/); |
988
|
|
|
|
|
|
|
} |
989
|
|
|
|
|
|
|
|
990
|
12
|
100
|
|
|
|
27
|
if ($type eq "master") |
991
|
|
|
|
|
|
|
{ |
992
|
1
|
|
|
|
|
5
|
$xpath{$name}->{type} = $type; |
993
|
1
|
|
|
|
|
5
|
next; |
994
|
|
|
|
|
|
|
} |
995
|
|
|
|
|
|
|
|
996
|
11
|
100
|
|
|
|
26
|
if ($type eq "scalar") |
997
|
|
|
|
|
|
|
{ |
998
|
8
|
|
|
|
|
23
|
$xpath{$name}->{path} = $xpath; |
999
|
8
|
|
|
|
|
29
|
next; |
1000
|
|
|
|
|
|
|
} |
1001
|
|
|
|
|
|
|
|
1002
|
3
|
100
|
|
|
|
15
|
if ($type eq "flag") |
1003
|
|
|
|
|
|
|
{ |
1004
|
2
|
|
|
|
|
8
|
$xpath{$name}->{type} = 'flag'; |
1005
|
2
|
|
|
|
|
4
|
$xpath{$name}->{path} = $xpath; |
1006
|
2
|
|
|
|
|
7
|
next; |
1007
|
|
|
|
|
|
|
} |
1008
|
|
|
|
|
|
|
|
1009
|
1
|
50
|
33
|
|
|
9
|
if (($funcHash{hash} eq "child-add") && exists($funcHash{add})) |
1010
|
|
|
|
|
|
|
{ |
1011
|
1
|
|
|
|
|
4
|
$xpath{$name}->{type} = "node"; |
1012
|
1
|
|
|
|
|
3
|
$xpath{$name}->{path} = $funcHash{add}->[3]; |
1013
|
1
|
|
|
|
|
4
|
$xpath{$name}->{child}->{ns} = $funcHash{add}->[1]; |
1014
|
1
|
|
|
|
|
3
|
$xpath{$name}->{calls} = [ 'Add' ]; |
1015
|
1
|
|
|
|
|
4
|
next; |
1016
|
|
|
|
|
|
|
} |
1017
|
|
|
|
|
|
|
} |
1018
|
|
|
|
|
|
|
|
1019
|
4
|
|
|
|
|
35
|
$self->AddNamespace(ns => $args{xmlns}, |
1020
|
|
|
|
|
|
|
tag => $tag, |
1021
|
|
|
|
|
|
|
xpath => \%xpath ); |
1022
|
|
|
|
|
|
|
} |
1023
|
|
|
|
|
|
|
|
1024
|
|
|
|
|
|
|
############################################################################### |
1025
|
|
|
|
|
|
|
# |
1026
|
|
|
|
|
|
|
# AgentsGet - Sends an empty IQ to the server/transport to request that the |
1027
|
|
|
|
|
|
|
# list of supported Agents be sent to them. Returns a hash |
1028
|
|
|
|
|
|
|
# containing the values for the agents. |
1029
|
|
|
|
|
|
|
# |
1030
|
|
|
|
|
|
|
############################################################################### |
1031
|
|
|
|
|
|
|
sub AgentsGet |
1032
|
|
|
|
|
|
|
{ |
1033
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
1034
|
|
|
|
|
|
|
|
1035
|
0
|
|
|
|
|
0
|
my $iq = $self->_iq(); |
1036
|
0
|
|
|
|
|
0
|
$iq->SetIQ(@_); |
1037
|
0
|
|
|
|
|
0
|
$iq->SetIQ(type=>"get"); |
1038
|
0
|
|
|
|
|
0
|
my $query = $iq->NewQuery("jabber:iq:agents"); |
1039
|
|
|
|
|
|
|
|
1040
|
0
|
|
|
|
|
0
|
$iq = $self->SendAndReceiveWithID($iq); |
1041
|
|
|
|
|
|
|
|
1042
|
0
|
0
|
|
|
|
0
|
return unless defined($iq); |
1043
|
|
|
|
|
|
|
|
1044
|
0
|
|
|
|
|
0
|
$query = $iq->GetQuery(); |
1045
|
0
|
|
|
|
|
0
|
my @agents = $query->GetAgents(); |
1046
|
|
|
|
|
|
|
|
1047
|
0
|
|
|
|
|
0
|
my %agents; |
1048
|
0
|
|
|
|
|
0
|
my $count = 0; |
1049
|
0
|
|
|
|
|
0
|
foreach my $agent (@agents) |
1050
|
|
|
|
|
|
|
{ |
1051
|
0
|
|
|
|
|
0
|
my $jid = $agent->GetJID(); |
1052
|
0
|
|
|
|
|
0
|
$agents{$jid}->{name} = $agent->GetName(); |
1053
|
0
|
|
|
|
|
0
|
$agents{$jid}->{description} = $agent->GetDescription(); |
1054
|
0
|
|
|
|
|
0
|
$agents{$jid}->{transport} = $agent->GetTransport(); |
1055
|
0
|
|
|
|
|
0
|
$agents{$jid}->{service} = $agent->GetService(); |
1056
|
0
|
|
|
|
|
0
|
$agents{$jid}->{register} = $agent->DefinedRegister(); |
1057
|
0
|
|
|
|
|
0
|
$agents{$jid}->{search} = $agent->DefinedSearch(); |
1058
|
0
|
|
|
|
|
0
|
$agents{$jid}->{groupchat} = $agent->DefinedGroupChat(); |
1059
|
0
|
|
|
|
|
0
|
$agents{$jid}->{agents} = $agent->DefinedAgents(); |
1060
|
0
|
|
|
|
|
0
|
$agents{$jid}->{order} = $count++; |
1061
|
|
|
|
|
|
|
} |
1062
|
|
|
|
|
|
|
|
1063
|
0
|
|
|
|
|
0
|
return %agents; |
1064
|
|
|
|
|
|
|
} |
1065
|
|
|
|
|
|
|
|
1066
|
|
|
|
|
|
|
|
1067
|
|
|
|
|
|
|
############################################################################### |
1068
|
|
|
|
|
|
|
# |
1069
|
|
|
|
|
|
|
# BrowseRequest - requests the browse information from the specified JID. |
1070
|
|
|
|
|
|
|
# |
1071
|
|
|
|
|
|
|
############################################################################### |
1072
|
|
|
|
|
|
|
sub BrowseRequest |
1073
|
|
|
|
|
|
|
{ |
1074
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
1075
|
0
|
|
|
|
|
0
|
my %args; |
1076
|
0
|
|
|
|
|
0
|
$args{mode} = "block"; |
1077
|
0
|
|
|
|
|
0
|
while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
|
0
|
|
|
|
|
0
|
|
1078
|
|
|
|
|
|
|
|
1079
|
0
|
0
|
|
|
|
0
|
my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef; |
1080
|
|
|
|
|
|
|
|
1081
|
0
|
|
|
|
|
0
|
my $iq = $self->_iq(); |
1082
|
0
|
|
|
|
|
0
|
$iq->SetIQ(to=>$args{jid}, |
1083
|
|
|
|
|
|
|
type=>"get"); |
1084
|
0
|
|
|
|
|
0
|
my $query = $iq->NewQuery("jabber:iq:browse"); |
1085
|
|
|
|
|
|
|
|
1086
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
1087
|
|
|
|
|
|
|
# Send the IQ with the next available ID and wait for a reply with that |
1088
|
|
|
|
|
|
|
# id to be received. Then grab the IQ reply. |
1089
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
1090
|
0
|
0
|
|
|
|
0
|
if ($args{mode} eq "passthru") |
1091
|
|
|
|
|
|
|
{ |
1092
|
0
|
|
|
|
|
0
|
my $id = $self->UniqueID(); |
1093
|
0
|
|
|
|
|
0
|
$iq->SetIQ(id=>$id); |
1094
|
0
|
|
|
|
|
0
|
$self->Send($iq); |
1095
|
0
|
|
|
|
|
0
|
return $id; |
1096
|
|
|
|
|
|
|
} |
1097
|
|
|
|
|
|
|
|
1098
|
0
|
0
|
|
|
|
0
|
return $self->SendWithID($iq) if ($args{mode} eq "nonblock"); |
1099
|
|
|
|
|
|
|
|
1100
|
0
|
|
|
|
|
0
|
$iq = $self->SendAndReceiveWithID($iq,$timeout); |
1101
|
|
|
|
|
|
|
|
1102
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
1103
|
|
|
|
|
|
|
# Check if there was an error. |
1104
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
1105
|
0
|
0
|
|
|
|
0
|
return unless defined($iq); |
1106
|
0
|
0
|
|
|
|
0
|
if ($iq->GetType() eq "error") |
1107
|
|
|
|
|
|
|
{ |
1108
|
0
|
|
|
|
|
0
|
$self->SetErrorCode($iq->GetErrorCode().": ".$iq->GetError()); |
1109
|
0
|
|
|
|
|
0
|
return; |
1110
|
|
|
|
|
|
|
} |
1111
|
|
|
|
|
|
|
|
1112
|
0
|
|
|
|
|
0
|
$query = $iq->GetQuery(); |
1113
|
|
|
|
|
|
|
|
1114
|
0
|
0
|
|
|
|
0
|
if (defined($query)) |
1115
|
|
|
|
|
|
|
{ |
1116
|
0
|
|
|
|
|
0
|
my %browse = %{$self->BrowseParse($query)}; |
|
0
|
|
|
|
|
0
|
|
1117
|
0
|
|
|
|
|
0
|
return %browse; |
1118
|
|
|
|
|
|
|
} |
1119
|
|
|
|
|
|
|
else |
1120
|
|
|
|
|
|
|
{ |
1121
|
0
|
|
|
|
|
0
|
return; |
1122
|
|
|
|
|
|
|
} |
1123
|
|
|
|
|
|
|
} |
1124
|
|
|
|
|
|
|
|
1125
|
|
|
|
|
|
|
|
1126
|
|
|
|
|
|
|
############################################################################### |
1127
|
|
|
|
|
|
|
# |
1128
|
|
|
|
|
|
|
# BrowseParse - helper function for BrowseRequest to convert the object |
1129
|
|
|
|
|
|
|
# tree into a hash for better consumption. |
1130
|
|
|
|
|
|
|
# |
1131
|
|
|
|
|
|
|
############################################################################### |
1132
|
|
|
|
|
|
|
sub BrowseParse |
1133
|
|
|
|
|
|
|
{ |
1134
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
1135
|
0
|
|
|
|
|
0
|
my $item = shift; |
1136
|
0
|
|
|
|
|
0
|
my %browse; |
1137
|
|
|
|
|
|
|
|
1138
|
0
|
0
|
|
|
|
0
|
if ($item->DefinedCategory()) |
1139
|
|
|
|
|
|
|
{ |
1140
|
0
|
|
|
|
|
0
|
$browse{category} = $item->GetCategory(); |
1141
|
|
|
|
|
|
|
} |
1142
|
|
|
|
|
|
|
else |
1143
|
|
|
|
|
|
|
{ |
1144
|
0
|
|
|
|
|
0
|
$browse{category} = $item->GetTag(); |
1145
|
|
|
|
|
|
|
} |
1146
|
0
|
|
|
|
|
0
|
$browse{type} = $item->GetType(); |
1147
|
0
|
|
|
|
|
0
|
$browse{name} = $item->GetName(); |
1148
|
0
|
|
|
|
|
0
|
$browse{jid} = $item->GetJID(); |
1149
|
0
|
|
|
|
|
0
|
$browse{ns} = [ $item->GetNS() ]; |
1150
|
|
|
|
|
|
|
|
1151
|
0
|
|
|
|
|
0
|
foreach my $subitem ($item->GetItems()) |
1152
|
|
|
|
|
|
|
{ |
1153
|
0
|
|
|
|
|
0
|
my ($subbrowse) = $self->BrowseParse($subitem); |
1154
|
0
|
|
|
|
|
0
|
push(@{$browse{children}},$subbrowse); |
|
0
|
|
|
|
|
0
|
|
1155
|
|
|
|
|
|
|
} |
1156
|
|
|
|
|
|
|
|
1157
|
0
|
|
|
|
|
0
|
return \%browse; |
1158
|
|
|
|
|
|
|
} |
1159
|
|
|
|
|
|
|
|
1160
|
|
|
|
|
|
|
|
1161
|
|
|
|
|
|
|
############################################################################### |
1162
|
|
|
|
|
|
|
# |
1163
|
|
|
|
|
|
|
# BrowseDBDelete - delete the JID from the DB completely. |
1164
|
|
|
|
|
|
|
# |
1165
|
|
|
|
|
|
|
############################################################################### |
1166
|
|
|
|
|
|
|
sub BrowseDBDelete |
1167
|
|
|
|
|
|
|
{ |
1168
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
1169
|
0
|
|
|
|
|
0
|
my ($jid) = @_; |
1170
|
|
|
|
|
|
|
|
1171
|
0
|
|
|
|
|
0
|
my $indexJID = $jid; |
1172
|
0
|
0
|
|
|
|
0
|
$indexJID = $jid->GetJID() if (ref($jid) eq "Net::Jabber::JID"); |
1173
|
|
|
|
|
|
|
|
1174
|
0
|
0
|
|
|
|
0
|
return if !exists($self->{BROWSEDB}->{$indexJID}); |
1175
|
0
|
|
|
|
|
0
|
delete($self->{BROWSEDB}->{$indexJID}); |
1176
|
0
|
|
|
|
|
0
|
$self->{DEBUG}->Log1("BrowseDBDelete: delete ",$indexJID," from the DB"); |
1177
|
|
|
|
|
|
|
} |
1178
|
|
|
|
|
|
|
|
1179
|
|
|
|
|
|
|
|
1180
|
|
|
|
|
|
|
############################################################################### |
1181
|
|
|
|
|
|
|
# |
1182
|
|
|
|
|
|
|
# BrowseDBQuery - retrieve the last Net::Jabber::Browse received with |
1183
|
|
|
|
|
|
|
# the highest priority. |
1184
|
|
|
|
|
|
|
# |
1185
|
|
|
|
|
|
|
############################################################################### |
1186
|
|
|
|
|
|
|
sub BrowseDBQuery |
1187
|
|
|
|
|
|
|
{ |
1188
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
1189
|
0
|
|
|
|
|
0
|
my %args; |
1190
|
0
|
|
|
|
|
0
|
while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
|
0
|
|
|
|
|
0
|
|
1191
|
|
|
|
|
|
|
|
1192
|
0
|
0
|
|
|
|
0
|
$args{timeout} = 10 unless exists($args{timeout}); |
1193
|
|
|
|
|
|
|
|
1194
|
0
|
|
|
|
|
0
|
my $indexJID = $args{jid}; |
1195
|
0
|
0
|
|
|
|
0
|
$indexJID = $args{jid}->GetJID() if (ref($args{jid}) eq "Net::Jabber::JID"); |
1196
|
|
|
|
|
|
|
|
1197
|
0
|
0
|
0
|
|
|
0
|
if ((exists($args{refresh}) && ($args{refresh} eq "1")) || |
|
|
|
0
|
|
|
|
|
1198
|
|
|
|
|
|
|
(!exists($self->{BROWSEDB}->{$indexJID}))) |
1199
|
|
|
|
|
|
|
{ |
1200
|
0
|
|
|
|
|
0
|
my %browse = $self->BrowseRequest(jid=>$args{jid}, |
1201
|
|
|
|
|
|
|
timeout=>$args{timeout}); |
1202
|
|
|
|
|
|
|
|
1203
|
0
|
|
|
|
|
0
|
$self->{BROWSEDB}->{$indexJID} = \%browse; |
1204
|
|
|
|
|
|
|
} |
1205
|
0
|
|
|
|
|
0
|
return %{$self->{BROWSEDB}->{$indexJID}}; |
|
0
|
|
|
|
|
0
|
|
1206
|
|
|
|
|
|
|
} |
1207
|
|
|
|
|
|
|
|
1208
|
|
|
|
|
|
|
|
1209
|
|
|
|
|
|
|
############################################################################### |
1210
|
|
|
|
|
|
|
# |
1211
|
|
|
|
|
|
|
# ByteStreamsProxyRequest - This queries a proxy server to get a list of |
1212
|
|
|
|
|
|
|
# |
1213
|
|
|
|
|
|
|
############################################################################### |
1214
|
|
|
|
|
|
|
sub ByteStreamsProxyRequest |
1215
|
|
|
|
|
|
|
{ |
1216
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
1217
|
0
|
|
|
|
|
0
|
my %args; |
1218
|
0
|
|
|
|
|
0
|
$args{mode} = "block"; |
1219
|
0
|
|
|
|
|
0
|
while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
|
0
|
|
|
|
|
0
|
|
1220
|
|
|
|
|
|
|
|
1221
|
0
|
0
|
|
|
|
0
|
my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef; |
1222
|
|
|
|
|
|
|
|
1223
|
0
|
|
|
|
|
0
|
my $iq = $self->_iq(); |
1224
|
0
|
|
|
|
|
0
|
$iq->SetIQ(to=>$args{jid}, |
1225
|
|
|
|
|
|
|
type=>"get"); |
1226
|
0
|
|
|
|
|
0
|
my $query = $iq->NewQuery("http://jabber.org/protocol/bytestreams"); |
1227
|
|
|
|
|
|
|
|
1228
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
1229
|
|
|
|
|
|
|
# Send the IQ with the next available ID and wait for a reply with that |
1230
|
|
|
|
|
|
|
# id to be received. Then grab the IQ reply. |
1231
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
1232
|
0
|
0
|
|
|
|
0
|
if ($args{mode} eq "passthru") |
1233
|
|
|
|
|
|
|
{ |
1234
|
0
|
|
|
|
|
0
|
my $id = $self->UniqueID(); |
1235
|
0
|
|
|
|
|
0
|
$iq->SetIQ(id=>$id); |
1236
|
0
|
|
|
|
|
0
|
$self->Send($iq); |
1237
|
0
|
|
|
|
|
0
|
return $id; |
1238
|
|
|
|
|
|
|
} |
1239
|
|
|
|
|
|
|
|
1240
|
0
|
0
|
|
|
|
0
|
return $self->SendWithID($iq) if ($args{mode} eq "nonblock"); |
1241
|
|
|
|
|
|
|
|
1242
|
0
|
|
|
|
|
0
|
$iq = $self->SendAndReceiveWithID($iq,$timeout); |
1243
|
|
|
|
|
|
|
|
1244
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
1245
|
|
|
|
|
|
|
# Check if there was an error. |
1246
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
1247
|
0
|
0
|
|
|
|
0
|
return unless defined($iq); |
1248
|
0
|
0
|
|
|
|
0
|
if ($iq->GetType() eq "error") |
1249
|
|
|
|
|
|
|
{ |
1250
|
0
|
|
|
|
|
0
|
$self->SetErrorCode($iq->GetErrorCode().": ".$iq->GetError()); |
1251
|
0
|
|
|
|
|
0
|
return; |
1252
|
|
|
|
|
|
|
} |
1253
|
|
|
|
|
|
|
|
1254
|
0
|
|
|
|
|
0
|
$query = $iq->GetQuery(); |
1255
|
|
|
|
|
|
|
|
1256
|
0
|
0
|
|
|
|
0
|
if (defined($query)) |
1257
|
|
|
|
|
|
|
{ |
1258
|
0
|
|
|
|
|
0
|
my @hosts = @{$self->ByteStreamsProxyParse($query)}; |
|
0
|
|
|
|
|
0
|
|
1259
|
0
|
|
|
|
|
0
|
return @hosts; |
1260
|
|
|
|
|
|
|
} |
1261
|
|
|
|
|
|
|
else |
1262
|
|
|
|
|
|
|
{ |
1263
|
0
|
|
|
|
|
0
|
return; |
1264
|
|
|
|
|
|
|
} |
1265
|
|
|
|
|
|
|
} |
1266
|
|
|
|
|
|
|
|
1267
|
|
|
|
|
|
|
|
1268
|
|
|
|
|
|
|
############################################################################### |
1269
|
|
|
|
|
|
|
# |
1270
|
|
|
|
|
|
|
# ByteStreamsProxyParse - helper function for ByteStreamProxyRequest to convert |
1271
|
|
|
|
|
|
|
# the object tree into a hash for better consumption. |
1272
|
|
|
|
|
|
|
# |
1273
|
|
|
|
|
|
|
############################################################################### |
1274
|
|
|
|
|
|
|
sub ByteStreamsProxyParse |
1275
|
|
|
|
|
|
|
{ |
1276
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
1277
|
0
|
|
|
|
|
0
|
my $item = shift; |
1278
|
|
|
|
|
|
|
|
1279
|
0
|
|
|
|
|
0
|
my @hosts; |
1280
|
|
|
|
|
|
|
|
1281
|
0
|
|
|
|
|
0
|
foreach my $host ($item->GetStreamHosts()) |
1282
|
|
|
|
|
|
|
{ |
1283
|
0
|
|
|
|
|
0
|
my %host; |
1284
|
0
|
|
|
|
|
0
|
$host{jid} = $host->GetJID(); |
1285
|
0
|
0
|
|
|
|
0
|
$host{host} = $host->GetHost() if $host->DefinedHost(); |
1286
|
0
|
0
|
|
|
|
0
|
$host{port} = $host->GetPort() if $host->DefinedPort(); |
1287
|
0
|
0
|
|
|
|
0
|
$host{zeroconf} = $host->GetZeroConf() if $host->DefinedZeroConf(); |
1288
|
|
|
|
|
|
|
|
1289
|
0
|
|
|
|
|
0
|
push(@hosts,\%host); |
1290
|
|
|
|
|
|
|
} |
1291
|
|
|
|
|
|
|
|
1292
|
0
|
|
|
|
|
0
|
return \@hosts; |
1293
|
|
|
|
|
|
|
} |
1294
|
|
|
|
|
|
|
|
1295
|
|
|
|
|
|
|
|
1296
|
|
|
|
|
|
|
############################################################################### |
1297
|
|
|
|
|
|
|
# |
1298
|
|
|
|
|
|
|
# ByteStreamsProxyActivate - This tells a proxy to activate the connection |
1299
|
|
|
|
|
|
|
# |
1300
|
|
|
|
|
|
|
############################################################################### |
1301
|
|
|
|
|
|
|
sub ByteStreamsProxyActivate |
1302
|
|
|
|
|
|
|
{ |
1303
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
1304
|
0
|
|
|
|
|
0
|
my %args; |
1305
|
0
|
|
|
|
|
0
|
$args{mode} = "block"; |
1306
|
0
|
|
|
|
|
0
|
while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
|
0
|
|
|
|
|
0
|
|
1307
|
|
|
|
|
|
|
|
1308
|
0
|
0
|
|
|
|
0
|
my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef; |
1309
|
|
|
|
|
|
|
|
1310
|
0
|
|
|
|
|
0
|
my $iq = $self->_iq(); |
1311
|
0
|
|
|
|
|
0
|
$iq->SetIQ(to=>$args{jid}, |
1312
|
|
|
|
|
|
|
type=>"set"); |
1313
|
0
|
|
|
|
|
0
|
my $query = $iq->NewQuery("http://jabber.org/protocol/bytestreams"); |
1314
|
0
|
0
|
|
|
|
0
|
$query->SetByteStreams(sid=>$args{sid}, |
1315
|
|
|
|
|
|
|
activate=>(ref($args{recipient}) eq "Net::Jabber::JID" ? $args{recipient}->GetJID("full") : $args{recipient}) |
1316
|
|
|
|
|
|
|
); |
1317
|
|
|
|
|
|
|
|
1318
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
1319
|
|
|
|
|
|
|
# Send the IQ with the next available ID and wait for a reply with that |
1320
|
|
|
|
|
|
|
# id to be received. Then grab the IQ reply. |
1321
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
1322
|
0
|
0
|
|
|
|
0
|
if ($args{mode} eq "passthru") |
1323
|
|
|
|
|
|
|
{ |
1324
|
0
|
|
|
|
|
0
|
my $id = $self->UniqueID(); |
1325
|
0
|
|
|
|
|
0
|
$iq->SetIQ(id=>$id); |
1326
|
0
|
|
|
|
|
0
|
$self->Send($iq); |
1327
|
0
|
|
|
|
|
0
|
return $id; |
1328
|
|
|
|
|
|
|
} |
1329
|
|
|
|
|
|
|
|
1330
|
0
|
0
|
|
|
|
0
|
return $self->SendWithID($iq) if ($args{mode} eq "nonblock"); |
1331
|
|
|
|
|
|
|
|
1332
|
0
|
|
|
|
|
0
|
$iq = $self->SendAndReceiveWithID($iq,$timeout); |
1333
|
|
|
|
|
|
|
|
1334
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
1335
|
|
|
|
|
|
|
# Check if there was an error. |
1336
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
1337
|
0
|
0
|
|
|
|
0
|
return unless defined($iq); |
1338
|
0
|
0
|
|
|
|
0
|
if ($iq->GetType() eq "error") |
1339
|
|
|
|
|
|
|
{ |
1340
|
0
|
|
|
|
|
0
|
$self->SetErrorCode($iq->GetErrorCode().": ".$iq->GetError()); |
1341
|
0
|
|
|
|
|
0
|
return; |
1342
|
|
|
|
|
|
|
} |
1343
|
|
|
|
|
|
|
|
1344
|
0
|
|
|
|
|
0
|
return 1; |
1345
|
|
|
|
|
|
|
} |
1346
|
|
|
|
|
|
|
|
1347
|
|
|
|
|
|
|
|
1348
|
|
|
|
|
|
|
############################################################################### |
1349
|
|
|
|
|
|
|
# |
1350
|
|
|
|
|
|
|
# ByteStreamsOffer - This offers a recipient a list of stream hosts to pick |
1351
|
|
|
|
|
|
|
# from. |
1352
|
|
|
|
|
|
|
# |
1353
|
|
|
|
|
|
|
############################################################################### |
1354
|
|
|
|
|
|
|
sub ByteStreamsOffer |
1355
|
|
|
|
|
|
|
{ |
1356
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
1357
|
0
|
|
|
|
|
0
|
my %args; |
1358
|
0
|
|
|
|
|
0
|
$args{mode} = "block"; |
1359
|
0
|
|
|
|
|
0
|
while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
|
0
|
|
|
|
|
0
|
|
1360
|
|
|
|
|
|
|
|
1361
|
0
|
0
|
|
|
|
0
|
my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef; |
1362
|
|
|
|
|
|
|
|
1363
|
0
|
|
|
|
|
0
|
my $iq = $self->_iq(); |
1364
|
0
|
|
|
|
|
0
|
$iq->SetIQ(to=>$args{jid}, |
1365
|
|
|
|
|
|
|
type=>"set"); |
1366
|
0
|
|
|
|
|
0
|
my $query = $iq->NewQuery("http://jabber.org/protocol/bytestreams"); |
1367
|
|
|
|
|
|
|
|
1368
|
0
|
|
|
|
|
0
|
$query->SetByteStreams(sid=>$args{sid}); |
1369
|
|
|
|
|
|
|
|
1370
|
0
|
|
|
|
|
0
|
foreach my $host (@{$args{streamhosts}}) |
|
0
|
|
|
|
|
0
|
|
1371
|
|
|
|
|
|
|
{ |
1372
|
0
|
0
|
|
|
|
0
|
$query->AddStreamHost(jid=>$host->{jid}, |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
1373
|
|
|
|
|
|
|
(exists($host->{host}) ? (host=>$host->{host}) : ()), |
1374
|
|
|
|
|
|
|
(exists($host->{port}) ? (port=>$host->{port}) : ()), |
1375
|
|
|
|
|
|
|
(exists($host->{zeroconf}) ? (zeroconf=>$host->{zeroconf}) : ()), |
1376
|
|
|
|
|
|
|
); |
1377
|
|
|
|
|
|
|
} |
1378
|
|
|
|
|
|
|
|
1379
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
1380
|
|
|
|
|
|
|
# Send the IQ with the next available ID and wait for a reply with that |
1381
|
|
|
|
|
|
|
# id to be received. Then grab the IQ reply. |
1382
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
1383
|
0
|
0
|
|
|
|
0
|
if ($args{mode} eq "passthru") |
1384
|
|
|
|
|
|
|
{ |
1385
|
0
|
|
|
|
|
0
|
my $id = $self->UniqueID(); |
1386
|
0
|
|
|
|
|
0
|
$iq->SetIQ(id=>$id); |
1387
|
0
|
|
|
|
|
0
|
$self->Send($iq); |
1388
|
0
|
|
|
|
|
0
|
return $id; |
1389
|
|
|
|
|
|
|
} |
1390
|
|
|
|
|
|
|
|
1391
|
0
|
0
|
|
|
|
0
|
return $self->SendWithID($iq) if ($args{mode} eq "nonblock"); |
1392
|
|
|
|
|
|
|
|
1393
|
0
|
|
|
|
|
0
|
$iq = $self->SendAndReceiveWithID($iq,$timeout); |
1394
|
|
|
|
|
|
|
|
1395
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
1396
|
|
|
|
|
|
|
# Check if there was an error. |
1397
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
1398
|
0
|
0
|
|
|
|
0
|
return unless defined($iq); |
1399
|
0
|
0
|
|
|
|
0
|
if ($iq->GetType() eq "error") |
1400
|
|
|
|
|
|
|
{ |
1401
|
0
|
|
|
|
|
0
|
$self->SetErrorCode($iq->GetErrorCode().": ".$iq->GetError()); |
1402
|
0
|
|
|
|
|
0
|
return; |
1403
|
|
|
|
|
|
|
} |
1404
|
|
|
|
|
|
|
|
1405
|
0
|
|
|
|
|
0
|
$query = $iq->GetQuery(); |
1406
|
|
|
|
|
|
|
|
1407
|
0
|
0
|
|
|
|
0
|
if (defined($query)) |
1408
|
|
|
|
|
|
|
{ |
1409
|
0
|
|
|
|
|
0
|
return $query->GetStreamHostUsedJID(); |
1410
|
|
|
|
|
|
|
} |
1411
|
|
|
|
|
|
|
else |
1412
|
|
|
|
|
|
|
{ |
1413
|
0
|
|
|
|
|
0
|
return; |
1414
|
|
|
|
|
|
|
} |
1415
|
|
|
|
|
|
|
} |
1416
|
|
|
|
|
|
|
|
1417
|
|
|
|
|
|
|
|
1418
|
|
|
|
|
|
|
############################################################################### |
1419
|
|
|
|
|
|
|
# |
1420
|
|
|
|
|
|
|
# DiscoInfoRequest - requests the disco information from the specified JID. |
1421
|
|
|
|
|
|
|
# |
1422
|
|
|
|
|
|
|
############################################################################### |
1423
|
|
|
|
|
|
|
sub DiscoInfoRequest |
1424
|
|
|
|
|
|
|
{ |
1425
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
1426
|
0
|
|
|
|
|
0
|
my %args; |
1427
|
0
|
|
|
|
|
0
|
$args{mode} = "block"; |
1428
|
0
|
|
|
|
|
0
|
while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
|
0
|
|
|
|
|
0
|
|
1429
|
|
|
|
|
|
|
|
1430
|
0
|
0
|
|
|
|
0
|
my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef; |
1431
|
|
|
|
|
|
|
|
1432
|
0
|
|
|
|
|
0
|
my $iq = $self->_iq(); |
1433
|
0
|
|
|
|
|
0
|
$iq->SetIQ(to=>$args{jid}, |
1434
|
|
|
|
|
|
|
type=>"get"); |
1435
|
0
|
|
|
|
|
0
|
my $query = $iq->NewQuery("http://jabber.org/protocol/disco#info"); |
1436
|
0
|
0
|
|
|
|
0
|
$query->SetDiscoInfo(node=>$args{node}) if exists($args{node}); |
1437
|
|
|
|
|
|
|
|
1438
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
1439
|
|
|
|
|
|
|
# Send the IQ with the next available ID and wait for a reply with that |
1440
|
|
|
|
|
|
|
# id to be received. Then grab the IQ reply. |
1441
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
1442
|
0
|
0
|
|
|
|
0
|
if ($args{mode} eq "passthru") |
1443
|
|
|
|
|
|
|
{ |
1444
|
0
|
|
|
|
|
0
|
my $id = $self->UniqueID(); |
1445
|
0
|
|
|
|
|
0
|
$iq->SetIQ(id=>$id); |
1446
|
0
|
|
|
|
|
0
|
$self->Send($iq); |
1447
|
0
|
|
|
|
|
0
|
return $id; |
1448
|
|
|
|
|
|
|
} |
1449
|
|
|
|
|
|
|
|
1450
|
0
|
0
|
|
|
|
0
|
return $self->SendWithID($iq) if ($args{mode} eq "nonblock"); |
1451
|
|
|
|
|
|
|
|
1452
|
0
|
|
|
|
|
0
|
$iq = $self->SendAndReceiveWithID($iq,$timeout); |
1453
|
|
|
|
|
|
|
|
1454
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
1455
|
|
|
|
|
|
|
# Check if there was an error. |
1456
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
1457
|
0
|
0
|
|
|
|
0
|
return unless defined($iq); |
1458
|
0
|
0
|
|
|
|
0
|
if ($iq->GetType() eq "error") |
1459
|
|
|
|
|
|
|
{ |
1460
|
0
|
|
|
|
|
0
|
$self->SetErrorCode($iq->GetErrorCode().": ".$iq->GetError()); |
1461
|
0
|
|
|
|
|
0
|
return; |
1462
|
|
|
|
|
|
|
} |
1463
|
0
|
0
|
|
|
|
0
|
return unless $iq->DefinedQuery(); |
1464
|
|
|
|
|
|
|
|
1465
|
0
|
|
|
|
|
0
|
$query = $iq->GetQuery(); |
1466
|
|
|
|
|
|
|
|
1467
|
0
|
|
|
|
|
0
|
return %{$self->DiscoInfoParse($query)}; |
|
0
|
|
|
|
|
0
|
|
1468
|
|
|
|
|
|
|
} |
1469
|
|
|
|
|
|
|
|
1470
|
|
|
|
|
|
|
|
1471
|
|
|
|
|
|
|
############################################################################### |
1472
|
|
|
|
|
|
|
# |
1473
|
|
|
|
|
|
|
# DiscoInfoParse - helper function for DiscoInfoRequest to convert the object |
1474
|
|
|
|
|
|
|
# tree into a hash for better consumption. |
1475
|
|
|
|
|
|
|
# |
1476
|
|
|
|
|
|
|
############################################################################### |
1477
|
|
|
|
|
|
|
sub DiscoInfoParse |
1478
|
|
|
|
|
|
|
{ |
1479
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
1480
|
0
|
|
|
|
|
0
|
my $item = shift; |
1481
|
|
|
|
|
|
|
|
1482
|
0
|
|
|
|
|
0
|
my %disco; |
1483
|
|
|
|
|
|
|
|
1484
|
0
|
|
|
|
|
0
|
foreach my $ident ($item->GetIdentities()) |
1485
|
|
|
|
|
|
|
{ |
1486
|
0
|
|
|
|
|
0
|
my %identity; |
1487
|
0
|
|
|
|
|
0
|
$identity{category} = $ident->GetCategory(); |
1488
|
0
|
|
|
|
|
0
|
$identity{name} = $ident->GetName(); |
1489
|
0
|
|
|
|
|
0
|
$identity{type} = $ident->GetType(); |
1490
|
0
|
|
|
|
|
0
|
push(@{$disco{identity}},\%identity); |
|
0
|
|
|
|
|
0
|
|
1491
|
|
|
|
|
|
|
} |
1492
|
|
|
|
|
|
|
|
1493
|
0
|
|
|
|
|
0
|
foreach my $feat ($item->GetFeatures()) |
1494
|
|
|
|
|
|
|
{ |
1495
|
0
|
|
|
|
|
0
|
$disco{feature}->{$feat->GetVar()} = 1; |
1496
|
|
|
|
|
|
|
} |
1497
|
|
|
|
|
|
|
|
1498
|
0
|
|
|
|
|
0
|
return \%disco; |
1499
|
|
|
|
|
|
|
} |
1500
|
|
|
|
|
|
|
|
1501
|
|
|
|
|
|
|
|
1502
|
|
|
|
|
|
|
############################################################################### |
1503
|
|
|
|
|
|
|
# |
1504
|
|
|
|
|
|
|
# DiscoItemsRequest - requests the disco information from the specified JID. |
1505
|
|
|
|
|
|
|
# |
1506
|
|
|
|
|
|
|
############################################################################### |
1507
|
|
|
|
|
|
|
sub DiscoItemsRequest |
1508
|
|
|
|
|
|
|
{ |
1509
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
1510
|
0
|
|
|
|
|
0
|
my %args; |
1511
|
0
|
|
|
|
|
0
|
$args{mode} = "block"; |
1512
|
0
|
|
|
|
|
0
|
while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
|
0
|
|
|
|
|
0
|
|
1513
|
|
|
|
|
|
|
|
1514
|
0
|
0
|
|
|
|
0
|
my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef; |
1515
|
|
|
|
|
|
|
|
1516
|
0
|
|
|
|
|
0
|
my $iq = $self->_iq(); |
1517
|
0
|
|
|
|
|
0
|
$iq->SetIQ(to=>$args{jid}, |
1518
|
|
|
|
|
|
|
type=>"get"); |
1519
|
0
|
|
|
|
|
0
|
my $query = $iq->NewQuery("http://jabber.org/protocol/disco#items"); |
1520
|
0
|
0
|
|
|
|
0
|
$query->SetDiscoItems(node=>$args{node}) if exists($args{node}); |
1521
|
|
|
|
|
|
|
|
1522
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
1523
|
|
|
|
|
|
|
# Send the IQ with the next available ID and wait for a reply with that |
1524
|
|
|
|
|
|
|
# id to be received. Then grab the IQ reply. |
1525
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
1526
|
0
|
0
|
|
|
|
0
|
if ($args{mode} eq "passthru") |
1527
|
|
|
|
|
|
|
{ |
1528
|
0
|
|
|
|
|
0
|
my $id = $self->UniqueID(); |
1529
|
0
|
|
|
|
|
0
|
$iq->SetIQ(id=>$id); |
1530
|
0
|
|
|
|
|
0
|
$self->Send($iq); |
1531
|
0
|
|
|
|
|
0
|
return $id; |
1532
|
|
|
|
|
|
|
} |
1533
|
|
|
|
|
|
|
|
1534
|
0
|
0
|
|
|
|
0
|
return $self->SendWithID($iq) if ($args{mode} eq "nonblock"); |
1535
|
|
|
|
|
|
|
|
1536
|
0
|
|
|
|
|
0
|
$iq = $self->SendAndReceiveWithID($iq,$timeout); |
1537
|
|
|
|
|
|
|
|
1538
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
1539
|
|
|
|
|
|
|
# Check if there was an error. |
1540
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
1541
|
0
|
0
|
|
|
|
0
|
return unless defined($iq); |
1542
|
0
|
0
|
|
|
|
0
|
if ($iq->GetType() eq "error") |
1543
|
|
|
|
|
|
|
{ |
1544
|
0
|
|
|
|
|
0
|
$self->SetErrorCode($iq->GetErrorCode().": ".$iq->GetError()); |
1545
|
0
|
|
|
|
|
0
|
return; |
1546
|
|
|
|
|
|
|
} |
1547
|
|
|
|
|
|
|
|
1548
|
0
|
|
|
|
|
0
|
$query = $iq->GetQuery(); |
1549
|
|
|
|
|
|
|
|
1550
|
0
|
0
|
|
|
|
0
|
if (defined($query)) |
1551
|
|
|
|
|
|
|
{ |
1552
|
0
|
|
|
|
|
0
|
my %disco = %{$self->DiscoItemsParse($query)}; |
|
0
|
|
|
|
|
0
|
|
1553
|
0
|
|
|
|
|
0
|
return %disco; |
1554
|
|
|
|
|
|
|
} |
1555
|
|
|
|
|
|
|
else |
1556
|
|
|
|
|
|
|
{ |
1557
|
0
|
|
|
|
|
0
|
return; |
1558
|
|
|
|
|
|
|
} |
1559
|
|
|
|
|
|
|
} |
1560
|
|
|
|
|
|
|
|
1561
|
|
|
|
|
|
|
|
1562
|
|
|
|
|
|
|
############################################################################### |
1563
|
|
|
|
|
|
|
# |
1564
|
|
|
|
|
|
|
# DiscoItemsParse - helper function for DiscoItemsRequest to convert the object |
1565
|
|
|
|
|
|
|
# tree into a hash for better consumption. |
1566
|
|
|
|
|
|
|
# |
1567
|
|
|
|
|
|
|
############################################################################### |
1568
|
|
|
|
|
|
|
sub DiscoItemsParse |
1569
|
|
|
|
|
|
|
{ |
1570
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
1571
|
0
|
|
|
|
|
0
|
my $item = shift; |
1572
|
|
|
|
|
|
|
|
1573
|
0
|
|
|
|
|
0
|
my %disco; |
1574
|
|
|
|
|
|
|
|
1575
|
0
|
|
|
|
|
0
|
foreach my $item ($item->GetItems()) |
1576
|
|
|
|
|
|
|
{ |
1577
|
0
|
|
|
|
|
0
|
$disco{$item->GetJID()}->{$item->GetNode()} = $item->GetName(); |
1578
|
|
|
|
|
|
|
} |
1579
|
|
|
|
|
|
|
|
1580
|
0
|
|
|
|
|
0
|
return \%disco; |
1581
|
|
|
|
|
|
|
} |
1582
|
|
|
|
|
|
|
|
1583
|
|
|
|
|
|
|
|
1584
|
|
|
|
|
|
|
############################################################################### |
1585
|
|
|
|
|
|
|
# |
1586
|
|
|
|
|
|
|
# FeatureNegRequest - requests a feature negotiation from the specified JID. |
1587
|
|
|
|
|
|
|
# |
1588
|
|
|
|
|
|
|
############################################################################### |
1589
|
|
|
|
|
|
|
sub FeatureNegRequest |
1590
|
|
|
|
|
|
|
{ |
1591
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
1592
|
0
|
|
|
|
|
0
|
my %args; |
1593
|
0
|
|
|
|
|
0
|
$args{mode} = "block"; |
1594
|
0
|
|
|
|
|
0
|
while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
|
0
|
|
|
|
|
0
|
|
1595
|
|
|
|
|
|
|
|
1596
|
0
|
0
|
|
|
|
0
|
my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef; |
1597
|
|
|
|
|
|
|
|
1598
|
0
|
|
|
|
|
0
|
my $iq = $self->_iq(); |
1599
|
0
|
|
|
|
|
0
|
$iq->SetIQ(to=>$args{jid}, |
1600
|
|
|
|
|
|
|
type=>"get"); |
1601
|
|
|
|
|
|
|
|
1602
|
0
|
|
|
|
|
0
|
my $query = $self->FeatureNegQuery($args{features}); |
1603
|
|
|
|
|
|
|
|
1604
|
0
|
|
|
|
|
0
|
$iq->AddQuery($query); |
1605
|
|
|
|
|
|
|
|
1606
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
1607
|
|
|
|
|
|
|
# Send the IQ with the next available ID and wait for a reply with that |
1608
|
|
|
|
|
|
|
# id to be received. Then grab the IQ reply. |
1609
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
1610
|
0
|
0
|
|
|
|
0
|
if ($args{mode} eq "passthru") |
1611
|
|
|
|
|
|
|
{ |
1612
|
0
|
|
|
|
|
0
|
my $id = $self->UniqueID(); |
1613
|
0
|
|
|
|
|
0
|
$iq->SetIQ(id=>$id); |
1614
|
0
|
|
|
|
|
0
|
$self->Send($iq); |
1615
|
0
|
|
|
|
|
0
|
return $id; |
1616
|
|
|
|
|
|
|
} |
1617
|
|
|
|
|
|
|
|
1618
|
0
|
0
|
|
|
|
0
|
return $self->SendWithID($iq) if ($args{mode} eq "nonblock"); |
1619
|
|
|
|
|
|
|
|
1620
|
0
|
|
|
|
|
0
|
$iq = $self->SendAndReceiveWithID($iq,$timeout); |
1621
|
|
|
|
|
|
|
|
1622
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
1623
|
|
|
|
|
|
|
# Check if there was an error. |
1624
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
1625
|
0
|
0
|
|
|
|
0
|
return unless defined($iq); |
1626
|
0
|
0
|
|
|
|
0
|
if ($iq->GetType() eq "error") |
1627
|
|
|
|
|
|
|
{ |
1628
|
0
|
|
|
|
|
0
|
$self->SetErrorCode($iq->GetErrorCode().": ".$iq->GetError()); |
1629
|
0
|
|
|
|
|
0
|
return; |
1630
|
|
|
|
|
|
|
} |
1631
|
|
|
|
|
|
|
|
1632
|
0
|
|
|
|
|
0
|
$query = $iq->GetQuery(); |
1633
|
|
|
|
|
|
|
|
1634
|
0
|
0
|
|
|
|
0
|
if (defined($query)) |
1635
|
|
|
|
|
|
|
{ |
1636
|
0
|
|
|
|
|
0
|
my %feats = %{$self->FeatureNegParse($query)}; |
|
0
|
|
|
|
|
0
|
|
1637
|
0
|
|
|
|
|
0
|
return %feats; |
1638
|
|
|
|
|
|
|
} |
1639
|
|
|
|
|
|
|
else |
1640
|
|
|
|
|
|
|
{ |
1641
|
0
|
|
|
|
|
0
|
return; |
1642
|
|
|
|
|
|
|
} |
1643
|
|
|
|
|
|
|
} |
1644
|
|
|
|
|
|
|
|
1645
|
|
|
|
|
|
|
#xxx fneg needs to reutrn a type='submit' on the x:data in a result |
1646
|
|
|
|
|
|
|
|
1647
|
|
|
|
|
|
|
|
1648
|
|
|
|
|
|
|
############################################################################### |
1649
|
|
|
|
|
|
|
# |
1650
|
|
|
|
|
|
|
# FeatureNegQuery - given a feature hash, return a query that contains it. |
1651
|
|
|
|
|
|
|
# |
1652
|
|
|
|
|
|
|
############################################################################### |
1653
|
|
|
|
|
|
|
sub FeatureNegQuery |
1654
|
|
|
|
|
|
|
{ |
1655
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
1656
|
0
|
|
|
|
|
0
|
my $features = shift; |
1657
|
|
|
|
|
|
|
|
1658
|
0
|
|
|
|
|
0
|
my $tag = "query"; |
1659
|
0
|
0
|
|
|
|
0
|
$tag = $Net::Jabber::Query::TAGS{'http://jabber.org/protocol/feature-neg'} |
1660
|
|
|
|
|
|
|
if exists($Net::Jabber::Query::TAGS{'http://jabber.org/protocol/feature-neg'}); |
1661
|
|
|
|
|
|
|
|
1662
|
0
|
|
|
|
|
0
|
my $query = new Net::Jabber::Query($tag); |
1663
|
0
|
|
|
|
|
0
|
$query->SetXMLNS("http://jabber.org/protocol/feature-neg"); |
1664
|
0
|
|
|
|
|
0
|
my $xdata = $query->NewX("jabber:x:data"); |
1665
|
|
|
|
|
|
|
|
1666
|
0
|
|
|
|
|
0
|
foreach my $feature (keys(%{$features})) |
|
0
|
|
|
|
|
0
|
|
1667
|
|
|
|
|
|
|
{ |
1668
|
0
|
|
|
|
|
0
|
my $field = $xdata->AddField(type=>"list-single", |
1669
|
|
|
|
|
|
|
var=>$feature); |
1670
|
0
|
|
|
|
|
0
|
foreach my $value (@{$features->{$feature}}) |
|
0
|
|
|
|
|
0
|
|
1671
|
|
|
|
|
|
|
{ |
1672
|
0
|
|
|
|
|
0
|
$field->AddOption(value=>$value); |
1673
|
|
|
|
|
|
|
} |
1674
|
|
|
|
|
|
|
} |
1675
|
|
|
|
|
|
|
|
1676
|
0
|
|
|
|
|
0
|
return $query; |
1677
|
|
|
|
|
|
|
} |
1678
|
|
|
|
|
|
|
|
1679
|
|
|
|
|
|
|
|
1680
|
|
|
|
|
|
|
############################################################################### |
1681
|
|
|
|
|
|
|
# |
1682
|
|
|
|
|
|
|
# FeatureNegParse - helper function for FeatureNegRequest to convert the object |
1683
|
|
|
|
|
|
|
# tree into a hash for better consumption. |
1684
|
|
|
|
|
|
|
# |
1685
|
|
|
|
|
|
|
############################################################################### |
1686
|
|
|
|
|
|
|
sub FeatureNegParse |
1687
|
|
|
|
|
|
|
{ |
1688
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
1689
|
0
|
|
|
|
|
0
|
my $item = shift; |
1690
|
|
|
|
|
|
|
|
1691
|
0
|
|
|
|
|
0
|
my %feats; |
1692
|
|
|
|
|
|
|
|
1693
|
0
|
|
|
|
|
0
|
my $xdata = $item->GetX("jabber:x:data"); |
1694
|
|
|
|
|
|
|
|
1695
|
0
|
|
|
|
|
0
|
foreach my $field ($xdata->GetFields()) |
1696
|
|
|
|
|
|
|
{ |
1697
|
0
|
|
|
|
|
0
|
my @options; |
1698
|
|
|
|
|
|
|
|
1699
|
0
|
|
|
|
|
0
|
foreach my $option ($field->GetOptions()) |
1700
|
|
|
|
|
|
|
{ |
1701
|
0
|
|
|
|
|
0
|
push(@options,$option->GetValue()); |
1702
|
|
|
|
|
|
|
} |
1703
|
|
|
|
|
|
|
|
1704
|
0
|
0
|
|
|
|
0
|
if ($#options == -1) |
1705
|
|
|
|
|
|
|
{ |
1706
|
|
|
|
|
|
|
|
1707
|
0
|
|
|
|
|
0
|
$feats{$field->GetVar()} = $field->GetValue(); |
1708
|
|
|
|
|
|
|
} |
1709
|
|
|
|
|
|
|
else |
1710
|
|
|
|
|
|
|
{ |
1711
|
0
|
|
|
|
|
0
|
$feats{$field->GetVar()} = \@options; |
1712
|
|
|
|
|
|
|
} |
1713
|
|
|
|
|
|
|
} |
1714
|
|
|
|
|
|
|
|
1715
|
0
|
|
|
|
|
0
|
return \%feats; |
1716
|
|
|
|
|
|
|
} |
1717
|
|
|
|
|
|
|
|
1718
|
|
|
|
|
|
|
#XXX - need a feature-neg answer function... |
1719
|
|
|
|
|
|
|
|
1720
|
|
|
|
|
|
|
############################################################################### |
1721
|
|
|
|
|
|
|
# |
1722
|
|
|
|
|
|
|
# FileTransferOffer - offer a file transfer JEP-95 |
1723
|
|
|
|
|
|
|
# |
1724
|
|
|
|
|
|
|
############################################################################### |
1725
|
|
|
|
|
|
|
sub FileTransferOffer |
1726
|
|
|
|
|
|
|
{ |
1727
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
1728
|
0
|
|
|
|
|
0
|
my %args; |
1729
|
0
|
|
|
|
|
0
|
$args{mode} = "block"; |
1730
|
0
|
|
|
|
|
0
|
while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
|
0
|
|
|
|
|
0
|
|
1731
|
|
|
|
|
|
|
|
1732
|
0
|
0
|
|
|
|
0
|
my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef; |
1733
|
|
|
|
|
|
|
|
1734
|
0
|
|
|
|
|
0
|
my $iq = $self->_iq(); |
1735
|
0
|
|
|
|
|
0
|
$iq->SetIQ(to=>$args{jid}, |
1736
|
|
|
|
|
|
|
type=>"set"); |
1737
|
0
|
|
|
|
|
0
|
my $query = $iq->NewQuery("http://jabber.org/protocol/si"); |
1738
|
0
|
|
|
|
|
0
|
my $profile = $query->NewQuery("http://jabber.org/protocol/si/profile/file-transfer"); |
1739
|
|
|
|
|
|
|
|
1740
|
|
|
|
|
|
|
# XXX support hashing via MD5 |
1741
|
|
|
|
|
|
|
# XXX support date via JEP-82 |
1742
|
|
|
|
|
|
|
|
1743
|
0
|
|
|
|
|
0
|
my ($filename) = ($args{filename} =~ /\/?([^\/]+)$/); |
1744
|
|
|
|
|
|
|
|
1745
|
0
|
|
|
|
|
0
|
$profile->SetFile(name=>$filename, |
1746
|
|
|
|
|
|
|
size=>(-s $args{filename}) |
1747
|
|
|
|
|
|
|
); |
1748
|
|
|
|
|
|
|
|
1749
|
0
|
0
|
|
|
|
0
|
$profile->SetFile(desc=>$args{desc}) if exists($args{desc}); |
1750
|
|
|
|
|
|
|
|
1751
|
0
|
0
|
|
|
|
0
|
$query->SetStream(mimetype=>(-B $args{filename} ? |
1752
|
|
|
|
|
|
|
"application/octect-stream" : |
1753
|
|
|
|
|
|
|
"text/plain" |
1754
|
|
|
|
|
|
|
), |
1755
|
|
|
|
|
|
|
id=>$args{sid}, |
1756
|
|
|
|
|
|
|
profile=>"http://jabber.org/protocol/si/profile/file-transfer" |
1757
|
|
|
|
|
|
|
); |
1758
|
|
|
|
|
|
|
|
1759
|
0
|
0
|
|
|
|
0
|
if (!exists($args{skip_methods})) |
1760
|
|
|
|
|
|
|
{ |
1761
|
0
|
0
|
|
|
|
0
|
if ($#{$args{methods}} == -1) |
|
0
|
|
|
|
|
0
|
|
1762
|
|
|
|
|
|
|
{ |
1763
|
0
|
|
|
|
|
0
|
print STDERR "You did not provide any valid methods for file transfer.\n"; |
1764
|
0
|
|
|
|
|
0
|
return; |
1765
|
|
|
|
|
|
|
} |
1766
|
|
|
|
|
|
|
|
1767
|
0
|
|
|
|
|
0
|
my $fneg = $self->FeatureNegQuery({'stream-method'=>$args{methods}}); |
1768
|
|
|
|
|
|
|
|
1769
|
0
|
|
|
|
|
0
|
$query->AddQuery($fneg); |
1770
|
|
|
|
|
|
|
} |
1771
|
|
|
|
|
|
|
|
1772
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
1773
|
|
|
|
|
|
|
# Send the IQ with the next available ID and wait for a reply with that |
1774
|
|
|
|
|
|
|
# id to be received. Then grab the IQ reply. |
1775
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
1776
|
0
|
0
|
|
|
|
0
|
if ($args{mode} eq "passthru") |
1777
|
|
|
|
|
|
|
{ |
1778
|
0
|
|
|
|
|
0
|
my $id = $self->UniqueID(); |
1779
|
0
|
|
|
|
|
0
|
$iq->SetIQ(id=>$id); |
1780
|
0
|
|
|
|
|
0
|
$self->Send($iq); |
1781
|
0
|
|
|
|
|
0
|
return $id; |
1782
|
|
|
|
|
|
|
} |
1783
|
|
|
|
|
|
|
|
1784
|
0
|
0
|
|
|
|
0
|
return $self->SendWithID($iq) if ($args{mode} eq "nonblock"); |
1785
|
|
|
|
|
|
|
|
1786
|
0
|
|
|
|
|
0
|
$iq = $self->SendAndReceiveWithID($iq,$timeout); |
1787
|
|
|
|
|
|
|
|
1788
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
1789
|
|
|
|
|
|
|
# Check if there was an error. |
1790
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
1791
|
0
|
0
|
|
|
|
0
|
return unless defined($iq); |
1792
|
0
|
0
|
|
|
|
0
|
if ($iq->GetType() eq "error") |
1793
|
|
|
|
|
|
|
{ |
1794
|
0
|
|
|
|
|
0
|
$self->SetErrorCode($iq->GetErrorCode().": ".$iq->GetError()); |
1795
|
0
|
|
|
|
|
0
|
return; |
1796
|
|
|
|
|
|
|
} |
1797
|
|
|
|
|
|
|
|
1798
|
0
|
|
|
|
|
0
|
$query = $iq->GetQuery(); |
1799
|
|
|
|
|
|
|
|
1800
|
0
|
0
|
|
|
|
0
|
if (defined($query)) |
1801
|
|
|
|
|
|
|
{ |
1802
|
0
|
|
|
|
|
0
|
my @fneg = $query->GetQuery("http://jabber.org/protocol/feature-neg"); |
1803
|
0
|
|
|
|
|
0
|
my @xdata = $fneg[0]->GetX("jabber:x:data"); |
1804
|
0
|
|
|
|
|
0
|
my @fields = $xdata[0]->GetFields(); |
1805
|
0
|
|
|
|
|
0
|
return $fields[0]->GetValue(); |
1806
|
|
|
|
|
|
|
# XXX need better error handling |
1807
|
|
|
|
|
|
|
} |
1808
|
|
|
|
|
|
|
else |
1809
|
|
|
|
|
|
|
{ |
1810
|
0
|
|
|
|
|
0
|
return; |
1811
|
|
|
|
|
|
|
} |
1812
|
|
|
|
|
|
|
} |
1813
|
|
|
|
|
|
|
|
1814
|
|
|
|
|
|
|
|
1815
|
|
|
|
|
|
|
############################################################################### |
1816
|
|
|
|
|
|
|
# |
1817
|
|
|
|
|
|
|
# TreeTransferOffer - offer a file transfer JEP-95 |
1818
|
|
|
|
|
|
|
# |
1819
|
|
|
|
|
|
|
############################################################################### |
1820
|
|
|
|
|
|
|
sub TreeTransferOffer |
1821
|
|
|
|
|
|
|
{ |
1822
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
1823
|
0
|
|
|
|
|
0
|
my %args; |
1824
|
0
|
|
|
|
|
0
|
$args{mode} = "block"; |
1825
|
0
|
|
|
|
|
0
|
while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
|
0
|
|
|
|
|
0
|
|
1826
|
|
|
|
|
|
|
|
1827
|
0
|
0
|
|
|
|
0
|
my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef; |
1828
|
|
|
|
|
|
|
|
1829
|
0
|
|
|
|
|
0
|
my $iq = $self->_iq(); |
1830
|
0
|
|
|
|
|
0
|
$iq->SetIQ(to=>$args{jid}, |
1831
|
|
|
|
|
|
|
type=>"set"); |
1832
|
0
|
|
|
|
|
0
|
my $query = $iq->NewQuery("http://jabber.org/protocol/si"); |
1833
|
0
|
|
|
|
|
0
|
my $profile = $query->NewQuery("http://jabber.org/protocol/si/profile/tree-transfer"); |
1834
|
|
|
|
|
|
|
|
1835
|
0
|
|
|
|
|
0
|
my ($root) = ($args{directory} =~ /\/?([^\/]+)$/); |
1836
|
|
|
|
|
|
|
|
1837
|
0
|
|
|
|
|
0
|
my $rootDir = $profile->AddDirectory(name=>$root); |
1838
|
|
|
|
|
|
|
|
1839
|
0
|
|
|
|
|
0
|
my %tree; |
1840
|
0
|
|
|
|
|
0
|
$tree{counter} = 0; |
1841
|
0
|
|
|
|
|
0
|
$self->TreeTransferDescend($args{sidbase}, |
1842
|
|
|
|
|
|
|
$args{directory}, |
1843
|
|
|
|
|
|
|
$rootDir, |
1844
|
|
|
|
|
|
|
\%tree |
1845
|
|
|
|
|
|
|
); |
1846
|
|
|
|
|
|
|
|
1847
|
0
|
|
|
|
|
0
|
$profile->SetTree(numfiles=>$tree{counter}, |
1848
|
|
|
|
|
|
|
size=>$tree{size} |
1849
|
|
|
|
|
|
|
); |
1850
|
|
|
|
|
|
|
|
1851
|
0
|
|
|
|
|
0
|
$query->SetStream(id=>$args{sidbase}, |
1852
|
|
|
|
|
|
|
profile=>"http://jabber.org/protocol/si/profile/tree-transfer" |
1853
|
|
|
|
|
|
|
); |
1854
|
|
|
|
|
|
|
|
1855
|
0
|
0
|
|
|
|
0
|
if ($#{$args{methods}} == -1) |
|
0
|
|
|
|
|
0
|
|
1856
|
|
|
|
|
|
|
{ |
1857
|
0
|
|
|
|
|
0
|
print STDERR "You did not provide any valid methods for the tree transfer.\n"; |
1858
|
0
|
|
|
|
|
0
|
return; |
1859
|
|
|
|
|
|
|
} |
1860
|
|
|
|
|
|
|
|
1861
|
0
|
|
|
|
|
0
|
my $fneg = $self->FeatureNegQuery({'stream-method'=>$args{methods}}); |
1862
|
|
|
|
|
|
|
|
1863
|
0
|
|
|
|
|
0
|
$query->AddQuery($fneg); |
1864
|
|
|
|
|
|
|
|
1865
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
1866
|
|
|
|
|
|
|
# Send the IQ with the next available ID and wait for a reply with that |
1867
|
|
|
|
|
|
|
# id to be received. Then grab the IQ reply. |
1868
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
1869
|
0
|
0
|
|
|
|
0
|
if ($args{mode} eq "passthru") |
1870
|
|
|
|
|
|
|
{ |
1871
|
0
|
|
|
|
|
0
|
my $id = $self->UniqueID(); |
1872
|
0
|
|
|
|
|
0
|
$iq->SetIQ(id=>$id); |
1873
|
0
|
|
|
|
|
0
|
$self->Send($iq); |
1874
|
0
|
|
|
|
|
0
|
$tree{id} = $id; |
1875
|
0
|
|
|
|
|
0
|
return %tree; |
1876
|
|
|
|
|
|
|
} |
1877
|
|
|
|
|
|
|
|
1878
|
0
|
0
|
|
|
|
0
|
return $self->SendWithID($iq) if ($args{mode} eq "nonblock"); |
1879
|
|
|
|
|
|
|
|
1880
|
0
|
|
|
|
|
0
|
$iq = $self->SendAndReceiveWithID($iq,$timeout); |
1881
|
|
|
|
|
|
|
|
1882
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
1883
|
|
|
|
|
|
|
# Check if there was an error. |
1884
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
1885
|
0
|
0
|
|
|
|
0
|
return unless defined($iq); |
1886
|
0
|
0
|
|
|
|
0
|
if ($iq->GetType() eq "error") |
1887
|
|
|
|
|
|
|
{ |
1888
|
0
|
|
|
|
|
0
|
$self->SetErrorCode($iq->GetErrorCode().": ".$iq->GetError()); |
1889
|
0
|
|
|
|
|
0
|
return; |
1890
|
|
|
|
|
|
|
} |
1891
|
|
|
|
|
|
|
|
1892
|
0
|
|
|
|
|
0
|
$query = $iq->GetQuery(); |
1893
|
|
|
|
|
|
|
|
1894
|
0
|
0
|
|
|
|
0
|
if (defined($query)) |
1895
|
|
|
|
|
|
|
{ |
1896
|
0
|
|
|
|
|
0
|
my @fneg = $query->GetQuery("http://jabber.org/protocol/feature-neg"); |
1897
|
0
|
|
|
|
|
0
|
my @xdata = $fneg[0]->GetX("jabber:x:data"); |
1898
|
0
|
|
|
|
|
0
|
my @fields = $xdata[0]->GetFields(); |
1899
|
0
|
|
|
|
|
0
|
return $fields[0]->GetValue(); |
1900
|
|
|
|
|
|
|
# XXX need better error handling |
1901
|
|
|
|
|
|
|
} |
1902
|
|
|
|
|
|
|
else |
1903
|
|
|
|
|
|
|
{ |
1904
|
0
|
|
|
|
|
0
|
return; |
1905
|
|
|
|
|
|
|
} |
1906
|
|
|
|
|
|
|
} |
1907
|
|
|
|
|
|
|
|
1908
|
|
|
|
|
|
|
|
1909
|
|
|
|
|
|
|
############################################################################### |
1910
|
|
|
|
|
|
|
# |
1911
|
|
|
|
|
|
|
# TreeTransferDescend - descend a directory structure and build the packet. |
1912
|
|
|
|
|
|
|
# |
1913
|
|
|
|
|
|
|
############################################################################### |
1914
|
|
|
|
|
|
|
sub TreeTransferDescend |
1915
|
|
|
|
|
|
|
{ |
1916
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
1917
|
0
|
|
|
|
|
0
|
my $sidbase = shift; |
1918
|
0
|
|
|
|
|
0
|
my $path = shift; |
1919
|
0
|
|
|
|
|
0
|
my $parent = shift; |
1920
|
0
|
|
|
|
|
0
|
my $tree = shift; |
1921
|
|
|
|
|
|
|
|
1922
|
0
|
|
|
|
|
0
|
$tree->{size} += (-s $path); |
1923
|
|
|
|
|
|
|
|
1924
|
0
|
|
|
|
|
0
|
opendir(DIR, $path); |
1925
|
0
|
|
|
|
|
0
|
foreach my $file ( sort {$a cmp $b} readdir(DIR) ) |
|
0
|
|
|
|
|
0
|
|
1926
|
|
|
|
|
|
|
{ |
1927
|
0
|
0
|
|
|
|
0
|
next if ($file =~ /^\.\.?$/); |
1928
|
|
|
|
|
|
|
|
1929
|
0
|
0
|
|
|
|
0
|
if (-d "$path/$file") |
1930
|
|
|
|
|
|
|
{ |
1931
|
0
|
|
|
|
|
0
|
my $tempParent = $parent->AddDirectory(name=>$file); |
1932
|
0
|
|
|
|
|
0
|
$self->TreeTransferDescend($sidbase, |
1933
|
|
|
|
|
|
|
"$path/$file", |
1934
|
|
|
|
|
|
|
$tempParent, |
1935
|
|
|
|
|
|
|
$tree |
1936
|
|
|
|
|
|
|
); |
1937
|
|
|
|
|
|
|
} |
1938
|
|
|
|
|
|
|
else |
1939
|
|
|
|
|
|
|
{ |
1940
|
0
|
|
|
|
|
0
|
$tree->{size} += (-s "$path/$file"); |
1941
|
|
|
|
|
|
|
|
1942
|
0
|
|
|
|
|
0
|
$tree->{tree}->{"$path/$file"}->{order} = $tree->{counter}; |
1943
|
0
|
|
|
|
|
0
|
$tree->{tree}->{"$path/$file"}->{sid} = |
1944
|
|
|
|
|
|
|
$sidbase."-".$tree->{counter}; |
1945
|
0
|
|
|
|
|
0
|
$tree->{tree}->{"$path/$file"}->{name} = $file; |
1946
|
|
|
|
|
|
|
|
1947
|
0
|
|
|
|
|
0
|
$parent->AddFile(name=>$tree->{tree}->{"$path/$file"}->{name}, |
1948
|
|
|
|
|
|
|
sid=>$tree->{tree}->{"$path/$file"}->{sid}); |
1949
|
0
|
|
|
|
|
0
|
$tree->{counter}++; |
1950
|
|
|
|
|
|
|
} |
1951
|
|
|
|
|
|
|
} |
1952
|
0
|
|
|
|
|
0
|
closedir(DIR); |
1953
|
|
|
|
|
|
|
} |
1954
|
|
|
|
|
|
|
|
1955
|
|
|
|
|
|
|
|
1956
|
|
|
|
|
|
|
############################################################################### |
1957
|
|
|
|
|
|
|
# |
1958
|
|
|
|
|
|
|
# LastQuery - Sends an iq:last query to either the server or the specified |
1959
|
|
|
|
|
|
|
# JID. |
1960
|
|
|
|
|
|
|
# |
1961
|
|
|
|
|
|
|
############################################################################### |
1962
|
|
|
|
|
|
|
sub LastQuery |
1963
|
|
|
|
|
|
|
{ |
1964
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
1965
|
0
|
|
|
|
|
0
|
my %args; |
1966
|
0
|
|
|
|
|
0
|
$args{mode} = "passthru"; |
1967
|
0
|
|
|
|
|
0
|
while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
|
0
|
|
|
|
|
0
|
|
1968
|
|
|
|
|
|
|
|
1969
|
0
|
0
|
|
|
|
0
|
$args{waitforid} = 0 unless exists($args{waitforid}); |
1970
|
0
|
|
|
|
|
0
|
my $waitforid = delete($args{waitforid}); |
1971
|
0
|
0
|
|
|
|
0
|
$args{mode} = "block" if $waitforid; |
1972
|
|
|
|
|
|
|
|
1973
|
0
|
0
|
|
|
|
0
|
my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef; |
1974
|
|
|
|
|
|
|
|
1975
|
0
|
|
|
|
|
0
|
my $iq = $self->_iq(); |
1976
|
0
|
0
|
|
|
|
0
|
$iq->SetIQ(to=>delete($args{to})) if exists($args{to}); |
1977
|
0
|
|
|
|
|
0
|
$iq->SetIQ(type=>'get'); |
1978
|
0
|
|
|
|
|
0
|
my $last = $iq->NewQuery("jabber:iq:last"); |
1979
|
|
|
|
|
|
|
|
1980
|
0
|
0
|
|
|
|
0
|
if ($args{mode} eq "passthru") |
1981
|
|
|
|
|
|
|
{ |
1982
|
0
|
|
|
|
|
0
|
my $id = $self->UniqueID(); |
1983
|
0
|
|
|
|
|
0
|
$iq->SetIQ(id=>$id); |
1984
|
0
|
|
|
|
|
0
|
$self->Send($iq); |
1985
|
0
|
|
|
|
|
0
|
return $id; |
1986
|
|
|
|
|
|
|
} |
1987
|
|
|
|
|
|
|
|
1988
|
0
|
0
|
|
|
|
0
|
return $self->SendWithID($iq) if ($args{mode} eq "nonblock"); |
1989
|
|
|
|
|
|
|
|
1990
|
0
|
|
|
|
|
0
|
$iq = $self->SendAndReceiveWithID($iq,$timeout); |
1991
|
|
|
|
|
|
|
|
1992
|
0
|
0
|
|
|
|
0
|
return unless defined($iq); |
1993
|
|
|
|
|
|
|
|
1994
|
0
|
|
|
|
|
0
|
$last = $iq->GetQuery(); |
1995
|
|
|
|
|
|
|
|
1996
|
0
|
0
|
|
|
|
0
|
return unless defined($last); |
1997
|
|
|
|
|
|
|
|
1998
|
0
|
|
|
|
|
0
|
return $last->GetLast(); |
1999
|
|
|
|
|
|
|
} |
2000
|
|
|
|
|
|
|
|
2001
|
|
|
|
|
|
|
|
2002
|
|
|
|
|
|
|
############################################################################### |
2003
|
|
|
|
|
|
|
# |
2004
|
|
|
|
|
|
|
# LastSend - sends an iq:last packet to the specified user. |
2005
|
|
|
|
|
|
|
# |
2006
|
|
|
|
|
|
|
############################################################################### |
2007
|
|
|
|
|
|
|
sub LastSend |
2008
|
|
|
|
|
|
|
{ |
2009
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
2010
|
0
|
|
|
|
|
0
|
my %args; |
2011
|
0
|
|
|
|
|
0
|
while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
|
0
|
|
|
|
|
0
|
|
2012
|
|
|
|
|
|
|
|
2013
|
0
|
0
|
|
|
|
0
|
$args{ignoreactivity} = 0 unless exists($args{ignoreactivity}); |
2014
|
0
|
|
|
|
|
0
|
my $ignoreActivity = delete($args{ignoreactivity}); |
2015
|
|
|
|
|
|
|
|
2016
|
0
|
|
|
|
|
0
|
my $iq = $self->_iq(); |
2017
|
0
|
|
|
|
|
0
|
$iq->SetIQ(to=>delete($args{to}), |
2018
|
|
|
|
|
|
|
type=>'result'); |
2019
|
0
|
|
|
|
|
0
|
my $last = $iq->NewQuery("jabber:iq:last"); |
2020
|
0
|
|
|
|
|
0
|
$last->SetLast(%args); |
2021
|
|
|
|
|
|
|
|
2022
|
0
|
|
|
|
|
0
|
$self->Send($iq,$ignoreActivity); |
2023
|
|
|
|
|
|
|
} |
2024
|
|
|
|
|
|
|
|
2025
|
|
|
|
|
|
|
|
2026
|
|
|
|
|
|
|
############################################################################### |
2027
|
|
|
|
|
|
|
# |
2028
|
|
|
|
|
|
|
# LastActivity - returns number of seconds since the last activity. |
2029
|
|
|
|
|
|
|
# |
2030
|
|
|
|
|
|
|
############################################################################### |
2031
|
|
|
|
|
|
|
sub LastActivity |
2032
|
|
|
|
|
|
|
{ |
2033
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
2034
|
|
|
|
|
|
|
|
2035
|
0
|
|
|
|
|
0
|
return (time - $self->{STREAM}->LastActivity($self->{SESSION}->{id})); |
2036
|
|
|
|
|
|
|
} |
2037
|
|
|
|
|
|
|
|
2038
|
|
|
|
|
|
|
|
2039
|
|
|
|
|
|
|
############################################################################### |
2040
|
|
|
|
|
|
|
# |
2041
|
|
|
|
|
|
|
# RegisterSendData - This is a self contained function to send a register iq |
2042
|
|
|
|
|
|
|
# tag with an id. It uses the jabber:x:data method to |
2043
|
|
|
|
|
|
|
# return the data. |
2044
|
|
|
|
|
|
|
# |
2045
|
|
|
|
|
|
|
############################################################################### |
2046
|
|
|
|
|
|
|
sub RegisterSendData |
2047
|
|
|
|
|
|
|
{ |
2048
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
2049
|
0
|
|
|
|
|
0
|
my $to = shift; |
2050
|
0
|
|
|
|
|
0
|
my %args; |
2051
|
0
|
|
|
|
|
0
|
while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
|
0
|
|
|
|
|
0
|
|
2052
|
|
|
|
|
|
|
|
2053
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
2054
|
|
|
|
|
|
|
# Create a Net::Jabber::IQ object to send to the server |
2055
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
2056
|
0
|
|
|
|
|
0
|
my $iq = $self->_iq(); |
2057
|
0
|
0
|
0
|
|
|
0
|
$iq->SetIQ(to=>$to) if (defined($to) && ($to ne "")); |
2058
|
0
|
|
|
|
|
0
|
$iq->SetIQ(type=>"set"); |
2059
|
0
|
|
|
|
|
0
|
my $iqRegister = $iq->NewQuery("jabber:iq:register"); |
2060
|
0
|
|
|
|
|
0
|
my $xForm = $iqRegister->NewX("jabber:x:data"); |
2061
|
0
|
|
|
|
|
0
|
foreach my $var (keys(%args)) |
2062
|
|
|
|
|
|
|
{ |
2063
|
0
|
0
|
|
|
|
0
|
next if ($args{$var} eq ""); |
2064
|
0
|
|
|
|
|
0
|
$xForm->AddField(var=>$var, |
2065
|
|
|
|
|
|
|
value=>$args{$var} |
2066
|
|
|
|
|
|
|
); |
2067
|
|
|
|
|
|
|
} |
2068
|
|
|
|
|
|
|
|
2069
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
2070
|
|
|
|
|
|
|
# Send the IQ with the next available ID and wait for a reply with that |
2071
|
|
|
|
|
|
|
# id to be received. Then grab the IQ reply. |
2072
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
2073
|
0
|
|
|
|
|
0
|
$iq = $self->SendAndReceiveWithID($iq); |
2074
|
|
|
|
|
|
|
|
2075
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
2076
|
|
|
|
|
|
|
# From the reply IQ determine if we were successful or not. If yes then |
2077
|
|
|
|
|
|
|
# return "". If no then return error string from the reply. |
2078
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
2079
|
0
|
0
|
|
|
|
0
|
return unless defined($iq); |
2080
|
0
|
0
|
|
|
|
0
|
return ( $iq->GetErrorCode() , $iq->GetError() ) |
2081
|
|
|
|
|
|
|
if ($iq->GetType() eq "error"); |
2082
|
0
|
|
|
|
|
0
|
return ("ok",""); |
2083
|
|
|
|
|
|
|
} |
2084
|
|
|
|
|
|
|
|
2085
|
|
|
|
|
|
|
|
2086
|
|
|
|
|
|
|
############################################################################### |
2087
|
|
|
|
|
|
|
# |
2088
|
|
|
|
|
|
|
# RPCSetCallBacks - place to register a callback for RPC calls. This is |
2089
|
|
|
|
|
|
|
# used in conjunction with the default IQ callback. |
2090
|
|
|
|
|
|
|
# |
2091
|
|
|
|
|
|
|
############################################################################### |
2092
|
|
|
|
|
|
|
sub RPCSetCallBacks |
2093
|
|
|
|
|
|
|
{ |
2094
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
2095
|
0
|
|
|
|
|
0
|
while($#_ >= 0) { |
2096
|
0
|
|
|
|
|
0
|
my $func = pop(@_); |
2097
|
0
|
|
|
|
|
0
|
my $method = pop(@_); |
2098
|
0
|
|
|
|
|
0
|
$self->{DEBUG}->Log2("RPCSetCallBacks: method($method) func($func)"); |
2099
|
0
|
0
|
|
|
|
0
|
if (defined($func)) |
2100
|
|
|
|
|
|
|
{ |
2101
|
0
|
|
|
|
|
0
|
$self->{RPCCB}{$method} = $func; |
2102
|
|
|
|
|
|
|
} |
2103
|
|
|
|
|
|
|
else |
2104
|
|
|
|
|
|
|
{ |
2105
|
0
|
|
|
|
|
0
|
delete($self->{RPCCB}{$method}); |
2106
|
|
|
|
|
|
|
} |
2107
|
|
|
|
|
|
|
} |
2108
|
|
|
|
|
|
|
} |
2109
|
|
|
|
|
|
|
|
2110
|
|
|
|
|
|
|
|
2111
|
|
|
|
|
|
|
############################################################################### |
2112
|
|
|
|
|
|
|
# |
2113
|
|
|
|
|
|
|
# RPCCall - Make an RPC call to the specified JID. |
2114
|
|
|
|
|
|
|
# |
2115
|
|
|
|
|
|
|
############################################################################### |
2116
|
|
|
|
|
|
|
sub RPCCall |
2117
|
|
|
|
|
|
|
{ |
2118
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
2119
|
0
|
|
|
|
|
0
|
my %args; |
2120
|
0
|
|
|
|
|
0
|
$args{mode} = "block"; |
2121
|
0
|
|
|
|
|
0
|
while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
|
0
|
|
|
|
|
0
|
|
2122
|
|
|
|
|
|
|
|
2123
|
0
|
0
|
|
|
|
0
|
my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef; |
2124
|
|
|
|
|
|
|
|
2125
|
0
|
|
|
|
|
0
|
my $iq = $self->_iq(); |
2126
|
0
|
|
|
|
|
0
|
$iq->SetIQ(type=>"set", |
2127
|
|
|
|
|
|
|
to=>delete($args{to})); |
2128
|
0
|
|
|
|
|
0
|
$iq->AddQuery($self->RPCEncode(type=>"methodCall", |
2129
|
|
|
|
|
|
|
%args)); |
2130
|
|
|
|
|
|
|
|
2131
|
0
|
0
|
|
|
|
0
|
if ($args{mode} eq "passthru") |
2132
|
|
|
|
|
|
|
{ |
2133
|
0
|
|
|
|
|
0
|
my $id = $self->UniqueID(); |
2134
|
0
|
|
|
|
|
0
|
$iq->SetIQ(id=>$id); |
2135
|
0
|
|
|
|
|
0
|
$self->Send($iq); |
2136
|
0
|
|
|
|
|
0
|
return $id; |
2137
|
|
|
|
|
|
|
} |
2138
|
|
|
|
|
|
|
|
2139
|
0
|
0
|
|
|
|
0
|
return $self->SendWithID($iq) if ($args{mode} eq "nonblock"); |
2140
|
|
|
|
|
|
|
|
2141
|
0
|
|
|
|
|
0
|
$iq = $self->SendAndReceiveWithID($iq,$timeout); |
2142
|
|
|
|
|
|
|
|
2143
|
0
|
0
|
|
|
|
0
|
return unless defined($iq); |
2144
|
|
|
|
|
|
|
|
2145
|
0
|
|
|
|
|
0
|
return $self->RPCParse($iq); |
2146
|
|
|
|
|
|
|
} |
2147
|
|
|
|
|
|
|
|
2148
|
|
|
|
|
|
|
|
2149
|
|
|
|
|
|
|
############################################################################### |
2150
|
|
|
|
|
|
|
# |
2151
|
|
|
|
|
|
|
# RPCResponse - Send back an RPC response, or fault, to the specified JID. |
2152
|
|
|
|
|
|
|
# |
2153
|
|
|
|
|
|
|
############################################################################### |
2154
|
|
|
|
|
|
|
sub RPCResponse |
2155
|
|
|
|
|
|
|
{ |
2156
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
2157
|
0
|
|
|
|
|
0
|
my %args; |
2158
|
0
|
|
|
|
|
0
|
while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
|
0
|
|
|
|
|
0
|
|
2159
|
|
|
|
|
|
|
|
2160
|
0
|
|
|
|
|
0
|
my $iq = $self->_iq(); |
2161
|
0
|
|
|
|
|
0
|
$iq->SetIQ(type=>"result", |
2162
|
|
|
|
|
|
|
to=>delete($args{to})); |
2163
|
0
|
|
|
|
|
0
|
$iq->AddQuery($self->RPCEncode(type=>"methodResponse", |
2164
|
|
|
|
|
|
|
%args)); |
2165
|
|
|
|
|
|
|
|
2166
|
0
|
|
|
|
|
0
|
$iq = $self->SendAndReceiveWithID($iq); |
2167
|
0
|
0
|
|
|
|
0
|
return unless defined($iq); |
2168
|
|
|
|
|
|
|
|
2169
|
0
|
|
|
|
|
0
|
return $self->RPCParse($iq); |
2170
|
|
|
|
|
|
|
} |
2171
|
|
|
|
|
|
|
|
2172
|
|
|
|
|
|
|
|
2173
|
|
|
|
|
|
|
############################################################################### |
2174
|
|
|
|
|
|
|
# |
2175
|
|
|
|
|
|
|
# RPCEncode - Returns a Net::Jabber::Query with the arguments encoded for the |
2176
|
|
|
|
|
|
|
# RPC packet. |
2177
|
|
|
|
|
|
|
# |
2178
|
|
|
|
|
|
|
############################################################################### |
2179
|
|
|
|
|
|
|
sub RPCEncode |
2180
|
|
|
|
|
|
|
{ |
2181
|
4
|
|
|
4
|
0
|
35984
|
my $self = shift; |
2182
|
4
|
|
|
|
|
13
|
my %args; |
2183
|
4
|
|
|
|
|
23
|
while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
|
13
|
|
|
|
|
64
|
|
2184
|
|
|
|
|
|
|
|
2185
|
4
|
|
|
|
|
35
|
my $query = new Net::Jabber::Stanza("query"); |
2186
|
4
|
|
|
|
|
76
|
$query->SetXMLNS("jabber:iq:rpc"); |
2187
|
|
|
|
|
|
|
|
2188
|
4
|
|
|
|
|
3706
|
my $source; |
2189
|
|
|
|
|
|
|
|
2190
|
4
|
100
|
|
|
|
24
|
if ($args{type} eq "methodCall") |
2191
|
|
|
|
|
|
|
{ |
2192
|
1
|
|
|
|
|
9
|
$source = $query->AddMethodCall(); |
2193
|
1
|
|
|
|
|
613
|
$source->SetMethodName($args{methodname}); |
2194
|
|
|
|
|
|
|
} |
2195
|
|
|
|
|
|
|
|
2196
|
4
|
100
|
|
|
|
1027
|
if ($args{type} eq "methodResponse") |
2197
|
|
|
|
|
|
|
{ |
2198
|
3
|
|
|
|
|
27
|
$source = $query->AddMethodResponse(); |
2199
|
|
|
|
|
|
|
} |
2200
|
|
|
|
|
|
|
|
2201
|
4
|
100
|
66
|
|
|
94
|
if (exists($args{faultcode}) || exists($args{faultstring})) |
|
|
50
|
|
|
|
|
|
2202
|
|
|
|
|
|
|
{ |
2203
|
1
|
|
|
|
|
12
|
my $struct = $source->AddFault()->AddValue()->AddStruct(); |
2204
|
1
|
|
|
|
|
24
|
$struct->AddMember(name=>"faultCode")->AddValue(i4=>$args{faultcode}); |
2205
|
1
|
|
|
|
|
1618
|
$struct->AddMember(name=>"faultString")->AddValue(string=>$args{faultstring}); |
2206
|
|
|
|
|
|
|
} |
2207
|
|
|
|
|
|
|
elsif (exists($args{params})) |
2208
|
|
|
|
|
|
|
{ |
2209
|
3
|
|
|
|
|
24
|
my $params = $source->AddParams(); |
2210
|
3
|
|
|
|
|
51
|
foreach my $param (@{$args{params}}) |
|
3
|
|
|
|
|
12
|
|
2211
|
|
|
|
|
|
|
{ |
2212
|
13
|
|
|
|
|
26160
|
$self->RPCEncode_Value($params->AddParam(),$param); |
2213
|
|
|
|
|
|
|
} |
2214
|
|
|
|
|
|
|
} |
2215
|
|
|
|
|
|
|
|
2216
|
4
|
|
|
|
|
7320
|
return $query; |
2217
|
|
|
|
|
|
|
} |
2218
|
|
|
|
|
|
|
|
2219
|
|
|
|
|
|
|
|
2220
|
|
|
|
|
|
|
############################################################################### |
2221
|
|
|
|
|
|
|
# |
2222
|
|
|
|
|
|
|
# RPCEncode_Value - Run through the value, and encode it into XML. |
2223
|
|
|
|
|
|
|
# |
2224
|
|
|
|
|
|
|
############################################################################### |
2225
|
|
|
|
|
|
|
sub RPCEncode_Value |
2226
|
|
|
|
|
|
|
{ |
2227
|
20
|
|
|
20
|
0
|
6454
|
my $self = shift; |
2228
|
20
|
|
|
|
|
34
|
my $obj = shift; |
2229
|
20
|
|
|
|
|
41
|
my $value = shift; |
2230
|
|
|
|
|
|
|
|
2231
|
20
|
100
|
|
|
|
88
|
if (ref($value) eq "ARRAY") |
|
|
100
|
|
|
|
|
|
2232
|
|
|
|
|
|
|
{ |
2233
|
1
|
|
|
|
|
6
|
my $array = $obj->AddValue()->AddArray(); |
2234
|
1
|
|
|
|
|
20
|
foreach my $data (@{$value}) |
|
1
|
|
|
|
|
6
|
|
2235
|
|
|
|
|
|
|
{ |
2236
|
3
|
|
|
|
|
3282
|
$self->RPCEncode_Value($array->AddData(),$data); |
2237
|
|
|
|
|
|
|
} |
2238
|
|
|
|
|
|
|
} |
2239
|
|
|
|
|
|
|
elsif (ref($value) eq "HASH") |
2240
|
|
|
|
|
|
|
{ |
2241
|
2
|
|
|
|
|
15
|
my $struct = $obj->AddValue()->AddStruct(); |
2242
|
2
|
|
|
|
|
35
|
foreach my $key (keys(%{$value})) |
|
2
|
|
|
|
|
12
|
|
2243
|
|
|
|
|
|
|
{ |
2244
|
4
|
|
|
|
|
3311
|
$self->RPCEncode_Value($struct->AddMember(name=>$key),$value->{$key}); |
2245
|
|
|
|
|
|
|
} |
2246
|
|
|
|
|
|
|
} |
2247
|
|
|
|
|
|
|
else |
2248
|
|
|
|
|
|
|
{ |
2249
|
17
|
100
|
|
|
|
173
|
if ($value =~ /^(int|i4|boolean|string|double|datetime|base64):/i) |
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
2250
|
|
|
|
|
|
|
{ |
2251
|
6
|
|
|
|
|
22
|
my $type = $1; |
2252
|
6
|
|
|
|
|
185
|
my($val) = ($value =~ /^$type:(.*)$/); |
2253
|
6
|
|
|
|
|
196
|
$obj->AddValue($type=>$val); |
2254
|
|
|
|
|
|
|
} |
2255
|
|
|
|
|
|
|
elsif ($value =~ /^[+-]?\d+$/) |
2256
|
|
|
|
|
|
|
{ |
2257
|
5
|
|
|
|
|
33
|
$obj->AddValue(i4=>$value); |
2258
|
|
|
|
|
|
|
} |
2259
|
|
|
|
|
|
|
elsif ($value =~ /^(-?(?:\d+(?:\.\d*)?|\.\d+)|([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?)$/) |
2260
|
|
|
|
|
|
|
{ |
2261
|
0
|
|
|
|
|
0
|
$obj->AddValue(double=>$value); |
2262
|
|
|
|
|
|
|
} |
2263
|
|
|
|
|
|
|
else |
2264
|
|
|
|
|
|
|
{ |
2265
|
6
|
|
|
|
|
50
|
$obj->AddValue(string=>$value); |
2266
|
|
|
|
|
|
|
} |
2267
|
|
|
|
|
|
|
} |
2268
|
|
|
|
|
|
|
} |
2269
|
|
|
|
|
|
|
|
2270
|
|
|
|
|
|
|
|
2271
|
|
|
|
|
|
|
############################################################################### |
2272
|
|
|
|
|
|
|
# |
2273
|
|
|
|
|
|
|
# RPCParse - Returns an array of the params sent in the RPC packet. |
2274
|
|
|
|
|
|
|
# |
2275
|
|
|
|
|
|
|
############################################################################### |
2276
|
|
|
|
|
|
|
sub RPCParse |
2277
|
|
|
|
|
|
|
{ |
2278
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
2279
|
0
|
|
|
|
|
0
|
my($iq) = @_; |
2280
|
|
|
|
|
|
|
|
2281
|
0
|
|
|
|
|
0
|
my $query = $iq->GetQuery(); |
2282
|
|
|
|
|
|
|
|
2283
|
0
|
|
|
|
|
0
|
my $source; |
2284
|
0
|
0
|
|
|
|
0
|
$source = $query->GetMethodCall() if $query->DefinedMethodCall(); |
2285
|
0
|
0
|
|
|
|
0
|
$source = $query->GetMethodResponse() if $query->DefinedMethodResponse(); |
2286
|
|
|
|
|
|
|
|
2287
|
0
|
0
|
|
|
|
0
|
if (defined($source)) |
2288
|
|
|
|
|
|
|
{ |
2289
|
0
|
0
|
0
|
|
|
0
|
if (($source->GetTag() eq "methodResponse") && ($source->DefinedFault())) |
2290
|
|
|
|
|
|
|
{ |
2291
|
0
|
|
|
|
|
0
|
my %response = |
2292
|
|
|
|
|
|
|
$self->RPCParse_Struct($source->GetFault()->GetValue()->GetStruct()); |
2293
|
0
|
|
|
|
|
0
|
return ("fault",\%response); |
2294
|
|
|
|
|
|
|
} |
2295
|
|
|
|
|
|
|
|
2296
|
0
|
0
|
|
|
|
0
|
if ($source->DefinedParams()) |
2297
|
|
|
|
|
|
|
{ |
2298
|
|
|
|
|
|
|
#------------------------------------------------------------------ |
2299
|
|
|
|
|
|
|
# The s part |
2300
|
|
|
|
|
|
|
#------------------------------------------------------------------ |
2301
|
0
|
|
|
|
|
0
|
my @response; |
2302
|
0
|
|
|
|
|
0
|
foreach my $param ($source->GetParams()->GetParams()) |
2303
|
|
|
|
|
|
|
{ |
2304
|
0
|
|
|
|
|
0
|
push(@response,$self->RPCParse_Value($param->GetValue())); |
2305
|
|
|
|
|
|
|
} |
2306
|
0
|
|
|
|
|
0
|
return ("ok",\@response); |
2307
|
|
|
|
|
|
|
} |
2308
|
|
|
|
|
|
|
} |
2309
|
|
|
|
|
|
|
else |
2310
|
|
|
|
|
|
|
{ |
2311
|
0
|
|
|
|
|
0
|
print "AAAAHHHH!!!!\n"; |
2312
|
|
|
|
|
|
|
} |
2313
|
|
|
|
|
|
|
} |
2314
|
|
|
|
|
|
|
|
2315
|
|
|
|
|
|
|
|
2316
|
|
|
|
|
|
|
############################################################################### |
2317
|
|
|
|
|
|
|
# |
2318
|
|
|
|
|
|
|
# RPCParse_Value - Takes a and returns the data it represents |
2319
|
|
|
|
|
|
|
# |
2320
|
|
|
|
|
|
|
############################################################################### |
2321
|
|
|
|
|
|
|
sub RPCParse_Value |
2322
|
|
|
|
|
|
|
{ |
2323
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
2324
|
0
|
|
|
|
|
0
|
my($value) = @_; |
2325
|
|
|
|
|
|
|
|
2326
|
0
|
0
|
|
|
|
0
|
if ($value->DefinedStruct()) |
2327
|
|
|
|
|
|
|
{ |
2328
|
0
|
|
|
|
|
0
|
my %struct = $self->RPCParse_Struct($value->GetStruct()); |
2329
|
0
|
|
|
|
|
0
|
return \%struct; |
2330
|
|
|
|
|
|
|
} |
2331
|
|
|
|
|
|
|
|
2332
|
0
|
0
|
|
|
|
0
|
if ($value->DefinedArray()) |
2333
|
|
|
|
|
|
|
{ |
2334
|
0
|
|
|
|
|
0
|
my @array = $self->RPCParse_Array($value->GetArray()); |
2335
|
0
|
|
|
|
|
0
|
return \@array; |
2336
|
|
|
|
|
|
|
} |
2337
|
|
|
|
|
|
|
|
2338
|
0
|
0
|
|
|
|
0
|
return $value->GetI4() if $value->DefinedI4(); |
2339
|
0
|
0
|
|
|
|
0
|
return $value->GetInt() if $value->DefinedInt(); |
2340
|
0
|
0
|
|
|
|
0
|
return $value->GetBoolean() if $value->DefinedBoolean(); |
2341
|
0
|
0
|
|
|
|
0
|
return $value->GetString() if $value->DefinedString(); |
2342
|
0
|
0
|
|
|
|
0
|
return $value->GetDouble() if $value->DefinedDouble(); |
2343
|
0
|
0
|
|
|
|
0
|
return $value->GetDateTime() if $value->DefinedDateTime(); |
2344
|
0
|
0
|
|
|
|
0
|
return $value->GetBase64() if $value->DefinedBase64(); |
2345
|
|
|
|
|
|
|
|
2346
|
0
|
|
|
|
|
0
|
return $value->GetValue(); |
2347
|
|
|
|
|
|
|
} |
2348
|
|
|
|
|
|
|
|
2349
|
|
|
|
|
|
|
|
2350
|
|
|
|
|
|
|
############################################################################### |
2351
|
|
|
|
|
|
|
# |
2352
|
|
|
|
|
|
|
# RPCParse_Struct - Takes a and returns the hash of values. |
2353
|
|
|
|
|
|
|
# |
2354
|
|
|
|
|
|
|
############################################################################### |
2355
|
|
|
|
|
|
|
sub RPCParse_Struct |
2356
|
|
|
|
|
|
|
{ |
2357
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
2358
|
0
|
|
|
|
|
0
|
my($struct) = @_; |
2359
|
|
|
|
|
|
|
|
2360
|
0
|
|
|
|
|
0
|
my %struct; |
2361
|
0
|
|
|
|
|
0
|
foreach my $member ($struct->GetMembers()) |
2362
|
|
|
|
|
|
|
{ |
2363
|
0
|
|
|
|
|
0
|
$struct{$member->GetName()} = $self->RPCParse_Value($member->GetValue()); |
2364
|
|
|
|
|
|
|
} |
2365
|
|
|
|
|
|
|
|
2366
|
0
|
|
|
|
|
0
|
return %struct; |
2367
|
|
|
|
|
|
|
} |
2368
|
|
|
|
|
|
|
|
2369
|
|
|
|
|
|
|
|
2370
|
|
|
|
|
|
|
############################################################################### |
2371
|
|
|
|
|
|
|
# |
2372
|
|
|
|
|
|
|
# RPCParse_Array - Takes a and returns the hash of values. |
2373
|
|
|
|
|
|
|
# |
2374
|
|
|
|
|
|
|
############################################################################### |
2375
|
|
|
|
|
|
|
sub RPCParse_Array |
2376
|
|
|
|
|
|
|
{ |
2377
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
2378
|
0
|
|
|
|
|
0
|
my($array) = @_; |
2379
|
|
|
|
|
|
|
|
2380
|
0
|
|
|
|
|
0
|
my @array; |
2381
|
0
|
|
|
|
|
0
|
foreach my $data ($array->GetDatas()) |
2382
|
|
|
|
|
|
|
{ |
2383
|
0
|
|
|
|
|
0
|
push(@array,$self->RPCParse_Value($data->GetValue())); |
2384
|
|
|
|
|
|
|
} |
2385
|
|
|
|
|
|
|
|
2386
|
0
|
|
|
|
|
0
|
return @array; |
2387
|
|
|
|
|
|
|
} |
2388
|
|
|
|
|
|
|
|
2389
|
|
|
|
|
|
|
|
2390
|
|
|
|
|
|
|
############################################################################### |
2391
|
|
|
|
|
|
|
# |
2392
|
|
|
|
|
|
|
# SearchRequest - This is a self contained function to send an iq tag |
2393
|
|
|
|
|
|
|
# an id that requests the target address to send back |
2394
|
|
|
|
|
|
|
# the required fields. It waits for a reply what the |
2395
|
|
|
|
|
|
|
# same id to come back and tell the caller what the |
2396
|
|
|
|
|
|
|
# fields are. |
2397
|
|
|
|
|
|
|
# |
2398
|
|
|
|
|
|
|
############################################################################### |
2399
|
|
|
|
|
|
|
sub SearchRequest |
2400
|
|
|
|
|
|
|
{ |
2401
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
2402
|
0
|
|
|
|
|
0
|
my %args; |
2403
|
0
|
|
|
|
|
0
|
$args{mode} = "block"; |
2404
|
0
|
|
|
|
|
0
|
while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
|
0
|
|
|
|
|
0
|
|
2405
|
|
|
|
|
|
|
|
2406
|
0
|
0
|
|
|
|
0
|
my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef; |
2407
|
|
|
|
|
|
|
|
2408
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
2409
|
|
|
|
|
|
|
# Create a Net::Jabber::IQ object to send to the server |
2410
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
2411
|
0
|
|
|
|
|
0
|
my $iq = $self->_iq(); |
2412
|
0
|
0
|
|
|
|
0
|
$iq->SetIQ(to=>delete($args{to})) if exists($args{to}); |
2413
|
0
|
|
|
|
|
0
|
$iq->SetIQ(type=>"get"); |
2414
|
0
|
|
|
|
|
0
|
my $query = $iq->NewQuery("jabber:iq:search"); |
2415
|
|
|
|
|
|
|
|
2416
|
0
|
|
|
|
|
0
|
$self->{DEBUG}->Log1("SearchRequest: sent(",$iq->GetXML(),")"); |
2417
|
|
|
|
|
|
|
|
2418
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
2419
|
|
|
|
|
|
|
# Send the IQ with the next available ID and wait for a reply with that |
2420
|
|
|
|
|
|
|
# id to be received. Then grab the IQ reply. |
2421
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
2422
|
0
|
0
|
|
|
|
0
|
if ($args{mode} eq "passthru") |
2423
|
|
|
|
|
|
|
{ |
2424
|
0
|
|
|
|
|
0
|
my $id = $self->UniqueID(); |
2425
|
0
|
|
|
|
|
0
|
$iq->SetIQ(id=>$id); |
2426
|
0
|
|
|
|
|
0
|
$self->Send($iq); |
2427
|
0
|
|
|
|
|
0
|
return $id; |
2428
|
|
|
|
|
|
|
} |
2429
|
|
|
|
|
|
|
|
2430
|
0
|
0
|
|
|
|
0
|
return $self->SendWithID($iq) if ($args{mode} eq "nonblock"); |
2431
|
|
|
|
|
|
|
|
2432
|
0
|
|
|
|
|
0
|
$iq = $self->SendAndReceiveWithID($iq,$timeout); |
2433
|
|
|
|
|
|
|
|
2434
|
0
|
0
|
|
|
|
0
|
$self->{DEBUG}->Log1("SearchRequest: received(",$iq->GetXML(),")") |
2435
|
|
|
|
|
|
|
if defined($iq); |
2436
|
|
|
|
|
|
|
|
2437
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
2438
|
|
|
|
|
|
|
# Check if there was an error. |
2439
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
2440
|
0
|
0
|
|
|
|
0
|
return unless defined($iq); |
2441
|
0
|
0
|
|
|
|
0
|
if ($iq->GetType() eq "error") |
2442
|
|
|
|
|
|
|
{ |
2443
|
0
|
|
|
|
|
0
|
$self->SetErrorCode($iq->GetErrorCode().": ".$iq->GetError()); |
2444
|
0
|
|
|
|
|
0
|
$self->{DEBUG}->Log1("SearchRequest: error(",$self->GetErrorCode(),")"); |
2445
|
0
|
|
|
|
|
0
|
return; |
2446
|
|
|
|
|
|
|
} |
2447
|
|
|
|
|
|
|
|
2448
|
0
|
|
|
|
|
0
|
my %search; |
2449
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
2450
|
|
|
|
|
|
|
# From the reply IQ determine what fields are required and send a hash |
2451
|
|
|
|
|
|
|
# back with the fields and any values that are already defined (like key) |
2452
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
2453
|
0
|
|
|
|
|
0
|
$query = $iq->GetQuery(); |
2454
|
0
|
|
|
|
|
0
|
$search{fields} = { $query->GetSearch() }; |
2455
|
|
|
|
|
|
|
|
2456
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
2457
|
|
|
|
|
|
|
# Get any forms so that we have the option of showing a nive dynamic form |
2458
|
|
|
|
|
|
|
# to the user and not just a bunch of fields. |
2459
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
2460
|
0
|
|
|
|
|
0
|
&ExtractForms(\%search,$query->GetX("jabber:x:data")); |
2461
|
|
|
|
|
|
|
|
2462
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
2463
|
|
|
|
|
|
|
# Get any oobs so that we have the option of sending the user to the http |
2464
|
|
|
|
|
|
|
# form and not a dynamic one. |
2465
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
2466
|
0
|
|
|
|
|
0
|
&ExtractOobs(\%search,$query->GetX("jabber:x:oob")); |
2467
|
|
|
|
|
|
|
|
2468
|
0
|
|
|
|
|
0
|
return %search; |
2469
|
|
|
|
|
|
|
} |
2470
|
|
|
|
|
|
|
|
2471
|
|
|
|
|
|
|
|
2472
|
|
|
|
|
|
|
############################################################################### |
2473
|
|
|
|
|
|
|
# |
2474
|
|
|
|
|
|
|
# SearchSend - This is a self contained function to send a search |
2475
|
|
|
|
|
|
|
# iq tag with an id. Then wait for a reply what the same |
2476
|
|
|
|
|
|
|
# id to come back and tell the caller what the result was. |
2477
|
|
|
|
|
|
|
# |
2478
|
|
|
|
|
|
|
############################################################################### |
2479
|
|
|
|
|
|
|
sub SearchSend |
2480
|
|
|
|
|
|
|
{ |
2481
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
2482
|
0
|
|
|
|
|
0
|
my %args; |
2483
|
0
|
|
|
|
|
0
|
while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
|
0
|
|
|
|
|
0
|
|
2484
|
|
|
|
|
|
|
|
2485
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
2486
|
|
|
|
|
|
|
# Create a Net::Jabber::IQ object to send to the server |
2487
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
2488
|
0
|
|
|
|
|
0
|
my $iq = $self->_iq(); |
2489
|
0
|
0
|
|
|
|
0
|
$iq->SetIQ(to=>delete($args{to})) if exists($args{to}); |
2490
|
0
|
|
|
|
|
0
|
$iq->SetIQ(type=>"set"); |
2491
|
0
|
|
|
|
|
0
|
my $iqSearch = $iq->NewQuery("jabber:iq:search"); |
2492
|
0
|
|
|
|
|
0
|
$iqSearch->SetSearch(%args); |
2493
|
|
|
|
|
|
|
|
2494
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
2495
|
|
|
|
|
|
|
# Send the IQ. |
2496
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
2497
|
0
|
|
|
|
|
0
|
$self->Send($iq); |
2498
|
|
|
|
|
|
|
} |
2499
|
|
|
|
|
|
|
|
2500
|
|
|
|
|
|
|
|
2501
|
|
|
|
|
|
|
############################################################################### |
2502
|
|
|
|
|
|
|
# |
2503
|
|
|
|
|
|
|
# SearchSendData - This is a self contained function to send a search iq tag |
2504
|
|
|
|
|
|
|
# with an id. It uses the jabber:x:data method to return the |
2505
|
|
|
|
|
|
|
# data. |
2506
|
|
|
|
|
|
|
# |
2507
|
|
|
|
|
|
|
############################################################################### |
2508
|
|
|
|
|
|
|
sub SearchSendData |
2509
|
|
|
|
|
|
|
{ |
2510
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
2511
|
0
|
|
|
|
|
0
|
my $to = shift; |
2512
|
0
|
|
|
|
|
0
|
my %args; |
2513
|
0
|
|
|
|
|
0
|
while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
|
0
|
|
|
|
|
0
|
|
2514
|
|
|
|
|
|
|
|
2515
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
2516
|
|
|
|
|
|
|
# Create a Net::Jabber::IQ object to send to the server |
2517
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
2518
|
0
|
|
|
|
|
0
|
my $iq = $self->_iq(); |
2519
|
0
|
0
|
0
|
|
|
0
|
$iq->SetIQ(to=>$to) if (defined($to) && ($to ne "")); |
2520
|
0
|
|
|
|
|
0
|
$iq->SetIQ(type=>"set"); |
2521
|
0
|
|
|
|
|
0
|
my $iqSearch = $iq->NewQuery("jabber:iq:search"); |
2522
|
0
|
|
|
|
|
0
|
my $xForm = $iqSearch->NewX("jabber:x:data"); |
2523
|
0
|
|
|
|
|
0
|
foreach my $var (keys(%args)) |
2524
|
|
|
|
|
|
|
{ |
2525
|
0
|
0
|
|
|
|
0
|
next if ($args{$var} eq ""); |
2526
|
0
|
|
|
|
|
0
|
$xForm->AddField(var=>$var, |
2527
|
|
|
|
|
|
|
value=>$args{$var} |
2528
|
|
|
|
|
|
|
); |
2529
|
|
|
|
|
|
|
} |
2530
|
|
|
|
|
|
|
|
2531
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
2532
|
|
|
|
|
|
|
# Send the IQ. |
2533
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
2534
|
0
|
|
|
|
|
0
|
$self->Send($iq); |
2535
|
|
|
|
|
|
|
} |
2536
|
|
|
|
|
|
|
|
2537
|
|
|
|
|
|
|
|
2538
|
|
|
|
|
|
|
############################################################################### |
2539
|
|
|
|
|
|
|
# |
2540
|
|
|
|
|
|
|
# TimeQuery - Sends an iq:time query to either the server or the specified |
2541
|
|
|
|
|
|
|
# JID. |
2542
|
|
|
|
|
|
|
# |
2543
|
|
|
|
|
|
|
############################################################################### |
2544
|
|
|
|
|
|
|
sub TimeQuery |
2545
|
|
|
|
|
|
|
{ |
2546
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
2547
|
0
|
|
|
|
|
0
|
my %args; |
2548
|
0
|
|
|
|
|
0
|
$args{mode} = "passthru"; |
2549
|
0
|
|
|
|
|
0
|
while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
|
0
|
|
|
|
|
0
|
|
2550
|
|
|
|
|
|
|
|
2551
|
0
|
0
|
|
|
|
0
|
$args{waitforid} = 0 unless exists($args{waitforid}); |
2552
|
0
|
|
|
|
|
0
|
my $waitforid = delete($args{waitforid}); |
2553
|
0
|
0
|
|
|
|
0
|
$args{mode} = "block" if $waitforid; |
2554
|
|
|
|
|
|
|
|
2555
|
0
|
0
|
|
|
|
0
|
my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef; |
2556
|
|
|
|
|
|
|
|
2557
|
0
|
|
|
|
|
0
|
my $iq = $self->_iq(); |
2558
|
0
|
0
|
|
|
|
0
|
$iq->SetIQ(to=>delete($args{to})) if exists($args{to}); |
2559
|
0
|
|
|
|
|
0
|
$iq->SetIQ(type=>'get',%args); |
2560
|
0
|
|
|
|
|
0
|
my $time = $iq->NewQuery("jabber:iq:time"); |
2561
|
|
|
|
|
|
|
|
2562
|
0
|
0
|
|
|
|
0
|
if ($args{mode} eq "passthru") |
2563
|
|
|
|
|
|
|
{ |
2564
|
0
|
|
|
|
|
0
|
my $id = $self->UniqueID(); |
2565
|
0
|
|
|
|
|
0
|
$iq->SetIQ(id=>$id); |
2566
|
0
|
|
|
|
|
0
|
$self->Send($iq); |
2567
|
0
|
|
|
|
|
0
|
return $id; |
2568
|
|
|
|
|
|
|
} |
2569
|
|
|
|
|
|
|
|
2570
|
0
|
0
|
|
|
|
0
|
return $self->SendWithID($iq) if ($args{mode} eq "nonblock"); |
2571
|
|
|
|
|
|
|
|
2572
|
0
|
|
|
|
|
0
|
$iq = $self->SendAndReceiveWithID($iq,$timeout); |
2573
|
|
|
|
|
|
|
|
2574
|
0
|
0
|
|
|
|
0
|
return unless defined($iq); |
2575
|
|
|
|
|
|
|
|
2576
|
0
|
|
|
|
|
0
|
my $query = $iq->GetQuery(); |
2577
|
|
|
|
|
|
|
|
2578
|
0
|
0
|
|
|
|
0
|
return unless defined($query); |
2579
|
|
|
|
|
|
|
|
2580
|
0
|
|
|
|
|
0
|
my %result; |
2581
|
0
|
|
|
|
|
0
|
$result{utc} = $query->GetUTC(); |
2582
|
0
|
|
|
|
|
0
|
$result{display} = $query->GetDisplay(); |
2583
|
0
|
|
|
|
|
0
|
$result{tz} = $query->GetTZ(); |
2584
|
0
|
|
|
|
|
0
|
return %result; |
2585
|
|
|
|
|
|
|
} |
2586
|
|
|
|
|
|
|
|
2587
|
|
|
|
|
|
|
|
2588
|
|
|
|
|
|
|
############################################################################### |
2589
|
|
|
|
|
|
|
# |
2590
|
|
|
|
|
|
|
# TimeSend - sends an iq:time packet to the specified user. |
2591
|
|
|
|
|
|
|
# |
2592
|
|
|
|
|
|
|
############################################################################### |
2593
|
|
|
|
|
|
|
sub TimeSend |
2594
|
|
|
|
|
|
|
{ |
2595
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
2596
|
0
|
|
|
|
|
0
|
my %args; |
2597
|
0
|
|
|
|
|
0
|
while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
|
0
|
|
|
|
|
0
|
|
2598
|
|
|
|
|
|
|
|
2599
|
0
|
|
|
|
|
0
|
my $iq = $self->_iq(); |
2600
|
0
|
|
|
|
|
0
|
$iq->SetIQ(to=>delete($args{to}), |
2601
|
|
|
|
|
|
|
type=>'result'); |
2602
|
0
|
|
|
|
|
0
|
my $time = $iq->NewQuery("jabber:iq:time"); |
2603
|
0
|
|
|
|
|
0
|
$time->SetTime(%args); |
2604
|
|
|
|
|
|
|
|
2605
|
0
|
|
|
|
|
0
|
$self->Send($iq); |
2606
|
|
|
|
|
|
|
} |
2607
|
|
|
|
|
|
|
|
2608
|
|
|
|
|
|
|
|
2609
|
|
|
|
|
|
|
|
2610
|
|
|
|
|
|
|
############################################################################### |
2611
|
|
|
|
|
|
|
# |
2612
|
|
|
|
|
|
|
# VersionQuery - Sends an iq:version query to either the server or the |
2613
|
|
|
|
|
|
|
# specified JID. |
2614
|
|
|
|
|
|
|
# |
2615
|
|
|
|
|
|
|
############################################################################### |
2616
|
|
|
|
|
|
|
sub VersionQuery |
2617
|
|
|
|
|
|
|
{ |
2618
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
2619
|
0
|
|
|
|
|
0
|
my %args; |
2620
|
0
|
|
|
|
|
0
|
$args{mode} = "passthru"; |
2621
|
0
|
|
|
|
|
0
|
while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
|
0
|
|
|
|
|
0
|
|
2622
|
|
|
|
|
|
|
|
2623
|
0
|
0
|
|
|
|
0
|
$args{waitforid} = 0 unless exists($args{waitforid}); |
2624
|
0
|
|
|
|
|
0
|
my $waitforid = delete($args{waitforid}); |
2625
|
0
|
0
|
|
|
|
0
|
$args{mode} = "block" if $waitforid; |
2626
|
|
|
|
|
|
|
|
2627
|
0
|
0
|
|
|
|
0
|
my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef; |
2628
|
|
|
|
|
|
|
|
2629
|
0
|
|
|
|
|
0
|
my $iq = $self->_iq(); |
2630
|
0
|
0
|
|
|
|
0
|
$iq->SetIQ(to=>delete($args{to})) if exists($args{to}); |
2631
|
0
|
|
|
|
|
0
|
$iq->SetIQ(type=>'get',%args); |
2632
|
0
|
|
|
|
|
0
|
my $version = $iq->NewQuery("jabber:iq:version"); |
2633
|
|
|
|
|
|
|
|
2634
|
0
|
0
|
|
|
|
0
|
if ($args{mode} eq "passthru") |
2635
|
|
|
|
|
|
|
{ |
2636
|
0
|
|
|
|
|
0
|
my $id = $self->UniqueID(); |
2637
|
0
|
|
|
|
|
0
|
$iq->SetIQ(id=>$id); |
2638
|
0
|
|
|
|
|
0
|
$self->Send($iq); |
2639
|
0
|
|
|
|
|
0
|
return $id; |
2640
|
|
|
|
|
|
|
} |
2641
|
|
|
|
|
|
|
|
2642
|
0
|
0
|
|
|
|
0
|
return $self->SendWithID($iq) if ($args{mode} eq "nonblock"); |
2643
|
|
|
|
|
|
|
|
2644
|
0
|
|
|
|
|
0
|
$iq = $self->SendAndReceiveWithID($iq,$timeout); |
2645
|
|
|
|
|
|
|
|
2646
|
0
|
0
|
|
|
|
0
|
return unless defined($iq); |
2647
|
|
|
|
|
|
|
|
2648
|
0
|
|
|
|
|
0
|
my $query = $iq->GetQuery(); |
2649
|
|
|
|
|
|
|
|
2650
|
0
|
0
|
|
|
|
0
|
return unless defined($query); |
2651
|
|
|
|
|
|
|
|
2652
|
0
|
|
|
|
|
0
|
my %result; |
2653
|
0
|
|
|
|
|
0
|
$result{name} = $query->GetName(); |
2654
|
0
|
|
|
|
|
0
|
$result{ver} = $query->GetVer(); |
2655
|
0
|
|
|
|
|
0
|
$result{os} = $query->GetOS(); |
2656
|
0
|
|
|
|
|
0
|
return %result; |
2657
|
|
|
|
|
|
|
} |
2658
|
|
|
|
|
|
|
|
2659
|
|
|
|
|
|
|
|
2660
|
|
|
|
|
|
|
############################################################################### |
2661
|
|
|
|
|
|
|
# |
2662
|
|
|
|
|
|
|
# VersionSend - sends an iq:version packet to the specified user. |
2663
|
|
|
|
|
|
|
# |
2664
|
|
|
|
|
|
|
############################################################################### |
2665
|
|
|
|
|
|
|
sub VersionSend |
2666
|
|
|
|
|
|
|
{ |
2667
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
2668
|
0
|
|
|
|
|
0
|
my %args; |
2669
|
0
|
|
|
|
|
0
|
while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
|
0
|
|
|
|
|
0
|
|
2670
|
|
|
|
|
|
|
|
2671
|
0
|
|
|
|
|
0
|
my $iq = $self->_iq(); |
2672
|
0
|
|
|
|
|
0
|
$iq->SetIQ(to=>delete($args{to}), |
2673
|
|
|
|
|
|
|
type=>'result'); |
2674
|
0
|
|
|
|
|
0
|
my $version = $iq->NewQuery("jabber:iq:version"); |
2675
|
0
|
|
|
|
|
0
|
$version->SetVersion(%args); |
2676
|
|
|
|
|
|
|
|
2677
|
0
|
|
|
|
|
0
|
$self->Send($iq); |
2678
|
|
|
|
|
|
|
} |
2679
|
|
|
|
|
|
|
|
2680
|
|
|
|
|
|
|
|
2681
|
|
|
|
|
|
|
############################################################################### |
2682
|
|
|
|
|
|
|
# |
2683
|
|
|
|
|
|
|
# MUCJoin - join a MUC room |
2684
|
|
|
|
|
|
|
# |
2685
|
|
|
|
|
|
|
############################################################################### |
2686
|
|
|
|
|
|
|
sub MUCJoin |
2687
|
|
|
|
|
|
|
{ |
2688
|
1
|
|
|
1
|
0
|
4475
|
my $self = shift; |
2689
|
1
|
|
|
|
|
2
|
my %args; |
2690
|
1
|
|
|
|
|
7
|
while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
|
4
|
|
|
|
|
19
|
|
2691
|
|
|
|
|
|
|
|
2692
|
1
|
|
|
|
|
14
|
my $presence = $self->_presence(); |
2693
|
1
|
|
|
|
|
234
|
$presence->SetTo($args{room}.'@'.$args{server}.'/'.$args{nick}); |
2694
|
1
|
|
|
|
|
729
|
my $x = $presence->NewChild("http://jabber.org/protocol/muc"); |
2695
|
|
|
|
|
|
|
|
2696
|
1
|
50
|
33
|
|
|
22
|
if (exists($args{password}) && ($args{password} ne "")) |
2697
|
|
|
|
|
|
|
{ |
2698
|
0
|
|
|
|
|
0
|
$x->SetMUC(password=>$args{password}); |
2699
|
|
|
|
|
|
|
} |
2700
|
|
|
|
|
|
|
|
2701
|
1
|
50
|
|
|
|
13
|
return $presence->GetXML() if exists($args{'__netjabber__:test'}); |
2702
|
0
|
|
|
|
|
|
$self->Send($presence); |
2703
|
|
|
|
|
|
|
} |
2704
|
|
|
|
|
|
|
|
2705
|
|
|
|
|
|
|
|
2706
|
|
|
|
|
|
|
############################################################################### |
2707
|
|
|
|
|
|
|
#+----------------------------------------------------------------------------- |
2708
|
|
|
|
|
|
|
#| |
2709
|
|
|
|
|
|
|
#| Helper Functions |
2710
|
|
|
|
|
|
|
#| |
2711
|
|
|
|
|
|
|
#+----------------------------------------------------------------------------- |
2712
|
|
|
|
|
|
|
############################################################################### |
2713
|
|
|
|
|
|
|
|
2714
|
|
|
|
|
|
|
|
2715
|
|
|
|
|
|
|
############################################################################### |
2716
|
|
|
|
|
|
|
# |
2717
|
|
|
|
|
|
|
# ExtractForms - Helper function to make extracting jabber:x:data for forms |
2718
|
|
|
|
|
|
|
# more centrally definable. |
2719
|
|
|
|
|
|
|
# |
2720
|
|
|
|
|
|
|
############################################################################### |
2721
|
|
|
|
|
|
|
sub ExtractForms |
2722
|
|
|
|
|
|
|
{ |
2723
|
0
|
|
|
0
|
0
|
|
my ($target,@xForms) = @_; |
2724
|
|
|
|
|
|
|
|
2725
|
0
|
|
|
|
|
|
my $tempVar = "1"; |
2726
|
0
|
|
|
|
|
|
foreach my $xForm (@xForms) { |
2727
|
0
|
|
|
|
|
|
$target->{instructions} = $xForm->GetInstructions(); |
2728
|
0
|
|
|
|
|
|
my $order = 0; |
2729
|
0
|
|
|
|
|
|
foreach my $field ($xForm->GetFields()) |
2730
|
|
|
|
|
|
|
{ |
2731
|
0
|
0
|
|
|
|
|
$target->{form}->[$order]->{type} = $field->GetType() |
2732
|
|
|
|
|
|
|
if $field->DefinedType(); |
2733
|
0
|
0
|
|
|
|
|
$target->{form}->[$order]->{label} = $field->GetLabel() |
2734
|
|
|
|
|
|
|
if $field->DefinedLabel(); |
2735
|
0
|
0
|
|
|
|
|
$target->{form}->[$order]->{desc} = $field->GetDesc() |
2736
|
|
|
|
|
|
|
if $field->DefinedDesc(); |
2737
|
0
|
0
|
|
|
|
|
$target->{form}->[$order]->{var} = $field->GetVar() |
2738
|
|
|
|
|
|
|
if $field->DefinedVar(); |
2739
|
0
|
0
|
|
|
|
|
$target->{form}->[$order]->{var} = "__netjabber__:tempvar:".$tempVar++ |
2740
|
|
|
|
|
|
|
if !$field->DefinedVar(); |
2741
|
0
|
0
|
|
|
|
|
if ($field->DefinedValue()) |
2742
|
|
|
|
|
|
|
{ |
2743
|
0
|
0
|
|
|
|
|
if ($field->GetType() eq "list-multi") |
2744
|
|
|
|
|
|
|
{ |
2745
|
0
|
|
|
|
|
|
$target->{form}->[$order]->{value} = [ $field->GetValue() ]; |
2746
|
|
|
|
|
|
|
} |
2747
|
|
|
|
|
|
|
else |
2748
|
|
|
|
|
|
|
{ |
2749
|
0
|
|
|
|
|
|
$target->{form}->[$order]->{value} = ($field->GetValue())[0]; |
2750
|
|
|
|
|
|
|
} |
2751
|
|
|
|
|
|
|
} |
2752
|
0
|
|
|
|
|
|
my $count = 0; |
2753
|
0
|
|
|
|
|
|
foreach my $option ($field->GetOptions()) |
2754
|
|
|
|
|
|
|
{ |
2755
|
0
|
|
|
|
|
|
$target->{form}->[$order]->{options}->[$count]->{value} = |
2756
|
|
|
|
|
|
|
$option->GetValue(); |
2757
|
0
|
|
|
|
|
|
$target->{form}->[$order]->{options}->[$count]->{label} = |
2758
|
|
|
|
|
|
|
$option->GetLabel(); |
2759
|
0
|
|
|
|
|
|
$count++; |
2760
|
|
|
|
|
|
|
} |
2761
|
0
|
|
|
|
|
|
$order++; |
2762
|
|
|
|
|
|
|
} |
2763
|
0
|
|
|
|
|
|
foreach my $reported ($xForm->GetReported()) |
2764
|
|
|
|
|
|
|
{ |
2765
|
0
|
|
|
|
|
|
my $order = 0; |
2766
|
0
|
|
|
|
|
|
foreach my $field ($reported->GetFields()) |
2767
|
|
|
|
|
|
|
{ |
2768
|
0
|
|
|
|
|
|
$target->{reported}->[$order]->{label} = $field->GetLabel(); |
2769
|
0
|
|
|
|
|
|
$target->{reported}->[$order]->{var} = $field->GetVar(); |
2770
|
0
|
|
|
|
|
|
$order++; |
2771
|
|
|
|
|
|
|
} |
2772
|
|
|
|
|
|
|
} |
2773
|
|
|
|
|
|
|
} |
2774
|
|
|
|
|
|
|
} |
2775
|
|
|
|
|
|
|
|
2776
|
|
|
|
|
|
|
|
2777
|
|
|
|
|
|
|
############################################################################### |
2778
|
|
|
|
|
|
|
# |
2779
|
|
|
|
|
|
|
# ExtractOobs - Helper function to make extracting jabber:x:oob for forms |
2780
|
|
|
|
|
|
|
# more centrally definable. |
2781
|
|
|
|
|
|
|
# |
2782
|
|
|
|
|
|
|
############################################################################### |
2783
|
|
|
|
|
|
|
sub ExtractOobs |
2784
|
|
|
|
|
|
|
{ |
2785
|
0
|
|
|
0
|
0
|
|
my ($target,@xOobs) = @_; |
2786
|
|
|
|
|
|
|
|
2787
|
0
|
|
|
|
|
|
foreach my $xOob (@xOobs) |
2788
|
|
|
|
|
|
|
{ |
2789
|
0
|
|
|
|
|
|
$target->{oob}->{url} = $xOob->GetURL(); |
2790
|
0
|
|
|
|
|
|
$target->{oob}->{desc} = $xOob->GetDesc(); |
2791
|
|
|
|
|
|
|
} |
2792
|
|
|
|
|
|
|
} |
2793
|
|
|
|
|
|
|
|
2794
|
|
|
|
|
|
|
|
2795
|
|
|
|
|
|
|
############################################################################### |
2796
|
|
|
|
|
|
|
#+----------------------------------------------------------------------------- |
2797
|
|
|
|
|
|
|
#| |
2798
|
|
|
|
|
|
|
#| Default CallBacks |
2799
|
|
|
|
|
|
|
#| |
2800
|
|
|
|
|
|
|
#+----------------------------------------------------------------------------- |
2801
|
|
|
|
|
|
|
############################################################################### |
2802
|
|
|
|
|
|
|
|
2803
|
|
|
|
|
|
|
|
2804
|
|
|
|
|
|
|
############################################################################### |
2805
|
|
|
|
|
|
|
# |
2806
|
|
|
|
|
|
|
# callbackInit - initialize the default callbacks |
2807
|
|
|
|
|
|
|
# |
2808
|
|
|
|
|
|
|
############################################################################### |
2809
|
|
|
|
|
|
|
sub callbackInit |
2810
|
|
|
|
|
|
|
{ |
2811
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
2812
|
|
|
|
|
|
|
|
2813
|
0
|
|
|
|
|
|
$self->SUPER::callbackInit(); |
2814
|
|
|
|
|
|
|
|
2815
|
|
|
|
|
|
|
$self->SetIQCallBacks("jabber:iq:last"=> |
2816
|
|
|
|
|
|
|
{ |
2817
|
0
|
|
|
0
|
|
|
get=>sub{ $self->callbackGetIQLast(@_) }, |
2818
|
0
|
|
|
0
|
|
|
result=>sub{ $self->callbackResultIQLast(@_) } |
2819
|
|
|
|
|
|
|
}, |
2820
|
|
|
|
|
|
|
"jabber:iq:rpc"=> |
2821
|
|
|
|
|
|
|
{ |
2822
|
0
|
|
|
0
|
|
|
set=>sub{ $self->callbackSetIQRPC(@_) }, |
2823
|
|
|
|
|
|
|
}, |
2824
|
|
|
|
|
|
|
"jabber:iq:time"=> |
2825
|
|
|
|
|
|
|
{ |
2826
|
0
|
|
|
0
|
|
|
get=>sub{ $self->callbackGetIQTime(@_) }, |
2827
|
0
|
|
|
0
|
|
|
result=>sub{ $self->callbackResultIQTime(@_) } |
2828
|
|
|
|
|
|
|
}, |
2829
|
|
|
|
|
|
|
"jabber:iq:version"=> |
2830
|
|
|
|
|
|
|
{ |
2831
|
0
|
|
|
0
|
|
|
get=>sub{ $self->callbackGetIQVersion(@_) }, |
2832
|
0
|
|
|
0
|
|
|
result=>sub{ $self->callbackResultIQVersion(@_) } |
2833
|
|
|
|
|
|
|
}, |
2834
|
0
|
|
|
|
|
|
); |
2835
|
|
|
|
|
|
|
} |
2836
|
|
|
|
|
|
|
|
2837
|
|
|
|
|
|
|
|
2838
|
|
|
|
|
|
|
############################################################################### |
2839
|
|
|
|
|
|
|
# |
2840
|
|
|
|
|
|
|
# callbackSetIQRPC - callback to handle auto-replying to an iq:rpc by calling |
2841
|
|
|
|
|
|
|
# the user registered functions. |
2842
|
|
|
|
|
|
|
# |
2843
|
|
|
|
|
|
|
############################################################################### |
2844
|
|
|
|
|
|
|
sub callbackSetIQRPC |
2845
|
|
|
|
|
|
|
{ |
2846
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
2847
|
0
|
|
|
|
|
|
my $sid = shift; |
2848
|
0
|
|
|
|
|
|
my $iq = shift; |
2849
|
|
|
|
|
|
|
|
2850
|
0
|
|
|
|
|
|
my $query = $iq->GetQuery(); |
2851
|
|
|
|
|
|
|
|
2852
|
0
|
|
|
|
|
|
my $reply = $iq->Reply(type=>"result"); |
2853
|
0
|
|
|
|
|
|
my $replyQuery = $reply->GetQuery(); |
2854
|
|
|
|
|
|
|
|
2855
|
0
|
0
|
|
|
|
|
if (!$query->DefinedMethodCall()) |
2856
|
|
|
|
|
|
|
{ |
2857
|
0
|
|
|
|
|
|
my $methodResponse = $replyQuery->AddMethodResponse(); |
2858
|
0
|
|
|
|
|
|
my $struct = $methodResponse->AddFault()->AddValue()->AddStruct(); |
2859
|
0
|
|
|
|
|
|
$struct->AddMember(name=>"faultCode")->AddValue(int=>400); |
2860
|
0
|
|
|
|
|
|
$struct->AddMember(name=>"faultString")->AddValue(string=>"Missing methodCall."); |
2861
|
0
|
|
|
|
|
|
$self->Send($reply,1); |
2862
|
0
|
|
|
|
|
|
return; |
2863
|
|
|
|
|
|
|
} |
2864
|
|
|
|
|
|
|
|
2865
|
0
|
0
|
|
|
|
|
if (!$query->GetMethodCall()->DefinedMethodName()) |
2866
|
|
|
|
|
|
|
{ |
2867
|
0
|
|
|
|
|
|
my $methodResponse = $replyQuery->AddMethodResponse(); |
2868
|
0
|
|
|
|
|
|
my $struct = $methodResponse->AddFault()->AddValue()->AddStruct(); |
2869
|
0
|
|
|
|
|
|
$struct->AddMember(name=>"faultCode")->AddValue(int=>400); |
2870
|
0
|
|
|
|
|
|
$struct->AddMember(name=>"faultString")->AddValue(string=>"Missing methodName."); |
2871
|
0
|
|
|
|
|
|
$self->Send($reply,1); |
2872
|
0
|
|
|
|
|
|
return; |
2873
|
|
|
|
|
|
|
} |
2874
|
|
|
|
|
|
|
|
2875
|
0
|
|
|
|
|
|
my $methodName = $query->GetMethodCall()->GetMethodName(); |
2876
|
|
|
|
|
|
|
|
2877
|
0
|
0
|
|
|
|
|
if (!exists($self->{RPCCB}->{$methodName})) |
2878
|
|
|
|
|
|
|
{ |
2879
|
0
|
|
|
|
|
|
my $methodResponse = $replyQuery->AddMethodResponse(); |
2880
|
0
|
|
|
|
|
|
my $struct = $methodResponse->AddFault()->AddValue()->AddStruct(); |
2881
|
0
|
|
|
|
|
|
$struct->AddMember(name=>"faultCode")->AddValue(int=>404); |
2882
|
0
|
|
|
|
|
|
$struct->AddMember(name=>"faultString")->AddValue(string=>"methodName $methodName not defined."); |
2883
|
0
|
|
|
|
|
|
$self->Send($reply,1); |
2884
|
0
|
|
|
|
|
|
return; |
2885
|
|
|
|
|
|
|
} |
2886
|
|
|
|
|
|
|
|
2887
|
0
|
|
|
|
|
|
my @params = $self->RPCParse($iq); |
2888
|
|
|
|
|
|
|
|
2889
|
0
|
|
|
|
|
|
my @return = &{$self->{RPCCB}->{$methodName}}($iq,$params[1]); |
|
0
|
|
|
|
|
|
|
2890
|
|
|
|
|
|
|
|
2891
|
0
|
0
|
|
|
|
|
if ($return[0] ne "ok") { |
2892
|
0
|
|
|
|
|
|
my $methodResponse = $replyQuery->AddMethodResponse(); |
2893
|
0
|
|
|
|
|
|
my $struct = $methodResponse->AddFault()->AddValue()->AddStruct(); |
2894
|
0
|
|
|
|
|
|
$struct->AddMember(name=>"faultCode")->AddValue(int=>$return[1]->{faultCode}); |
2895
|
0
|
|
|
|
|
|
$struct->AddMember(name=>"faultString")->AddValue(string=>$return[1]->{faultString}); |
2896
|
0
|
|
|
|
|
|
$self->Send($reply,1); |
2897
|
0
|
|
|
|
|
|
return; |
2898
|
|
|
|
|
|
|
} |
2899
|
0
|
|
|
|
|
|
$reply->RemoveQuery(); |
2900
|
0
|
|
|
|
|
|
$reply->AddQuery($self->RPCEncode(type=>"methodResponse", |
2901
|
|
|
|
|
|
|
params=>$return[1])); |
2902
|
|
|
|
|
|
|
|
2903
|
0
|
|
|
|
|
|
$self->Send($reply,1); |
2904
|
|
|
|
|
|
|
} |
2905
|
|
|
|
|
|
|
|
2906
|
|
|
|
|
|
|
|
2907
|
|
|
|
|
|
|
############################################################################### |
2908
|
|
|
|
|
|
|
# |
2909
|
|
|
|
|
|
|
# callbackGetIQTime - callback to handle auto-replying to an iq:time get. |
2910
|
|
|
|
|
|
|
# |
2911
|
|
|
|
|
|
|
############################################################################### |
2912
|
|
|
|
|
|
|
sub callbackGetIQTime |
2913
|
|
|
|
|
|
|
{ |
2914
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
2915
|
0
|
|
|
|
|
|
my $sid = shift; |
2916
|
0
|
|
|
|
|
|
my $iq = shift; |
2917
|
|
|
|
|
|
|
|
2918
|
0
|
|
|
|
|
|
my $query = $iq->GetQuery(); |
2919
|
|
|
|
|
|
|
|
2920
|
0
|
|
|
|
|
|
my $reply = $iq->Reply(type=>"result"); |
2921
|
0
|
|
|
|
|
|
my $replyQuery = $reply->GetQuery(); |
2922
|
0
|
|
|
|
|
|
$replyQuery->SetTime(); |
2923
|
|
|
|
|
|
|
|
2924
|
0
|
|
|
|
|
|
$self->Send($reply,1); |
2925
|
|
|
|
|
|
|
} |
2926
|
|
|
|
|
|
|
|
2927
|
|
|
|
|
|
|
|
2928
|
|
|
|
|
|
|
############################################################################### |
2929
|
|
|
|
|
|
|
# |
2930
|
|
|
|
|
|
|
# callbackResultIQTime - callback to handle formatting iq:time result into |
2931
|
|
|
|
|
|
|
# a message. |
2932
|
|
|
|
|
|
|
# |
2933
|
|
|
|
|
|
|
############################################################################### |
2934
|
|
|
|
|
|
|
sub callbackResultIQTime |
2935
|
|
|
|
|
|
|
{ |
2936
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
2937
|
0
|
|
|
|
|
|
my $sid = shift; |
2938
|
0
|
|
|
|
|
|
my $iq = shift; |
2939
|
|
|
|
|
|
|
|
2940
|
0
|
|
|
|
|
|
my $fromJID = $iq->GetFrom("jid"); |
2941
|
0
|
|
|
|
|
|
my $query = $iq->GetQuery(); |
2942
|
|
|
|
|
|
|
|
2943
|
0
|
|
|
|
|
|
my $body = "UTC: ".$query->GetUTC()."\n"; |
2944
|
0
|
|
|
|
|
|
$body .= "Time: ".$query->GetDisplay()."\n"; |
2945
|
0
|
|
|
|
|
|
$body .= "Timezone: ".$query->GetTZ()."\n"; |
2946
|
|
|
|
|
|
|
|
2947
|
0
|
|
|
|
|
|
my $message = $self->_message(); |
2948
|
0
|
|
|
|
|
|
$message->SetMessage(to=>$iq->GetTo(), |
2949
|
|
|
|
|
|
|
from=>$iq->GetFrom(), |
2950
|
|
|
|
|
|
|
subject=>"CTCP: Time", |
2951
|
|
|
|
|
|
|
body=>$body); |
2952
|
|
|
|
|
|
|
|
2953
|
|
|
|
|
|
|
|
2954
|
0
|
|
|
|
|
|
$self->CallBack($sid,$message); |
2955
|
|
|
|
|
|
|
} |
2956
|
|
|
|
|
|
|
|
2957
|
|
|
|
|
|
|
|
2958
|
|
|
|
|
|
|
############################################################################### |
2959
|
|
|
|
|
|
|
# |
2960
|
|
|
|
|
|
|
# callbackGetIQVersion - callback to handle auto-replying to an iq:time |
2961
|
|
|
|
|
|
|
# get. |
2962
|
|
|
|
|
|
|
# |
2963
|
|
|
|
|
|
|
############################################################################### |
2964
|
|
|
|
|
|
|
sub callbackGetIQVersion |
2965
|
|
|
|
|
|
|
{ |
2966
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
2967
|
0
|
|
|
|
|
|
my $sid = shift; |
2968
|
0
|
|
|
|
|
|
my $iq = shift; |
2969
|
|
|
|
|
|
|
|
2970
|
0
|
|
|
|
|
|
my $query = $iq->GetQuery(); |
2971
|
|
|
|
|
|
|
|
2972
|
0
|
|
|
|
|
|
my $reply = $iq->Reply(type=>"result"); |
2973
|
0
|
|
|
|
|
|
my $replyQuery = $reply->GetQuery(); |
2974
|
0
|
|
|
|
|
|
$replyQuery->SetVersion(name=>$self->{INFO}->{name}, |
2975
|
|
|
|
|
|
|
ver=>$self->{INFO}->{version}, |
2976
|
|
|
|
|
|
|
os=>""); |
2977
|
|
|
|
|
|
|
|
2978
|
0
|
|
|
|
|
|
$self->Send($reply,1); |
2979
|
|
|
|
|
|
|
} |
2980
|
|
|
|
|
|
|
|
2981
|
|
|
|
|
|
|
|
2982
|
|
|
|
|
|
|
############################################################################### |
2983
|
|
|
|
|
|
|
# |
2984
|
|
|
|
|
|
|
# callbackResultIQVersion - callback to handle formatting iq:time result |
2985
|
|
|
|
|
|
|
# into a message. |
2986
|
|
|
|
|
|
|
# |
2987
|
|
|
|
|
|
|
############################################################################### |
2988
|
|
|
|
|
|
|
sub callbackResultIQVersion |
2989
|
|
|
|
|
|
|
{ |
2990
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
2991
|
0
|
|
|
|
|
|
my $sid = shift; |
2992
|
0
|
|
|
|
|
|
my $iq = shift; |
2993
|
|
|
|
|
|
|
|
2994
|
0
|
|
|
|
|
|
my $query = $iq->GetQuery(); |
2995
|
|
|
|
|
|
|
|
2996
|
0
|
|
|
|
|
|
my $body = "Program: ".$query->GetName()."\n"; |
2997
|
0
|
|
|
|
|
|
$body .= "Version: ".$query->GetVer()."\n"; |
2998
|
0
|
|
|
|
|
|
$body .= "OS: ".$query->GetOS()."\n"; |
2999
|
|
|
|
|
|
|
|
3000
|
0
|
|
|
|
|
|
my $message = $self->_message(); |
3001
|
0
|
|
|
|
|
|
$message->SetMessage(to=>$iq->GetTo(), |
3002
|
|
|
|
|
|
|
from=>$iq->GetFrom(), |
3003
|
|
|
|
|
|
|
subject=>"CTCP: Version", |
3004
|
|
|
|
|
|
|
body=>$body); |
3005
|
|
|
|
|
|
|
|
3006
|
0
|
|
|
|
|
|
$self->CallBack($sid,$message); |
3007
|
|
|
|
|
|
|
} |
3008
|
|
|
|
|
|
|
|
3009
|
|
|
|
|
|
|
|
3010
|
|
|
|
|
|
|
############################################################################### |
3011
|
|
|
|
|
|
|
# |
3012
|
|
|
|
|
|
|
# callbackGetIQLast - callback to handle auto-replying to an iq:last get. |
3013
|
|
|
|
|
|
|
# |
3014
|
|
|
|
|
|
|
############################################################################### |
3015
|
|
|
|
|
|
|
sub callbackGetIQLast |
3016
|
|
|
|
|
|
|
{ |
3017
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
3018
|
0
|
|
|
|
|
|
my $sid = shift; |
3019
|
0
|
|
|
|
|
|
my $iq = shift; |
3020
|
|
|
|
|
|
|
|
3021
|
0
|
|
|
|
|
|
my $query = $iq->GetQuery(); |
3022
|
0
|
|
|
|
|
|
my $reply = $iq->Reply(type=>"result"); |
3023
|
0
|
|
|
|
|
|
my $replyQuery = $reply->GetQuery(); |
3024
|
0
|
|
|
|
|
|
$replyQuery->SetLast(seconds=>$self->LastActivity()); |
3025
|
|
|
|
|
|
|
|
3026
|
0
|
|
|
|
|
|
$self->Send($reply,1); |
3027
|
|
|
|
|
|
|
} |
3028
|
|
|
|
|
|
|
|
3029
|
|
|
|
|
|
|
|
3030
|
|
|
|
|
|
|
############################################################################### |
3031
|
|
|
|
|
|
|
# |
3032
|
|
|
|
|
|
|
# callbackResultIQLast - callback to handle formatting iq:last result into |
3033
|
|
|
|
|
|
|
# a message. |
3034
|
|
|
|
|
|
|
# |
3035
|
|
|
|
|
|
|
############################################################################### |
3036
|
|
|
|
|
|
|
sub callbackResultIQLast |
3037
|
|
|
|
|
|
|
{ |
3038
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
3039
|
0
|
|
|
|
|
|
my $sid = shift; |
3040
|
0
|
|
|
|
|
|
my $iq = shift; |
3041
|
|
|
|
|
|
|
|
3042
|
0
|
|
|
|
|
|
my $fromJID = $iq->GetFrom("jid"); |
3043
|
0
|
|
|
|
|
|
my $query = $iq->GetQuery(); |
3044
|
0
|
|
|
|
|
|
my $seconds = $query->GetSeconds(); |
3045
|
|
|
|
|
|
|
|
3046
|
0
|
|
|
|
|
|
my $lastTime = &Net::Jabber::GetTimeStamp("local",(time - $seconds),"long"); |
3047
|
|
|
|
|
|
|
|
3048
|
0
|
|
|
|
|
|
my $elapsedTime = &Net::Jabber::GetHumanTime($seconds); |
3049
|
|
|
|
|
|
|
|
3050
|
0
|
|
|
|
|
|
my $body; |
3051
|
0
|
0
|
|
|
|
|
if ($fromJID->GetUserID() eq "") |
|
|
0
|
|
|
|
|
|
3052
|
|
|
|
|
|
|
{ |
3053
|
0
|
|
|
|
|
|
$body = "Start Time: $lastTime\n"; |
3054
|
0
|
|
|
|
|
|
$body .= "Up time: $elapsedTime\n"; |
3055
|
0
|
0
|
|
|
|
|
$body .= "Message: ".$query->GetMessage()."\n" |
3056
|
|
|
|
|
|
|
if ($query->DefinedMessage()); |
3057
|
|
|
|
|
|
|
} |
3058
|
|
|
|
|
|
|
elsif ($fromJID->GetResource() eq "") |
3059
|
|
|
|
|
|
|
{ |
3060
|
0
|
|
|
|
|
|
$body = "Logout Time: $lastTime\n"; |
3061
|
0
|
|
|
|
|
|
$body .= "Elapsed time: $elapsedTime\n"; |
3062
|
0
|
0
|
|
|
|
|
$body .= "Message: ".$query->GetMessage()."\n" |
3063
|
|
|
|
|
|
|
if ($query->DefinedMessage()); |
3064
|
|
|
|
|
|
|
} |
3065
|
|
|
|
|
|
|
else |
3066
|
|
|
|
|
|
|
{ |
3067
|
0
|
|
|
|
|
|
$body = "Last activity: $lastTime\n"; |
3068
|
0
|
|
|
|
|
|
$body .= "Elapsed time: $elapsedTime\n"; |
3069
|
0
|
0
|
|
|
|
|
$body .= "Message: ".$query->GetMessage()."\n" |
3070
|
|
|
|
|
|
|
if ($query->DefinedMessage()); |
3071
|
|
|
|
|
|
|
} |
3072
|
|
|
|
|
|
|
|
3073
|
0
|
|
|
|
|
|
my $message = $self->_message(); |
3074
|
0
|
|
|
|
|
|
$message->SetMessage(from=>$iq->GetFrom(), |
3075
|
|
|
|
|
|
|
subject=>"Last Activity", |
3076
|
|
|
|
|
|
|
body=>$body); |
3077
|
|
|
|
|
|
|
|
3078
|
0
|
|
|
|
|
|
$self->CallBack($sid,$message); |
3079
|
|
|
|
|
|
|
} |
3080
|
|
|
|
|
|
|
|
3081
|
|
|
|
|
|
|
|
3082
|
|
|
|
|
|
|
1; |