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.

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