Net/IRC3/Connection.pm

package Net::IRC3::Connection;
use strict;
use AnyEvent;
use IO::Socket::INET;
use Net::IRC3 qw/mk_msg parse_irc_msg/;

=head1 NAME

Net::IRC3::Connection - An IRC connection abstraction

=head1 SYNOPSIS

   #...
   $con->send_msg (undef, "PRIVMSG", "Hello there!", "yournick");
   #...

=head1 DESCRIPTION

The connection class. Here the actual interesting stuff can be done,
such as sending and receiving IRC messages.

=head2 METHODS

=over 4

=cut

package Net::IRC3::Connection;

use strict;
use AnyEvent;
use IO::Socket::INET;
use Net::IRC3 qw/parse_irc_msg mk_msg/;

sub new
{
  my $this = shift;
  my $class = ref($this) || $this;

  my $self = {
     pirc => $_[0],
     s => $_[1],
     h => $_[2],
     p => $_[3],
     cbs => {},
     heap => {}
  };

  bless $self, $class;

  return $self;
}

=item B<disconnect_server ($reason)>

Unregisters the connection in the main Net::IRC3 object, closes
the sockets and send a 'disconnect' event with C<$reason> as argument.

=cut

sub disconnect_server {
   my ($self, $reason) = @_;

   $self->event (disconnect => $reason);

   delete $self->{rw};
   delete $self->{ww};
   delete $self->{pirc}->{connections}->{$self->{h} . ":" . $self->{p}};

   eval { $self->{s}->close }
}

=item B<heap ()>

Returns a hash reference that is local to this connection object
that lets you store any information you want.

=cut

sub heap {
   my ($self) = @_;
   return $self->{heap};
}

=item B<send_msg (@ircmsg)>

This function sends a message to the server. C<@ircmsg> is the argumentlist
for C<mk_msg>.

=cut

sub send_msg {
   my ($self, @msg) = @_;
   my $data = mk_msg (@msg);

   my ($host, $port) = ($self->{h}, $self->{p});
   $self->{outbuf} .= $data;

   unless (defined $self->{ww}) {
      my $sock = $self->{s};
      $self->{ww} =
         AnyEvent->io (poll => 'w', fh => $sock, cb => sub {
            my $l = syswrite $sock, $self->{outbuf};

            substr $self->{outbuf}, 0, $l, "";

            if (length ($self->{outbuf}) == 0) { delete $self->{ww} }

            unless ($l) {
               # XXX: is this behaviour correct or ok?
               $self->disconnect_server ("Error while writing to IRC server '$host:$port': $!");
               return;
            }
         });
   }
}

=item B<reg_cb ($cmd, $cb)>

This registers a callback in the connection class.
These callbacks will be called by internal events and
by IRC protocol commands.

The first argument to the callbacks is always the connection object
itself.

If a callback returns a false value, it will be unregistered.

NOTE: I<A callback has to return true to stay alive>

If C<$cmd> starts with 'irc_' the callback C<$cb> will be registered
for a IRC protocol command. The command is the suffix of C<$cmd> then.
The second argument to the callback is the message hash reference
that has the layout that is returned by C<parse_irc_msg>.

With the special C<$cmd> 'irc_*' the callback will be called on I<any>
IRC command that is received.

EXAMPLE:

   $con->reg_cb (irc_privmsg => \&privmsg_handler);
   # privmsg_handler will be called if an IRC message
   # with the command 'PRIVMSG' arrives.

If C<$cmd> is not prefixed with a 'irc_' it will be called when an event
with the name C<$cmd> is emitted. The arguments to the callback depend
on the event that is emitted (but remember: the first argument will always be the
connection object)

Following events are emitted by this module and shouldn't be emitted
from a module user call to C<event>.

=over 4

=item B<disconnect $reason>

This event will be generated if the connection is somehow terminated.
It will also be emitted when C<disconnect_server> is called.
The second argument to the callback is C<$reason>, a string that contains
a clue about why the connection terminated.

=back

=cut

sub reg_cb {
   my ($self, $cmd, $cb) = @_;

   if ($cmd =~ m/^irc_(\S+)/i) {
      push @{$self->{cbs}->{lc $1}}, $cb;

   } else {
      push @{$self->{events}->{$cmd}}, $cb;
   }

   1;
}

=item B<event ($event, @args)>

This function emits an event with the name C<$event> and the arguments C<@args>.
The registerd callback that has been registered with C<reg_cb> will be called
with the first argument being the connection object and the rest of the arguments
being C<@args>.

