line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# $Id: MgmtProfile.pm,v 1.10 2003/09/11 19:57:31 davidb Exp $ |
2
|
|
|
|
|
|
|
# |
3
|
|
|
|
|
|
|
# Copyright (C) 2003 Verisign, Inc. |
4
|
|
|
|
|
|
|
# |
5
|
|
|
|
|
|
|
# This library is free software; you can redistribute it and/or |
6
|
|
|
|
|
|
|
# modify it under the terms of the GNU Lesser General Public |
7
|
|
|
|
|
|
|
# License as published by the Free Software Foundation; either |
8
|
|
|
|
|
|
|
# version 2.1 of the License, or (at your option) any later version. |
9
|
|
|
|
|
|
|
# |
10
|
|
|
|
|
|
|
# This library is distributed in the hope that it will be useful, |
11
|
|
|
|
|
|
|
# but WITHOUT ANY WARRANTY; without even the implied warranty of |
12
|
|
|
|
|
|
|
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
13
|
|
|
|
|
|
|
# Lesser General Public License for more details. |
14
|
|
|
|
|
|
|
# |
15
|
|
|
|
|
|
|
# You should have received a copy of the GNU Lesser General Public |
16
|
|
|
|
|
|
|
# License along with this library; if not, write to the Free Software |
17
|
|
|
|
|
|
|
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 |
18
|
|
|
|
|
|
|
# USA |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
package Net::BEEP::Lite::MgmtProfile; |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
=head1 NAME |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
Net::BEEP::Lite::MgmtProfile |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
=head1 SYNOPSIS |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
my $mgmt_profile |
29
|
|
|
|
|
|
|
= Net::BEEP::Lite::MgmtProfile->new(AllowMultipleChannels => 1) |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
my $greeting_msg = $mgmt_profile->greeting_message($session); |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
my $start_channel_msg |
34
|
|
|
|
|
|
|
= $mgmt_profile->start_channel_message($session, |
35
|
|
|
|
|
|
|
(URI => "http://xml.resources.org/profiles/NULL/ECHO", |
36
|
|
|
|
|
|
|
ServerName => "localhost", |
37
|
|
|
|
|
|
|
StartData => "echo this!")); |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
=head1 DESCRIPTION |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
This is a subclass of C. It is the |
43
|
|
|
|
|
|
|
special profile that deals with the BEEP channel management messages |
44
|
|
|
|
|
|
|
that occur on channel zero. User code is not expected to instantate |
45
|
|
|
|
|
|
|
instances of this class on their own. In general, this is created and |
46
|
|
|
|
|
|
|
used solely by the C class and its subclasses. |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
Both server and client sessions use this, as it handles both sides of |
49
|
|
|
|
|
|
|
the conversation. |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
This profile is designed to be shared between different sessions, just |
52
|
|
|
|
|
|
|
as part of the general design principle for profiles. However, within |
53
|
|
|
|
|
|
|
this framework (and Perl in general) this is unlikely to be actually |
54
|
|
|
|
|
|
|
true (due to forking, or even ithreads). |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
=cut |
57
|
|
|
|
|
|
|
|
58
|
3
|
|
|
3
|
|
28492
|
use Carp; |
|
3
|
|
|
|
|
7
|
|
|
3
|
|
|
|
|
269
|
|
59
|
3
|
|
|
3
|
|
20
|
use strict; |
|
3
|
|
|
|
|
16
|
|
|
3
|
|
|
|
|
2380
|
|
60
|
3
|
|
|
3
|
|
20
|
use warnings; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
98
|
|
61
|
|
|
|
|
|
|
|
62
|
3
|
|
|
3
|
|
1447
|
use XML::LibXML; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
use MIME::Base64; |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
use Net::BEEP::Lite::Message; |
66
|
|
|
|
|
|
|
use base qw(Net::BEEP::Lite::BaseProfile); |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
=head1 CONSTRUCTOR |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
=over 4 |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
=item new( I ) |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
This is the main constructor for this class. It takes named |
75
|
|
|
|
|
|
|
parameters as arguments. See the C method of this class |
76
|
|
|
|
|
|
|
and the superclass (C) for valid argument |
77
|
|
|
|
|
|
|
names. |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
=back |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
=cut |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
sub new { |
84
|
|
|
|
|
|
|
my $this = shift; |
85
|
|
|
|
|
|
|
my $class = ref($this) || $this; |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
my $self = {}; |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
bless $self, $class; |
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
$self->SUPER::initialize(@_); |
92
|
|
|
|
|
|
|
$self->initialize(@_); |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
$self->{parser} = XML::LibXML->new(); |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
$self; |
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
} |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
=head1 METHODS |
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
=over 4 |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
=item initialize( I ) |
105
|
|
|
|
|
|
|
|
106
|
|
|
|
|
|
|
Initialize the object. This takes the same arguments as the |
107
|
|
|
|
|
|
|
constructor (Indeed, the constructor is just calling this method). |
108
|
|
|
|
|
|
|
This method takes the following named parameters: |
109
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
=over 4 |
111
|
|
|
|
|
|
|
|
112
|
|
|
|
|
|
|
=item AllowMultipleChannels |
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
if false, attempts to start more than one data channel by the peer |
115
|
|
|
|
|
|
|
will fail. This is set to B by default. |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
=back |
118
|
|
|
|
|
|
|
|
119
|
|
|
|
|
|
|
=cut |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
sub initialize { |
122
|
|
|
|
|
|
|
my $self = shift; |
123
|
|
|
|
|
|
|
my %args = @_; |
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
# by default, we do not allow multiple channels |
126
|
|
|
|
|
|
|
$self->{allow_multiple} = 0; |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
for (keys %args) { |
129
|
|
|
|
|
|
|
my $val = $args{$_}; |
130
|
|
|
|
|
|
|
|
131
|
|
|
|
|
|
|
/^AllowMultipleChannels/io and do { |
132
|
|
|
|
|
|
|
$self->allow_multiple_channels($val); |
133
|
|
|
|
|
|
|
next; |
134
|
|
|
|
|
|
|
}; |
135
|
|
|
|
|
|
|
} |
136
|
|
|
|
|
|
|
} |
137
|
|
|
|
|
|
|
|
138
|
|
|
|
|
|
|
=item allow_multiple_channels([value]) |
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
If an argument is given, it is used as the boolean value for whether |
141
|
|
|
|
|
|
|
or not start channel requests should be allowed when there is already |
142
|
|
|
|
|
|
|
an existing open channel. It returns the current (possibly just set) |
143
|
|
|
|
|
|
|
value. |
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
=cut |
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
sub allow_multiple_channels { |
148
|
|
|
|
|
|
|
my $self = shift; |
149
|
|
|
|
|
|
|
my $val = shift; |
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
$self->{allow_multiple} = $val if defined $val; |
152
|
|
|
|
|
|
|
$self->{allow_multiple}; |
153
|
|
|
|
|
|
|
} |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
# This will parse the BEEP management channel message XML content. |
156
|
|
|
|
|
|
|
sub _parse_message { |
157
|
|
|
|
|
|
|
my $self = shift; |
158
|
|
|
|
|
|
|
my $message = shift; |
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
my $ct = $message->content_type(); |
161
|
|
|
|
|
|
|
confess "invalid mangement channel content type ($ct)\n" |
162
|
|
|
|
|
|
|
if $ct ne "application/beep+xml"; |
163
|
|
|
|
|
|
|
|
164
|
|
|
|
|
|
|
my $content = $message->content(); |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
# parse the content. |
167
|
|
|
|
|
|
|
my $doc = $self->{parser}->parse_string($content); |
168
|
|
|
|
|
|
|
|
169
|
|
|
|
|
|
|
$doc->documentElement(); |
170
|
|
|
|
|
|
|
} |
171
|
|
|
|
|
|
|
|
172
|
|
|
|
|
|
|
=item MSG($session, $message) |
173
|
|
|
|
|
|
|
|
174
|
|
|
|
|
|
|
Handle MSG type messages. This method handles BEEP "" and |
175
|
|
|
|
|
|
|
"" messages. Returns $message. |
176
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
=cut |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
sub MSG { |
180
|
|
|
|
|
|
|
my $self = shift; |
181
|
|
|
|
|
|
|
my $session = shift; |
182
|
|
|
|
|
|
|
my $message = shift; |
183
|
|
|
|
|
|
|
|
184
|
|
|
|
|
|
|
print STDERR "MgmtProfile->handling MSG: ", $message->content(), "\n" |
185
|
|
|
|
|
|
|
if $self->{debug}; |
186
|
|
|
|
|
|
|
|
187
|
|
|
|
|
|
|
my $root = $self->_parse_message($message); |
188
|
|
|
|
|
|
|
my $name = $root->nodeName; |
189
|
|
|
|
|
|
|
|
190
|
|
|
|
|
|
|
# handle start message. |
191
|
|
|
|
|
|
|
if ($name eq "start") { |
192
|
|
|
|
|
|
|
|
193
|
|
|
|
|
|
|
# if we are not allowed to open multiple channels (in addition to |
194
|
|
|
|
|
|
|
# the management channel), don't. |
195
|
|
|
|
|
|
|
if ($session->num_open_channels() >= 1 and |
196
|
|
|
|
|
|
|
!$self->allow_multiple_channels()) { |
197
|
|
|
|
|
|
|
my $resp = $self->_error_message($message->msgno(), |
198
|
|
|
|
|
|
|
550, "Channel creation not allowed."); |
199
|
|
|
|
|
|
|
$session->send_message($resp); |
200
|
|
|
|
|
|
|
return $message; |
201
|
|
|
|
|
|
|
} |
202
|
|
|
|
|
|
|
|
203
|
|
|
|
|
|
|
my $number = $root->getAttribute("number"); |
204
|
|
|
|
|
|
|
my $server_name = $root->getAttribute("serverName"); |
205
|
|
|
|
|
|
|
|
206
|
|
|
|
|
|
|
my @profile_elements = $root->getElementsByTagName("profile"); |
207
|
|
|
|
|
|
|
# for now, if there are multiple presented profiles, we just pick |
208
|
|
|
|
|
|
|
# the first one that we support (not the "best" one). |
209
|
|
|
|
|
|
|
my ($profile, $data, $encoded); |
210
|
|
|
|
|
|
|
for my $pe (@profile_elements) { |
211
|
|
|
|
|
|
|
my $uri = $pe->getAttribute("uri"); |
212
|
|
|
|
|
|
|
$profile = $session->get_local_profile($uri); |
213
|
|
|
|
|
|
|
|
214
|
|
|
|
|
|
|
if ($profile) { |
215
|
|
|
|
|
|
|
my $encoding_attr = $pe->getAttribute("encoding") || ""; |
216
|
|
|
|
|
|
|
$encoded = ($encoding_attr eq "base64"); |
217
|
|
|
|
|
|
|
$data = $pe->textContent; |
218
|
|
|
|
|
|
|
$data = decode_base64($data) if $encoded; |
219
|
|
|
|
|
|
|
last; |
220
|
|
|
|
|
|
|
} |
221
|
|
|
|
|
|
|
} |
222
|
|
|
|
|
|
|
|
223
|
|
|
|
|
|
|
# if we don't support any of the profiles presented... |
224
|
|
|
|
|
|
|
if (not $profile) { |
225
|
|
|
|
|
|
|
# send the error response. |
226
|
|
|
|
|
|
|
my $resp = $self->_error_message |
227
|
|
|
|
|
|
|
($message->msgno(), 550, "all requested profiles are unsupported"); |
228
|
|
|
|
|
|
|
$session->send_message($resp); |
229
|
|
|
|
|
|
|
return $message; |
230
|
|
|
|
|
|
|
} |
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
# set the server name, if we got it. |
233
|
|
|
|
|
|
|
$session->servername($server_name); |
234
|
|
|
|
|
|
|
|
235
|
|
|
|
|
|
|
# get the profile's input |
236
|
|
|
|
|
|
|
my ($resp_data, $encode); |
237
|
|
|
|
|
|
|
my @res = $profile->start_channel_request($session, $message, $data); |
238
|
|
|
|
|
|
|
|
239
|
|
|
|
|
|
|
if ($res[0] and $res[0] eq 'NUL') { |
240
|
|
|
|
|
|
|
# NUL means to do nothing at all. |
241
|
|
|
|
|
|
|
return $message; |
242
|
|
|
|
|
|
|
} |
243
|
|
|
|
|
|
|
elsif ($res[0] and $res[0] eq 'ERR') { |
244
|
|
|
|
|
|
|
# ERR means that the profile has refused the channel creation. |
245
|
|
|
|
|
|
|
my $resp = $self->_error_message($res[1], $res[2]); |
246
|
|
|
|
|
|
|
$session->send_message($resp); |
247
|
|
|
|
|
|
|
return $message; |
248
|
|
|
|
|
|
|
} |
249
|
|
|
|
|
|
|
elsif ($res[0] and $res[0] eq 'RPY') { |
250
|
|
|
|
|
|
|
# RPY means that the profile wants to send some response data |
251
|
|
|
|
|
|
|
# back along with creating the channel. |
252
|
|
|
|
|
|
|
$resp_data = $res[1]; |
253
|
|
|
|
|
|
|
$encode = $res[2] || 0; |
254
|
|
|
|
|
|
|
$resp_data = encode_base64($resp_data) if $encode; |
255
|
|
|
|
|
|
|
} |
256
|
|
|
|
|
|
|
# other responses or undef means to return a plain response. |
257
|
|
|
|
|
|
|
|
258
|
|
|
|
|
|
|
# IMPORTANT: add the channel to the session. |
259
|
|
|
|
|
|
|
$session->_add_channel($number, $profile); |
260
|
|
|
|
|
|
|
|
261
|
|
|
|
|
|
|
# return a "profile" response. |
262
|
|
|
|
|
|
|
$self->send_profile_message($session, $message->msgno(), $profile->uri(), |
263
|
|
|
|
|
|
|
$resp_data, $encode); |
264
|
|
|
|
|
|
|
|
265
|
|
|
|
|
|
|
return $message; |
266
|
|
|
|
|
|
|
} |
267
|
|
|
|
|
|
|
# handle close message. |
268
|
|
|
|
|
|
|
elsif ($name eq "close") { |
269
|
|
|
|
|
|
|
|
270
|
|
|
|
|
|
|
my $number = $root->getAttribute("number"); |
271
|
|
|
|
|
|
|
my $code = $root->getAttribute("code"); |
272
|
|
|
|
|
|
|
|
273
|
|
|
|
|
|
|
my $resp = $self->_new_mgmt_message(Type => 'RPY', |
274
|
|
|
|
|
|
|
Msgno => $message->msgno(), |
275
|
|
|
|
|
|
|
Content => ""); |
276
|
|
|
|
|
|
|
|
277
|
|
|
|
|
|
|
$session->send_message($resp); |
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
# close the session if the channel number was zero. |
280
|
|
|
|
|
|
|
if ($number == 0) { |
281
|
|
|
|
|
|
|
# FIXME: I don't see any reason why I can't close the socket |
282
|
|
|
|
|
|
|
# immediately after sending the "ok", but beepcore-java will |
283
|
|
|
|
|
|
|
# throw an exception. |
284
|
|
|
|
|
|
|
|
285
|
|
|
|
|
|
|
# FIXME: what I really want to do is just wait for the other end |
286
|
|
|
|
|
|
|
# to close the socket (and only close) |
287
|
|
|
|
|
|
|
select(undef, undef, undef, 0.2); |
288
|
|
|
|
|
|
|
$session->close_session(); |
289
|
|
|
|
|
|
|
} else { |
290
|
|
|
|
|
|
|
# IMPORTANT: otherwise, destroy the channel. |
291
|
|
|
|
|
|
|
$session->_del_channel($number); |
292
|
|
|
|
|
|
|
} |
293
|
|
|
|
|
|
|
} |
294
|
|
|
|
|
|
|
|
295
|
|
|
|
|
|
|
$message; |
296
|
|
|
|
|
|
|
} |
297
|
|
|
|
|
|
|
|
298
|
|
|
|
|
|
|
=item RPY($session, $message) |
299
|
|
|
|
|
|
|
|
300
|
|
|
|
|
|
|
This method handles RPY type BEEP messages. It handles "", |
301
|
|
|
|
|
|
|
"", and "" responses. It returns $message. |
302
|
|
|
|
|
|
|
|
303
|
|
|
|
|
|
|
=cut |
304
|
|
|
|
|
|
|
|
305
|
|
|
|
|
|
|
sub RPY { |
306
|
|
|
|
|
|
|
my $self = shift; |
307
|
|
|
|
|
|
|
my $session = shift; |
308
|
|
|
|
|
|
|
my $message = shift; |
309
|
|
|
|
|
|
|
|
310
|
|
|
|
|
|
|
print STDERR "MgmtProfile->handling RPY:\n", $message->content(), "\n" |
311
|
|
|
|
|
|
|
if $self->{debug}; |
312
|
|
|
|
|
|
|
|
313
|
|
|
|
|
|
|
my $root = $self->_parse_message($message); |
314
|
|
|
|
|
|
|
my $name = $root->nodeName; |
315
|
|
|
|
|
|
|
|
316
|
|
|
|
|
|
|
# handle greeting message. |
317
|
|
|
|
|
|
|
if ($name eq "greeting") { |
318
|
|
|
|
|
|
|
|
319
|
|
|
|
|
|
|
my @profile_elements = $root->getElementsByTagName("profile"); |
320
|
|
|
|
|
|
|
for my $pe (@profile_elements) { |
321
|
|
|
|
|
|
|
my $uri = $pe->getAttribute('uri'); |
322
|
|
|
|
|
|
|
$session->add_remote_profile($uri); |
323
|
|
|
|
|
|
|
} |
324
|
|
|
|
|
|
|
|
325
|
|
|
|
|
|
|
} |
326
|
|
|
|
|
|
|
# handle ok message. |
327
|
|
|
|
|
|
|
elsif ($name eq "ok") { |
328
|
|
|
|
|
|
|
|
329
|
|
|
|
|
|
|
# This relies on the fact that send_close_channel_message will |
330
|
|
|
|
|
|
|
# stow the channel to be closed in the session. |
331
|
|
|
|
|
|
|
my $number = $session->{closing_channel_number}; |
332
|
|
|
|
|
|
|
|
333
|
|
|
|
|
|
|
if ($number == 0) { |
334
|
|
|
|
|
|
|
# received for close of channel zero means to close the |
335
|
|
|
|
|
|
|
# session. |
336
|
|
|
|
|
|
|
$session->close_session(); |
337
|
|
|
|
|
|
|
} else { |
338
|
|
|
|
|
|
|
# we just close the requested channel. |
339
|
|
|
|
|
|
|
$session->_del_channel($number); |
340
|
|
|
|
|
|
|
} |
341
|
|
|
|
|
|
|
|
342
|
|
|
|
|
|
|
} |
343
|
|
|
|
|
|
|
# handle 'profile' message |
344
|
|
|
|
|
|
|
elsif ($name eq "profile") { |
345
|
|
|
|
|
|
|
|
346
|
|
|
|
|
|
|
# IMPORTANT: add the channel. This relies on the fact that |
347
|
|
|
|
|
|
|
# send_start_channel_message will set the channel being started in |
348
|
|
|
|
|
|
|
# the session. |
349
|
|
|
|
|
|
|
$session->_add_channel($session->{starting_channel_number}); |
350
|
|
|
|
|
|
|
|
351
|
|
|
|
|
|
|
# we probably don't need this check, since only client sessions |
352
|
|
|
|
|
|
|
# will get this (in this implementation, anyway). |
353
|
|
|
|
|
|
|
if ($session->can('selected_profile')) { |
354
|
|
|
|
|
|
|
my $uri = $root->getAttribute('uri'); |
355
|
|
|
|
|
|
|
$session->selected_profile($uri); |
356
|
|
|
|
|
|
|
} |
357
|
|
|
|
|
|
|
|
358
|
|
|
|
|
|
|
# if there is any response data in the |
359
|
|
|
|
|
|
|
my $encoding_attr = $root->getAttribute("encoding") || ""; |
360
|
|
|
|
|
|
|
my $encoded = ($encoding_attr eq "base64"); |
361
|
|
|
|
|
|
|
my $data = $root->textContent; |
362
|
|
|
|
|
|
|
$data = decode_base64($data) if $data and $encoded; |
363
|
|
|
|
|
|
|
|
364
|
|
|
|
|
|
|
$session->{start_channel_data} = $data if $data; |
365
|
|
|
|
|
|
|
} |
366
|
|
|
|
|
|
|
else { |
367
|
|
|
|
|
|
|
confess "unknown RPY encountered: ", $message->content(), "\n"; |
368
|
|
|
|
|
|
|
} |
369
|
|
|
|
|
|
|
|
370
|
|
|
|
|
|
|
$message; |
371
|
|
|
|
|
|
|
} |
372
|
|
|
|
|
|
|
|
373
|
|
|
|
|
|
|
=item ERR($session, $message) |
374
|
|
|
|
|
|
|
|
375
|
|
|
|
|
|
|
This method handles ERR type messages. Currently, it doesn't really |
376
|
|
|
|
|
|
|
do anything with them. It returns $message. |
377
|
|
|
|
|
|
|
|
378
|
|
|
|
|
|
|
=cut |
379
|
|
|
|
|
|
|
|
380
|
|
|
|
|
|
|
sub ERR { |
381
|
|
|
|
|
|
|
my $self = shift; |
382
|
|
|
|
|
|
|
my $session = shift; |
383
|
|
|
|
|
|
|
my $message = shift; |
384
|
|
|
|
|
|
|
|
385
|
|
|
|
|
|
|
print STDERR "got an error: ", $message->content(), "\n" |
386
|
|
|
|
|
|
|
if $self->{debug}; |
387
|
|
|
|
|
|
|
return $message; |
388
|
|
|
|
|
|
|
} |
389
|
|
|
|
|
|
|
|
390
|
|
|
|
|
|
|
=item greeting_message(@profile_uris) |
391
|
|
|
|
|
|
|
|
392
|
|
|
|
|
|
|
This method returns a formatted C containing a |
393
|
|
|
|
|
|
|
valid "" message. It will advertise the profiles in |
394
|
|
|
|
|
|
|
@profile_uris.. |
395
|
|
|
|
|
|
|
|
396
|
|
|
|
|
|
|
=cut |
397
|
|
|
|
|
|
|
|
398
|
|
|
|
|
|
|
sub greeting_message { |
399
|
|
|
|
|
|
|
my $self = shift; |
400
|
|
|
|
|
|
|
my @profile_list = @_; |
401
|
|
|
|
|
|
|
|
402
|
|
|
|
|
|
|
my $greeting_el = XML::LibXML::Element->new("greeting"); |
403
|
|
|
|
|
|
|
for my $uri (@profile_list) { |
404
|
|
|
|
|
|
|
my $profile_el = XML::LibXML::Element->new("profile"); |
405
|
|
|
|
|
|
|
$profile_el->setAttribute("uri", $uri); |
406
|
|
|
|
|
|
|
$greeting_el->appendChild($profile_el); |
407
|
|
|
|
|
|
|
} |
408
|
|
|
|
|
|
|
|
409
|
|
|
|
|
|
|
my $msg = $self->_new_mgmt_message |
410
|
|
|
|
|
|
|
(Type => 'RPY', |
411
|
|
|
|
|
|
|
Msgno => 0, |
412
|
|
|
|
|
|
|
Content => $greeting_el->toString()); |
413
|
|
|
|
|
|
|
|
414
|
|
|
|
|
|
|
$msg; |
415
|
|
|
|
|
|
|
} |
416
|
|
|
|
|
|
|
|
417
|
|
|
|
|
|
|
=item send_greeting_message($session) |
418
|
|
|
|
|
|
|
|
419
|
|
|
|
|
|
|
Format and send the greeting message to the peer. It uses the session |
420
|
|
|
|
|
|
|
to determine was profiles to advertise. |
421
|
|
|
|
|
|
|
|
422
|
|
|
|
|
|
|
=cut |
423
|
|
|
|
|
|
|
|
424
|
|
|
|
|
|
|
sub send_greeting_message { |
425
|
|
|
|
|
|
|
my $self = shift; |
426
|
|
|
|
|
|
|
my $session = shift; |
427
|
|
|
|
|
|
|
|
428
|
|
|
|
|
|
|
my @profile_list = $session->get_local_profile_uris(); |
429
|
|
|
|
|
|
|
my $msg = $self->greeting_message(@profile_list); |
430
|
|
|
|
|
|
|
|
431
|
|
|
|
|
|
|
$session->send_message($msg); |
432
|
|
|
|
|
|
|
|
433
|
|
|
|
|
|
|
$msg; |
434
|
|
|
|
|
|
|
} |
435
|
|
|
|
|
|
|
|
436
|
|
|
|
|
|
|
=item start_channel_message( I ) |
437
|
|
|
|
|
|
|
|
438
|
|
|
|
|
|
|
This method will return a formatted "" message. It accepts a |
439
|
|
|
|
|
|
|
named parameter list. The following named parameters are accepted: |
440
|
|
|
|
|
|
|
|
441
|
|
|
|
|
|
|
=over 4 |
442
|
|
|
|
|
|
|
|
443
|
|
|
|
|
|
|
=item Channel |
444
|
|
|
|
|
|
|
|
445
|
|
|
|
|
|
|
The channel number to request. This is usually assigned by the |
446
|
|
|
|
|
|
|
session. It is required. |
447
|
|
|
|
|
|
|
|
448
|
|
|
|
|
|
|
=item URI |
449
|
|
|
|
|
|
|
|
450
|
|
|
|
|
|
|
The profile URI to request. Currently this only allows one URI. This |
451
|
|
|
|
|
|
|
is required. |
452
|
|
|
|
|
|
|
|
453
|
|
|
|
|
|
|
=item ServerName |
454
|
|
|
|
|
|
|
|
455
|
|
|
|
|
|
|
The "server name" to present to the server. Essentially this is the |
456
|
|
|
|
|
|
|
name the client thinks the server is. It is optional. |
457
|
|
|
|
|
|
|
|
458
|
|
|
|
|
|
|
=item StartData |
459
|
|
|
|
|
|
|
|
460
|
|
|
|
|
|
|
Data to piggyback with the start channel request. This is optional. |
461
|
|
|
|
|
|
|
|
462
|
|
|
|
|
|
|
=item Encoding |
463
|
|
|
|
|
|
|
|
464
|
|
|
|
|
|
|
Set this to true of the StartData value is base64 encoded. |
465
|
|
|
|
|
|
|
|
466
|
|
|
|
|
|
|
=back |
467
|
|
|
|
|
|
|
|
468
|
|
|
|
|
|
|
=cut |
469
|
|
|
|
|
|
|
|
470
|
|
|
|
|
|
|
sub start_channel_message { |
471
|
|
|
|
|
|
|
my $self = shift; |
472
|
|
|
|
|
|
|
my %args = @_; |
473
|
|
|
|
|
|
|
|
474
|
|
|
|
|
|
|
my ($number, $uri, $encoding, $servername, $data); |
475
|
|
|
|
|
|
|
# get the optional args |
476
|
|
|
|
|
|
|
for (keys %args) { |
477
|
|
|
|
|
|
|
my $val = $args{$_}; |
478
|
|
|
|
|
|
|
/^Channel$/i and do { |
479
|
|
|
|
|
|
|
$number = $val; |
480
|
|
|
|
|
|
|
next; |
481
|
|
|
|
|
|
|
}; |
482
|
|
|
|
|
|
|
/^URI/i and do { |
483
|
|
|
|
|
|
|
$uri = $val; |
484
|
|
|
|
|
|
|
next; |
485
|
|
|
|
|
|
|
}; |
486
|
|
|
|
|
|
|
/^encoding$/i and do { |
487
|
|
|
|
|
|
|
$encoding = $val; |
488
|
|
|
|
|
|
|
next; |
489
|
|
|
|
|
|
|
}; |
490
|
|
|
|
|
|
|
/^server.?name$/i and do { |
491
|
|
|
|
|
|
|
$servername = $val; |
492
|
|
|
|
|
|
|
next; |
493
|
|
|
|
|
|
|
}; |
494
|
|
|
|
|
|
|
/^start.?data$/i and do { |
495
|
|
|
|
|
|
|
$data = $val; |
496
|
|
|
|
|
|
|
next; |
497
|
|
|
|
|
|
|
}; |
498
|
|
|
|
|
|
|
} |
499
|
|
|
|
|
|
|
|
500
|
|
|
|
|
|
|
croak "start_channel_message(): missing required parameter 'Channel'\n" |
501
|
|
|
|
|
|
|
if not $number; |
502
|
|
|
|
|
|
|
croak "start_channel_message(): missing required parameter 'URI'\n" |
503
|
|
|
|
|
|
|
if not $uri; |
504
|
|
|
|
|
|
|
|
505
|
|
|
|
|
|
|
my $start_el = XML::LibXML::Element->new("start"); |
506
|
|
|
|
|
|
|
|
507
|
|
|
|
|
|
|
$start_el->setAttribute("number", $number); |
508
|
|
|
|
|
|
|
$start_el->setAttribute("serverName", $servername) if $servername; |
509
|
|
|
|
|
|
|
|
510
|
|
|
|
|
|
|
my $profile_el = XML::LibXML::Element->new("profile"); |
511
|
|
|
|
|
|
|
$profile_el->setAttribute('uri', $uri); |
512
|
|
|
|
|
|
|
$start_el->appendChild($profile_el); |
513
|
|
|
|
|
|
|
|
514
|
|
|
|
|
|
|
# FIXME: should be able to pass in a Node or string as data. |
515
|
|
|
|
|
|
|
if ($data) { |
516
|
|
|
|
|
|
|
if (!ref($data)) { |
517
|
|
|
|
|
|
|
my $cdata = XML::LibXML::CDATASection->new($data); |
518
|
|
|
|
|
|
|
$profile_el->appendChild($cdata); |
519
|
|
|
|
|
|
|
} elsif ($data->isa('XML::LibXML::CDATASection')) { |
520
|
|
|
|
|
|
|
$profile_el->appendChild($data); |
521
|
|
|
|
|
|
|
} |
522
|
|
|
|
|
|
|
$profile_el->setAttribute("encoding", "base64") if $encoding; |
523
|
|
|
|
|
|
|
} |
524
|
|
|
|
|
|
|
|
525
|
|
|
|
|
|
|
my $msg = $self->_new_mgmt_message(Type => 'MSG', |
526
|
|
|
|
|
|
|
Content => $start_el->toString()); |
527
|
|
|
|
|
|
|
$msg; |
528
|
|
|
|
|
|
|
} |
529
|
|
|
|
|
|
|
|
530
|
|
|
|
|
|
|
=item send_start_channel_message($session, I) |
531
|
|
|
|
|
|
|
|
532
|
|
|
|
|
|
|
In addition to the session, the parameters are the same as the named |
533
|
|
|
|
|
|
|
parameters for the C method. The 'Channel' |
534
|
|
|
|
|
|
|
parameter may (and usually is) omitted. This method returns the |
535
|
|
|
|
|
|
|
channel number requested, and the message itself |
536
|
|
|
|
|
|
|
|
537
|
|
|
|
|
|
|
=cut |
538
|
|
|
|
|
|
|
|
539
|
|
|
|
|
|
|
sub send_start_channel_message { |
540
|
|
|
|
|
|
|
my $self = shift; |
541
|
|
|
|
|
|
|
my $session = shift; |
542
|
|
|
|
|
|
|
my %args = @_; |
543
|
|
|
|
|
|
|
|
544
|
|
|
|
|
|
|
$args{Channel} = $session->_next_channel_number() |
545
|
|
|
|
|
|
|
if not $args{Channel}; |
546
|
|
|
|
|
|
|
|
547
|
|
|
|
|
|
|
$session->{starting_channel_number} = $args{Channel}; |
548
|
|
|
|
|
|
|
|
549
|
|
|
|
|
|
|
my $msg = $self->start_channel_message(%args); |
550
|
|
|
|
|
|
|
|
551
|
|
|
|
|
|
|
$session->send_message($msg); |
552
|
|
|
|
|
|
|
|
553
|
|
|
|
|
|
|
($args{Channel}, $msg); |
554
|
|
|
|
|
|
|
} |
555
|
|
|
|
|
|
|
|
556
|
|
|
|
|
|
|
=item close_channel_message($channel_number, [$code, $content, $lang]) |
557
|
|
|
|
|
|
|
|
558
|
|
|
|
|
|
|
This method will return a formatted "" message. $channel_number |
559
|
|
|
|
|
|
|
is required. $code will default to '200'. $content is optional. |
560
|
|
|
|
|
|
|
$lang is also optional, and is only meaningful if there is content. |
561
|
|
|
|
|
|
|
|
562
|
|
|
|
|
|
|
=cut |
563
|
|
|
|
|
|
|
|
564
|
|
|
|
|
|
|
sub close_channel_message { |
565
|
|
|
|
|
|
|
my $self = shift; |
566
|
|
|
|
|
|
|
my $chno = shift; |
567
|
|
|
|
|
|
|
my $code = shift || 200; |
568
|
|
|
|
|
|
|
my $content = shift; |
569
|
|
|
|
|
|
|
my $lang = shift; |
570
|
|
|
|
|
|
|
|
571
|
|
|
|
|
|
|
my $close_el = XML::LibXML::Element->new("close"); |
572
|
|
|
|
|
|
|
$close_el->setAttribute("number", $chno); |
573
|
|
|
|
|
|
|
$close_el->setAttribute("code", $code); |
574
|
|
|
|
|
|
|
$close_el->setAttribute("xml:lang", $lang) if $lang; |
575
|
|
|
|
|
|
|
$close_el->appendText($content) if $content; |
576
|
|
|
|
|
|
|
|
577
|
|
|
|
|
|
|
|
578
|
|
|
|
|
|
|
$self->_new_mgmt_message(Type => 'MSG', |
579
|
|
|
|
|
|
|
Content => $close_el->toString()); |
580
|
|
|
|
|
|
|
} |
581
|
|
|
|
|
|
|
|
582
|
|
|
|
|
|
|
=item send_close_channel_message($session, $channel_number, |
583
|
|
|
|
|
|
|
[$code, $content, $lang]) |
584
|
|
|
|
|
|
|
|
585
|
|
|
|
|
|
|
This method will format and send a "" message. Except for the |
586
|
|
|
|
|
|
|
addition of the $session parameter, the parameters are the same as |
587
|
|
|
|
|
|
|
C. |
588
|
|
|
|
|
|
|
|
589
|
|
|
|
|
|
|
=cut |
590
|
|
|
|
|
|
|
|
591
|
|
|
|
|
|
|
sub send_close_channel_message { |
592
|
|
|
|
|
|
|
my $self = shift; |
593
|
|
|
|
|
|
|
my $session = shift; |
594
|
|
|
|
|
|
|
my $chno = shift; |
595
|
|
|
|
|
|
|
|
596
|
|
|
|
|
|
|
my $msg = $self->close_channel_message($chno, @_); |
597
|
|
|
|
|
|
|
|
598
|
|
|
|
|
|
|
$session->{closing_channel_number} = $chno; |
599
|
|
|
|
|
|
|
|
600
|
|
|
|
|
|
|
$session->send_message($msg); |
601
|
|
|
|
|
|
|
|
602
|
|
|
|
|
|
|
$msg; |
603
|
|
|
|
|
|
|
} |
604
|
|
|
|
|
|
|
|
605
|
|
|
|
|
|
|
=item profile_message($uri, [$content, [$encoded]]) |
606
|
|
|
|
|
|
|
|
607
|
|
|
|
|
|
|
Generate a "" message content for $uri. If $content is |
608
|
|
|
|
|
|
|
provided, include it as text content contained within the |
609
|
|
|
|
|
|
|
element. If $encoded is set to true, set the 'encoding' attribute to |
610
|
|
|
|
|
|
|
'base64'. |
611
|
|
|
|
|
|
|
|
612
|
|
|
|
|
|
|
=cut |
613
|
|
|
|
|
|
|
|
614
|
|
|
|
|
|
|
sub profile_message { |
615
|
|
|
|
|
|
|
my $self = shift; |
616
|
|
|
|
|
|
|
my $msgno = shift; |
617
|
|
|
|
|
|
|
my $uri = shift; |
618
|
|
|
|
|
|
|
my $content = shift; |
619
|
|
|
|
|
|
|
my $encoded = shift; |
620
|
|
|
|
|
|
|
|
621
|
|
|
|
|
|
|
my $profile_el = XML::LibXML::Element->new("profile"); |
622
|
|
|
|
|
|
|
$profile_el->setAttribute("uri", $uri); |
623
|
|
|
|
|
|
|
|
624
|
|
|
|
|
|
|
if ($content) { |
625
|
|
|
|
|
|
|
if (!ref($content)) { |
626
|
|
|
|
|
|
|
$profile_el->appendText($content); |
627
|
|
|
|
|
|
|
} elsif ($content->isa('XML::LibXML::Node')) { |
628
|
|
|
|
|
|
|
$profile_el->appendChild($content); |
629
|
|
|
|
|
|
|
} |
630
|
|
|
|
|
|
|
} |
631
|
|
|
|
|
|
|
$self->_new_mgmt_message(Type => 'RPY', |
632
|
|
|
|
|
|
|
Msgno => $msgno, |
633
|
|
|
|
|
|
|
Content => $profile_el->toString()); |
634
|
|
|
|
|
|
|
} |
635
|
|
|
|
|
|
|
|
636
|
|
|
|
|
|
|
=item send_profile_message($session, $uri, [$content, [$encoded]]) |
637
|
|
|
|
|
|
|
|
638
|
|
|
|
|
|
|
Generate and send a "" message to the peer. Except for the |
639
|
|
|
|
|
|
|
$session paramter, the parameters are the same as for the |
640
|
|
|
|
|
|
|
C method. |
641
|
|
|
|
|
|
|
|
642
|
|
|
|
|
|
|
=cut |
643
|
|
|
|
|
|
|
|
644
|
|
|
|
|
|
|
sub send_profile_message { |
645
|
|
|
|
|
|
|
my $self = shift; |
646
|
|
|
|
|
|
|
my $session = shift; |
647
|
|
|
|
|
|
|
|
648
|
|
|
|
|
|
|
my $msg = $self->profile_message(@_); |
649
|
|
|
|
|
|
|
|
650
|
|
|
|
|
|
|
$session->send_message($msg); |
651
|
|
|
|
|
|
|
|
652
|
|
|
|
|
|
|
$msg; |
653
|
|
|
|
|
|
|
} |
654
|
|
|
|
|
|
|
|
655
|
|
|
|
|
|
|
|
656
|
|
|
|
|
|
|
# A convenience wrapper around the process of creating a new |
657
|
|
|
|
|
|
|
# management BEEP message. |
658
|
|
|
|
|
|
|
sub _new_mgmt_message { |
659
|
|
|
|
|
|
|
my $self = shift; |
660
|
|
|
|
|
|
|
my %args = @_; |
661
|
|
|
|
|
|
|
|
662
|
|
|
|
|
|
|
$args{Content_Type} = "application/beep+xml"; |
663
|
|
|
|
|
|
|
$args{Channel} = 0; |
664
|
|
|
|
|
|
|
|
665
|
|
|
|
|
|
|
Net::BEEP::Lite::Message->new(%args); |
666
|
|
|
|
|
|
|
} |
667
|
|
|
|
|
|
|
|
668
|
|
|
|
|
|
|
# create a new BEEP management error message. |
669
|
|
|
|
|
|
|
sub _error_message { |
670
|
|
|
|
|
|
|
my $self = shift; |
671
|
|
|
|
|
|
|
my $msgno = shift; |
672
|
|
|
|
|
|
|
my $code = shift; |
673
|
|
|
|
|
|
|
my $content = shift; |
674
|
|
|
|
|
|
|
|
675
|
|
|
|
|
|
|
my $error_el = XML::LibXML::Element->new("error"); |
676
|
|
|
|
|
|
|
$error_el->setAttribute("code", $code); |
677
|
|
|
|
|
|
|
$error_el->appendText($content) if $content; |
678
|
|
|
|
|
|
|
|
679
|
|
|
|
|
|
|
$self->_new_mgmt_message(Type => 'ERR', |
680
|
|
|
|
|
|
|
Msgno => $msgno, |
681
|
|
|
|
|
|
|
Content => $error_el->toString()); |
682
|
|
|
|
|
|
|
} |
683
|
|
|
|
|
|
|
|
684
|
|
|
|
|
|
|
=pod |
685
|
|
|
|
|
|
|
|
686
|
|
|
|
|
|
|
=back |
687
|
|
|
|
|
|
|
|
688
|
|
|
|
|
|
|
=head1 SEE ALSO |
689
|
|
|
|
|
|
|
|
690
|
|
|
|
|
|
|
L, L, and |
691
|
|
|
|
|
|
|
L |
692
|
|
|
|
|
|
|
|
693
|
|
|
|
|
|
|
=cut |
694
|
|
|
|
|
|
|
|
695
|
|
|
|
|
|
|
1; |