Net-Knuddels/Net/Knuddels.pm

=head1 NAME

Net::Knuddels - www.knuddels.de protocol implementation.

=head1 SYNOPSIS

 use Net::Knuddels;

=head1 DESCRIPTION

RTSL.

=cut

package Net::Knuddels;

use Net::Knuddels::Dictionary;

use strict;
use utf8;

use Carp;
use Math::BigInt;

sub _to32($) {
   unpack "l", pack "L", (new Math::BigInt $_[0]) & 0xffffffff
}

sub hash_pw($$) {
   my ($challenge, $pw) = @_;

   my $l1 = length $pw;
   my $l2 = length $challenge;

   my $k = chr ($l1 ^ ($l2 << 4));

   my $l = $l1 < $l2 ? $l2 : $l1;

   my $xor = substr +($pw x 100) ^ ($challenge x 100) ^ ($k x 100), 0, $l;

   my ($i, $j);

   --$l;

   if ($l <= 17) {
      for (0 .. $l) {
         $i = _to32 $i * 3 + ord substr $xor, $l - $_;
         $j = _to32 $j * 5 + ord substr $xor, $_;
      }
   } else {
      for ($_ = $l; $_ >= 0; $_ -= int $_/19) {
         $i = _to32 $i * 5 + ord substr $xor, $_;
         $j = _to32 $j * 3 + ord substr $xor, $l - $_;
      }
   }

   $i ^= $j;
   _to32 (($i & 0xffffff) ^ ($i >> 24))
}

my $RE_dec = join "|", keys %$Net::Knuddels::Dictionary;

sub decode {
   my $bin = unpack "b*", $_[0];
   my $res = "";

   while ($bin =~ /\G($RE_dec)/cog) {
      my $frag = $Net::Knuddels::Dictionary->{$1};
      $frag = chr unpack "v", pack "b*", $bin =~ /\G(.{16})/cg && $1 if $frag eq "\\\\\\";
      $res .= $frag;
   }
   $bin =~ /\G(.*[^0].*)$/ and die "Net::Knuddels::Receiver: undecodable message tail '$1'";

   $res
}

my %encode = reverse %$Net::Knuddels::Dictionary;

my $RE_enc = join "|", map quotemeta, sort { (length $b) <=> (length $a) } keys %encode;

sub encode($) {
   my ($msg) = @_;

   my $data = "";

   while () {
      $data .= $encode{$1} while $msg =~ /\G($RE_enc)/cog;

      $msg =~ /\G./csog
         or last;

      $data .= $encode{"\\\\\\"} . unpack "b*", pack "v", ord $1;
   }

   pack "b*", $data
}

=head2 CLASS Net::Knuddels::Protocol

You B<must> call the C<destroy> method of this class when you no longer
use it, as circular references will keep the object alive otherwise.

=over 4

=cut

package Net::Knuddels::Protocol;

=item new

Create a new C<Net::Knuddels::Protocol> object.

=cut

sub new {
   my $class = shift;

   my %data;

   my $self = bless {
      @_
   }, $class;

   $self;
}

=item $protocol->feed_data ($octets)

Feed raw protocol data into the decoder.

=cut

sub feed_data($$) {
   my ($self, $data) = @_;

   # split data stream into packets

   $data = "$self->{rbuf}$data";

   while () {
      1 <= length $data or last;
      my $len = ord substr $data, 0, 1;

      my $skip;
      if ($len & 0x80) {
         my $tail = (($len >> 5) & 3) - 1;
         $len = ($len & 0x1f) + 1;

         $tail < length $data or last;
         $len += (ord substr $data, $_ + 1, 1) << ($_ * 8 + 5)
            for 0 .. $tail;

         $skip = 2 + $tail;
      } else {
         $skip = 1;
         $len++;
      }

      $len + $skip <= length $data or last;
      substr $data, 0, $skip, "";
      my $msg = substr $data, 0, $len, "";

      $self->feed_msg ($msg);
   }

   $self->{rbuf} = $data;
}

sub feed_msg($$) {
   my ($self, $msg) = @_;

   $self->feed_event (split /\0/, Net::Knuddels::decode $msg);
}

sub feed_event($@) {
   my ($self, @cmd) = @_;

   my $ev = $self->{cb}{ALL};
   $_->(@cmd) for values %$ev;

   unless ($self->{cb}{$cmd[0]}) {
      my $ev = $self->{cb}{UNHANDLED};
      $_->(@cmd) for values %$ev;
   }

   my $ev = $self->{cb}{shift @cmd};
   $_->(@cmd) for values %$ev;
}

=item $msg = $protocol->encode_msg (@strings)

Join the strings with C<\0>, encode the result into a protocol packet and
return it.

=cut

sub encode_msg($@) {
   my ($self, @args) = @_;
   my $msg = Net::Knuddels::encode join "\0", @args;
   my $len = (length $msg) - 1;

   if ($len < 0x80) {
      (chr $len) . $msg
   } else {
      (chr 0x80 | 0x40 | ($len & 0x1f))
      . (chr +($len >>  5) % 0xff)
      . (chr +($len >> 13) % 0xff)
      . $msg
   }
}

=item $protocol->register ($type => $callback)

Register a callback for events of type C<$type>, which is either the name
of a low-level event sent by the server (such as "k" for dialog box) or
the name of a generated event, such as C<login>.

=cut

sub register {
   my ($self, $type, $cb) = @_;

   $self->{cb}{$type}{$cb} = $cb;
}

