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/;

=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

=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 => 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' => $!);
            $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};
}

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