Net::xAP - A base class for protocols such as IMAP, ACAP, IMSP, and ICAP.

#!/usr/local/bin/perl
#
# Copyright (c) 1997-1999 Kevin Johnson <kjj@pobox.com>.
#
# All rights reserved. This program is free software; you can
# redistribute it and/or modify it under the same terms as Perl
# itself.
#
# $Id: xAP.pm,v 1.2 1999/10/03 15:00:19 kjj Exp $

require 5.005;

package Net::xAP;

use strict;

use IO::Socket;
use Carp;

use vars qw($VERSION @ISA);

$VERSION = '0.02';

use constant ATOM => 0;
use constant ASTRING => 1;
use constant PARENS => 2;
use constant STRING => 3;
use constant SASLRESP => 4;
use constant QSTRING => 5;

sub last_command_time { return $_[0]->{LastCmdTime} }

sub connection { return $_[0]->{Connection} }

sub new {
  my $class = shift;
  my $type = ref($class) || $class;
  my $host = shift;
  my $peerport = shift;
  my %options = @_;

  my $self = bless {}, $class;

  $self->{Options}  = {%options};

  # some default option settings
  $self->{Options}{Synchronous} ||= 1;
  $self->{Options}{Debug} ||= 0;
  $self->{Options}{NonSyncLits} ||= 0;

  if (substr($host, 0, 1) eq '/') {
    my ($child, $parent) = IO::Socket->socketpair(AF_UNIX,
						  SOCK_STREAM, PF_UNSPEC)
      or croak "socketpair: $!";
    $child->autoflush(1);
    $parent->autoflush(1);
    my $pid;
    if ($pid = fork) {
      $self->{Connection} = $child;
      $parent->close;
    } else {
      croak "can't fork: $!\n" unless defined($pid);
      $child->close;
      open(STDIN,  "<&" . $parent->fileno)
	or croak "can't dup parent to stdin: $!\n";
      open(STDOUT, ">&" . $parent->fileno)
	or croak "can't dup parent to stdout: $!\n";
      $^W = 0;			# squelch warning emitted by exec()
      exec($host) or croak "can't exec $host: $!\n";
    }
  } else {
    $self->{Connection} = IO::Socket::INET->new(PeerAddr => $host,
						PeerPort => $peerport,
						Proto => 'tcp',
						%options) or return undef;
    $self->{Connection}->autoflush(1);
  }

  $self->{Pending} = ();
  $self->{Sequence} = 0;

  return $self;
}