=item $protocol->destroy

I<MUST> be called to destroy the object, otherwise it will leak (no automatic cleanup).

=cut

sub destroy {
   my ($self) = @_;

   delete $self->{cb};
}

=back

=head2 CLASS Net::Knuddels::Client

Implement a Knuddels client connection.

=over 4

=cut

package Net::Knuddels::Client;

sub handle_room {
  my ($self, $room) = @_;

  if ($room eq "-") {
    if (scalar (keys %{$self->{room}}) == 1) {
      return (keys %{$self->{room}})[0];
    } else {
      warn "Couldn't assign '-' room to a room!";
      return '#nosuchroom';
    }
  } else {
    return $room;
  }
}

sub update_user_stats {
  my ($user) = @_;

  if ($user->{name} =~ s/\cJ(\d+)$//) {
    $user->{age} = $1 
  }

  if ($user->{picture} =~ m/\bmale/) {
    $user->{gender} = 'm'; 

  } elsif ($user->{picture} =~ m/female/) {
    $user->{gender} = 'f';
  }

  return $user;
}

sub del1 {
  my ($str) = @_;
  my $s = substr ($$str, 0, 1);
  $$str = substr ($$str, 1);
  $s
}

sub del2 {
  my ($str) = @_;
  my $s = substr ($$str, 0, 2);
  $$str = substr ($$str, 2);
  $s
}

sub todelim {
  my ($str) = @_;
  $$str =~ s/^(.*?)\365//;
  $1;
}

sub chk_flag {
  my ($str) = @_;
  if ($$str =~ s/^\343//) {
    return 1;
  } 
  return 0;
}

my %switch_main = (
  's' => sub {

  },
  'w' => sub {

  },
);

=pod
sub clean_windef {
  my ($self, $windef) = @_;

  my $wd = {};

  $wd->{title} = todelim \$windef;

  while (not chk_flag \$windef) {
    my $c = del1 \$windef;
    if ($c eq 's') {
      $wd->{cmd}      = todelim \$windef;
      $wd->{nickname} = todelim \$windef;
    } elsif ($c eq 'w' or $c eq 'p') {
      del2 \$windef;
    } elsif ($c eq 'h' or $c eq 'f') {
      del1 \$windef;
    } elsif ($c eq 'r') {
       # ... resizeable
    }
  }

  my $fl1 = 0;
  do { # holgi, i will hit you
    my $c = del1 \$windef;

    if ($c eq 'U') {
      $wd->{weird_field} = todelim \$windef;
      $fl1 = 1;
      
    } elsif ($c eq 'G') {
      del2 \$windef; del2 \$windef;
      
    } elsif ($c eq 'F') {

    } elsif ($c eq 'B') {
      del1 \$windef;
      
    } else {
      $fl2 = 1;
      $windef = $c . $windef;
    }
  } while ($fl1);

  while (not chk_flag \$windef) {
    if ($fl2) { 
      my $c = del1 \$winddef 
      if (not ($c eq 'N' 
            or $c eq 'S'
            or $c eq 'E'
            or $c eq 'W'
            or $c eq 'C')) 
          {
            $windef = $c . $windef;
          }
    }

  }

  return $wd;
}
=cut

=item new Net::Knuddels::Client [IO::Socket::new arguments]

Create a new client connection.

=cut

use IO::Socket::INET;

