Net/IRC3/Util.pm

package Net::IRC3::Util;
use strict;
no warnings;
use Exporter;
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);

=head1 NAME

Net::IRC3::Util - Common utilities that help with IRC protocol handling

=head1 SYNOPSIS

   use Net::IRC3 qw/parse_irc_msg mk_msg/;

   my $msgdata = mk_msg (undef, PRIVMSG => "my hands glow!", "mcmanus");

=head1 FUNCTIONS

These are some utility functions that might come in handy when
handling the IRC protocol.

You can export these with eg.:

   use Net::IRC3 qw/parse_irc_msg/;

=over 4

=item B<parse_irc_msg ($ircline)>

This method parses the C<$ircline>, which is one line of the IRC protocol
without the trailing "\015\012".

It returns a hash which has the following entrys:

=over 4

=item prefix

The message prefix.

=item command

The IRC command.

=item params

The parameters to the IRC command in a array reference,
this includes the trailing parameter (the one after the ':' or
the 14th parameter).

=item trailing

This is set if there was a trailing parameter (the one after the ':' or
the 14th parameter).

=back

=cut

sub parse_irc_msg {
  my ($msg) = @_;

  my $cmd;
  my $pref;
  my $t;
  my @a;

  my $p = $msg =~ s/^(:([^ ]+)[ ])?([A-Za-z]+|\d{3})//;
  $pref = $2;
  $cmd = $3;

  my $i = 0;

  while ($msg =~ s/^[ ]([^ :\015\012\0][^ \015\012\0]*)//) {

    push @a, $1 if defined $1;
    if (++$i > 13) { last; }
  }

  if ($i == 14) {

    if ($msg =~ s/^[ ]:?([^\015\012\0]*)//) {
      $t = $1 if $1 ne "";
    }

  } else {

    if ($msg =~ s/^[ ]:([^\015\012\0]*)//) {
      $t = $1 if $1 ne "";
    }
  }

  push @a, $t if defined $t;

  my $m = { prefix => $pref, command => $cmd, params => \@a, trailing => $t };
  return $p ? $m : undef;
}

=item B<mk_msg ($prefix, $command, $trailing, @params)>

This function assembles a IRC message. The generated
message will look like (pseudo code!)

   :<prefix> <command> <params> :<trail>

Please refer to RFC 2812 how IRC messages normally look like.

The prefix and the trailing string will be omitted if they are C<undef>.

EXAMPLES:

   mk_msg (undef, "PRIVMSG", "you suck!", "magnus");
   # will return: "PRIVMSG magnus :you suck!\015\012"

   mk_msg (undef, "JOIN", undef, "#test");
   # will return: "JOIN #test\015\012"

=cut

sub mk_msg {
  my ($prefix, $command, $trail, @params) = @_;
  my $msg = "";

  $msg .= defined $prefix ? ":$prefix " : "";
  $msg .= "$command";

  # FIXME: params must be counted, and if > 13 they have to be
  # concationated with $trail
  map { $msg .= " $_" } @params;

  $msg .= defined $trail ? " :$trail" : "";
  $msg .= "\015\012";

  return $msg;
}

my @_ctcp_lowlevel_escape = ("\000", "0", "\012", "n", "\015", "r", "\020", "\020");

sub unescape_lowlevel {
   my ($data) = @_;
   my %map = reverse @_ctcp_lowlevel_escape;
   $data =~ s/\020(.)/defined $map{$1} ? $map{$1} : $1/ge;
   $data
}

sub escape_lowlevel {
   my ($data) = @_;
   my %map = @_ctcp_lowlevel_escape;
   $data =~ s/([\000\012\015\020])/"\020$map{$1}"/ge;
   $data
}

sub unescape_ctcp {
   my ($data) = @_;
   $data =~ s/\\(.)/$1 eq 'a' ? "\001" : ($1 eq "\\" ? "\\" : $1)/eg;
   $data
}

sub escape_ctcp {
   my ($data) = @_;
   $data =~ s/([\\\001])/$1 eq "\001" ? "\\a" : "\\\\"/eg;
   $data
}

=item B<decode_ctcp ($trailing)>

This function decodes the C<$trailing> part of an IRC message.
It will first unescape the lower layer, extract CTCP messages
and then return a list with two elements: the line without the ctcp messages
and an array reference which contains array references of CTCP messages.
Those CTCP message array references will have the CTCP message tag as
first element (eg. "VERSION") and the rest of the CTCP message as the second
element.

=cut

sub decode_ctcp {
   my ($line) = @_;

   $line = unescape_lowlevel ($line);
   my @ctcp;
   while ($line =~ /\G\001([^\001]*)\001/g) {
      my $msg = unescape_ctcp ($1);
      my ($tag, $data) = split / /, $msg, 2;
      push @ctcp, [$tag, $data];
   }

   $line =~ s/\001[^\001]*\001//g;

   return ($line, \@ctcp)
}

