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 => 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.15
Committed:	Wed Apr 18 21:10:21 2007 UTC (19 years, 6 months ago) by elmex
Branch:	MAIN
Changes since 1.14:	+3 -0 lines
Log Message:	added CTCP support
#	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			Blocking => 0
72			) 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.1	}
219
220			=item B<heap ()>
221
222			Returns a hash reference that is local to this connection object
223			that lets you store any information you want.
224
225			=cut
226
227			sub heap {
228			my ($self) = @_;
229			return $self->{heap};
230			}
231
232	elmex	1.9	=item B<send_raw ($ircline)>
233	elmex	1.1
234	elmex	1.9	This method sends C<$ircline> straight to the server without any
235			further processing done.
236	elmex	1.1
237			=cut
238
239	elmex	1.9	sub send_raw {
240			my ($self, $ircline) = @_;
241			$self->_send_raw ("$ircline\015\012");
242			}
243	elmex	1.5
244	elmex	1.9	sub _send_raw {
245			my ($self, $data) = @_;
246	elmex	1.6
247	elmex	1.9	$self->{outbuf} .= $data;
248	elmex	1.12	$self->_start_writer;
249	elmex	1.9	}
250
251			=item B<send_msg (@ircmsg)>
252
253			This function sends a message to the server. C<@ircmsg> is the argumentlist
254			for C<Net::IRC3::Util::mk_msg>.
255
256			=cut
257
258			sub send_msg {
259			my ($self, @msg) = @_;
260
261			$self->event (sent => @msg);
262			$self->_send_raw (mk_msg (@msg));
263	elmex	1.1	}
264
265	elmex	1.3	=item B<reg_cb ($cmd, $cb)> or B<reg_cb ($cmd1, $cb1, $cmd2, $cb2, ..., $cmdN, $cbN)>
266	elmex	1.1
267			This registers a callback in the connection class.
268			These callbacks will be called by internal events and
269	elmex	1.3	by IRC protocol commands. You can also specify multiple callback registrations.
270	elmex	1.1
271			The first argument to the callbacks is always the connection object
272			itself.
273
274			If a callback returns a false value, it will be unregistered.
275
276			NOTE: I<A callback has to return true to stay alive>
277
278			If C<$cmd> starts with 'irc_' the callback C<$cb> will be registered
279			for a IRC protocol command. The command is the suffix of C<$cmd> then.
280			The second argument to the callback is the message hash reference
281	elmex	1.6	that has the layout that is returned by C<Net::IRC3::Util::parse_irc_msg>.
282	elmex	1.1
283			With the special C<$cmd> 'irc_*' the callback will be called on I<any>
284			IRC command that is received.
285
286			EXAMPLE:
287
288			$con->reg_cb (irc_privmsg => \&privmsg_handler);
289			# privmsg_handler will be called if an IRC message
290			# with the command 'PRIVMSG' arrives.
291
292			If C<$cmd> is not prefixed with a 'irc_' it will be called when an event
293			with the name C<$cmd> is emitted. The arguments to the callback depend
294			on the event that is emitted (but remember: the first argument will always be the
295			connection object)
296
297			Following events are emitted by this module and shouldn't be emitted
298			from a module user call to C<event>.
299
300			=over 4
301
302	elmex	1.10	=item B<connect>
303
304			This event is generated when the socket was successfully connected.
305
306			=item B<connect_error $error>
307
308			This event is generated when the socket couldn't be connected successfully.
309
310	elmex	1.1	=item B<disconnect $reason>
311
312			This event will be generated if the connection is somehow terminated.
313	elmex	1.2	It will also be emitted when C<disconnect> is called.
314	elmex	1.1	The second argument to the callback is C<$reason>, a string that contains
315			a clue about why the connection terminated.
316
317	elmex	1.5	If you want to reestablish a connection, call C<connect> again.
318	elmex	1.2
319	elmex	1.6	=item B<sent @ircmsg>
320
321			Emitted when a message (C<@ircmsg>) was sent to the server.
322			C<@ircmsg> are the arguments to C<Net::IRC3::Util::mk_msg>.
323
324			=item B<'*' $msg>
325	elmex	1.14
326	elmex	1.6	=item B<read $msg>
327
328			Emitted when a message (C<$msg>) was read from the server.
329			C<$msg> is the hash reference returned by C<Net::IRC3::Util::parse_irc_msg>;
330
331	elmex	1.1	=back
332
333			=cut
334
335			sub reg_cb {
336	elmex	1.3	my ($self, %regs) = @_;
337	elmex	1.1
338	elmex	1.3	for my $cmd (keys %regs) {
339			my $cb = $regs{$cmd};
340	elmex	1.1
341	elmex	1.3	if ($cmd =~ m/^irc_(\S+)/i) {
342			push @{$self->{cbs}->{lc $1}}, $cb;
343
344			} else {
345			push @{$self->{events}->{$cmd}}, $cb;
346			}
347	elmex	1.1	}
348
349			1;
350			}
351
352			=item B<event ($event, @args)>
353
354			This function emits an event with the name C<$event> and the arguments C<@args>.
355			The registerd callback that has been registered with C<reg_cb> will be called
356			with the first argument being the connection object and the rest of the arguments
357			being C<@args>.
358
359			EXAMPLE
360
361			$con->reg_cb (test_event => sub { print "Yay, i love $_[1]!!\n");
362			$con->event (test_event => "IRC");
363
364			# will print "Yay, i love IRC!!\n"
365
366			=cut
367
368			sub event {
369			my ($self, $ev, @arg) = @_;
370
371			my $nxt = [];
372
373			for (@{$self->{events}->{lc $ev}}) {
374			$_->($self, @arg) and push @$nxt, $_;
375			}
376
377			$self->{events}->{lc $ev} = $nxt;
378			}
379
380			# internal function, called by the read callbacks above.
381	elmex	1.12	sub _feed_irc_data {
382	elmex	1.1	my ($self, $data) = @_;
383
384			$self->{buffer} .= $data;
385
386			my @msg;
387			while ($self->{buffer} =~ s/^([^\015\012]*)\015?\012//) {
388			push @msg, $1;
389			}
390
391			for (@msg) {
392			my $m = parse_irc_msg ($_);
393
394	elmex	1.6	$self->event (read => $m);
395
396	elmex	1.1	my $nxt = [];
397
398			for (@{$self->{cbs}->{lc $m->{command}}}) {
399			$_->($self, $m) and push @$nxt, $_;
400			}
401
402			$self->{cbs}->{lc $m->{command}} = $nxt;
403
404			$nxt = [];
405
406			for (@{$self->{cbs}->{'*'}}) {
407			$_->($self, $m) and push @$nxt, $_;
408			}
409
410			$self->{cbs}->{'*'} = $nxt;
411			}
412			}
413
414
415			=back
416
417			=head1 AUTHOR
418
419			Robin Redeker, C<< <elmex@ta-sa.org> >>
420
421			=head1 SEE ALSO
422
423			L<Net::IRC3>
424
425	elmex	1.8	L<Net::IRC3::Client::Connection>
426
427	elmex	1.1	=head1 COPYRIGHT & LICENSE
428
429	elmex	1.7	Copyright 2006 Robin Redeker, all rights reserved.
430	elmex	1.1
431			This program is free software; you can redistribute it and/or modify it
432			under the same terms as Perl itself.
433
434			=cut
435
436			1;