sub new {
   my ($class, @arg) = @_;

   my $fh = new IO::Socket::INET @arg
     or Carp::croak "Net::Knuddels::Client::new: $!";

   my $self = bless {
      fh    => $fh,
      proto => (new Net::Knuddels::Protocol),
   }, $class;

   syswrite $fh, "\0";

   $self->register ("(" => sub {
      $self->{login_challenge} = $_[0];
      $self->{login_room}      = $_[1];
      $self->{proto}->feed_event (login => $_[1]);
   });
   
   $self->register (k => sub {
      my @str = map { s/[\356\343]//; $_ } @_;
      my @out;
      push @out, split /#/, $_ for @str;
      $self->{proto}->feed_event (dialog => \@out);
   });
   
   $self->register (t => sub {
      my $src = $_[0];

      if ($src eq '-') {
        $_[2] = $self->{knuddels_nick} . " " . $_[2];

      } else {
        $_[2] = $src . " " . $_[2];
      }
      $self->{proto}->feed_event (action_room => $self->handle_room ($_[1]), $_[2]);
   });
   
   $self->register (r => sub {
      my $src = $_[0];
      $src = $self->{knuddels_nick} if $src eq "-";
      $self->{proto}->feed_event (msg_priv => $self->handle_room ($_[2]), $src, $_[1], $_[3]);
   });
   
   $self->register (e => sub {
      $self->{proto}->feed_event (msg_room => $self->handle_room ($_[1]), $_[0], $_[2]);
   });
   
   $self->register (l => sub {

   });

   $self->register (l => sub {
      my $room = $self->handle_room ($_[0]);
      return if $room eq "-"; # things that shouln't happen

      my $user = {
        name => $_[1],
        flag => $_[2],
        color => $_[3],
        picture => $_[4]
      };

      update_user_stats ($user);

      my $rl = $self->{user_lists}->{lc $room}->{lc $user->{name}} = $user;
      
      $self->{proto}->feed_event (join_room => $room, $user);
   });
   $self->register (w => sub {
      my $room = $self->handle_room ($_[1]);
      return if $room eq "-"; # things that shouln't happen

      my $username = $_[0];

      my $u = delete $self->{user_lists}->{lc $room}->{lc $username};

      if (not defined $u) {
        warn "User $username wasn't in room $room, trying to fix... but be careful!!!\n";
        $u = { name => $username };
      }

      $self->{proto}->feed_event (part_room => $room, $u);
   });
   
   $self->register (b => sub {
      my @arg = @_;
      my $cc = {};
      $self->{knuddels_rooms}->{$cc->{name}} = {};

      my $last = $cc;
      my $chan_cnt = 2;

      while (@arg) {
        $cc->{name} = shift @arg;

        if ($cc->{name} =~ s/\cJ(\d+)$//) {
          $cc->{user_count} = $1;
        }
        if ($cc->{name} =~ m/^"/) {
          $cc->{name} = "$last->{name} $chan_cnt";
          $chan_cnt++;

        } else {
          $last = $cc;
          $chan_cnt = 2;
        }

 
        $cc->{flag1} = shift @arg;
        $cc->{flag2} = shift @arg;

        my $i = 0;

        for (my $a = shift @arg; $a ne "-"; $a = shift @arg) {

          if ($i == 0) {
            $cc->{picture} = $a;
            $cc->{full_flag} = 1 if $cc->{picture} =~ m/full/i;
          }
          $i++;
        }

        $self->{knuddels_rooms}->{$cc->{name}} = $cc;
        $cc = {};
      }

      $self->{proto}->feed_event (room_list => $self->{knuddels_rooms});
   });

   $self->register (d => sub {
      my $room = $self->handle_room ($_[0]);
      
      delete $self->{room}->{lc $room};
      $self->{room}->{lc $_[1]} = { name => $_[1] };
      
      $self->{proto}->feed_event (change_room => $room, $_[1]);
   });
   
   $self->register ('6' => sub {
      # i have no exact clue what this message does,
      # but java-code seems to say i should do this:
      
      warn "*********************** SIX MESSAGE GOT!!! CHECK PROTOCOL FOR OCCURENCE!!";
      # delete $self->{room}->{lc ($self->handle_room ($_[0]))};
   });

   $self->register (a => sub {
      $self->{my_nick} = $_[1]; # i'm really _not_ shure about this

      my $ri = $self->{room}->{lc $_[0]} = { 
        name => $_[0],
        picture => $_[7],
      };

      $self->{proto}->feed_event (room_info => $_[0], $ri);
   });
   
   $self->register (u => sub {
      my $room = shift;
      my $rl = $self->{user_lists}->{lc $room} = {};
      my $cur_u = {};

      while (@_) {
        $cur_u->{name} = shift;
        $cur_u->{flag} = shift;
        $cur_u->{color} = shift;
        
        my $i = 0;

        while ((my $nxt = shift) ne "-") {
          if ($i == 0) {
            $cur_u->{picture} = $nxt;
          }
          $i++;
        }

        update_user_stats ($cur_u);
        $rl->{lc $cur_u->{name}} = $cur_u;
        $cur_u = {};
      }
      $self->{proto}->feed_event (user_list => $room, $rl);
   });

   $self
}

=item $client->fh

Return the fh used for communications. You are responsible for calling C<<
$client->ready >> whenever the fh becomes ready for reading.

=cut

sub fh {
   $_[0]->{fh}
}

=item $client->ready

To be called then the filehandle is ready for reading. Returns false if
the server closed the connection, true otherwise.

=cut

sub ready {
   my ($self) = @_;

   sysread $self->{fh}, my $buf, 8192
      or return;

   $self->{proto}->feed_data ($buf);

   1;
}

=item $client->command ($type => @args)

Send a message of type C<$type> and the given arguments to the server.

=cut

sub command {
   my ($self, $type, @args) = @_;

   #use Dumpvalue; Dumpvalue->new (compactDump => 1, veryCompact => 1, quoteHighBit => 1, tick => '"')->dumpValue ([$type, @args]);

   syswrite $self->{fh}, $self->{proto}->encode_msg ($type, @args);
}

=item $client->login ($url, $unknown)

Send a 't' message. The default for C<$url> is
C<http://www.knuddels.de/applet.html?v=86a&c=0> and C<$unknown> is C<6>.

=cut

sub login {
   my ($self, $url, $unknown) = @_;

   $self->command ("t", "V8.6a", $url || "http://www.knuddels.de/applet.html?v=86a&c=0", $unknown || 3);
}

=item $client->enter_room ($room, $nick, $password)

Enters a room C<$room> with C<$nick> and C<$password>.
(for joining multiple rooms call this multiple times)

NOTE: i won't allow joins to multiple rooms with different nick/password's,
the java client reacted very confused.. don't know whether the server supports this.

=cut

sub enter_room {
   my ($self, $room, $nick, $password) = @_;

   if (defined $self->{knuddels_nick} and $self->{knuddels_nick} ne $nick) {
     return # i don't think knuddels-server will be happy if 
            # we join multiple rooms on multiple accounts over 1 connection
   }

   exists $self->{login_challenge} or Carp::croak "set_nick can only be called after a login event";

   $self->{knuddels_nick} = $nick;
   print "ENTER: $room\n";
   $self->command ("n", $room, $nick, Net::Knuddels::hash_pw $self->{login_challenge}, $password);
}

=item $client->send_whois ($nick)
 
  Sends a whois-request for $nick.

=cut
sub send_whois {
  my ($self, $room, $nick) = @_;

  print "send: $room:/w $nick\n";
  $self->command ("e", $room, "/w $nick");
}


=item $client->send_room_msg ($nick, $room, $message)
  
  Sends a private C<$message> to C<$nick> over C<$room>.

=cut
sub send_room_msg {
  my ($self, $room, $message) = @_;

  print "SEND ROOM:$room\: $message\n";
  $self->command ("e", $room, $message);
}


=item $client->send_priv_msg ($nick, $room, $message)
  
  Sends a private C<$message> to C<$nick> over C<$room>.

=cut
sub send_priv_msg {
  my ($self, $nick, $room, $message) = @_;

  print "SEND PRIV:$room: /p $nick:$message\n";
  $self->command ("e", $room, "/p $nick:$message");
}

=item $client->send_join_room ($oldroom, $room)

  Sends the server a join command for C<$room>. This
  will result in a room change from C<$oldroom> to C<$room>.

=cut
sub send_join_room {
  my ($self, $old_room, $room) = @_;

  print "JOIN ROOM: #room : /go $room\n";
  $self->command ("e", $old_room, "/go $room");
}

=item $client->send_exit_room ($room)
  
  Exits C<$room> completly. (can be seen as counter method for C<enter_room ()>);

=cut
sub send_exit_room {
  my ($self, $room) = @_;
  print "EXIT EOORM: $room \n";
  $self->command ("w", $room, "\0", "\0");
  delete $self->{room}->{lc $room};
}

=item $client->register ($type => $cb)

See L<Net::Knuddels::Protocol::register>. The following extra events will
be generated by this class:

   login
      set_nick can only be called _after_ a login event has occured.

   msg_room => $room, $user, $msg
      produced when a public message is uttered :)

   msg_room => $room, $src, $dst, $msg
      personal message from $src to $dst

   user_list => $room, $list
      the userlist of a channel named $room, a elmement of the list (a user)
      looks like: 
         {
           name => <name>, 
           flag => <some flag i don't know what it means>, 
           color => like /\d+.\d+.\d+/,
           age   => /\d+/,
           gender => /(f|m)/, 
           picture => <the picture file to put behind the nick> 
         }

   room_info => $room, $room_info
      some information about the $room:
      $room_info =
      {
         picture => <some picturefile>
      }

   join_room => $room, $user
      join message of $user joined the room $room
      $user contains the user structure (see user_list).
      
   part_room => $room, $user
      part message of $user who left the room $room
      $user contains the user structure (see user_list).
