package Net::IRC3::Util; use strict; use Exporter; our @ISA = qw/Exporter/; our @EXPORT_OK = qw(mk_msg parse_irc_msg split_prefix prefix_nick decode_ctcp filter_ctcp_text_attr prefix_user prefix_host); =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 =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 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 This function assembles a IRC message. The generated message will look like (pseudo code!) : : Please refer to RFC 2812 how IRC messages normally look like. The prefix and the trailing string will be omitted if they are C. 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; } =item B =cut sub decode_ctcp { my ($line) = @_; while ($line =~ /\G\001([^\001]*)\001/g) { my $req = $1; } $line =~ s/\001[^\001]*\001//g; return $line; } # implemented after the below CTCP spec, but # doesnt seem to be used by anyone... so it's untested. sub filter_ctcp_text_attr { my ($line, $cb) = @_; $cb ||= sub { '' }; $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 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. =cut sub split_prefix { my ($prfx) = @_; if (ref ($prfx) eq 'HASH') { $prfx = $prfx->{prefix}; } $prfx =~ m/^\s*([^!]*)!([^@]*)@(.*?)\s*$/; return ($1, $2, $3); } =item B A shortcut to extract the nickname from the C<$prefix>. C<$prefix> can also be a hash like it is returned by C. =cut sub prefix_nick { my ($prfx) = @_; return (split_prefix ($prfx))[0]; } =item B A shortcut to extract the username from the C<$prefix>. C<$prefix> can also be a hash like it is returned by C. =cut sub prefix_user { my ($prfx) = @_; return (split_prefix ($prfx))[1]; } =item B A shortcut to extract the hostname from the C<$prefix>. C<$prefix> can also be a hash like it is returned by C. =cut sub prefix_host { my ($self, $prfx) = @_; return (split_prefix ($prfx))[2]; } =back =head1 AUTHOR Robin Redeker, C<< >> =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;