sub command {
  my $self = shift;
  my $cmd_callback = shift;
  my $cmd = shift;

  unless ($#_ % 2) {
    carp("odd number of args given to Net::xAP command method");
    return undef;
  }
  unless (defined($self->{Connection})) {
    carp("no connection open in $self");
    return undef;
  }

  my $resp;

  $self->{Sequence}++;

  $self->{Pending}{$self->{Sequence}} = $cmd_callback;

  my @list = ($self->{Sequence}, $cmd);
  while (my ($type, $value) = splice @_, 0, 2) {
    if ($type == ATOM) {	# maybe we should check for non-ATOM chars
      push @list, $value;
    } elsif ($type == PARENS) {
      push @list, '(' . join(' ', @{$value}) . ')';
    } elsif ($type == QSTRING) {
      $value =~ s/([\\\"])/\\$1/g;
      push @list, "\"$value\"";
    } elsif (($type == ASTRING) || ($type == STRING)) {
      my $astring
	= ($type == ASTRING)
	  ? $self->_as_astring($value)
	    : $self->_as_string($value);
      if (ref($astring) eq 'ARRAY') {
	if ($self->{Options}{NonSyncLits}) {
	  push @list, "{$astring->[0]+}\r\n$astring->[1]";
	} else {
	  push @list, "{$astring->[0]}";
	  $self->_send_string(join(' ', @list))->_send_eol;
	  my $list;
	  my $tag;
	  # loop until we get a continuation request or a
	  # command-completion response
	  while (1) {
	    my $str = $self->getline;
	    $tag = substr($str, 0, index($str, ' '));
	    last if ($tag eq '+');
	    last if (defined($self->_process_response($str)));
	  }
	  @list = ($astring->[1]) if $tag eq '+'
	}
      } else {
	push @list, $astring;
      }
    } elsif ($type == SASLRESP) {
      $self->_send_string(join(' ', @list))->_send_eol;
      my $list;
      my $tag;
      my $func = $value;
      my $i = 0;
    SASL: while (1) {
	my $str;
	while (1) {
	  $str = $self->getline;
	  ($tag) = split(/\s/, $str);
	  # $tag = substr($str, 0, index($str, ' '));
	  last if ($tag eq '+');
	  last SASL if (defined($resp = $self->_process_response($str)));
	}
	if ($tag eq '+') {
	  $str = substr($str, 2);
	  my $saslresp = &$func($i++, $str);
	  last unless defined($saslresp);
	  $self->_send_string($saslresp)->_send_eol;
	  next;
	}
      }
      @list = ();
    } else {
      croak "unknown argument type: $type";
    }
  }
  $self->_send_string(join(' ', @list))->_send_eol if (scalar @list);
  $self->{LastCmdTime} = time;
  if ($self->{Options}{Synchronous}) {
    return $resp if defined($resp);
    return $self->response;
  }
  return $self->{Sequence};
}

sub parse_fields {
  my $self = shift;
  my $str = shift;
  return undef unless defined($str);
  my @list;
  my @stack = ([]);

  my $pos = 0;
  my $len = length($str);

  while ($pos < $len) {
    my $c = substr($str, $pos, 1);
    if ($c eq ' ') {
      $pos++;
    } elsif ($c eq '(') {
      push @{$stack[-1]}, [];
      push @stack, $stack[-1]->[-1];
      $pos++;
    } elsif ($c eq ')') {
      pop(@stack);
      $pos++;
    } elsif (substr($str, $pos) =~ /^(\"(?:[^\\\"]|\\\")*\")/) { # qstring
      my $str = substr($1, 1, -1);
      $pos += length $1;
      $str =~ s/\\([\\\"])/$1/g;
      push @{$stack[-1]}, $str;
    } elsif (substr($str, $pos) =~ /^\{(\d+)\}/) { # literal
      $pos += length($1) + 2;
      push @{$stack[-1]}, substr($str, $pos, $1);
      $pos += $1;
    } elsif (substr($str, $pos)
	     =~ /^([^\x00-\x1f\x7f\(\)\{\s\"]+)/) {
      push @{$stack[-1]}, $1;
      $pos += length $1;
    } else {
      croak "parse_fields: eeek! bad parse at position $pos [$str]\n";
    }
  }
  return $stack[0];
}

sub _as_astring {
  my $self = shift;
  my $str = shift;
  my $type = 0;

  my $len = length $str;

  if (($len > 1024) || ($str =~ /[\x00\x0a\x0d\x80-\xff]/)) { # literal
    return [($len, $str)];
  } elsif ($str =~ /[\"\\\x01-\x20\x22\x25\x28-\x2a\{]/) { # qstring
    $str =~ s/([\\\"])/\\$1/g;
    return "\"$str\"";
  } elsif ($str eq '') {
    return '""';
  } else {
    return $str;
  }
}

sub _as_string {
  my $self = shift;
  my $str = shift;
  my $type = 0;

  my $len = length $str;

  if (($len > 1024) || ($str =~ /[\x00\x0a\x0d\"\\\x80-\xff]/)) { # literal
    return [($len, $str)];
  } elsif ($str eq '') {
    return '""';
  } else {
    $str =~ s/([\\\"])/\\$1/g;
    return "\"$str\"";
  }
}

sub _send_string {
  my $self = shift;
  my $str = shift;
  my $len = length $str;

  ($self->{Connection}->syswrite($str, $len) == $len) or return undef;
  $self->debug_print(1, $str) if $self->debug;
  return $self;
}

sub _send_eol {
  my $self = shift;
  ($self->{Connection}->syswrite("\r\n", 2) == 2) or return undef;
  $self->debug_print(1, "eol") if $self->debug;
  return $self;
}

sub response {
  my $self = shift;

  my $response;
  do {
    $response = $self->_process_response($self->getline);
  } until defined($response);

  return $response;
}

sub _process_response {
  my $self = shift;
  my $str = shift;

  # trigger response callback
  my $response = &{$self->{ResponseCallback}}($str);
  return undef unless defined($response);
  $self->debug_print(0, "callback returned $response") if $self->debug;

  # if we get this far it's a completion response, so trigger
  # completion callback

  my $tag = $response->tag;
  if (defined($self->{Pending}{$tag})) {
    &{$self->{Pending}{$tag}}($response);
    delete $self->{Pending}{$tag}; # forget the pending command
  }
  return $response;
}

sub getline {
  my $self = shift;
  my $pstr;

  while (1) {
    my $str = $self->{Connection}->getline or return undef;
    $str =~ s/\r?\n$//;		# strip trailing EOL
    $pstr .= $str;
    last if ($str !~ /\{(\d+)\}$/); # done if no literal at end of string
    my $amt = $1;
    my $literal;
    $self->{Connection}->read($literal, $amt) == $amt or return undef;
    $pstr .= $literal;
  }
  $self->debug_print(0, $pstr) if $self->debug;
  return $pstr;
}

sub close_connection {
  my $ret = $_[0]->connection->close;
  $_[0]->{Connection} = undef;
  return $ret;
}

sub sequence { $_[0]->{Sequence} }

sub next_sequence { $_[0]->{Sequence} + 1 }

sub pending { sort { $a <=> $b } keys %{$_[0]->{Pending}} }

###############################################################################

sub quote {
  my $self = shift;
  my $str = shift;
  return 'nil' unless defined($str);
  $str =~ s/([\\\"])/\\$1/g;
  return "\"$str\"";
}

sub dequote {
  my $self = shift;
  my $str = shift;
  return undef if (lc($str) eq 'nil');
  return $str unless ($str =~ /^\"(.*)\"$/);
  $str = $1;
  $str =~ s/\\(.)/$1/g;
  return $str;
}

###############################################################################

sub debug {
  $_[0]->{Options}{Debug} = $_[1] if (defined($_[1]));
  return $_[0]->{Options}{Debug};
}

sub debug_print {
  my @time = localtime;
  print(STDERR
	$_[1]?'->':'<-',
	" $_[0] ",
	sprintf("%02d:%02d:%02d", @time[2..4]),
	" [", $_[0]->debug_text($_[1], $_[2]), "]\n");
}

sub debug_text { $_[2] }

###############################################################################
package Net::xAP::Response;

sub new {
  my $class = shift;
  my $type = ref($class) || $class;

  my $self = bless {}, $class;

  $self->{Sequence} = 0;
  $self->{Status} = '';
  $self->{Text} = '';

  return $self;
}

sub tag { $_[0]->{Sequence} }

sub status { $_[0]->{Status} }

sub text { $_[0]->{Text} }

sub status_code { $_[0]->{StatusCode} }

###############################################################################

1;