=item B<encode_ctcp (@msg)>

This function encodes a ctcp message for the trailing part of a NOTICE
or PRIVMSG. C<@msg> is an array of strings or array references.
If an array reference occurs in the C<@msg> array it's first
element will be interpreted as CTCP TAG (eg. one of PING, VERSION, .. whatever)
the rest of the array ref will be appended to the tag and seperated by
spaces.

All parts of the message will be contatenated and lowlevel quoted.
That means you can embed _any_ character from 0 to 255 in this message (thats
what the lowlevel quoting allows).

=cut

sub encode_ctcp {
   my (@args) = @_;
   escape_lowlevel (
      join "", map {
         ref $_
            ? "\001" . escape_ctcp (join " ", @$_) . "\001"
            : $_
      } @args
   )
}

=item B<filter_colors ($line)>

This function will filter out any mIRC colors and (most) ansi escape sequences.
Unfortunately the mIRC color coding will destroy improper colored numbers. So this
function may destroy the message in some occasions a bit.

=cut

sub filter_colors($) {
   my ($line) = @_;
   $line =~ s/\x1B\[.*?[\x00-\x1F\x40-\x7E]//g; # see ECMA-48 + advice by urxvt author
   $line =~ s/\x03\d\d?(?:,\d\d?)?//g;          # see http://www.mirc.co.uk/help/color.txt
   $line =~ s/[\x03\x16\x02\x1f\x0f]//g;        # see some undefined place :-)
   $line
}


# implemented after the below CTCP spec, but
# doesnt seem to be used by anyone... so it's untested.
sub filter_ctcp_text_attr_bogus {
   my ($line, $cb) = @_;
   return unless $cb;
   $line =~ s/\006([BVUSI])/{warn "FIL\n"; my $c = $cb->($1); defined $c ? $c : "\006$1"}/ieg;
   $line =~ s/\006CA((?:I[0-9A-F]|#[0-9A-F]{3}){2})/{my $c = $cb->($1); defined $c ? $c : "\006CA$1"}/ieg;
   $line =~ s/\006C([FB])(I[0-9A-F]|#[0-9A-F]{3})/{my $c = $cb->($1, $2); defined $c ? $c : "\006C$1$2"}/ieg;
   $line =~ s/\006CX([AFB])/{my $c = $cb->($1); defined $c ? $c : "\006CX$1"}/ieg;
   return $line;
}

=item B<split_prefix ($prefix)>

This function splits an IRC user prefix as described by RFC 2817
into the three parts: nickname, user and host. Which will be
returned as a list with that order.

C<$prefix> can also be a hash like it is returned by C<parse_irc_msg>.

=cut

sub split_prefix {
   my ($prfx) = @_;

   if (ref ($prfx) eq 'HASH') {
      $prfx = $prfx->{prefix};
   }

   # this splitting does indeed use the servername as nickname, but there
   # is no way for a client to distinguish.
   $prfx =~ m/^\s*([^!]*)(?:!([^@]*))?(?:@(.*?))?\s*$/;
   return ($1, $2, $3);
}

=item B<prefix_nick ($prefix)>

A shortcut to extract the nickname from the C<$prefix>.

C<$prefix> can also be a hash like it is returned by C<parse_irc_msg>.

=cut

sub prefix_nick {
   my ($prfx) = @_;
   return (split_prefix ($prfx))[0];
}

=item B<prefix_user ($prefix)>

A shortcut to extract the username from the C<$prefix>.

C<$prefix> can also be a hash like it is returned by C<parse_irc_msg>.

=cut

sub prefix_user {
   my ($prfx) = @_;
   return (split_prefix ($prfx))[1];
}

=item B<prefix_host ($prefix)>

A shortcut to extract the hostname from the C<$prefix>.

C<$prefix> can also be a hash like it is returned by C<parse_irc_msg>.

=cut

sub prefix_host {
   my ($prfx) = @_;
   return (split_prefix ($prfx))[2];
}


=item B<rfc_code_to_name ($code)>

This function is a interface to the internal mapping or numeric
replies to the reply name in RFC 2812 (which you may also consult).

C<$code> is returned if no name for C<$code> exists
(as some server may extended the protocol).

=back

=cut

our %RFC_NUMCODE_MAP = (
   '001' => 'RPL_WELCOME',
   '002' => 'RPL_YOURHOST',
   '003' => 'RPL_CREATED',
   '004' => 'RPL_MYINFO',
   '005' => 'RPL_BOUNCE',
   '200' => 'RPL_TRACELINK',
   '201' => 'RPL_TRACECONNECTING',
   '202' => 'RPL_TRACEHANDSHAKE',
   '203' => 'RPL_TRACEUNKNOWN',
   '204' => 'RPL_TRACEOPERATOR',
   '205' => 'RPL_TRACEUSER',
   '206' => 'RPL_TRACESERVER',
   '207' => 'RPL_TRACESERVICE',
   '208' => 'RPL_TRACENEWTYPE',
   '209' => 'RPL_TRACECLASS',
   '210' => 'RPL_TRACERECONNECT',
   '211' => 'RPL_STATSLINKINFO',
   '212' => 'RPL_STATSCOMMANDS',
   '219' => 'RPL_ENDOFSTATS',
   '221' => 'RPL_UMODEIS',
   '233' => 'RPL_SERVICE',
   '234' => 'RPL_SERVLIST',
   '235' => 'RPL_SERVLISTEND',
   '242' => 'RPL_STATSUPTIME',
   '243' => 'RPL_STATSOLINE',
   '250' => 'RPL_STATSDLINE',
   '251' => 'RPL_LUSERCLIENT',
   '252' => 'RPL_LUSEROP',
   '253' => 'RPL_LUSERUNKNOWN',
   '254' => 'RPL_LUSERCHANNELS',
   '255' => 'RPL_LUSERME',
   '256' => 'RPL_ADMINME',
   '257' => 'RPL_ADMINLOC1',
   '258' => 'RPL_ADMINLOC2',
   '259' => 'RPL_ADMINEMAIL',
   '261' => 'RPL_TRACELOG',
   '262' => 'RPL_TRACEEND',
   '263' => 'RPL_TRYAGAIN',
   '301' => 'RPL_AWAY',
   '302' => 'RPL_USERHOST',
   '303' => 'RPL_ISON',
   '305' => 'RPL_UNAWAY',
   '306' => 'RPL_NOWAWAY',
   '311' => 'RPL_WHOISUSER',
   '312' => 'RPL_WHOISSERVER',
   '313' => 'RPL_WHOISOPERATOR',
   '314' => 'RPL_WHOWASUSER',
   '315' => 'RPL_ENDOFWHO',
   '317' => 'RPL_WHOISIDLE',
   '318' => 'RPL_ENDOFWHOIS',
   '319' => 'RPL_WHOISCHANNELS',
   '321' => 'RPL_LISTSTART',
   '322' => 'RPL_LIST',
   '323' => 'RPL_LISTEND',
   '324' => 'RPL_CHANNELMODEIS',
   '325' => 'RPL_UNIQOPIS',
   '331' => 'RPL_NOTOPIC',
   '332' => 'RPL_TOPIC',
   '341' => 'RPL_INVITING',
   '342' => 'RPL_SUMMONING',
   '346' => 'RPL_INVITELIST',
   '347' => 'RPL_ENDOFINVITELIST',
   '348' => 'RPL_EXCEPTLIST',
   '349' => 'RPL_ENDOFEXCEPTLIST',
   '351' => 'RPL_VERSION',
   '352' => 'RPL_WHOREPLY',
   '353' => 'RPL_NAMREPLY',
   '364' => 'RPL_LINKS',
   '365' => 'RPL_ENDOFLINKS',
   '366' => 'RPL_ENDOFNAMES',
   '367' => 'RPL_BANLIST',
   '368' => 'RPL_ENDOFBANLIST',
   '369' => 'RPL_ENDOFWHOWAS',
   '371' => 'RPL_INFO',
   '372' => 'RPL_MOTD',
   '374' => 'RPL_ENDOFINFO',
   '375' => 'RPL_MOTDSTART',
   '376' => 'RPL_ENDOFMOTD',
   '381' => 'RPL_YOUREOPER',
   '382' => 'RPL_REHASHING',
   '383' => 'RPL_YOURESERVICE',
   '384' => 'RPL_MYPORTIS',
   '391' => 'RPL_TIME',
   '392' => 'RPL_USERSSTART',
   '393' => 'RPL_USERS',
   '394' => 'RPL_ENDOFUSERS',
   '395' => 'RPL_NOUSERS',
   '401' => 'ERR_NOSUCHNICK',
   '402' => 'ERR_NOSUCHSERVER',
   '403' => 'ERR_NOSUCHCHANNEL',
   '404' => 'ERR_CANNOTSENDTOCHAN',
   '405' => 'ERR_TOOMANYCHANNELS',
   '406' => 'ERR_WASNOSUCHNICK',
   '407' => 'ERR_TOOMANYTARGETS',
   '408' => 'ERR_NOSUCHSERVICE',
   '409' => 'ERR_NOORIGIN',
   '411' => 'ERR_NORECIPIENT',
   '412' => 'ERR_NOTEXTTOSEND',
   '413' => 'ERR_NOTOPLEVEL',
   '414' => 'ERR_WILDTOPLEVEL',
   '415' => 'ERR_BADMASK',
   '421' => 'ERR_UNKNOWNCOMMAND',
   '422' => 'ERR_NOMOTD',
   '423' => 'ERR_NOADMININFO',
   '424' => 'ERR_FILEERROR',
   '431' => 'ERR_NONICKNAMEGIVEN',
   '432' => 'ERR_ERRONEUSNICKNAME',
   '433' => 'ERR_NICKNAMEINUSE',
   '436' => 'ERR_NICKCOLLISION',
   '437' => 'ERR_UNAVAILRESOURCE',
   '441' => 'ERR_USERNOTINCHANNEL',
   '442' => 'ERR_NOTONCHANNEL',
   '443' => 'ERR_USERONCHANNEL',
   '444' => 'ERR_NOLOGIN',
   '445' => 'ERR_SUMMONDISABLED',
   '446' => 'ERR_USERSDISABLED',
   '451' => 'ERR_NOTREGISTERED',
   '461' => 'ERR_NEEDMOREPARAMS',
   '462' => 'ERR_ALREADYREGISTRED',
   '463' => 'ERR_NOPERMFORHOST',
   '464' => 'ERR_PASSWDMISMATCH',
   '465' => 'ERR_YOUREBANNEDCREEP',
   '466' => 'ERR_YOUWILLBEBANNED',
   '467' => 'ERR_KEYSET',
   '471' => 'ERR_CHANNELISFULL',
   '472' => 'ERR_UNKNOWNMODE',
   '473' => 'ERR_INVITEONLYCHAN',
   '474' => 'ERR_BANNEDFROMCHAN',
   '475' => 'ERR_BADCHANNELKEY',
   '476' => 'ERR_BADCHANMASK',
   '477' => 'ERR_NOCHANMODES',
   '478' => 'ERR_BANLISTFULL',
   '481' => 'ERR_NOPRIVILEGES',
   '482' => 'ERR_CHANOPRIVSNEEDED',
   '483' => 'ERR_CANTKILLSERVER',
   '484' => 'ERR_RESTRICTED',
   '485' => 'ERR_UNIQOPPRIVSNEEDED',
   '491' => 'ERR_NOOPERHOST',
   '492' => 'ERR_NOSERVICEHOST',
   '501' => 'ERR_UMODEUNKNOWNFLAG',
   '502' => 'ERR_USERSDONTMATCH',
);

sub rfc_code_to_name {
   my ($code) = @_;
   return $RFC_NUMCODE_MAP{$code} || $code;
}

=head1 AUTHOR

Robin Redeker, C<< <elmex@ta-sa.org> >>

=head1 SEE ALSO

Internet Relay Chat Client To Client Protocol from February 2, 1997
http://www.invlogic.com/irc/ctcp.html

RFC 2812 - Internet Relay Chat: Client Protocol

=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:	Sat Aug 18 12:59:37 2007 UTC (17 years, 3 months ago) by elmex
Branch:	MAIN
CVS Tags:	HEAD
Changes since 1.14:	+2 -1 lines
Log Message:	filter some more thigns...
#	User	Rev	Content
1	elmex	1.1	package Net::IRC3::Util;
2			use strict;
3	elmex	1.9	no warnings;
4	elmex	1.1	use Exporter;
5			our @ISA = qw/Exporter/;
6			our @EXPORT_OK =
7			qw(mk_msg parse_irc_msg split_prefix prefix_nick
8	elmex	1.12	decode_ctcp encode_ctcp filter_ctcp_text_attr prefix_user prefix_host
9	elmex	1.13	rfc_code_to_name filter_colors);
10	elmex	1.1
11			=head1 NAME
12
13			Net::IRC3::Util - Common utilities that help with IRC protocol handling
14
15	elmex	1.2	=head1 SYNOPSIS
16
17			use Net::IRC3 qw/parse_irc_msg mk_msg/;
18
19	elmex	1.7	my $msgdata = mk_msg (undef, PRIVMSG => "my hands glow!", "mcmanus");
20	elmex	1.2
21	elmex	1.1	=head1 FUNCTIONS
22
23			These are some utility functions that might come in handy when
24			handling the IRC protocol.
25
26			You can export these with eg.:
27
28			use Net::IRC3 qw/parse_irc_msg/;
29
30			=over 4
31
32			=item B<parse_irc_msg ($ircline)>
33
34			This method parses the C<$ircline>, which is one line of the IRC protocol
35			without the trailing "\015\012".
36
37			It returns a hash which has the following entrys:
38
39			=over 4
40
41			=item prefix
42
43			The message prefix.
44
45			=item command
46
47			The IRC command.
48
49			=item params
50
51			The parameters to the IRC command in a array reference,
52			this includes the trailing parameter (the one after the ':' or
53			the 14th parameter).
54
55			=item trailing
56
57			This is set if there was a trailing parameter (the one after the ':' or
58			the 14th parameter).
59
60			=back
61
62			=cut
63
64			sub parse_irc_msg {
65			my ($msg) = @_;
66
67			my $cmd;
68			my $pref;
69			my $t;
70			my @a;
71
72			my $p = $msg =~ s/^(:([^ ]+)[ ])?([A-Za-z]+\|\d{3})//;
73			$pref = $2;
74			$cmd = $3;
75
76			my $i = 0;
77
78			while ($msg =~ s/^[ ]([^ :\015\012\0][^ \015\012\0]*)//) {
79
80			push @a, $1 if defined $1;
81			if (++$i > 13) { last; }
82			}
83
84			if ($i == 14) {
85
86			if ($msg =~ s/^[ ]:?([^\015\012\0]*)//) {
87			$t = $1 if $1 ne "";
88			}
89
90			} else {
91
92			if ($msg =~ s/^[ ]:([^\015\012\0]*)//) {
93			$t = $1 if $1 ne "";
94			}
95			}
96
97			push @a, $t if defined $t;
98
99			my $m = { prefix => $pref, command => $cmd, params => \@a, trailing => $t };
100			return $p ? $m : undef;
101			}
102
103			=item B<mk_msg ($prefix, $command, $trailing, @params)>
104
105			This function assembles a IRC message. The generated
106			message will look like (pseudo code!)
107
108			:<prefix> <command> <params> :<trail>
109
110			Please refer to RFC 2812 how IRC messages normally look like.
111
112			The prefix and the trailing string will be omitted if they are C<undef>.
113
114			EXAMPLES:
115
116			mk_msg (undef, "PRIVMSG", "you suck!", "magnus");
117			# will return: "PRIVMSG magnus :you suck!\015\012"
118
119			mk_msg (undef, "JOIN", undef, "#test");
120	elmex	1.5	# will return: "JOIN #test\015\012"
121	elmex	1.1
122			=cut
123
124			sub mk_msg {
125			my ($prefix, $command, $trail, @params) = @_;
126			my $msg = "";
127
128			$msg .= defined $prefix ? ":$prefix " : "";
129			$msg .= "$command";
130
131			# FIXME: params must be counted, and if > 13 they have to be
132			# concationated with $trail
133			map { $msg .= " $_" } @params;
134
135			$msg .= defined $trail ? " :$trail" : "";
136			$msg .= "\015\012";
137
138			return $msg;
139			}
140
141	elmex	1.12	my @_ctcp_lowlevel_escape = ("\000", "0", "\012", "n", "\015", "r", "\020", "\020");
142
143			sub unescape_lowlevel {
144			my ($data) = @_;
145			my %map = reverse @_ctcp_lowlevel_escape;
146			$data =~ s/\020(.)/defined $map{$1} ? $map{$1} : $1/ge;
147			$data
148			}
149
150			sub escape_lowlevel {
151			my ($data) = @_;
152			my %map = @_ctcp_lowlevel_escape;
153			$data =~ s/([\000\012\015\020])/"\020$map{$1}"/ge;
154			$data
155			}
156
157			sub unescape_ctcp {
158			my ($data) = @_;
159			$data =~ s/\\(.)/$1 eq 'a' ? "\001" : ($1 eq "\\" ? "\\" : $1)/eg;
160			$data
161			}
162
163			sub escape_ctcp {
164			my ($data) = @_;
165			$data =~ s/([\\\001])/$1 eq "\001" ? "\\a" : "\\\\"/eg;
166			$data
167			}
168
169			=item B<decode_ctcp ($trailing)>
170
171			This function decodes the C<$trailing> part of an IRC message.
172			It will first unescape the lower layer, extract CTCP messages
173			and then return a list with two elements: the line without the ctcp messages
174			and an array reference which contains array references of CTCP messages.
175			Those CTCP message array references will have the CTCP message tag as
176			first element (eg. "VERSION") and the rest of the CTCP message as the second
177			element.
178
179			=cut
180
181	elmex	1.1	sub decode_ctcp {
182	elmex	1.6	my ($line) = @_;
183	elmex	1.1
184	elmex	1.12	$line = unescape_lowlevel ($line);
185			my @ctcp;
186	elmex	1.6	while ($line =~ /\G\001([^\001]*)\001/g) {
187	elmex	1.12	my $msg = unescape_ctcp ($1);
188			my ($tag, $data) = split / /, $msg, 2;
189			push @ctcp, [$tag, $data];
190	elmex	1.6	}
191	elmex	1.1
192	elmex	1.6	$line =~ s/\001[^\001]*\001//g;
193	elmex	1.1
194	elmex	1.12	return ($line, \@ctcp)
195			}
196
197			=item B<encode_ctcp (@msg)>
198
199			This function encodes a ctcp message for the trailing part of a NOTICE
200			or PRIVMSG. C<@msg> is an array of strings or array references.
201			If an array reference occurs in the C<@msg> array it's first
202			element will be interpreted as CTCP TAG (eg. one of PING, VERSION, .. whatever)
203			the rest of the array ref will be appended to the tag and seperated by
204			spaces.
205
206			All parts of the message will be contatenated and lowlevel quoted.
207			That means you can embed _any_ character from 0 to 255 in this message (thats
208			what the lowlevel quoting allows).
209
210			=cut
211
212			sub encode_ctcp {
213			my (@args) = @_;
214			escape_lowlevel (
215			join "", map {
216			ref $_
217			? "\001" . escape_ctcp (join " ", @$_) . "\001"
218			: $_
219			} @args
220			)
221	elmex	1.6	}
222	elmex	1.1
223	elmex	1.13	=item B<filter_colors ($line)>
224	elmex	1.8
225	elmex	1.13	This function will filter out any mIRC colors and (most) ansi escape sequences.
226			Unfortunately the mIRC color coding will destroy improper colored numbers. So this
227			function may destroy the message in some occasions a bit.
228	elmex	1.8
229			=cut
230	elmex	1.13
231	elmex	1.14	sub filter_colors($) {
232	elmex	1.13	my ($line) = @_;
233			$line =~ s/\x1B\[.*?[\x00-\x1F\x40-\x7E]//g; # see ECMA-48 + advice by urxvt author
234	elmex	1.15	$line =~ s/\x03\d\d?(?:,\d\d?)?//g; # see http://www.mirc.co.uk/help/color.txt
235			$line =~ s/[\x03\x16\x02\x1f\x0f]//g; # see some undefined place :-)
236	elmex	1.13	$line
237			}
238
239
240	elmex	1.6	# implemented after the below CTCP spec, but
241			# doesnt seem to be used by anyone... so it's untested.
242	elmex	1.13	sub filter_ctcp_text_attr_bogus {
243	elmex	1.6	my ($line, $cb) = @_;
244	elmex	1.10	return unless $cb;
245	elmex	1.6	$line =~ s/\006([BVUSI])/{warn "FIL\n"; my $c = $cb->($1); defined $c ? $c : "\006$1"}/ieg;
246			$line =~ s/\006CA((?:I[0-9A-F]\|#[0-9A-F]{3}){2})/{my $c = $cb->($1); defined $c ? $c : "\006CA$1"}/ieg;
247			$line =~ s/\006C([FB])(I[0-9A-F]\|#[0-9A-F]{3})/{my $c = $cb->($1, $2); defined $c ? $c : "\006C$1$2"}/ieg;
248			$line =~ s/\006CX([AFB])/{my $c = $cb->($1); defined $c ? $c : "\006CX$1"}/ieg;
249			return $line;
250	elmex	1.1	}
251
252			=item B<split_prefix ($prefix)>
253
254			This function splits an IRC user prefix as described by RFC 2817
255			into the three parts: nickname, user and host. Which will be
256			returned as a list with that order.
257
258			C<$prefix> can also be a hash like it is returned by C<parse_irc_msg>.
259
260			=cut
261
262			sub split_prefix {
263			my ($prfx) = @_;
264
265			if (ref ($prfx) eq 'HASH') {
266			$prfx = $prfx->{prefix};
267			}
268
269	elmex	1.11	# this splitting does indeed use the servername as nickname, but there
270			# is no way for a client to distinguish.
271			$prfx =~ m/^\s([^!])(?:!([^@]))?(?:@(.?))?\s*$/;
272	elmex	1.1	return ($1, $2, $3);
273			}
274
275			=item B<prefix_nick ($prefix)>
276
277			A shortcut to extract the nickname from the C<$prefix>.
278
279			C<$prefix> can also be a hash like it is returned by C<parse_irc_msg>.
280
281			=cut
282
283			sub prefix_nick {
284			my ($prfx) = @_;
285			return (split_prefix ($prfx))[0];
286			}
287
288			=item B<prefix_user ($prefix)>
289
290			A shortcut to extract the username from the C<$prefix>.
291
292			C<$prefix> can also be a hash like it is returned by C<parse_irc_msg>.
293
294			=cut
295
296			sub prefix_user {
297			my ($prfx) = @_;
298			return (split_prefix ($prfx))[1];
299			}
300
301			=item B<prefix_host ($prefix)>
302
303			A shortcut to extract the hostname from the C<$prefix>.
304
305			C<$prefix> can also be a hash like it is returned by C<parse_irc_msg>.
306
307			=cut
308
309			sub prefix_host {
310	elmex	1.8	my ($prfx) = @_;
311	elmex	1.1	return (split_prefix ($prfx))[2];
312			}
313
314
315	elmex	1.7	=item B<rfc_code_to_name ($code)>
316
317			This function is a interface to the internal mapping or numeric
318			replies to the reply name in RFC 2812 (which you may also consult).
319
320			C<$code> is returned if no name for C<$code> exists
321			(as some server may extended the protocol).
322
323	elmex	1.8	=back
324
325	elmex	1.7	=cut
326
327			our %RFC_NUMCODE_MAP = (
328			'001' => 'RPL_WELCOME',
329			'002' => 'RPL_YOURHOST',
330			'003' => 'RPL_CREATED',
331			'004' => 'RPL_MYINFO',
332			'005' => 'RPL_BOUNCE',
333			'200' => 'RPL_TRACELINK',
334			'201' => 'RPL_TRACECONNECTING',
335			'202' => 'RPL_TRACEHANDSHAKE',
336			'203' => 'RPL_TRACEUNKNOWN',
337			'204' => 'RPL_TRACEOPERATOR',
338			'205' => 'RPL_TRACEUSER',
339			'206' => 'RPL_TRACESERVER',
340			'207' => 'RPL_TRACESERVICE',
341			'208' => 'RPL_TRACENEWTYPE',
342			'209' => 'RPL_TRACECLASS',
343			'210' => 'RPL_TRACERECONNECT',
344			'211' => 'RPL_STATSLINKINFO',
345			'212' => 'RPL_STATSCOMMANDS',
346			'219' => 'RPL_ENDOFSTATS',
347			'221' => 'RPL_UMODEIS',
348			'233' => 'RPL_SERVICE',
349			'234' => 'RPL_SERVLIST',
350			'235' => 'RPL_SERVLISTEND',
351			'242' => 'RPL_STATSUPTIME',
352			'243' => 'RPL_STATSOLINE',
353			'250' => 'RPL_STATSDLINE',
354			'251' => 'RPL_LUSERCLIENT',
355			'252' => 'RPL_LUSEROP',
356			'253' => 'RPL_LUSERUNKNOWN',
357			'254' => 'RPL_LUSERCHANNELS',
358			'255' => 'RPL_LUSERME',
359			'256' => 'RPL_ADMINME',
360			'257' => 'RPL_ADMINLOC1',
361			'258' => 'RPL_ADMINLOC2',
362			'259' => 'RPL_ADMINEMAIL',
363			'261' => 'RPL_TRACELOG',
364			'262' => 'RPL_TRACEEND',
365			'263' => 'RPL_TRYAGAIN',
366			'301' => 'RPL_AWAY',
367			'302' => 'RPL_USERHOST',
368			'303' => 'RPL_ISON',
369			'305' => 'RPL_UNAWAY',
370			'306' => 'RPL_NOWAWAY',
371			'311' => 'RPL_WHOISUSER',
372			'312' => 'RPL_WHOISSERVER',
373			'313' => 'RPL_WHOISOPERATOR',
374			'314' => 'RPL_WHOWASUSER',
375			'315' => 'RPL_ENDOFWHO',
376			'317' => 'RPL_WHOISIDLE',
377			'318' => 'RPL_ENDOFWHOIS',
378			'319' => 'RPL_WHOISCHANNELS',
379			'321' => 'RPL_LISTSTART',
380			'322' => 'RPL_LIST',
381			'323' => 'RPL_LISTEND',
382			'324' => 'RPL_CHANNELMODEIS',
383			'325' => 'RPL_UNIQOPIS',
384			'331' => 'RPL_NOTOPIC',
385			'332' => 'RPL_TOPIC',
386			'341' => 'RPL_INVITING',
387			'342' => 'RPL_SUMMONING',
388			'346' => 'RPL_INVITELIST',
389			'347' => 'RPL_ENDOFINVITELIST',
390			'348' => 'RPL_EXCEPTLIST',
391			'349' => 'RPL_ENDOFEXCEPTLIST',
392			'351' => 'RPL_VERSION',
393			'352' => 'RPL_WHOREPLY',
394			'353' => 'RPL_NAMREPLY',
395			'364' => 'RPL_LINKS',
396			'365' => 'RPL_ENDOFLINKS',
397			'366' => 'RPL_ENDOFNAMES',
398			'367' => 'RPL_BANLIST',
399			'368' => 'RPL_ENDOFBANLIST',
400			'369' => 'RPL_ENDOFWHOWAS',
401			'371' => 'RPL_INFO',
402			'372' => 'RPL_MOTD',
403			'374' => 'RPL_ENDOFINFO',
404			'375' => 'RPL_MOTDSTART',
405			'376' => 'RPL_ENDOFMOTD',
406			'381' => 'RPL_YOUREOPER',
407			'382' => 'RPL_REHASHING',
408			'383' => 'RPL_YOURESERVICE',
409			'384' => 'RPL_MYPORTIS',
410			'391' => 'RPL_TIME',
411			'392' => 'RPL_USERSSTART',
412			'393' => 'RPL_USERS',
413			'394' => 'RPL_ENDOFUSERS',
414			'395' => 'RPL_NOUSERS',
415			'401' => 'ERR_NOSUCHNICK',
416			'402' => 'ERR_NOSUCHSERVER',
417			'403' => 'ERR_NOSUCHCHANNEL',
418			'404' => 'ERR_CANNOTSENDTOCHAN',
419			'405' => 'ERR_TOOMANYCHANNELS',
420			'406' => 'ERR_WASNOSUCHNICK',
421			'407' => 'ERR_TOOMANYTARGETS',
422			'408' => 'ERR_NOSUCHSERVICE',
423			'409' => 'ERR_NOORIGIN',
424			'411' => 'ERR_NORECIPIENT',
425			'412' => 'ERR_NOTEXTTOSEND',
426			'413' => 'ERR_NOTOPLEVEL',
427			'414' => 'ERR_WILDTOPLEVEL',
428			'415' => 'ERR_BADMASK',
429			'421' => 'ERR_UNKNOWNCOMMAND',
430			'422' => 'ERR_NOMOTD',
431			'423' => 'ERR_NOADMININFO',
432			'424' => 'ERR_FILEERROR',
433			'431' => 'ERR_NONICKNAMEGIVEN',
434			'432' => 'ERR_ERRONEUSNICKNAME',
435			'433' => 'ERR_NICKNAMEINUSE',
436			'436' => 'ERR_NICKCOLLISION',
437			'437' => 'ERR_UNAVAILRESOURCE',
438			'441' => 'ERR_USERNOTINCHANNEL',
439			'442' => 'ERR_NOTONCHANNEL',
440			'443' => 'ERR_USERONCHANNEL',
441			'444' => 'ERR_NOLOGIN',
442			'445' => 'ERR_SUMMONDISABLED',
443			'446' => 'ERR_USERSDISABLED',
444			'451' => 'ERR_NOTREGISTERED',
445			'461' => 'ERR_NEEDMOREPARAMS',
446			'462' => 'ERR_ALREADYREGISTRED',
447			'463' => 'ERR_NOPERMFORHOST',
448			'464' => 'ERR_PASSWDMISMATCH',
449			'465' => 'ERR_YOUREBANNEDCREEP',
450			'466' => 'ERR_YOUWILLBEBANNED',
451			'467' => 'ERR_KEYSET',
452			'471' => 'ERR_CHANNELISFULL',
453			'472' => 'ERR_UNKNOWNMODE',
454			'473' => 'ERR_INVITEONLYCHAN',
455			'474' => 'ERR_BANNEDFROMCHAN',
456			'475' => 'ERR_BADCHANNELKEY',
457			'476' => 'ERR_BADCHANMASK',
458			'477' => 'ERR_NOCHANMODES',
459			'478' => 'ERR_BANLISTFULL',
460			'481' => 'ERR_NOPRIVILEGES',
461			'482' => 'ERR_CHANOPRIVSNEEDED',
462			'483' => 'ERR_CANTKILLSERVER',
463			'484' => 'ERR_RESTRICTED',
464			'485' => 'ERR_UNIQOPPRIVSNEEDED',
465			'491' => 'ERR_NOOPERHOST',
466			'492' => 'ERR_NOSERVICEHOST',
467			'501' => 'ERR_UMODEUNKNOWNFLAG',
468			'502' => 'ERR_USERSDONTMATCH',
469			);
470
471			sub rfc_code_to_name {
472			my ($code) = @_;
473			return $RFC_NUMCODE_MAP{$code} \|\| $code;
474			}
475
476	elmex	1.1	=head1 AUTHOR
477
478			Robin Redeker, C<< <elmex@ta-sa.org> >>
479
480			=head1 SEE ALSO
481
482	elmex	1.6	Internet Relay Chat Client To Client Protocol from February 2, 1997
483			http://www.invlogic.com/irc/ctcp.html
484
485	elmex	1.1	RFC 2812 - Internet Relay Chat: Client Protocol
486
487			=head1 COPYRIGHT & LICENSE
488
489	elmex	1.3	Copyright 2006 Robin Redeker, all rights reserved.
490	elmex	1.1
491			This program is free software; you can redistribute it and/or modify it
492			under the same terms as Perl itself.
493
494			=cut
495
496			1;