source: perl/lib/Net/Jabber/Server.pm @ cb54527

barnowl_perlaimdebianrelease-1.4release-1.5release-1.6release-1.7release-1.8release-1.9
Last change on this file since cb54527 was cb54527, checked in by Nelson Elhage <nelhage@mit.edu>, 14 years ago
Getting rid of indirect object syntax new calls. Quoting perlobj: > But what if there are no arguments? In that case, Perl must guess what > you want. Even worse, it must make that guess *at compile time*. Usually > Perl gets it right, but when it doesn't you get a function call compiled > as a method, or vice versa. This can introduce subtle bugs that are hard > to detect. > > For example, a call to a method "new" in indirect notation -- as C++ > programmers are wont to make -- can be miscompiled into a subroutine > call if there's already a "new" function in scope. You'd end up calling > the current package's "new" as a subroutine, rather than the desired > class's method. The compiler tries to cheat by remembering bareword > "require"s, but the grief when it messes up just isn't worth the years > of debugging it will take you to track down such subtle bugs.
  • Property mode set to 100644
File size: 12.1 KB
Line 
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#  Jabber
19#  Copyright (C) 1998-1999 The Jabber Team http://jabber.org/
20#
21##############################################################################
22
23package Net::Jabber::Server;
24
25=head1 NAME
26
27Net::Jabber::Server - Jabber Server Library
28
29=head1 SYNOPSIS
30
31  Net::Jabber::Server is a module that provides a developer easy access
32  to developing applications that need an embedded Jabber server.
33
34=head1 DESCRIPTION
35
36  Server.pm seeks to provide enough high level APIs and automation of
37  the low level APIs that writing and spawning a Jabber Server in Perl
38  is trivial.  For those that wish to work with the low level you can
39  do that too, but those functions are covered in the documentation for
40  each module.
41
42  Net::Jabber::Server provides functions to run a full Jabber server that
43  accepts incoming connections and delivers packets to external Jabber
44  servers.  You can use all or none of the functions, there is no requirement.
45
46  For more information on how the details for how Net::Jabber is written
47  please see the help for Net::Jabber itself.
48
49  For a full list of high level functions available please see
50  Net::Jabber::Protocol.
51
52=head2 Basic Functions
53
54    use Net::Jabber qw(Server);
55
56    $Server = Net::Jabber::Server->new();
57
58    $Server->Start();
59    $Server->Start(jabberxml=>"custom_jabber.xml",
60                   hostname=>"foobar.net");
61
62    %status = $Server->Process();
63    %status = $Server->Process(5);
64   
65    $Server->Stop();
66
67=head1 METHODS
68
69=head2 Basic Functions
70
71    new(debuglevel=>0|1|2, - creates the Server object.  debugfile
72        debugfile=>string,   should be set to the path for the debug
73        debugtime=>0|1)      log to be written.  If set to "stdout"
74                             then the debug will go there.  debuglevel
75                             controls the amount of debug.  For more
76                             information about the valid setting for
77                             debuglevel, debugfile, and debugtime see
78                             Net::Jabber::Debug.
79
80    Start(hostname=>string, - starts the server listening on the proper
81          jaberxml=>string)   ports.  hostname is a quick way of telling
82                              the server the hostname to listen on.
83                              jabberxml defines the path to a different
84                              jabberd configuration file (default is
85                              "./jabber.xml").
86
87    Process(integer) - takes the timeout period as an argument.  If no
88                       timeout is listed then the function blocks until
89                       a packet is received.  Otherwise it waits that
90                       number of seconds and then exits so your program
91                       can continue doing useful things.  NOTE: This is
92                       important for GUIs.  You need to leave time to
93                       process GUI commands even if you are waiting for
94                       packets.  The following are the possible return
95                       values for each hash entry, and what they mean:
96
97                           1   - Status ok, data received.
98                           0   - Status ok, no data received.
99                         undef - Status not ok, stop processing.
100                       
101                       IMPORTANT: You need to check the output of every
102                       Process.  If you get an undef then the connection
103                       died and you should behave accordingly.
104
105    Stop() - stops the server from running and shuts down all sub programs.
106
107=head1 AUTHOR
108
109By Ryan Eatmon in January of 2001 for http://jabber.org.
110
111=head1 COPYRIGHT
112
113This module is free software; you can redistribute it and/or modify
114it under the same terms as Perl itself.
115
116=cut
117
118use strict;
119use Carp;
120use base qw( Net::Jabber::Protocol );
121use vars qw( $VERSION );
122
123$VERSION = "2.0";
124
125use Net::Jabber::Data;
126($Net::Jabber::Data::VERSION < $VERSION) &&
127  die("Net::Jabber::Data $VERSION required--this is only version $Net::Jabber::Data::VERSION");
128
129use Net::Jabber::XDB;
130($Net::Jabber::XDB::VERSION < $VERSION) &&
131  die("Net::Jabber::XDB $VERSION required--this is only version $Net::Jabber::XDB::VERSION");
132
133#use Net::Jabber::Log;
134#($Net::Jabber::Log::VERSION < $VERSION) &&
135#  die("Net::Jabber::Log $VERSION required--this is only version $Net::Jabber::Log::VERSION");
136
137use Net::Jabber::Dialback;
138($Net::Jabber::Dialback::VERSION < $VERSION) &&
139  die("Net::Jabber::Dialback $VERSION required--this is only version $Net::Jabber::Dialback::VERSION");
140
141use Net::Jabber::Key;
142($Net::Jabber::Key::VERSION < $VERSION) &&
143  die("Net::Jabber::Key $VERSION required--this is only version $Net::Jabber::Key::VERSION");
144
145sub new
146{
147    srand( time() ^ ($$ + ($$ << 15)));
148
149    my $proto = shift;
150    my $self = { };
151
152    my %args;
153    while($#_ >= 0) { $args{ lc(pop(@_)) } = pop(@_); }
154
155    bless($self, $proto);
156
157    $self->{KEY} = Net::Jabber::Key->new();
158
159    $self->{DEBUG} =
160        Net::Jabber::Debug->new(level=>exists($args{debuglevel}) ? $args{debuglevel} : -1,
161                                file=>exists($args{debugfile}) ? $args{debugfile} : "stdout",
162                                time=>exists($args{debugtime}) ? $args{debugtime} : 0,
163                                setdefault=>1,
164                                header=>"NJ::Server"
165                               );
166
167    $self->{SERVER} = { hostname => "localhost",
168                        port => 5269,
169                        servername => ""};
170
171    $self->{STREAM} = new XML::Stream(style=>"node",
172                                      debugfh=>$self->{DEBUG}->GetHandle(),
173                                      debuglevel=>$self->{DEBUG}->GetLevel(),
174                                      debugtime=>$self->{DEBUG}->GetTime());
175
176    $self->{STREAM}->SetCallBacks(node=>sub{ $self->CallBack(@_) },
177                                  sid=>sub{ return $self->{KEY}->Generate()});
178
179    $self->{VERSION} = $VERSION;
180
181    return $self;
182}
183
184
185##############################################################################
186#
187# Start - starts the server running
188#
189##############################################################################
190sub Start
191{
192    my $self = shift;
193    my %args;
194    while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
195
196    $self->{STOP} = 0;
197
198    $self->SetCallBacks('message'=>sub{ $self->messageHandler(@_); },
199                        'presence'=>sub{ $self->presenceHandler(@_); },
200                        'iq'=>sub{ $self->iqHandler(@_); },
201                        'db:result'=>sub{ $self->dbresultHandler(@_); },
202                        'db:verify'=>sub{ $self->dbverifyHandler(@_); },
203                       );
204
205    my $hostname = $self->{SERVER}->{hostname};
206    $hostname = $args{hostname} if exists($args{hostname});
207
208    my $status = $self->{STREAM}->Listen(hostname=>$hostname,
209                         port=>$self->{SERVER}->{port},
210                         namespace=>"jabber:server");
211
212    while($self->{STOP} == 0) {
213        while(($self->{STOP} == 0) && defined($self->{STREAM}->Process())) {
214        }
215    }
216}
217
218
219###############################################################################
220#
221#  Process - If a timeout value is specified then the function will wait
222#            that long before returning.  This is useful for apps that
223#            need to handle other processing while still waiting for
224#            packets.  If no timeout is listed then the function waits
225#            until a packet is returned.  Either way the function exits
226#            as soon as a packet is returned.
227#
228###############################################################################
229sub Process
230{
231    my $self = shift;
232    my ($timeout) = @_;
233    my %status;
234
235    if (exists($self->{PROCESSERROR}) && ($self->{PROCESSERROR} == 1))
236    {
237        croak("You should always check the output of the Process call.  If it was undef\nthen there was a fatal error that you need to check.  There is an error in your\nprogram.");
238    }
239
240    $self->{DEBUG}->Log1("Process: timeout($timeout)") if defined($timeout);
241
242    if (!defined($timeout) || ($timeout eq ""))
243    {
244        while(1)
245        {
246            %status = $self->{STREAM}->Process();
247            $self->{DEBUG}->Log1("Process: status($status{$self->{SESSION}->{id}})");
248            last if ($status{$self->{SESSION}->{id}} != 0);
249            select(undef,undef,undef,.25);
250        }
251        $self->{DEBUG}->Log1("Process: return($status{$self->{SESSION}->{id}})");
252        if ($status{$self->{SESSION}->{id}} == -1)
253        {
254            $self->{PROCESSERROR} = 1;
255            return;
256        }
257        else
258        {
259            return $status{$self->{SESSION}->{id}};
260        }
261    }
262    else
263    {
264        %status = $self->{STREAM}->Process($timeout);
265        if ($status{$self->{SESSION}->{id}} == -1)
266        {
267            $self->{PROCESSERROR} = 1;
268            return;
269        }
270        else
271        {
272            return $status{$self->{SESSION}->{id}};
273        }
274    }
275}
276
277
278##############################################################################
279#
280# Stop - shuts down the server
281#
282##############################################################################
283sub Stop
284{
285    my $self = shift;
286    $self->{STOP} = 1;
287}
288
289
290sub messageHandler
291{
292    my $self = shift;
293    my $sid = shift;
294    my ($message) = @_;
295
296    $self->{DEBUG}->Log2("messageHandler: message(",$message->GetXML(),")");
297
298    my $reply = $message->Reply();
299    $self->Send($reply);
300}
301
302
303sub presenceHandler
304{
305    my $self = shift;
306    my $sid = shift;
307    my ($presence) = @_;
308
309    $self->{DEBUG}->Log2("presenceHandler: presence(",$presence->GetXML(),")");
310}
311
312
313sub iqHandler
314{
315    my $self = shift;
316    my $sid = shift;
317    my ($iq) = @_;
318
319    $self->{DEBUG}->Log2("iqHandler: iq(",$iq->GetXML(),")");
320}
321
322
323sub dbresultHandler
324{
325    my $self = shift;
326    my $sid = shift;
327    my ($dbresult) = @_;
328
329    $self->{DEBUG}->Log2("dbresultHandler: dbresult(",$dbresult->GetXML(),")");
330
331    my $dbverify = Net::Jabber::Dialback::Verify->new();
332    $dbverify->SetVerify(to=>$dbresult->GetFrom(),
333                         from=>$dbresult->GetTo(),
334                         id=>$self->{STREAM}->GetRoot($sid)->{id},
335                         data=>$dbresult->GetData());
336    $self->Send($dbverify);
337}
338
339
340sub dbverifyHandler
341{
342    my $self = shift;
343    my $sid = shift;
344    my ($dbverify) = @_;
345
346    $self->{DEBUG}->Log2("dbverifyHandler: dbverify(",$dbverify->GetXML(),")");
347}
348
349
350sub Send
351{
352    my $self = shift;
353    my $object = shift;
354
355    if (ref($object) eq "")
356    {
357        my ($server) = ($object =~ /to=[\"\']([^\"\']+)[\"\']/);
358        $server =~ s/^\S*\@?(\S+)\/?.*$/$1/;
359        $self->SendXML($server,$object);
360    }
361    else
362    {
363        $self->SendXML($object->GetTo("jid")->GetServer(),$object->GetXML());
364    }
365 }
366
367
368sub SendXML {
369    my $self = shift;
370    my $server = shift;
371    my $xml = shift;
372    $self->{DEBUG}->Log1("SendXML: server($server) sent($xml)");
373
374    my $sid = $self->{STREAM}->Host2SID($server);
375    if (!defined($sid)) {
376        $self->{STREAM}->Connect(hostname=>$server,
377                     port=>5269,
378                     connectiontype=>"tcpip",
379                     namespace=>"jabber:server");
380        $sid = $self->{STREAM}->Host2SID($server);
381    }
382    $self->{DEBUG}->Log1("SendXML: sid($sid)");
383    &{$self->{CB}->{send}}($sid,$xml) if exists($self->{CB}->{send});
384    $self->{STREAM}->Send($sid,$xml);
385}
386
387
388#
389# by not send xmlns:db='jabber:server:dialback' to a server, we operate in
390# legacy mode, and do not have to do dialback.
391#
392
3931;
Note: See TracBrowser for help on using the repository browser.