Net/IRC3/Connection.pm

package Net::IRC3::Connection;
use strict;
no warnings;
use AnyEvent;
use POSIX;
use IO::Socket::INET;
use IO::Handle;
use Net::IRC3::Util 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.

Please note that CTCP support is available through the functions
C<encode_ctcp> and C<decode_ctcp> provided by L<Net::IRC3::Util>.

=head2 METHODS

=over 4

=item B<new>

This constructor does take no arguments.

=cut

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

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

  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 => 1
   ) 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' => $!);
            $self->_clear_me;
         } else {
            $self->use_socket ($host, $port, $self->{socket});
         }
         0
      });
   1
}

=item B<use_socket ($host, $port, $socket)>

This method can be used instead of C<connect> to handle IRC messages
that are received and sent over the C<$socket>.

In this case C<$host> and C<$port> are just documentation for the error messages.

=cut

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

   $self->{host} = $host;
   $self->{port} = $port;
   $self->{socket} = $socket;
   $socket->blocking (0);

   $self->{connected} = 1;
   $self->event ('connect');
   $self->_start_reader;
   $self->_start_writer;
}

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);
   $self->_clear_me;

}

=item B<is_connected>

Returns true when this connection is connected.
Otherwise false.

=cut

sub is_connected {
   my ($self) = @_;
   $self->{socket} && $self->{connected}
}

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

   delete $self->{connected};

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

   delete $self->{socket};

   delete $self->{cbs};
   delete $self->{events};
}

=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}->{$ev}}) {
      $_->($self, @arg) and push @$nxt, $_;
   }

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