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

B<NOTE:> This module is B<DEPRECATED>, please use L<AnyEvent::IRC> for new programs,
and possibly port existing L<Net::IRC3> applications to L<AnyEvent::IRC>. Though the
API of L<AnyEvent::IRC> has incompatible changes, it's still fairly similar.


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

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