dAmn/ClientPerl

This is NOT Public Domain or GPL. The code may only be used to learn about the dAmn protocol. If you modify it, you must send me (moeffju) your changes, either by posting on the Wiki (create a new page like dAmn/Client[Language]/[nickname]) or by e-mailing me (see ../Who).
This is not quite working all the time. Especially packet parsing is ugly (but functional).
Better packet routines at ../SampleCode.
#!/usr/bin/perl

# (c) copyright 2004 Matthias "moeffju" Bauer
# <URL:http://moeffju.net/w/dAmn/moin.cgi> for details
#
# Code may only be used to learn about the dAmn protocol. If you modify it, you must make your
# changes public either in the Wiki at above URL, or by e-mailing me (address is in the Wiki).

use strict;
use warnings;

use IO::Socket::INET;

our $debug = 0;            # Change this to 1 to enable debugging.

my %dAmn = (
  server => 'jasper.deviantart.com',
  port => 3900,
  nick = 'YOUR NICK',              # your deviantART username
  authtok = 'YOUR AUTH TOKEN');    # see the Wiki for information

## no user servicable parts below
## may contain small parts - keep out of children

sub dAmn_main;

our $debugspace = undef;

sub debug {
  return unless $debug;
  my ($space, $message, @args) = @_;
  return unless $message;
  $space = $debugspace if ($space eq '');
  $debugspace = $space;
  if (@args) {
    printf STDERR "[${space}] ${message}\n", @args;
  } else {
    printf STDERR "[${space}] ${message}\n";
  }
}

sub state {
  my $msg = shift;
  
  print STDOUT "$msg\n";
}

sub dAmn_parse_packet {
  my $data = shift;

  my ($cmd, $param, $arg, $body);

  if ($data =~ m/\n/) {
    my @parts = split(/\n\000/, $data);
    my @tmp = split /\n/, $parts[0];
    $parts[0] = \@tmp;
    
    ($cmd, $param) = split(/ /, $parts[0]->[0]);
    debug("dAmn_parse_packet", "Command is '%s', parameter '%s'", $cmd, $param);
    $arg = $parts[0]->[1];
    debug("", "Arg is '%s'", $arg) if $arg;
    shift(@parts);
    debug("", "Parts = (%s)", join('; ', (map { join(', ', split(/\n/)); } @parts) ));
    if (0 && ref $parts[0]) {
      my @tmp = @{$parts[0]};
      shift(@tmp);
      shift(@tmp);
      $body = join(', ', @tmp);
    } else {
      $body = substr($data,0,-1);
      $body =~ s/^.*?\n\n//;
      $body =~ s/\n/  /g;
      $body = printable($body);
    }

    return { cmd => $cmd, param => $param, arg => $arg, body => $body };
  } else {
    debug("dAmn_parse_packet", "Packet data is null.");
    return undef;
  }
}

sub dAmn_build_packet {
  my ($cmd, $param, $arg, $body) = @_;
  
  my $pkt = '';
  
  $pkt .= $cmd;
  $pkt .= " $param\n" if $param;
  $pkt .= "$arg\n" if $arg;
  $pkt .= $body if $body;
  $pkt .= "\000";
  
  return $pkt;
}

sub dAmn_main {
  my $socket = shift;
  my ($e, $p, $i);
  
  debug("dAmn_main", "Connected to server.");
  state("Connected to $dAmn{server}");
  
  $p = dAmn_build_packet('dAmnClient', '0.1', undef) .
       dAmn_build_packet('login', $dAmn{nick}, "pk=$dAmn{authtok}");
  debug("", ">>> %s", printable($p));
  print $socket $p;
  $socket->sysread($e, 1024);
  debug("", "<<< %s", printable($e)) if $e;
  state("login: should have worked");

  $p = dAmn_build_packet('join', "chat:$dAmn{channel}", undef);
  debug("", ">>> %s", printable($p));
  print $socket $p;
  $socket->sysread($e, 1024);
  debug("", "<<< %s", printable($e)) if $e;
  $socket->sysread($e, 1024);
  debug("", "<<< %s", printable($e)) if $e;
  $socket->sysread($e, 1024);
  debug("", "<<< %s", printable($e)) if $e;
  state("joined #$dAmn{channel}");
  
  $| = 1;
  ReadMode 4;
  { do {
    while ($socket->sysread($e, 4096) > 0) {
      debug("", "<<< %s", printable($e)) if $e;
      
      $p = dAmn_parse_packet($e);
      $p->{param} = '' unless $p->{param};
      $p->{arg} = '' unless $p->{arg};
      $p->{body} = '' unless $p->{body};
      state("$p->{body}");

      my $ch = ReadKey -1;
      if ($ch) {
        if ($ch eq "\n") {
          chomp($i);
          last if $i eq '/quit';
          print ">>> <$dAmn{nick}>   $i\n";
          $p = dAmn_build_packet('send', "chat:$dAmn{channel}", "\nmsg main\n", $i);
          debug("", ">>> %s", printable($p));
          print $socket $p;
          $i = "";
        } else {
          $i .= $ch;
        }
      }
    }
  } while ($i ne '/quit'); }
}

sub printable {
  my $s = shift;
  
  $s =~ s/[^\w\d \t\.\?!:=-]/sprintf("%%%02x", ord($&))/egm;
  
  return $s;
}

sub sample {
  my @sample = (
    "dAmnServer 0.1\012\000login moeffju\ne=ok\n\000",
    "join chat:coffeehouse\ne=ok\n\000property chat:coffeehouse\np=privclasses\n\n99:Founders\n75:Operators\n50:Members\n1:Banned\n25:Guests\n\000property chat:coffeehouse\np=members\n\nmember moeffju\npc=Guests\nusericon=1\nsymbol=*\nrealname=is a manipulative bitch :|\ntypename=General Digital Photographer\n\n\000property chat:coffeehouse\np=topic\n\n\000property chat:coffeehouse\np=title\n\n\000",
    "recv chat:coffeehouse\n\nmsg main\nfrom=moeffju\n\nThis is a message\000",
    );
    
  foreach my $s (@sample) {
    debug("sample_data", "Trying sample packet '%s'", (split(/\n/,$s))[0] . ' ...');
    dAmn_parse_packet($s);
  }
}

my $socket = IO::Socket::INET->new(
    PeerAddr => $dAmn{server},
    PeerPort => $dAmn{port},
    Proto => 'tcp'
  )
  or die "Unable to open socket to $dAmn{server}:$dAmn{port}: $!";

dAmn_main($socket);

close $socket;

ReadMode 0;

1;
dAmn Interoperability Project — READ-ONLY ARCHIVE
