File Coverage

blib/lib/POE/Filter/CTCP/Hybrid.pm

Criterion	Covered	Total	%
statement	12	89	13.4
branch	0	40	0.0
condition	0	3	0.0
subroutine	4	12	33.3
pod	4	4	100.0
total	20	148	13.5

# $Id: Filter-CTCP.pm,v 1.3 1999/12/12 11:48:07 dennis Exp $
#
# POE::Filter::CTCP, by Dennis Taylor
#
# This module may be used, modified, and distributed under the same
# terms as Perl itself. Please see the license that came with your Perl
# distribution for details.
#

package POE::Filter::CTCP::Hybrid;

push (@INC,".");
use strict;
use Carp;
use File::Basename ();
use POE::Filter::IRC::Hybrid;


# Create a new, empty POE::Filter::CTCP object.
sub new {
  my $class = shift;
  my %args = @_;

  my $self = { 'irc_filter' => POE::Filter::IRC::Hybrid->new() };
  bless $self, $class;
}


# Set/clear the 'debug' flag.
sub debug {
  my $self = shift;
  $self->{'debug'} = $_[0] if @_;
  return( $self->{'debug'} );
}


# For each line of raw CTCP input data that we're fed, spit back the
# appropriate CTCP and normal message events.
sub get {
  my ($self, $lineref) = @_;
  my ($who, $type, $where, $ctcp, $text, $name, $args);
  my $events = [];

 LINE:
  foreach my $line (@$lineref) {
    ($who, $type, $where, $ctcp, $text) = _ctcp_dequote( $line );

    foreach (@$ctcp) {
      ($name, $args) = $_ =~ /^(\w+)(?: (.*))?/
	or do { warn "Received malformed CTCP message: \"$_\""; next LINE; };
      if (lc $name eq 'dcc') {
	$args =~ /^(\w+) (\S+) (\d+) (\d+)(?: (\d+))?$/
	  or do { warn "Received malformed DCC request: \"$_\""; next LINE; };
	my $basename = File::Basename::basename( $2 );
	push @$events, { name => 'dcc_request',
			 args => [ $who, uc $1, $4, { open => undef,
						      nick => $who,
						      type => uc $1,
						      file => $basename,
						      size => $5,
						      done => 0,
						      addr => $3,
						      port => $4,
						    }, $basename, $5 ]
		       };

      } else {
	push @$events, { name => $type . '_' . lc $name,
			 args => [ $who, [split /,/, $where],
				   (defined $args ? $args : '') ]
		       };
      }
    }

    if ($text and @$text > 0) {
      $line =~ /^(:\S+ +\w+ +\S+ +)/ or warn "What the heck? \"$line\"";
      $text = $1 . ':' . join '', @$text;
      $text =~ s/\cP/^P/g;
      warn "CTCP: $text\n" if $self->{'debug'};
      push @$events, @{$self->{irc_filter}->get( [$text] )};
    }
  }

  return $events;
}


# For each line of text we're fed, spit back a CTCP-quoted version of
# that line.
sub put {
  my ($self, $lineref) = @_;
  my $quoted = [];

  foreach my $line (@$lineref) {
    push @$quoted, _ctcp_quote( $line );
  }

  return $quoted;
}


# Quotes a string in a low-level, protocol-safe, utterly brain-dead
# fashion. Returns the quoted string.
sub _low_quote {
  my $line = shift;
  my %enquote = ("\012" => 'n', "\015" => 'r', "\0" => '0', "\cP" => "\cP");

  unless (defined $line) {
    die "Not enough arguments to POE::Filter::CTCP->_low_quote";
  }

  if ($line =~ tr/[\012\015\0\cP]//) { # quote \n, \r, ^P, and \0.
    $line =~ s/([\012\015\0\cP])/\cP$enquote{$1}/g;
  }

  return $line;
}


# Does low-level dequoting on CTCP messages. I hate this protocol.
# Yes, I copied this whole section out of Net::IRC.
sub _low_dequote {
  my $line = shift;
  my %dequote = (n => "\012", r => "\015", 0 => "\0", "\cP" => "\cP");

  unless (defined $line) {
    die "Not enough arguments to POE::Filter::CTCP->_low_dequote";
  }

  # Thanks to Abigail ([e-mail]) for this clever bit.
  if ($line =~ tr/\cP//) {	# dequote \n, \r, ^P, and \0.
    $line =~ s/\cP([nr0\cP])/$dequote{$1}/g;
  }

  return $line;
}


# Properly CTCP-quotes a message. Whoop.
sub _ctcp_quote {
  my $line = shift;

  $line = _low_quote( $line );
#  $line =~ s/\\/\\\\/g;
  $line =~ s/\001/\\a/g;

  return "\001" . $line . "\001";
}


# Splits a message into CTCP and text chunks. This is gross. Most of
# this is also stolen from Net::IRC, but I wrote that too, so it's
# used with permission. ;-)
sub _ctcp_dequote {
  my $line = shift;
  my (@chunks, $ctcp, $text, $who, $type, $where, $msg);

  # CHUNG! CHUNG! CHUNG!

  unless (defined $line) {
    die "Not enough arguments to POE::Filter::CTCP->_ctcp_dequote";
  }

  # Strip out any low-level quoting in the text.
  $line = _low_dequote( $line );

  # Filter misplaced \001s before processing... (Thanks, tchrist!)
  substr($line, rindex($line, "\001"), 1) = '\\a'
    unless ($line =~ tr/\001//) % 2 == 0;

  return unless $line =~ tr/\001//;

  ($who, $type, $where, $msg) = ($line =~ /^:(\S+) +(\w+) +(\S+) +:?(.*)$/)
    or return;
  @chunks = split /\001/, $msg;
  shift @chunks unless length $chunks[0]; # FIXME: Is this safe?

  foreach (@chunks) {
    # Dequote unnecessarily quoted chars, and convert escaped \'s and ^A's.
    s/\\([^\\a])/$1/g;
    s/\\\\/\\/g;
    s/\\a/\001/g;
  }

  # If the line begins with a control-A, the first chunk is a CTCP
  # message. Otherwise, it starts with text and alternates with CTCP
  # messages. Really stupid protocol.

  if ($msg =~ /^\001/) {
    push @$ctcp, shift @chunks;
  }

  while (@chunks) {
    push @$text, shift @chunks;
    push @$ctcp, shift @chunks if @chunks;
  }

  # Is this a CTCP request or reply?
  if ($type eq 'PRIVMSG') {
    $type = 'ctcp';
  } else {
    $type = 'ctcpreply';
  }

  return ($who, $type, $where, $ctcp, $text);
}


1;

__END__