=cut

sub register {
   my ($self, $type, $cb) = @_;

   $self->{proto}->register ($type, $cb);
}

=back

=head1 AUTHOR

 Marc Lehmann <pcg@goof.com>
 http://home.schmorp.de/
  
=cut

1;

Revision:	1.25
Committed:	Mon Jan 24 05:58:15 2005 UTC (19 years, 4 months ago) by root
Branch:	MAIN
Changes since 1.24:	+4 -4 lines
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.8	=head1 NAME
2
3			Net::Knuddels - www.knuddels.de protocol implementation.
4
5			=head1 SYNOPSIS
6
7			use Net::Knuddels;
8
9			=head1 DESCRIPTION
10
11			RTSL.
12
13			=cut
14
15	root	1.1	package Net::Knuddels;
16
17	root	1.3	use Net::Knuddels::Dictionary;
18
19	root	1.2	use strict;
20			use utf8;
21
22	root	1.4	use Carp;
23			use Math::BigInt;
24
25	root	1.14	sub _to32($) {
26			unpack "l", pack "L", (new Math::BigInt $_[0]) & 0xffffffff
27			}
28
29	root	1.4	sub hash_pw($$) {
30			my ($challenge, $pw) = @_;
31
32			my $l1 = length $pw;
33			my $l2 = length $challenge;
34
35			my $k = chr ($l1 ^ ($l2 << 4));
36
37			my $l = $l1 < $l2 ? $l2 : $l1;
38
39			my $xor = substr +($pw x 100) ^ ($challenge x 100) ^ ($k x 100), 0, $l;
40
41			my ($i, $j);
42
43			--$l;
44
45			if ($l <= 17) {
46			for (0 .. $l) {
47	root	1.25	$i = _to32 $i * 3 + ord substr $xor, $l - $_;
48			$j = _to32 $j * 5 + ord substr $xor, $_;
49	root	1.4	}
50			} else {
51			for ($_ = $l; $_ >= 0; $_ -= int $_/19) {
52	root	1.25	$i = _to32 $i * 5 + ord substr $xor, $_;
53			$j = _to32 $j * 3 + ord substr $xor, $l - $_;
54	root	1.4	}
55			}
56
57			$i ^= $j;
58	root	1.14	_to32 (($i & 0xffffff) ^ ($i >> 24))
59	root	1.4	}
60
61	root	1.10	my $RE_dec = join "\|", keys %$Net::Knuddels::Dictionary;
62
63			sub decode {
64			my $bin = unpack "b*", $_[0];
65			my $res = "";
66
67			while ($bin =~ /\G($RE_dec)/cog) {
68			my $frag = $Net::Knuddels::Dictionary->{$1};
69	root	1.14	$frag = chr unpack "v", pack "b*", $bin =~ /\G(.{16})/cg && $1 if $frag eq "\\\\\\";
70	root	1.10	$res .= $frag;
71			}
72			$bin =~ /\G(.[^0].)$/ and die "Net::Knuddels::Receiver: undecodable message tail '$1'";
73
74			$res
75			}
76
77	root	1.9	my %encode = reverse %$Net::Knuddels::Dictionary;
78
79	root	1.10	my $RE_enc = join "\|", map quotemeta, sort { (length $b) <=> (length $a) } keys %encode;
80	root	1.9
81	root	1.10	sub encode($) {
82	root	1.9	my ($msg) = @_;
83
84			my $data = "";
85
86			while () {
87			$data .= $encode{$1} while $msg =~ /\G($RE_enc)/cog;
88
89			$msg =~ /\G./csog
90			or last;
91
92			$data .= $encode{"\\\\\\"} . unpack "b*", pack "v", ord $1;
93			}
94
95			pack "b*", $data
96			}
97
98	root	1.5	=head2 CLASS Net::Knuddels::Protocol
99
100			You B<must> call the C<destroy> method of this class when you no longer
101			use it, as circular references will keep the object alive otherwise.
102
103	root	1.6	=over 4
104
105	root	1.8	=cut
106
107			package Net::Knuddels::Protocol;
108
109	root	1.6	=item new
110
111			Create a new C<Net::Knuddels::Protocol> object.
112
113	root	1.5	=cut
114	root	1.2
115			sub new {
116			my $class = shift;
117
118	root	1.4	my %data;
119
120			my $self = bless {
121			@_
122			}, $class;
123
124			$self;
125	root	1.2	}
126
127	root	1.6	=item $protocol->feed_data ($octets)
128
129			Feed raw protocol data into the decoder.
130
131			=cut
132
133	root	1.2	sub feed_data($$) {
134			my ($self, $data) = @_;
135
136			# split data stream into packets
137
138			$data = "$self->{rbuf}$data";
139
140			while () {
141			1 <= length $data or last;
142			my $len = ord substr $data, 0, 1;
143
144			my $skip;
145			if ($len & 0x80) {
146			my $tail = (($len >> 5) & 3) - 1;
147			$len = ($len & 0x1f) + 1;
148
149			$tail < length $data or last;
150			$len += (ord substr $data, $_ + 1, 1) << ($_ * 8 + 5)
151			for 0 .. $tail;
152
153			$skip = 2 + $tail;
154			} else {
155			$skip = 1;
156			$len++;
157			}
158
159			$len + $skip <= length $data or last;
160			substr $data, 0, $skip, "";
161			my $msg = substr $data, 0, $len, "";
162
163			$self->feed_msg ($msg);
164			}
165
166			$self->{rbuf} = $data;
167			}
168
169			sub feed_msg($$) {
170			my ($self, $msg) = @_;
171	root	1.1
172	root	1.10	$self->feed_event (split /\0/, Net::Knuddels::decode $msg);
173	root	1.1	}
174
175	root	1.2	sub feed_event($@) {
176	root	1.14	my ($self, @cmd) = @_;
177	root	1.1
178	root	1.14	my $ev = $self->{cb}{ALL};
179			$_->(@cmd) for values %$ev;
180
181			unless ($self->{cb}{$cmd[0]}) {
182			my $ev = $self->{cb}{UNHANDLED};
183			$_->(@cmd) for values %$ev;
184	root	1.1	}
185	root	1.14
186			my $ev = $self->{cb}{shift @cmd};
187			$_->(@cmd) for values %$ev;
188	root	1.2	}
189	root	1.1
190	root	1.11	=item $msg = $protocol->encode_msg (@strings)
191
192			Join the strings with C<\0>, encode the result into a protocol packet and
193			return it.
194
195			=cut
196
197			sub encode_msg($@) {
198			my ($self, @args) = @_;
199			my $msg = Net::Knuddels::encode join "\0", @args;
200	root	1.12	my $len = (length $msg) - 1;
201
202			if ($len < 0x80) {
203			(chr $len) . $msg
204			} else {
205			(chr 0x80 \| 0x40 \| ($len & 0x1f))
206			. (chr +($len >> 5) % 0xff)
207			. (chr +($len >> 13) % 0xff)
208			. $msg
209			}
210	root	1.11	}
211
212	root	1.6	=item $protocol->register ($type => $callback)
213
214			Register a callback for events of type C<$type>, which is either the name
215			of a low-level event sent by the server (such as "k" for dialog box) or
216	root	1.16	the name of a generated event, such as C<login>.
217	root	1.6
218			=cut
219
220	root	1.2	sub register {
221			my ($self, $type, $cb) = @_;
222	root	1.1
223	root	1.2	$self->{cb}{$type}{$cb} = $cb;
224	root	1.1	}
225
226	root	1.8	=item $protocol->destroy
227
228	root	1.9	I<MUST> be called to destroy the object, otherwise it will leak (no automatic cleanup).
229	root	1.8
230			=cut
231
232	root	1.5	sub destroy {
233			my ($self) = @_;
234
235			delete $self->{cb};
236			}
237
238	root	1.6	=back
239
240	root	1.8	=head2 CLASS Net::Knuddels::Client
241
242	root	1.9	Implement a Knuddels client connection.
243
244	root	1.8	=over 4
245
246			=cut
247
248			package Net::Knuddels::Client;
249
250	root	1.16	sub handle_room {
251			my ($self, $room) = @_;
252
253			if ($room eq "-") {
254	elmex	1.23	if (scalar (keys %{$self->{room}}) == 1) {
255			return (keys %{$self->{room}})[0];
256	root	1.16	} else {
257			warn "Couldn't assign '-' room to a room!";
258	elmex	1.23	return '#nosuchroom';
259	root	1.16	}
260			} else {
261			return $room;
262			}
263			}
264
265	elmex	1.20	sub update_user_stats {
266			my ($user) = @_;
267	root	1.16
268			if ($user->{name} =~ s/\cJ(\d+)$//) {
269			$user->{age} = $1
270			}
271
272			if ($user->{picture} =~ m/\bmale/) {
273			$user->{gender} = 'm';
274	elmex	1.20
275	root	1.16	} elsif ($user->{picture} =~ m/female/) {
276			$user->{gender} = 'f';
277			}
278	root	1.19
279	root	1.16	return $user;
280			}
281
282	elmex	1.22	sub del1 {
283			my ($str) = @_;
284			my $s = substr ($$str, 0, 1);
285			$$str = substr ($$str, 1);
286			$s
287			}
288
289			sub del2 {
290			my ($str) = @_;
291			my $s = substr ($$str, 0, 2);
292			$$str = substr ($$str, 2);
293			$s
294			}
295
296			sub todelim {
297			my ($str) = @_;
298			$$str =~ s/^(.*?)\365//;
299			$1;
300			}
301
302			sub chk_flag {
303			my ($str) = @_;
304			if ($$str =~ s/^\343//) {
305			return 1;
306			}
307			return 0;
308			}
309
310			my %switch_main = (
311			's' => sub {
312
313			},
314			'w' => sub {
315
316			},
317			);
318
319			=pod
320	elmex	1.18	sub clean_windef {
321			my ($self, $windef) = @_;
322
323			my $wd = {};
324
325	elmex	1.22	$wd->{title} = todelim \$windef;
326
327			while (not chk_flag \$windef) {
328			my $c = del1 \$windef;
329			if ($c eq 's') {
330			$wd->{cmd} = todelim \$windef;
331			$wd->{nickname} = todelim \$windef;
332			} elsif ($c eq 'w' or $c eq 'p') {
333			del2 \$windef;
334			} elsif ($c eq 'h' or $c eq 'f') {
335			del1 \$windef;
336			} elsif ($c eq 'r') {
337			# ... resizeable
338			}
339	elmex	1.18	}
340
341	elmex	1.22	my $fl1 = 0;
342			do { # holgi, i will hit you
343			my $c = del1 \$windef;
344
345			if ($c eq 'U') {
346			$wd->{weird_field} = todelim \$windef;
347			$fl1 = 1;
348
349			} elsif ($c eq 'G') {
350			del2 \$windef; del2 \$windef;
351
352			} elsif ($c eq 'F') {
353
354			} elsif ($c eq 'B') {
355			del1 \$windef;
356
357			} else {
358			$fl2 = 1;
359			$windef = $c . $windef;
360			}
361			} while ($fl1);
362
363			while (not chk_flag \$windef) {
364			if ($fl2) {
365			my $c = del1 \$winddef
366			if (not ($c eq 'N'
367			or $c eq 'S'
368			or $c eq 'E'
369			or $c eq 'W'
370			or $c eq 'C'))
371			{
372			$windef = $c . $windef;
373			}
374	elmex	1.18	}
375	elmex	1.22
376	elmex	1.18	}
377
378			return $wd;
379			}
380	elmex	1.22	=cut
381	elmex	1.18
382	root	1.9	=item new Net::Knuddels::Client [IO::Socket::new arguments]
383
384			Create a new client connection.
385
386			=cut
387
388			use IO::Socket::INET;
389
390			sub new {
391			my ($class, @arg) = @_;
392
393			my $fh = new IO::Socket::INET @arg
394			or Carp::croak "Net::Knuddels::Client::new: $!";
395
396			my $self = bless {
397			fh => $fh,
398			proto => (new Net::Knuddels::Protocol),
399			}, $class;
400
401			syswrite $fh, "\0";
402
403	root	1.16	$self->register ("(" => sub {
404			$self->{login_challenge} = $_[0];
405			$self->{login_room} = $_[1];
406	elmex	1.23	$self->{proto}->feed_event (login => $_[1]);
407	root	1.16	});
408	elmex	1.23
409	elmex	1.22	$self->register (k => sub {
410			my @str = map { s/[\356\343]//; $_ } @_;
411			my @out;
412			push @out, split /#/, $_ for @str;
413			$self->{proto}->feed_event (dialog => \@out);
414			});
415	elmex	1.23
416	elmex	1.21	$self->register (t => sub {
417			my $src = $_[0];
418	elmex	1.23
419	elmex	1.21	if ($src eq '-') {
420			$_[2] = $self->{knuddels_nick} . " " . $_[2];
421	elmex	1.23
422	elmex	1.21	} else {
423			$_[2] = $src . " " . $_[2];
424			}
425			$self->{proto}->feed_event (action_room => $self->handle_room ($_[1]), $_[2]);
426			});
427	elmex	1.23
428	root	1.16	$self->register (r => sub {
429	elmex	1.21	my $src = $_[0];
430			$src = $self->{knuddels_nick} if $src eq "-";
431			$self->{proto}->feed_event (msg_priv => $self->handle_room ($_[2]), $src, $_[1], $_[3]);
432	root	1.16	});
433	elmex	1.23
434	root	1.16	$self->register (e => sub {
435			$self->{proto}->feed_event (msg_room => $self->handle_room ($_[1]), $_[0], $_[2]);
436			});
437	elmex	1.23
438			$self->register (l => sub {
439
440			});
441
442	root	1.16	$self->register (l => sub {
443			my $room = $self->handle_room ($_[0]);
444			return if $room eq "-"; # things that shouln't happen
445
446			my $user = {
447			name => $_[1],
448			flag => $_[2],
449			color => $_[3],
450			picture => $_[4]
451			};
452
453	elmex	1.20	update_user_stats ($user);
454	root	1.16
455			my $rl = $self->{user_lists}->{lc $room}->{lc $user->{name}} = $user;
456
457			$self->{proto}->feed_event (join_room => $room, $user);
458			});
459			$self->register (w => sub {
460			my $room = $self->handle_room ($_[1]);
461			return if $room eq "-"; # things that shouln't happen
462
463			my $username = $_[0];
464
465			my $u = delete $self->{user_lists}->{lc $room}->{lc $username};
466
467			if (not defined $u) {
468			warn "User $username wasn't in room $room, trying to fix... but be careful!!!\n";
469			$u = { name => $username };
470			}
471
472			$self->{proto}->feed_event (part_room => $room, $u);
473			});
474	elmex	1.23
475			$self->register (b => sub {
476			my @arg = @_;
477			my $cc = {};
478			$self->{knuddels_rooms}->{$cc->{name}} = {};
479
480			my $last = $cc;
481			my $chan_cnt = 2;
482
483			while (@arg) {
484			$cc->{name} = shift @arg;
485
486			if ($cc->{name} =~ s/\cJ(\d+)$//) {
487			$cc->{user_count} = $1;
488			}
489			if ($cc->{name} =~ m/^"/) {
490			$cc->{name} = "$last->{name} $chan_cnt";
491			$chan_cnt++;
492
493			} else {
494			$last = $cc;
495			$chan_cnt = 2;
496			}
497
498
499			$cc->{flag1} = shift @arg;
500			$cc->{flag2} = shift @arg;
501
502			my $i = 0;
503
504			for (my $a = shift @arg; $a ne "-"; $a = shift @arg) {
505
506			if ($i == 0) {
507			$cc->{picture} = $a;
508			$cc->{full_flag} = 1 if $cc->{picture} =~ m/full/i;
509			}
510			$i++;
511			}
512
513			$self->{knuddels_rooms}->{$cc->{name}} = $cc;
514			$cc = {};
515	root	1.16	}
516
517	elmex	1.23	$self->{proto}->feed_event (room_list => $self->{knuddels_rooms});
518			});
519
520			$self->register (d => sub {
521			my $room = $self->handle_room ($_[0]);
522
523			delete $self->{room}->{lc $room};
524			$self->{room}->{lc $_[1]} = { name => $_[1] };
525
526			$self->{proto}->feed_event (change_room => $room, $_[1]);
527			});
528
529			$self->register ('6' => sub {
530			# i have no exact clue what this message does,
531			# but java-code seems to say i should do this:
532
533			warn "*********************** SIX MESSAGE GOT!!! CHECK PROTOCOL FOR OCCURENCE!!";
534			# delete $self->{room}->{lc ($self->handle_room ($_[0]))};
535			});
536
537			$self->register (a => sub {
538	root	1.16	$self->{my_nick} = $_[1]; # i'm really _not_ shure about this
539
540			my $ri = $self->{room}->{lc $_[0]} = {
541	elmex	1.23	name => $_[0],
542	root	1.16	picture => $_[7],
543			};
544
545			$self->{proto}->feed_event (room_info => $_[0], $ri);
546			});
547	elmex	1.23
548	root	1.16	$self->register (u => sub {
549			my $room = shift;
550			my $rl = $self->{user_lists}->{lc $room} = {};
551			my $cur_u = {};
552
553			while (@_) {
554			$cur_u->{name} = shift;
555			$cur_u->{flag} = shift;
556			$cur_u->{color} = shift;
557
558			my $i = 0;
559
560			while ((my $nxt = shift) ne "-") {
561			if ($i == 0) {
562			$cur_u->{picture} = $nxt;
563			}
564			$i++;
565			}
566
567	elmex	1.20	update_user_stats ($cur_u);
568	root	1.16	$rl->{lc $cur_u->{name}} = $cur_u;
569			$cur_u = {};
570			}
571			$self->{proto}->feed_event (user_list => $room, $rl);
572			});
573
574	root	1.9	$self
575			}
576
577			=item $client->fh
578
579			Return the fh used for communications. You are responsible for calling C<<
580	root	1.13	$client->ready >> whenever the fh becomes ready for reading.
581	root	1.9
582			=cut
583
584			sub fh {
585			$_[0]->{fh}
586			}
587
588	root	1.13	=item $client->ready
589
590			To be called then the filehandle is ready for reading. Returns false if
591			the server closed the connection, true otherwise.
592
593			=cut
594
595			sub ready {
596			my ($self) = @_;
597
598			sysread $self->{fh}, my $buf, 8192
599			or return;
600
601			$self->{proto}->feed_data ($buf);
602
603			1;
604			}
605
606	root	1.9	=item $client->command ($type => @args)
607
608			Send a message of type C<$type> and the given arguments to the server.
609
610			=cut
611
612			sub command {
613			my ($self, $type, @args) = @_;
614
615	root	1.14	#use Dumpvalue; Dumpvalue->new (compactDump => 1, veryCompact => 1, quoteHighBit => 1, tick => '"')->dumpValue ([$type, @args]);
616	root	1.13
617			syswrite $self->{fh}, $self->{proto}->encode_msg ($type, @args);
618	root	1.9	}
619
620			=item $client->login ($url, $unknown)
621
622			Send a 't' message. The default for C<$url> is
623			C<http://www.knuddels.de/applet.html?v=86a&c=0> and C<$unknown> is C<6>.
624
625			=cut
626
627			sub login {
628	root	1.13	my ($self, $url, $unknown) = @_;
629
630			$self->command ("t", "V8.6a", $url \|\| "http://www.knuddels.de/applet.html?v=86a&c=0", $unknown \|\| 3);
631			}
632
633	elmex	1.23	=item $client->enter_room ($room, $nick, $password)
634
635			Enters a room C<$room> with C<$nick> and C<$password>.
636			(for joining multiple rooms call this multiple times)
637	root	1.13
638	elmex	1.23	NOTE: i won't allow joins to multiple rooms with different nick/password's,
639			the java client reacted very confused.. don't know whether the server supports this.
640	root	1.13
641			=cut
642
643	elmex	1.23	sub enter_room {
644	root	1.13	my ($self, $room, $nick, $password) = @_;
645
646	elmex	1.23	if (defined $self->{knuddels_nick} and $self->{knuddels_nick} ne $nick) {
647			return # i don't think knuddels-server will be happy if
648			# we join multiple rooms on multiple accounts over 1 connection
649			}
650
651	root	1.16	exists $self->{login_challenge} or Carp::croak "set_nick can only be called after a login event";
652	root	1.13
653	elmex	1.21	$self->{knuddels_nick} = $nick;
654	elmex	1.23	print "ENTER: $room\n";
655	root	1.16	$self->command ("n", $room, $nick, Net::Knuddels::hash_pw $self->{login_challenge}, $password);
656	root	1.9	}
657
658	elmex	1.22	=item $client->send_whois ($nick)
659
660			Sends a whois-request for $nick.
661
662			=cut
663			sub send_whois {
664			my ($self, $room, $nick) = @_;
665
666			print "send: $room:/w $nick\n";
667			$self->command ("e", $room, "/w $nick");
668			}
669
670
671	elmex	1.21	=item $client->send_room_msg ($nick, $room, $message)
672
673			Sends a private C<$message> to C<$nick> over C<$room>.
674
675			=cut
676			sub send_room_msg {
677			my ($self, $room, $message) = @_;
678
679	elmex	1.23	print "SEND ROOM:$room\: $message\n";
680	elmex	1.21	$self->command ("e", $room, $message);
681			}
682
683
684			=item $client->send_priv_msg ($nick, $room, $message)
685
686			Sends a private C<$message> to C<$nick> over C<$room>.
687
688			=cut
689			sub send_priv_msg {
690			my ($self, $nick, $room, $message) = @_;
691
692	elmex	1.23	print "SEND PRIV:$room: /p $nick:$message\n";
693	elmex	1.21	$self->command ("e", $room, "/p $nick:$message");
694			}
695
696	elmex	1.23	=item $client->send_join_room ($oldroom, $room)
697
698			Sends the server a join command for C<$room>. This
699			will result in a room change from C<$oldroom> to C<$room>.
700
701			=cut
702			sub send_join_room {
703			my ($self, $old_room, $room) = @_;
704
705			print "JOIN ROOM: #room : /go $room\n";
706			$self->command ("e", $old_room, "/go $room");
707			}
708
709			=item $client->send_exit_room ($room)
710
711			Exits C<$room> completly. (can be seen as counter method for C<enter_room ()>);
712
713			=cut
714			sub send_exit_room {
715			my ($self, $room) = @_;
716			print "EXIT EOORM: $room \n";
717			$self->command ("w", $room, "\0", "\0");
718			delete $self->{room}->{lc $room};
719			}
720
721	root	1.9	=item $client->register ($type => $cb)
722
723	root	1.16	See L<Net::Knuddels::Protocol::register>. The following extra events will
724			be generated by this class:
725	root	1.9
726	root	1.16	login
727			set_nick can only be called _after_ a login event has occured.
728
729			msg_room => $room, $user, $msg
730			produced when a public message is uttered :)
731
732			msg_room => $room, $src, $dst, $msg
733			personal message from $src to $dst
734
735			user_list => $room, $list
736			the userlist of a channel named $room, a elmement of the list (a user)
737			looks like:
738			{
739			name => <name>,
740			flag => <some flag i don't know what it means>,
741			color => like /\d+.\d+.\d+/,
742			age => /\d+/,
743			gender => /(f\|m)/,
744			picture => <the picture file to put behind the nick>
745			}
746
747			room_info => $room, $room_info
748			some information about the $room:
749			$room_info =
750			{
751			picture => <some picturefile>
752			}
753
754			join_room => $room, $user
755			join message of $user joined the room $room
756			$user contains the user structure (see user_list).
757
758			part_room => $room, $user
759			part message of $user who left the room $room
760			$user contains the user structure (see user_list).
761	root	1.9	=cut
762
763			sub register {
764			my ($self, $type, $cb) = @_;
765
766	root	1.13	$self->{proto}->register ($type, $cb);
767	root	1.9	}
768
769	root	1.8	=back
770
771			=head1 AUTHOR
772
773			Marc Lehmann <pcg@goof.com>
774			http://home.schmorp.de/
775
776	root	1.6	=cut
777
778	root	1.2	1;
779