EXAMPLE

   $con->reg_cb (test_event => sub { print "Yay, i love $_[1]!!\n");
   $con->event (test_event => "IRC");

   # will print "Yay, i love IRC!!\n"

=cut

sub event {
   my ($self, $ev, @arg) = @_;

   my $nxt = [];

   for (@{$self->{events}->{lc $ev}}) {
      $_->($self, @arg) and push @$nxt, $_;
   }

   $self->{events}->{lc $ev} = $nxt;
}

# internal function, called by the read callbacks above.
sub feed_irc_data {
   my ($self, $data) = @_;

   $self->{buffer} .= $data;

   my @msg;
   while ($self->{buffer} =~ s/^([^\015\012]*)\015?\012//) {
      push @msg, $1;
   }

   for (@msg) {
      my $m = parse_irc_msg ($_);

      my $nxt = [];

      for (@{$self->{cbs}->{lc $m->{command}}}) {
         $_->($self, $m) and push @$nxt, $_;
      }

      $self->{cbs}->{lc $m->{command}} = $nxt;

      $nxt = [];

      for (@{$self->{cbs}->{'*'}}) {
         $_->($self, $m) and push @$nxt, $_;
      }

      $self->{cbs}->{'*'} = $nxt;
   }
}


=back

=head1 AUTHOR

Robin Redeker, C<< <elmex@ta-sa.org> >>

=head1 SEE ALSO

L<Net::IRC3>

=head1 COPYRIGHT & LICENSE

Copyright 2006 Robin Redker, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

1;
Revision:	1.1
Committed:	Sun Jul 16 02:41:37 2006 UTC (20 years, 3 months ago) by elmex
Branch:	MAIN
Log Message:	some major change on the module layout
#	User	Rev	Content
1	elmex	1.1	package Net::IRC3::Connection;
2			use strict;
3			use AnyEvent;
4			use IO::Socket::INET;
5			use Net::IRC3 qw/mk_msg parse_irc_msg/;
6
7			=head1 NAME
8
9			Net::IRC3::Connection - An IRC connection abstraction
10
11			=head1 SYNOPSIS
12
13			#...
14			$con->send_msg (undef, "PRIVMSG", "Hello there!", "yournick");
15			#...
16
17			=head1 DESCRIPTION
18
19			The connection class. Here the actual interesting stuff can be done,
20			such as sending and receiving IRC messages.
21
22			=head2 METHODS
23
24			=over 4
25
26			=cut
27
28			package Net::IRC3::Connection;
29
30			use strict;
31			use AnyEvent;
32			use IO::Socket::INET;
33			use Net::IRC3 qw/parse_irc_msg mk_msg/;
34
35			sub new
36			{
37			my $this = shift;
38			my $class = ref($this) \|\| $this;
39
40			my $self = {
41			pirc => $_[0],
42			s => $_[1],
43			h => $_[2],
44			p => $_[3],
45			cbs => {},
46			heap => {}
47			};
48
49			bless $self, $class;
50
51			return $self;
52			}
53
54			=item B<disconnect_server ($reason)>
55
56			Unregisters the connection in the main Net::IRC3 object, closes
57			the sockets and send a 'disconnect' event with C<$reason> as argument.
58
59			=cut
60
61			sub disconnect_server {
62			my ($self, $reason) = @_;
63
64			$self->event (disconnect => $reason);
65
66			delete $self->{rw};
67			delete $self->{ww};
68			delete $self->{pirc}->{connections}->{$self->{h} . ":" . $self->{p}};
69
70			eval { $self->{s}->close }
71			}
72
73			=item B<heap ()>
74
75			Returns a hash reference that is local to this connection object
76			that lets you store any information you want.
77
78			=cut
79
80			sub heap {
81			my ($self) = @_;
82			return $self->{heap};
83			}
84
85			=item B<send_msg (@ircmsg)>
86
87			This function sends a message to the server. C<@ircmsg> is the argumentlist
88			for C<mk_msg>.
89
90			=cut
91
92			sub send_msg {
93			my ($self, @msg) = @_;
94			my $data = mk_msg (@msg);
95
96			my ($host, $port) = ($self->{h}, $self->{p});
97			$self->{outbuf} .= $data;
98
99			unless (defined $self->{ww}) {
100			my $sock = $self->{s};
101			$self->{ww} =
102			AnyEvent->io (poll => 'w', fh => $sock, cb => sub {
103			my $l = syswrite $sock, $self->{outbuf};
104
105			substr $self->{outbuf}, 0, $l, "";
106
107			if (length ($self->{outbuf}) == 0) { delete $self->{ww} }
108
109			unless ($l) {
110			# XXX: is this behaviour correct or ok?
111			$self->disconnect_server ("Error while writing to IRC server '$host:$port': $!");
112			return;
113			}
114			});
115			}
116			}
117
118			=item B<reg_cb ($cmd, $cb)>
119
120			This registers a callback in the connection class.
121			These callbacks will be called by internal events and
122			by IRC protocol commands.
123
124			The first argument to the callbacks is always the connection object
125			itself.
126
127			If a callback returns a false value, it will be unregistered.
128
129			NOTE: I<A callback has to return true to stay alive>
130
131			If C<$cmd> starts with 'irc_' the callback C<$cb> will be registered
132			for a IRC protocol command. The command is the suffix of C<$cmd> then.
133			The second argument to the callback is the message hash reference
134			that has the layout that is returned by C<parse_irc_msg>.
135
136			With the special C<$cmd> 'irc_*' the callback will be called on I<any>
137			IRC command that is received.
138
139			EXAMPLE:
140
141			$con->reg_cb (irc_privmsg => \&privmsg_handler);
142			# privmsg_handler will be called if an IRC message
143			# with the command 'PRIVMSG' arrives.
144
145			If C<$cmd> is not prefixed with a 'irc_' it will be called when an event
146			with the name C<$cmd> is emitted. The arguments to the callback depend
147			on the event that is emitted (but remember: the first argument will always be the
148			connection object)
149
150			Following events are emitted by this module and shouldn't be emitted
151			from a module user call to C<event>.
152
153			=over 4
154
155			=item B<disconnect $reason>
156
157			This event will be generated if the connection is somehow terminated.
158			It will also be emitted when C<disconnect_server> is called.
159			The second argument to the callback is C<$reason>, a string that contains
160			a clue about why the connection terminated.
161
162			=back
163
164			=cut
165
166			sub reg_cb {
167			my ($self, $cmd, $cb) = @_;
168
169			if ($cmd =~ m/^irc_(\S+)/i) {
170			push @{$self->{cbs}->{lc $1}}, $cb;
171
172			} else {
173			push @{$self->{events}->{$cmd}}, $cb;
174			}
175
176			1;
177			}
178
179			=item B<event ($event, @args)>
180
181			This function emits an event with the name C<$event> and the arguments C<@args>.
182			The registerd callback that has been registered with C<reg_cb> will be called
183			with the first argument being the connection object and the rest of the arguments
184			being C<@args>.
185
186			EXAMPLE
187
188			$con->reg_cb (test_event => sub { print "Yay, i love $_[1]!!\n");
189			$con->event (test_event => "IRC");
190
191			# will print "Yay, i love IRC!!\n"
192
193			=cut
194
195			sub event {
196			my ($self, $ev, @arg) = @_;
197
198			my $nxt = [];
199
200			for (@{$self->{events}->{lc $ev}}) {
201			$_->($self, @arg) and push @$nxt, $_;
202			}
203
204			$self->{events}->{lc $ev} = $nxt;
205			}
206
207			# internal function, called by the read callbacks above.
208			sub feed_irc_data {
209			my ($self, $data) = @_;
210
211			$self->{buffer} .= $data;
212
213			my @msg;
214			while ($self->{buffer} =~ s/^([^\015\012]*)\015?\012//) {
215			push @msg, $1;
216			}
217
218			for (@msg) {
219			my $m = parse_irc_msg ($_);
220
221			my $nxt = [];
222
223			for (@{$self->{cbs}->{lc $m->{command}}}) {
224			$_->($self, $m) and push @$nxt, $_;
225			}
226
227			$self->{cbs}->{lc $m->{command}} = $nxt;
228
229			$nxt = [];
230
231			for (@{$self->{cbs}->{'*'}}) {
232			$_->($self, $m) and push @$nxt, $_;
233			}
234
235			$self->{cbs}->{'*'} = $nxt;
236			}
237			}
238
239
240			=back
241
242			=head1 AUTHOR
243
244			Robin Redeker, C<< <elmex@ta-sa.org> >>
245
246			=head1 SEE ALSO
247
248			L<Net::IRC3>
249
250			=head1 COPYRIGHT & LICENSE
251
252			Copyright 2006 Robin Redker, all rights reserved.
253
254			This program is free software; you can redistribute it and/or modify it
255			under the same terms as Perl itself.
256
257			=cut
258
259			1;