Net/IRC3/Connection.pm

package Net::IRC3::Connection;
use strict;
use AnyEvent;
use POSIX;
use IO::Socket::INET;
use IO::Handle;
use Net::IRC3::Util qw/mk_msg parse_irc_msg/;
use Devel::FindRef;

=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

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

  my $self = {
     cbs  => {},
     heap => {}
  };

  bless $self, $class;

  return $self;
}

=item B<connect ($host, $port)>

Tries to open a socket to the host C<$host> and the port C<$port>.
If an error occured it will die (use eval to catch the exception).

=cut

sub connect {
   my ($self, $host, $port) = @_;

   $self->{socket}
      and return;

   my $sock = IO::Socket::INET->new (
      PeerAddr => $host,
      PeerPort => $port,
      Proto    => 'tcp',
      Blocking => 0
   ) or die "couldn't connect to irc server '$host:$port': $!\n";;

   $self->{socket} = $sock;
   $self->{host}   = $host;
   $self->{port}   = $port;

   $self->{cw} =
      AnyEvent->io (poll => 'w', fh => $self->{socket}, cb => sub {
         my ($w) = @_;
         # FIXME: handle EAGAIN ?
         delete $self->{cw};

         if ($! = $sock->sockopt (SO_ERROR)) {
            $self->event ('connect_error' => $!);
         } else {
            $self->{connected} = 1;
            $self->event ('connect');
            $self->start_reader;
            $self->start_writer;
         }
         0
      });
   1
}

sub start_reader {
   my ($self) = @_;
   my ($host, $port) = ($self->{host}, $self->{port});

   return if $self->{rw};
   return unless $self->{socket};

   $self->{rw} =
      AnyEvent->io (poll => 'r', fh => $self->{socket}, cb => sub {
         my $data;
         my $l = $self->{socket}->sysread ($data, 1024);

         # FIXME: handle EAGAIN
         if (defined $l) {
            if ($l == 0) {
               $self->disconnect ("EOF from IRC server '$host:$port'");
               return
            } else {
               $self->feed_irc_data ($data);
            }

         } else {
            if ($! == EAGAIN()) {
               return;

            } else {
               $self->disconnect ("Error while reading from IRC server '$host:$port': $!");
               return;
            }
         }
      });
}


sub start_writer {
   my ($self) = @_;

   return unless $self->{socket} && $self->{connected} && length ($self->{outbuf}) > 0;

   my ($host, $port) = ($self->{host}, $self->{port});

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

            if (defined $l) {
               substr $self->{outbuf}, 0, $l, "";
               if (length ($self->{outbuf}) == 0) { delete $self->{ww} }

            } else {
               if ($! == EAGAIN()) {

                  return;
               } else {
                  $self->disconnect ("Error while writing to IRC server '$self->{host}:$self->{port}': $!");
                  return;
               }
            }
         });
   }
}

=item B<disconnect ($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 {
   my ($self, $reason) = @_;

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

   delete $self->{connected};

   delete $self->{rw};
   delete $self->{ww};
   delete $self->{cw};

   delete $self->{socket};
}

=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_raw ($ircline)>

This method sends C<$ircline> straight to the server without any
further processing done.

=cut

sub send_raw {
   my ($self, $ircline) = @_;
   $self->_send_raw ("$ircline\015\012");
}

sub _send_raw {
   my ($self, $data) = @_;

   $self->{outbuf} .= $data;
   $self->start_writer;
}

=item B<send_msg (@ircmsg)>

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

=cut

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

   $self->event (sent => @msg);
   $self->_send_raw (mk_msg (@msg));
}

=item B<reg_cb ($cmd, $cb)> or B<reg_cb ($cmd1, $cb1, $cmd2, $cb2, ..., $cmdN, $cbN)>

This registers a callback in the connection class.
These callbacks will be called by internal events and
by IRC protocol commands. You can also specify multiple callback registrations.

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<Net::IRC3::Util::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<connect>

This event is generated when the socket was successfully connected.

=item B<connect_error $error>

This event is generated when the socket couldn't be connected successfully.

=item B<disconnect $reason>

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

If you want to reestablish a connection, call C<connect> again.

=item B<sent @ircmsg>

Emitted when a message (C<@ircmsg>) was sent to the server.
C<@ircmsg> are the arguments to C<Net::IRC3::Util::mk_msg>.

=item B<'*' $msg>
=item B<read $msg>

