File Coverage

blib/lib/IRC/Toolkit/CTCP.pm

Criterion	Covered	Total	%
statement	48	56	85.7
branch	20	38	52.6
condition	3	6	50.0
subroutine	8	8	100.0
pod	3	3	100.0
total	82	111	73.8

package IRC::Toolkit::CTCP;
$IRC::Toolkit::CTCP::VERSION = '0.092002';
use strictures 2;
use Carp 'confess';

use parent 'Exporter::Tiny';
our @EXPORT = qw/
  ctcp_quote
  ctcp_unquote
  ctcp_extract
/;

use IRC::Message::Object 'ircmsg';

use Scalar::Util 'blessed';

my %quote = (
  "\012" => 'n',
  "\015" => 'r',
  "\0"   => '0',
  "\cP"  => "\cP",
);
my %dequote = reverse %quote;

## CTCP handling logic borrowed from POE::Filter::IRC::Compat  /  Net::IRC
##  (by BinGOs, fimm, Abigail et al)

sub ctcp_quote {
  my ($line) = @_;
  confess "Expected a line" unless defined $line;

  if ($line =~ tr/[\012\015\0\cP]//) {
    $line =~ s/([\012\015\0\cP])/\cP$quote{$1}/g;
  }

  $line =~ s/\001/\\a/g;
  "\001$line\001"
}

sub ctcp_unquote {
  my ($line) = @_;
  confess "Expected a line" unless defined $line;

  if ($line =~ tr/\cP//) {
    $line =~ s/\cP([nr0\cP])/$dequote{$1}/g;
  }

  substr $line, rindex($line, "\001"), 1, '\\a'
    if ($line =~ tr/\001//) % 2 != 0;
  return unless $line =~ tr/\001//;

  my @chunks = split /\001/, $line;
  shift @chunks unless length $chunks[0];
  ## De-quote / convert escapes
  s/\\([^\\a])/$1/g, s/\\\\/\\/g, s/\\a/\001/g for @chunks;

  my (@ctcp, @text);

  ## If we start with a ctrl+A, the first chunk is CTCP:
  if (index($line, "\001") == 0) {
    push @ctcp, shift @chunks;
  }
  ## Otherwise we start with text and alternate CTCP:
  while (@chunks) {
    push @text, shift @chunks;
    push @ctcp, shift @chunks if @chunks;
  }

  +{ ctcp => \@ctcp, text => \@text }
}

sub ctcp_extract {
  my ($input) = @_;

  unless (blessed $input && $input->isa('IRC::Message::Object')) {
    $input = ref $input ?
      ircmsg(%$input) : ircmsg(raw_line => $input)
  }

  my $type = uc($input->command) eq 'PRIVMSG' ? 'ctcp' : 'ctcpreply' ;
  my $line = $input->params->[1];
  my $unquoted = ctcp_unquote($line);
  return unless $unquoted and @{ $unquoted->{ctcp} };

  my ($name, $params);
  CTCP: for my $str ($unquoted->{ctcp}->[0]) {
    ($name, $params) = $str =~ /^(\w+)(?: +(.*))?/;
    last CTCP unless $name;
    $name = lc $name;
    if ($name eq 'dcc') {
      ## Does no extra work to parse DCC
      ## ... but see POE::Filter::IRC::Compat for that
      my ($dcc_type, $dcc_params) = $params =~ /^(\w+) +(.+)/;
      last CTCP unless $dcc_type;
      return ircmsg(
        ( $input->prefix ? (prefix => $input->prefix) : () ),
        command => 'dcc_request_'.lc($dcc_type),
        params  => [
          $input->prefix,
          $dcc_params
        ],
        raw_line => $input->raw_line,
      )
    } else {
      return ircmsg(
        ( $input->prefix ? (prefix => $input->prefix) : () ),
        command => $type .'_'. $name,
        params  => [
          $input->params->[0],
          ( defined $params ? $params : '' ),
        ],
        raw_line => $input->raw_line,
      )
    }
  }

  undef
}


1;

=pod

=head1 NAME

IRC::Toolkit::CTCP - CTCP parsing utilities

=head1 SYNOPSIS

  ## Extract first CTCP request/reply from a message:
  if (my $ctcp_ev = ctcp_extract( $orig_msg ) ) {
    ## CTCP was found; $ctcp_ev is an IRC::Message::Object
    ...
  }

  ## Properly CTCP-quote a string:
  my $quoted_ctcp = ctcp_quote("PING 1234");

  ## Deparse CTCP messages (including multipart):
  if (my $ref = ctcp_unquote($raw_line)) {
    my @ctcp = @{ $ref->{ctcp} };
    my @txt  = @{ $ref->{text} };
    ...
  }

=head1 DESCRIPTION

Utility functions useful for quoting/unquoting/extracting CTCP.

=head2 ctcp_extract

Takes input (in the form of an L instance,
a hash such as that produced by L, or a
raw line) and attempts to extract a valid CTCP request or reply.

Returns an L whose C carries an
appropriate prefix (one of B, B, or B) prepended
to the CTCP command:

  ## '$ev' is your incoming or outgoing IRC::Message::Object
  ## CTCP VERSION request:
  $ev->command eq 'ctcp_version'

  ## Reply to CTCP VERSION:
  $ev->command eq 'ctcpreply_version'

  ## DCC SEND:
  $ev->command eq 'dcc_request_send'

Returns C if no valid CTCP was found; this is a breaking change in
C, as previous versions returned the empty list.

=head2 ctcp_quote

CTCP quote a raw line.

=head2 ctcp_unquote

Deparses a raw line possibly containing CTCP.

Returns a hash with two keys, B and B, whose values are
ARRAYs containing the CTCP and text portions of a CTCP-quoted message.

Returns an empty list if no valid CTCP was found.

=head1 AUTHOR

Jon Portnoy

Code derived from L and L,
copyright BinGOs, HINRIK, fimm, Abigail et al

Licensed under the same terms as Perl.

=cut