1 | =pod |
---|
2 | |
---|
3 | Net::OSCAR::Connection::Server -- Net::OSCAR server connection |
---|
4 | |
---|
5 | =cut |
---|
6 | |
---|
7 | package Net::OSCAR::Connection::Server; |
---|
8 | |
---|
9 | $VERSION = '1.925'; |
---|
10 | $REVISION = '$Revision: 1.5 $'; |
---|
11 | @ISA = qw(Net::OSCAR::Connection); |
---|
12 | |
---|
13 | use strict; |
---|
14 | use vars qw($VERSION @ISA); |
---|
15 | use Carp; |
---|
16 | use Socket; |
---|
17 | use Symbol; |
---|
18 | |
---|
19 | use Net::OSCAR::Common qw(:all); |
---|
20 | use Net::OSCAR::Constants; |
---|
21 | use Net::OSCAR::Connection; |
---|
22 | use Net::OSCAR::ServerCallbacks; |
---|
23 | |
---|
24 | sub new($@) { |
---|
25 | my $class = shift; |
---|
26 | my $self = $class->SUPER::new(@_); |
---|
27 | $self->listen($self->{session}->{port}) unless exists($self->{socket}); |
---|
28 | |
---|
29 | $self->{oscar_state} = "listening"; |
---|
30 | $self->{signon_done} = 0; |
---|
31 | |
---|
32 | return $self; |
---|
33 | } |
---|
34 | |
---|
35 | sub process_one($;$$$) { |
---|
36 | my($self, $read, $write, $error) = @_; |
---|
37 | my $snac; |
---|
38 | |
---|
39 | if($error) { |
---|
40 | $self->{sockerr} = 1; |
---|
41 | return $self->disconnect(); |
---|
42 | } |
---|
43 | |
---|
44 | if($write && $self->{outbuff}) { |
---|
45 | $self->log_print(OSCAR_DBG_DEBUG, "Flushing output buffer."); |
---|
46 | $self->flap_put(); |
---|
47 | } |
---|
48 | |
---|
49 | if($read && !$self->{connected}) { |
---|
50 | $self->log_print(OSCAR_DBG_NOTICE, "Incoming connection."); |
---|
51 | |
---|
52 | my $socket = gensym(); |
---|
53 | accept($socket, $self->{socket}); |
---|
54 | my $peer = $self->{session}->addconn(socket => $socket, conntype => CONNTYPE_SERVER, description => "new peer"); |
---|
55 | |
---|
56 | $peer->set_blocking(0); |
---|
57 | $peer->{connected} = 1; |
---|
58 | $peer->{state} = "write"; |
---|
59 | $peer->{oscar_state} = "new"; |
---|
60 | $self->{session}->callback_connection_changed($peer, "write"); |
---|
61 | return 1; |
---|
62 | } elsif($write and $self->{oscar_state} eq "new") { |
---|
63 | $self->log_print(OSCAR_DBG_DEBUG, "Putting connack."); |
---|
64 | $self->flap_put(pack("N", 1), FLAP_CHAN_NEWCONN); |
---|
65 | $self->{state} = "readwrite"; |
---|
66 | $self->{session}->callback_connection_changed($self, "readwrite"); |
---|
67 | $self->{oscar_state} = "ready"; |
---|
68 | |
---|
69 | $self->{families} = {}; |
---|
70 | $self->{families}->{$_} = 1 foreach (1..30); |
---|
71 | } elsif($read) { |
---|
72 | my $no_reread = 0; |
---|
73 | |
---|
74 | while(1) { |
---|
75 | my $flap = $self->flap_get($no_reread) or return 0; |
---|
76 | next if length($flap) == 4; |
---|
77 | my $snac = $self->snac_decode($flap) or return 0; |
---|
78 | Net::OSCAR::ServerCallbacks::process_snac($self, $snac); |
---|
79 | } continue { |
---|
80 | $no_reread = 1; |
---|
81 | } |
---|
82 | } |
---|
83 | } |
---|
84 | |
---|
85 | 1; |
---|