Emitted when a message (C<$msg>) was read from the server.
C<$msg> is the hash reference returned by C<Net::IRC3::Util::parse_irc_msg>;

=back

=cut

sub reg_cb {
   my ($self, %regs) = @_;

   for my $cmd (keys %regs) {
      my $cb = $regs{$cmd};

      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 ($_);

      $self->event (read => $m);

      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>

L<Net::IRC3::Client::Connection>

=head1 COPYRIGHT & LICENSE

Copyright 2006 Robin Redeker, 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.11
Committed:	Sat Feb 17 23:42:00 2007 UTC (19 years, 8 months ago) by elmex
Branch:	MAIN
Changes since 1.10:	+17 -5 lines
Log Message:	disconnect now also does send channel_add/remove events
#	User	Rev	Content
1	elmex	1.1	package Net::IRC3::Connection;
2			use strict;
3			use AnyEvent;
4	elmex	1.10	use POSIX;
5	elmex	1.1	use IO::Socket::INET;
6	elmex	1.11	use IO::Handle;
7	elmex	1.4	use Net::IRC3::Util qw/mk_msg parse_irc_msg/;
8	elmex	1.11	use Devel::FindRef;
9	elmex	1.1
10			=head1 NAME
11
12			Net::IRC3::Connection - An IRC connection abstraction
13
14			=head1 SYNOPSIS
15
16			#...
17			$con->send_msg (undef, "PRIVMSG", "Hello there!", "yournick");
18			#...
19
20			=head1 DESCRIPTION
21
22			The connection class. Here the actual interesting stuff can be done,
23			such as sending and receiving IRC messages.
24
25			=head2 METHODS
26
27			=over 4
28
29			=cut
30
31			sub new
32			{
33			my $this = shift;
34			my $class = ref($this) \|\| $this;
35
36			my $self = {
37	elmex	1.5	cbs => {},
38	elmex	1.1	heap => {}
39			};
40
41			bless $self, $class;
42
43			return $self;
44			}
45
46	elmex	1.5	=item B<connect ($host, $port)>
47
48			Tries to open a socket to the host C<$host> and the port C<$port>.
49			If an error occured it will die (use eval to catch the exception).
50
51			=cut
52
53			sub connect {
54			my ($self, $host, $port) = @_;
55
56			$self->{socket}
57			and return;
58
59			my $sock = IO::Socket::INET->new (
60			PeerAddr => $host,
61			PeerPort => $port,
62			Proto => 'tcp',
63			Blocking => 0
64			) or die "couldn't connect to irc server '$host:$port': $!\n";;
65
66			$self->{socket} = $sock;
67			$self->{host} = $host;
68			$self->{port} = $port;
69
70	elmex	1.10	$self->{cw} =
71	elmex	1.11	AnyEvent->io (poll => 'w', fh => $self->{socket}, cb => sub {
72			my ($w) = @_;
73	elmex	1.10	# FIXME: handle EAGAIN ?
74			delete $self->{cw};
75	elmex	1.11
76	elmex	1.10	if ($! = $sock->sockopt (SO_ERROR)) {
77			$self->event ('connect_error' => $!);
78			} else {
79			$self->{connected} = 1;
80			$self->event ('connect');
81			$self->start_reader;
82			$self->start_writer;
83			}
84	elmex	1.11	0
85	elmex	1.10	});
86	elmex	1.11	1
87	elmex	1.10	}
88
89			sub start_reader {
90			my ($self) = @_;
91	elmex	1.11	my ($host, $port) = ($self->{host}, $self->{port});
92
93			return if $self->{rw};
94			return unless $self->{socket};
95	elmex	1.10
96	elmex	1.5	$self->{rw} =
97	elmex	1.11	AnyEvent->io (poll => 'r', fh => $self->{socket}, cb => sub {
98			my $data;
99			my $l = $self->{socket}->sysread ($data, 1024);
100	elmex	1.5
101	elmex	1.10	# FIXME: handle EAGAIN
102			if (defined $l) {
103			if ($l == 0) {
104			$self->disconnect ("EOF from IRC server '$host:$port'");
105			return
106			} else {
107			$self->feed_irc_data ($data);
108			}
109	elmex	1.5
110	elmex	1.10	} else {
111			if ($! == EAGAIN()) {
112	elmex	1.5	return;
113
114			} else {
115			$self->disconnect ("Error while reading from IRC server '$host:$port': $!");
116			return;
117			}
118			}
119			});
120			}
121
122	elmex	1.10
123			sub start_writer {
124			my ($self) = @_;
125
126			return unless $self->{socket} && $self->{connected} && length ($self->{outbuf}) > 0;
127
128			my ($host, $port) = ($self->{host}, $self->{port});
129
130			unless (defined $self->{ww}) {
131			$self->{ww} =
132			AnyEvent->io (poll => 'w', fh => $self->{socket}, cb => sub {
133			my $l = syswrite $self->{socket}, $self->{outbuf};
134
135			if (defined $l) {
136			substr $self->{outbuf}, 0, $l, "";
137			if (length ($self->{outbuf}) == 0) { delete $self->{ww} }
138
139			} else {
140			if ($! == EAGAIN()) {
141
142			return;
143			} else {
144			$self->disconnect ("Error while writing to IRC server '$self->{host}:$self->{port}': $!");
145			return;
146			}
147			}
148			});
149			}
150			}
151
152	elmex	1.2	=item B<disconnect ($reason)>
153	elmex	1.1
154			Unregisters the connection in the main Net::IRC3 object, closes
155			the sockets and send a 'disconnect' event with C<$reason> as argument.
156
157			=cut
158
159	elmex	1.2	sub disconnect {
160	elmex	1.1	my ($self, $reason) = @_;
161
162			$self->event (disconnect => $reason);
163
164	elmex	1.11	delete $self->{connected};
165
166	elmex	1.1	delete $self->{rw};
167			delete $self->{ww};
168	elmex	1.11	delete $self->{cw};
169	elmex	1.1
170	elmex	1.5	delete $self->{socket};
171	elmex	1.1	}
172
173			=item B<heap ()>
174
175			Returns a hash reference that is local to this connection object
176			that lets you store any information you want.
177
178			=cut
179
180			sub heap {
181			my ($self) = @_;
182			return $self->{heap};
183			}
184
185	elmex	1.9	=item B<send_raw ($ircline)>
186	elmex	1.1
187	elmex	1.9	This method sends C<$ircline> straight to the server without any
188			further processing done.
189	elmex	1.1
190			=cut
191
192	elmex	1.9	sub send_raw {
193			my ($self, $ircline) = @_;
194			$self->_send_raw ("$ircline\015\012");
195			}
196	elmex	1.5
197	elmex	1.9	sub _send_raw {
198			my ($self, $data) = @_;
199	elmex	1.6
200	elmex	1.9	$self->{outbuf} .= $data;
201	elmex	1.10	$self->start_writer;
202	elmex	1.9	}
203
204			=item B<send_msg (@ircmsg)>
205
206			This function sends a message to the server. C<@ircmsg> is the argumentlist
207			for C<Net::IRC3::Util::mk_msg>.
208
209			=cut
210
211			sub send_msg {
212			my ($self, @msg) = @_;
213
214			$self->event (sent => @msg);
215			$self->_send_raw (mk_msg (@msg));
216	elmex	1.1	}
217
218	elmex	1.3	=item B<reg_cb ($cmd, $cb)> or B<reg_cb ($cmd1, $cb1, $cmd2, $cb2, ..., $cmdN, $cbN)>
219	elmex	1.1
220			This registers a callback in the connection class.
221			These callbacks will be called by internal events and
222	elmex	1.3	by IRC protocol commands. You can also specify multiple callback registrations.
223	elmex	1.1
224			The first argument to the callbacks is always the connection object
225			itself.
226
227			If a callback returns a false value, it will be unregistered.
228
229			NOTE: I<A callback has to return true to stay alive>
230
231			If C<$cmd> starts with 'irc_' the callback C<$cb> will be registered
232			for a IRC protocol command. The command is the suffix of C<$cmd> then.
233			The second argument to the callback is the message hash reference
234	elmex	1.6	that has the layout that is returned by C<Net::IRC3::Util::parse_irc_msg>.
235	elmex	1.1
236			With the special C<$cmd> 'irc_*' the callback will be called on I<any>
237			IRC command that is received.
238
239			EXAMPLE:
240
241			$con->reg_cb (irc_privmsg => \&privmsg_handler);
242			# privmsg_handler will be called if an IRC message
243			# with the command 'PRIVMSG' arrives.
244
245			If C<$cmd> is not prefixed with a 'irc_' it will be called when an event
246			with the name C<$cmd> is emitted. The arguments to the callback depend
247			on the event that is emitted (but remember: the first argument will always be the
248			connection object)
249
250			Following events are emitted by this module and shouldn't be emitted
251			from a module user call to C<event>.
252
253			=over 4
254
255	elmex	1.10	=item B<connect>
256
257			This event is generated when the socket was successfully connected.
258
259			=item B<connect_error $error>
260
261			This event is generated when the socket couldn't be connected successfully.
262
263	elmex	1.1	=item B<disconnect $reason>
264
265			This event will be generated if the connection is somehow terminated.
266	elmex	1.2	It will also be emitted when C<disconnect> is called.
267	elmex	1.1	The second argument to the callback is C<$reason>, a string that contains
268			a clue about why the connection terminated.
269
270	elmex	1.5	If you want to reestablish a connection, call C<connect> again.
271	elmex	1.2
272	elmex	1.6	=item B<sent @ircmsg>
273
274			Emitted when a message (C<@ircmsg>) was sent to the server.
275			C<@ircmsg> are the arguments to C<Net::IRC3::Util::mk_msg>.
276
277			=item B<'*' $msg>
278			=item B<read $msg>
279
280			Emitted when a message (C<$msg>) was read from the server.
281			C<$msg> is the hash reference returned by C<Net::IRC3::Util::parse_irc_msg>;
282
283	elmex	1.1	=back
284
285			=cut
286
287			sub reg_cb {
288	elmex	1.3	my ($self, %regs) = @_;
289	elmex	1.1
290	elmex	1.3	for my $cmd (keys %regs) {
291			my $cb = $regs{$cmd};
292	elmex	1.1
293	elmex	1.3	if ($cmd =~ m/^irc_(\S+)/i) {
294			push @{$self->{cbs}->{lc $1}}, $cb;
295
296			} else {
297			push @{$self->{events}->{$cmd}}, $cb;
298			}
299	elmex	1.1	}
300
301			1;
302			}
303
304			=item B<event ($event, @args)>
305
306			This function emits an event with the name C<$event> and the arguments C<@args>.
307			The registerd callback that has been registered with C<reg_cb> will be called
308			with the first argument being the connection object and the rest of the arguments
309			being C<@args>.
310
311			EXAMPLE
312
313			$con->reg_cb (test_event => sub { print "Yay, i love $_[1]!!\n");
314			$con->event (test_event => "IRC");
315
316			# will print "Yay, i love IRC!!\n"
317
318			=cut
319
320			sub event {
321			my ($self, $ev, @arg) = @_;
322
323			my $nxt = [];
324
325			for (@{$self->{events}->{lc $ev}}) {
326			$_->($self, @arg) and push @$nxt, $_;
327			}
328
329			$self->{events}->{lc $ev} = $nxt;
330			}
331
332			# internal function, called by the read callbacks above.
333			sub feed_irc_data {
334			my ($self, $data) = @_;
335
336			$self->{buffer} .= $data;
337
338			my @msg;
339			while ($self->{buffer} =~ s/^([^\015\012]*)\015?\012//) {
340			push @msg, $1;
341			}
342
343			for (@msg) {
344			my $m = parse_irc_msg ($_);
345
346	elmex	1.6	$self->event (read => $m);
347
348	elmex	1.1	my $nxt = [];
349
350			for (@{$self->{cbs}->{lc $m->{command}}}) {
351			$_->($self, $m) and push @$nxt, $_;
352			}
353
354			$self->{cbs}->{lc $m->{command}} = $nxt;
355
356			$nxt = [];
357
358			for (@{$self->{cbs}->{'*'}}) {
359			$_->($self, $m) and push @$nxt, $_;
360			}
361
362			$self->{cbs}->{'*'} = $nxt;
363			}
364			}
365
366
367			=back
368
369			=head1 AUTHOR
370
371			Robin Redeker, C<< <elmex@ta-sa.org> >>
372
373			=head1 SEE ALSO
374
375			L<Net::IRC3>
376
377	elmex	1.8	L<Net::IRC3::Client::Connection>
378
379	elmex	1.1	=head1 COPYRIGHT & LICENSE
380
381	elmex	1.7	Copyright 2006 Robin Redeker, all rights reserved.
382	elmex	1.1
383			This program is free software; you can redistribute it and/or modify it
384			under the same terms as Perl itself.
385
386			=cut
387
388			1;