r46781 - in /branches/upstream/libanyevent-irc-perl/current: Changes META.yml Makefile.PL README lib/AnyEvent/IRC.pm lib/AnyEvent/IRC/Client.pm lib/AnyEvent/IRC/Connection.pm lib/AnyEvent/IRC/Util.pm
angelabad-guest at users.alioth.debian.org
angelabad-guest at users.alioth.debian.org
Thu Nov 5 11:58:38 UTC 2009
Author: angelabad-guest
Date: Thu Nov 5 11:58:21 2009
New Revision: 46781
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=46781
Log:
[svn-upgrade] Integrating new upstream version, libanyevent-irc-perl (0.95)
Modified:
branches/upstream/libanyevent-irc-perl/current/Changes
branches/upstream/libanyevent-irc-perl/current/META.yml
branches/upstream/libanyevent-irc-perl/current/Makefile.PL
branches/upstream/libanyevent-irc-perl/current/README
branches/upstream/libanyevent-irc-perl/current/lib/AnyEvent/IRC.pm
branches/upstream/libanyevent-irc-perl/current/lib/AnyEvent/IRC/Client.pm
branches/upstream/libanyevent-irc-perl/current/lib/AnyEvent/IRC/Connection.pm
branches/upstream/libanyevent-irc-perl/current/lib/AnyEvent/IRC/Util.pm
Modified: branches/upstream/libanyevent-irc-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libanyevent-irc-perl/current/Changes?rev=46781&op=diff
==============================================================================
--- branches/upstream/libanyevent-irc-perl/current/Changes (original)
+++ branches/upstream/libanyevent-irc-perl/current/Changes Thu Nov 5 11:58:21 2009
@@ -1,4 +1,11 @@
Revision history for AnyEvent::IRC
+
+0.95 Thu Nov 5 00:15:55 CET 2009
+ - added away_status method and events for tracking your away status.
+ - implemented send_long_message.
+ - added send_initial_whois option to ::Client constructor.
+ - added dependency to Encode.
+ - fixed a bug in ident handling, it now also detects nick changes.
0.9 Mon Sep 28 14:51:29 CEST 2009
- made AnyEvent::IRC::Client connection object reusable.
Modified: branches/upstream/libanyevent-irc-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libanyevent-irc-perl/current/META.yml?rev=46781&op=diff
==============================================================================
--- branches/upstream/libanyevent-irc-perl/current/META.yml (original)
+++ branches/upstream/libanyevent-irc-perl/current/META.yml Thu Nov 5 11:58:21 2009
@@ -1,6 +1,6 @@
--- #YAML:1.0
name: AnyEvent-IRC
-version: 0.9
+version: 0.95
abstract: An event system independend IRC protocol module
author:
- Robin Redeker <elmex at ta-sa.org>
@@ -13,6 +13,7 @@
requires:
AnyEvent: 5.111
common::sense: 0
+ Encode: 0
Object::Event: 0.6
Scalar::Util: 0
Test::More: 0
Modified: branches/upstream/libanyevent-irc-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libanyevent-irc-perl/current/Makefile.PL?rev=46781&op=diff
==============================================================================
--- branches/upstream/libanyevent-irc-perl/current/Makefile.PL (original)
+++ branches/upstream/libanyevent-irc-perl/current/Makefile.PL Thu Nov 5 11:58:21 2009
@@ -15,6 +15,7 @@
'Object::Event' => '0.6',
'common::sense' => 0,
'Scalar::Util' => 0,
+ 'Encode' => 0,
},
dist => {
COMPRESS => 'gzip -9f',
Modified: branches/upstream/libanyevent-irc-perl/current/README
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libanyevent-irc-perl/current/README?rev=46781&op=diff
==============================================================================
--- branches/upstream/libanyevent-irc-perl/current/README (original)
+++ branches/upstream/libanyevent-irc-perl/current/README Thu Nov 5 11:58:21 2009
@@ -2,7 +2,7 @@
AnyEvent::IRC - An event system independend IRC protocol module
VERSION
- Version 0.9
+ Version 0.95
SYNOPSIS
Using the simplistic AnyEvent::IRC::Connection:
Modified: branches/upstream/libanyevent-irc-perl/current/lib/AnyEvent/IRC.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libanyevent-irc-perl/current/lib/AnyEvent/IRC.pm?rev=46781&op=diff
==============================================================================
--- branches/upstream/libanyevent-irc-perl/current/lib/AnyEvent/IRC.pm (original)
+++ branches/upstream/libanyevent-irc-perl/current/lib/AnyEvent/IRC.pm Thu Nov 5 11:58:21 2009
@@ -8,11 +8,11 @@
=head1 VERSION
-Version 0.9
+Version 0.95
=cut
-our $VERSION = '0.9';
+our $VERSION = '0.95';
=head1 SYNOPSIS
Modified: branches/upstream/libanyevent-irc-perl/current/lib/AnyEvent/IRC/Client.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libanyevent-irc-perl/current/lib/AnyEvent/IRC/Client.pm?rev=46781&op=diff
==============================================================================
--- branches/upstream/libanyevent-irc-perl/current/lib/AnyEvent/IRC/Client.pm (original)
+++ branches/upstream/libanyevent-irc-perl/current/lib/AnyEvent/IRC/Client.pm Thu Nov 5 11:58:21 2009
@@ -3,11 +3,13 @@
use Scalar::Util qw/weaken/;
+use Encode;
use AnyEvent::Socket;
use AnyEvent::Handle;
use AnyEvent::IRC::Util
qw/prefix_nick decode_ctcp split_prefix
- is_nick_prefix join_prefix encode_ctcp/;
+ is_nick_prefix join_prefix encode_ctcp
+ split_unicode_string mk_msg/;
use base AnyEvent::IRC::Connection::;
@@ -170,6 +172,20 @@
Emitted when C<$old_nick> is renamed to C<$new_nick>.
C<$is_myself> is true when yourself was the one who changed the nick.
+=item away_status_change => $bool
+
+Emitted whenever a presence/away status change for you was detected.
+C<$bool> is true if you are now away, or false/undef if you are not
+away anymore.
+
+You can change your away status by emitting the C<AWAY> IRC command:
+
+ $cl->send_srv (AWAY => "I'm not here right now");
+
+Or reset it:
+
+ $cl->send_srv ('AWAY');
+
=item ctcp => $src, $target, $tag, $msg, $type
Emitted when a CTCP message was found in either a NOTICE or PRIVMSG
@@ -292,12 +308,29 @@
=over 4
-=item $cl = AnyEvent::IRC::Client->new ()
-
-This constructor takes no arguments.
+=item $cl = AnyEvent::IRC::Client->new (%args)
+
+This is the constructor of a L<AnyEvent::IRC::Client> object,
+which stands logically for a client connected to ONE IRC server.
+You can reuse it and call C<connect> once it disconnected.
B<NOTE:> You are free to use the hash member C<heap> to store any associated
data with this object. For example retry timers or anything else.
+
+C<%args> may contain these options:
+
+=over 4
+
+=item send_initial_whois => $bool
+
+If this option is enabled an initial C<WHOIS> command is sent to your own
+NICKNAME to determine your own I<ident>. See also the method C<nick_ident>.
+This is necessary to ensure that the information about your own nickname
+is available as early as possible for the C<send_long_message> method.
+
+C<$bool> is C<false> by default.
+
+=back
=cut
@@ -325,6 +358,8 @@
$self->reg_cb (irc_366 => \&endofnames_cb);
$self->reg_cb (irc_352 => \&whoreply_cb);
$self->reg_cb (irc_311 => \&whoisuser_cb);
+ $self->reg_cb (irc_305 => \&away_change_cb);
+ $self->reg_cb (irc_306 => \&away_change_cb);
$self->reg_cb (irc_ping => \&ping_cb);
$self->reg_cb (irc_pong => \&pong_cb);
@@ -343,6 +378,8 @@
$self->reg_cb (ctcp => \&ctcp_auto_reply_cb);
$self->reg_cb (registered => \®istered_cb);
+
+ $self->reg_cb (nick_change => \&update_ident_nick_change_cb);
$self->{def_nick_change} = $self->{nick_change} =
sub {
@@ -373,6 +410,7 @@
irc_433 => \&change_nick_login_cb,
);
+ delete $self->{away_status};
delete $self->{dcc};
delete $self->{dcc_id};
delete $self->{_tmp_namereply};
@@ -658,6 +696,88 @@
$self->{chan_queue}->{$self->lower_case ($chan)} = [];
}
+=item my (@lines) = $cl->send_long_message ($encoding, $overhead, $cmd, @params, $msg)
+
+As IRC only allows 512 byte blocks of messages and sometimes
+your messages might get longer, you have a problem. This method
+will solve your problem:
+
+This method can be used to split up long messages into multiple
+commands.
+
+C<$cmd> and C<@params> are the IRC command and it's first parameters,
+except the last one: the C<$msg>. C<$msg> can be a Unicode string,
+which will be encoded in C<$encoding> before sending.
+
+If you want to send a CTCP message you can encode it in the C<$cmd> by
+appending the CTCP command with a C<"\001">. For example if you want to
+send a CTCP ACTION you have to give this C<$cmd>:
+
+ $cl->send_long_message (undef, 0, "PRIVMSG\001ACTION", "#test", "rofls");
+
+C<$encoding> can be undef if you don't need any recoding of C<$msg>.
+But in case you want to send Unicode it is necessary to determine where
+to split a message exactly, to not break the encoding.
+
+Please also note that the C<nick_ident> for your own nick is necessary to
+compute this. To ensure best performance as possible use the
+C<send_initial_whois> option if you want to use this method.
+
+But note that this method might not work 100% correct and you might still get
+at least partially chopped off lines if you use C<send_long_message> before the
+C<WHOIS> reply to C<send_initial_whois> arrived.
+
+To be on the safest side you might want to wait until that initial C<WHOIS>
+reply arrived.
+
+The return value of this method is the list of the actually sent lines (but
+without encoding applied).
+
+=cut
+
+sub send_long_message {
+ my ($self, $encoding, $overhead, $cmd, @params) = @_;
+ my $msg = pop @params;
+
+ my $ctcp;
+ ($cmd, $ctcp) = split /\001/, $cmd;
+
+ my $id = $self->nick_ident ($self->nick);
+ if ($id eq '') {
+ $id = "X" x 60; # just in case the ident is not available...
+ }
+
+ my $init_len = length mk_msg ($id, $cmd, @params, " "); # i know off by 1
+
+ if ($ctcp ne '') {
+ $init_len += length ($ctcp) + 3; # CTCP cmd + " " + "\001" x 2
+ }
+
+ my $max_len = 500; # give 10 bytes extra margin
+
+ my $line_len = $max_len - $init_len;
+
+ # split up the multiple lines in the message:
+ my @lines = split /\n/, $msg;
+
+ # splitup long lines into multiple ones:
+ @lines =
+ map split_unicode_string ($encoding, $_, $line_len), @lines;
+
+ # send lines line-by-line:
+ for my $line (@lines) {
+ my $smsg = encode ($encoding, $line);
+
+ if ($ctcp ne '') {
+ $smsg = encode_ctcp ([$ctcp, $smsg])
+ }
+
+ $self->send_srv ($cmd => @params, $smsg);
+ }
+
+ @lines
+}
+
=item $cl->enable_ping ($interval, $cb)
This method enables a periodical ping to the server with an interval of
@@ -840,6 +960,9 @@
This method returns the whole ident of the C<$nick> if the informations is available.
If the nick's ident hasn't been seen yet, undef is returned.
+B<NOTE:> If you want to rely on the C<nick_ident> of your own nick you should
+make sure to enable the C<send_initial_whois> option in the constructor.
+
=cut
sub nick_ident {
@@ -847,7 +970,16 @@
$self->{idents}->{$self->lower_case ($nick)}
}
+=item my $bool = $cl->away_status
+
+Returns a true value if you are away or undef if you are not away.
+
+=cut
+
+sub away_status { $_[0]->{away_status} }
+
=item $cl->ctcp_auto_reply ($ctcp_command, @msg)
+
=item $cl->ctcp_auto_reply ($ctcp_command, $coderef)
This method installs an auto-reply for the reception of the C<$ctcp_command>
@@ -1266,6 +1398,9 @@
sub registered_cb {
my ($self, $msg) = @_;
+ $self->send_srv (WHOIS => $self->nick)
+ if $self->{send_initial_whois};
+
for (@{$self->{con_queue}}) {
$self->send_msg (@$_);
}
@@ -1347,11 +1482,11 @@
}
}
+ $self->event (nick_change => $nick, $newnick, $wasme);
+
for (@chans) {
$self->event (channel_change => $_, $nick, $newnick, $wasme);
}
-
- $self->event (nick_change => $nick, $newnick, $wasme);
}
sub namereply_cb {
@@ -1407,7 +1542,7 @@
my $chan = $msg->{params}->[0];
my $nick = prefix_nick ($msg);
- $self->event (part => $nick, $chan, $self->_was_me ($msg), $msg->{params}->[1]);
+ $self->event (part => $nick, $chan, $self->_was_me ($msg), $msg->{params}->[1]);
$self->channel_remove ($msg, $chan, [$nick]);
$self->event (channel_remove => $msg, $chan, $nick);
}
@@ -1453,6 +1588,18 @@
}
}
+sub away_change_cb {
+ my ($self, $msg) = @_;
+
+ if ($msg->{command} eq '305') { # no longer away
+ delete $self->{away_status};
+ } else { # away
+ $self->{away_status} = 1;
+ }
+
+ $self->event (away_status_change => $self->{away_status});
+}
+
sub debug_cb {
my ($self, $msg) = @_;
$self->event (debug_recv => $msg);
@@ -1513,6 +1660,17 @@
}
}
+sub update_ident_nick_change_cb {
+ my ($self, $old, $new) = @_;
+
+ my $oldid = $self->nick_ident ($old);
+ return unless defined $oldid;
+
+ my ($n, $u, $h) = split_prefix ($oldid);
+
+ $self->update_ident (join_prefix ($new, $u, $h));
+}
+
sub ctcp_auto_reply_cb {
my ($self, $src, $targ, $tag, $msg, $type) = @_;
Modified: branches/upstream/libanyevent-irc-perl/current/lib/AnyEvent/IRC/Connection.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libanyevent-irc-perl/current/lib/AnyEvent/IRC/Connection.pm?rev=46781&op=diff
==============================================================================
--- branches/upstream/libanyevent-irc-perl/current/lib/AnyEvent/IRC/Connection.pm (original)
+++ branches/upstream/libanyevent-irc-perl/current/lib/AnyEvent/IRC/Connection.pm Thu Nov 5 11:58:21 2009
@@ -223,7 +223,12 @@
sub _feed_irc_data {
my ($self, $line) = @_;
+ #d# warn "LINE:[" . $line . "][".length ($line)."]";
+
my $m = parse_irc_msg ($line);
+ #d# warn "MESSAGE{$m->{params}->[-1]}[".(length $m->{params}->[-1])."]\n";
+ #d# warn "HEX:" . join ('', map { sprintf "%2.2x", ord ($_) } split //, $line)
+ #d# . "\n";
$self->event (read => $m);
$self->event ('irc_*' => $m);
Modified: branches/upstream/libanyevent-irc-perl/current/lib/AnyEvent/IRC/Util.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libanyevent-irc-perl/current/lib/AnyEvent/IRC/Util.pm?rev=46781&op=diff
==============================================================================
--- branches/upstream/libanyevent-irc-perl/current/lib/AnyEvent/IRC/Util.pm (original)
+++ branches/upstream/libanyevent-irc-perl/current/lib/AnyEvent/IRC/Util.pm Thu Nov 5 11:58:21 2009
@@ -1,11 +1,13 @@
package AnyEvent::IRC::Util;
use common::sense;
use Exporter;
+use Encode;
our @ISA = qw/Exporter/;
our @EXPORT_OK =
qw(mk_msg parse_irc_msg split_prefix prefix_nick
decode_ctcp encode_ctcp filter_ctcp_text_attr prefix_user prefix_host
- rfc_code_to_name filter_colors is_nick_prefix join_prefix);
+ rfc_code_to_name filter_colors is_nick_prefix join_prefix
+ split_unicode_string);
=head1 NAME
@@ -188,6 +190,13 @@
}
$line =~ s/\001[^\001]*\001//g;
+
+ # try to parse broken ctcp messages anyway
+ if ($line =~ s/\001([^\001]*)$//) {
+ my $msg = unescape_ctcp ($1);
+ my ($tag, $data) = split / /, $msg, 2;
+ push @ctcp, [$tag, $data];
+ }
return ($line, \@ctcp)
}
@@ -493,6 +502,39 @@
return $RFC_NUMCODE_MAP{$code} || $code;
}
+=item my (@lines) = split_unicode_string ($encoding, $string, $maxlinebytes)
+
+This function splits up C<$string> into multiple C<@lines> which are
+not longer than C<$maxlinebytes> bytes. Encoding can be given in C<$encoding>.
+(eg. 'utf-8'). But the output will not be encoded.
+
+This function takes care that your characters are not garbled.
+
+=cut
+
+sub split_unicode_string {
+ my ($enc, $str, $maxlen) = @_;
+
+ return $str unless length (encode ($enc, $str)) > $maxlen;
+
+ my $cur_out = '';
+ my @lines;
+
+ while (length ($str) > 0) {
+
+ while (length (encode ($enc, $cur_out)) <= $maxlen
+ && length ($str) > 0) {
+
+ $cur_out .= substr $str, 0, 1, '';
+ }
+
+ push @lines, $cur_out;
+ $cur_out = '';
+ }
+
+ @lines
+}
+
=head1 AUTHOR
Robin Redeker, C<< <elmex at ta-sa.org> >>
More information about the Pkg-perl-cvs-commits
mailing list