view release on metacpan or  search on metacpan

lib/AnyEvent/IRC/Util.pm  view on Meta::CPAN

   } else {
      if ($msg =~ s/^[ ]:([^\015\012\0]*)//) {
         push @{$msg{params}}, $1 if defined $1;
      }
   }

   \%msg
}

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

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

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

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

The prefix will be omitted if they are C<undef>.

Please note that only the last parameter may contain spaces, and if it
contains spaces it will be quoted as the trailing part of the
IRC message.

NOTE: The trailing "\015\012" is NOT added by this function!

EXAMPLES:

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

   mk_msg (undef, "PRIVMSG", "magnus", "Hi!");
   # will return: "PRIVMSG magnus :Hi!"

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

=cut

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

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

  my $trail;
  if (@params && ($params[-1] =~ /\x20/ || $params[-1] =~ /^:/)) {
     $trail = pop @params;
  }

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

  $msg .= defined $trail ? " :$trail" : "";

  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 ($data)>

This function decodes CTCP messages contained in an IRC message.
C<$data> should be the last parameter of a IRC PRIVMSG or NOTICE.

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;

   # 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)
}

=item B<encode_ctcp (@msg)>

This function encodes a CTCP message for the transmission via the NOTICE
or PRIVMSG command. 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 separated by
spaces.

All parts of the message will be concatenated 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<is_nick_prefix ($prefix)>

Returns true if the prefix is a nick prefix, containing user and host.

=cut

sub is_nick_prefix {
   my ($prfx) = @_;
   $prfx =~ m/^\s*([^!]+)!([^@]+)@(.+)?\s*$/;
}