Net/IRC3/Connection.pm

package Net::IRC3::Connection;
use strict;
use AnyEvent;
use IO::Socket::INET;
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

=cut

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

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

  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->{rw} =
      AnyEvent->io (poll => 'r', fh => $sock, cb => sub {
         my $l = sysread $sock, my $data, 1024;

         $self->feed_irc_data ($data);

         unless ($l) {

            if (defined $l) {
               $self->disconnect ("EOF from IRC server '$host:$port'");
               return;

            } else {
               $self->disconnect ("Error while reading from IRC server '$host:$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);

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

   eval { $self->{socket}->close };
   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_msg (@ircmsg)>

This function sends a message to the server. C<@ircmsg> is the argumentlist
for C<mk_msg>.

=cut

sub send_msg {
   my ($self, @msg) = @_;

   $self->{socket} or return;

   my $data = mk_msg (@msg);

   my ($host, $port) = ($self->{host}, $self->{port});
   $self->{outbuf} .= $data;

   unless (defined $self->{ww}) {
      my $sock = $self->{socket};
      $self->{ww} =
         AnyEvent->io (poll => 'w', fh => $sock, cb => sub {
            my $l = syswrite $sock, $self->{outbuf};

            substr $self->{outbuf}, 0, $l, "";

            if (length ($self->{outbuf}) == 0) { delete $self->{ww} }

            unless ($l) {
               # XXX: is this behaviour correct or ok?
               $self->disconnect ("Error while writing to IRC server '$self->{host}:$self->{port}': $!");
               return;
            }
         });
   }
}

=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<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<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.

=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 ($_);

      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>

=head1 COPYRIGHT & LICENSE

Copyright 2006 Robin Redker, 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.5
Committed:	Mon Jul 17 15:09:20 2006 UTC (20 years, 3 months ago) by elmex
Branch:	MAIN
Changes since 1.4:	+54 -21 lines
Log Message:	simplyfied the whole module a bit.
#	User	Rev	Content
1	elmex	1.1	package Net::IRC3::Connection;
2			use strict;
3			use AnyEvent;
4			use IO::Socket::INET;
5	elmex	1.4	use Net::IRC3::Util qw/mk_msg parse_irc_msg/;
6	elmex	1.1
7			=head1 NAME
8
9			Net::IRC3::Connection - An IRC connection abstraction
10
11			=head1 SYNOPSIS
12
13			#...
14			$con->send_msg (undef, "PRIVMSG", "Hello there!", "yournick");
15			#...
16
17			=head1 DESCRIPTION
18
19			The connection class. Here the actual interesting stuff can be done,
20			such as sending and receiving IRC messages.
21
22			=head2 METHODS
23
24			=over 4
25
26			=cut
27
28			sub new
29			{
30			my $this = shift;
31			my $class = ref($this) \|\| $this;
32
33			my $self = {
34	elmex	1.5	cbs => {},
35	elmex	1.1	heap => {}
36			};
37
38			bless $self, $class;
39
40			return $self;
41			}
42
43	elmex	1.5	=item B<connect ($host, $port)>
44
45			Tries to open a socket to the host C<$host> and the port C<$port>.
46			If an error occured it will die (use eval to catch the exception).
47
48			=cut
49
50			sub connect {
51			my ($self, $host, $port) = @_;
52
53			$self->{socket}
54			and return;
55
56			my $sock = IO::Socket::INET->new (
57			PeerAddr => $host,
58			PeerPort => $port,
59			Proto => 'tcp',
60			Blocking => 0
61			) or die "couldn't connect to irc server '$host:$port': $!\n";;
62
63			$self->{socket} = $sock;
64			$self->{host} = $host;
65			$self->{port} = $port;
66
67			$self->{rw} =
68			AnyEvent->io (poll => 'r', fh => $sock, cb => sub {
69			my $l = sysread $sock, my $data, 1024;
70
71			$self->feed_irc_data ($data);
72
73			unless ($l) {
74
75			if (defined $l) {
76			$self->disconnect ("EOF from IRC server '$host:$port'");
77			return;
78
79			} else {
80			$self->disconnect ("Error while reading from IRC server '$host:$port': $!");
81			return;
82			}
83			}
84			});
85			}
86
87	elmex	1.2	=item B<disconnect ($reason)>
88	elmex	1.1
89			Unregisters the connection in the main Net::IRC3 object, closes
90			the sockets and send a 'disconnect' event with C<$reason> as argument.
91
92			=cut
93
94	elmex	1.2	sub disconnect {
95	elmex	1.1	my ($self, $reason) = @_;
96
97			$self->event (disconnect => $reason);
98
99			delete $self->{rw};
100			delete $self->{ww};
101
102	elmex	1.5	eval { $self->{socket}->close };
103			delete $self->{socket};
104	elmex	1.1	}
105
106			=item B<heap ()>
107
108			Returns a hash reference that is local to this connection object
109			that lets you store any information you want.
110
111			=cut
112
113			sub heap {
114			my ($self) = @_;
115			return $self->{heap};
116			}
117
118			=item B<send_msg (@ircmsg)>
119
120			This function sends a message to the server. C<@ircmsg> is the argumentlist
121			for C<mk_msg>.
122
123			=cut
124
125			sub send_msg {
126			my ($self, @msg) = @_;
127	elmex	1.5
128			$self->{socket} or return;
129
130	elmex	1.1	my $data = mk_msg (@msg);
131
132	elmex	1.5	my ($host, $port) = ($self->{host}, $self->{port});
133	elmex	1.1	$self->{outbuf} .= $data;
134
135			unless (defined $self->{ww}) {
136	elmex	1.5	my $sock = $self->{socket};
137	elmex	1.1	$self->{ww} =
138			AnyEvent->io (poll => 'w', fh => $sock, cb => sub {
139			my $l = syswrite $sock, $self->{outbuf};
140
141			substr $self->{outbuf}, 0, $l, "";
142
143			if (length ($self->{outbuf}) == 0) { delete $self->{ww} }
144
145			unless ($l) {
146			# XXX: is this behaviour correct or ok?
147	elmex	1.5	$self->disconnect ("Error while writing to IRC server '$self->{host}:$self->{port}': $!");
148	elmex	1.1	return;
149			}
150			});
151			}
152			}
153
154	elmex	1.3	=item B<reg_cb ($cmd, $cb)> or B<reg_cb ($cmd1, $cb1, $cmd2, $cb2, ..., $cmdN, $cbN)>
155	elmex	1.1
156			This registers a callback in the connection class.
157			These callbacks will be called by internal events and
158	elmex	1.3	by IRC protocol commands. You can also specify multiple callback registrations.
159	elmex	1.1
160			The first argument to the callbacks is always the connection object
161			itself.
162
163			If a callback returns a false value, it will be unregistered.
164
165			NOTE: I<A callback has to return true to stay alive>
166
167			If C<$cmd> starts with 'irc_' the callback C<$cb> will be registered
168			for a IRC protocol command. The command is the suffix of C<$cmd> then.
169			The second argument to the callback is the message hash reference
170			that has the layout that is returned by C<parse_irc_msg>.
171
172			With the special C<$cmd> 'irc_*' the callback will be called on I<any>
173			IRC command that is received.
174
175			EXAMPLE:
176
177			$con->reg_cb (irc_privmsg => \&privmsg_handler);
178			# privmsg_handler will be called if an IRC message
179			# with the command 'PRIVMSG' arrives.
180
181			If C<$cmd> is not prefixed with a 'irc_' it will be called when an event
182			with the name C<$cmd> is emitted. The arguments to the callback depend
183			on the event that is emitted (but remember: the first argument will always be the
184			connection object)
185
186			Following events are emitted by this module and shouldn't be emitted
187			from a module user call to C<event>.
188
189			=over 4
190
191			=item B<disconnect $reason>
192
193			This event will be generated if the connection is somehow terminated.
194	elmex	1.2	It will also be emitted when C<disconnect> is called.
195	elmex	1.1	The second argument to the callback is C<$reason>, a string that contains
196			a clue about why the connection terminated.
197
198	elmex	1.5	If you want to reestablish a connection, call C<connect> again.
199	elmex	1.2
200	elmex	1.1	=back
201
202			=cut
203
204			sub reg_cb {
205	elmex	1.3	my ($self, %regs) = @_;
206	elmex	1.1
207	elmex	1.3	for my $cmd (keys %regs) {
208			my $cb = $regs{$cmd};
209	elmex	1.1
210	elmex	1.3	if ($cmd =~ m/^irc_(\S+)/i) {
211			push @{$self->{cbs}->{lc $1}}, $cb;
212
213			} else {
214			push @{$self->{events}->{$cmd}}, $cb;
215			}
216	elmex	1.1	}
217
218			1;
219			}
220
221			=item B<event ($event, @args)>
222
223			This function emits an event with the name C<$event> and the arguments C<@args>.
224			The registerd callback that has been registered with C<reg_cb> will be called
225			with the first argument being the connection object and the rest of the arguments
226			being C<@args>.
227
228			EXAMPLE
229
230			$con->reg_cb (test_event => sub { print "Yay, i love $_[1]!!\n");
231			$con->event (test_event => "IRC");
232
233			# will print "Yay, i love IRC!!\n"
234
235			=cut
236
237			sub event {
238			my ($self, $ev, @arg) = @_;
239
240			my $nxt = [];
241
242			for (@{$self->{events}->{lc $ev}}) {
243			$_->($self, @arg) and push @$nxt, $_;
244			}
245
246			$self->{events}->{lc $ev} = $nxt;
247			}
248
249			# internal function, called by the read callbacks above.
250			sub feed_irc_data {
251			my ($self, $data) = @_;
252
253			$self->{buffer} .= $data;
254
255			my @msg;
256			while ($self->{buffer} =~ s/^([^\015\012]*)\015?\012//) {
257			push @msg, $1;
258			}
259
260			for (@msg) {
261			my $m = parse_irc_msg ($_);
262
263			my $nxt = [];
264
265			for (@{$self->{cbs}->{lc $m->{command}}}) {
266			$_->($self, $m) and push @$nxt, $_;
267			}
268
269			$self->{cbs}->{lc $m->{command}} = $nxt;
270
271			$nxt = [];
272
273			for (@{$self->{cbs}->{'*'}}) {
274			$_->($self, $m) and push @$nxt, $_;
275			}
276
277			$self->{cbs}->{'*'} = $nxt;
278			}
279			}
280
281
282			=back
283
284			=head1 AUTHOR
285
286			Robin Redeker, C<< <elmex@ta-sa.org> >>
287
288			=head1 SEE ALSO
289
290			L<Net::IRC3>
291
292			=head1 COPYRIGHT & LICENSE
293
294			Copyright 2006 Robin Redker, all rights reserved.
295
296			This program is free software; you can redistribute it and/or modify it
297			under the same terms as Perl itself.
298
299			=cut
300
301			1;