> 32) & 0xffffffff; } sub enc_I8 { $data .= pack "c", $_[0]; } sub enc_I16 { enc_U16 unpack "S", pack "s", $_[0]; } sub enc_I32 { enc_U32 unpack "I", pack "i", $_[0]; } sub enc_DATA { # a dream! $data .= $_[0]; } sub enc_STRING { # should use encode for speed and clarity ;) $data .= pack "v*", map ord, split //, $_[0]; } sub enc_password { require Math::BigInt; # I insist on 32-bit-perl.. should use C # $hash must be 64 bit my $hash = new Math::BigInt; $hash = $hash * 1055 + ord for split //, $_[0]; enc_U64 $hash; } ]]> ############################################################################# # types ############################################################################# # structures ############################################################################# # "less" primitive types 1, square => 2, circle => 3, small_b => 4, small_w => 5, gray => 6, move => 7, addstone => 8, ); my %code_marker = reverse %marker_code; # this was the most horrible thing to decode. still not everything is decoded correctly(?) sub dec_TREE { my @r; while (length $data) { my $type = dec_U8; my $add = $type < 128; $type &= 127; if ($type == 127) { dec_U8; # unused?? *sigh* push @r, [add_node => dec_I32]; } elsif ($type == 126) { push @r, [set_node => dec_I32]; } elsif ($type == 125) { push @r, [set_current => dec_I32]; } elsif ($type == 34) { push @r, [score => dec_U8, dec_score1000]; } elsif ($type == 25) { push @r, [result => dec_result]; } elsif ($type == 23) { push @r, [mark => $add, MARK_GRAYED, dec_U8, dec_U8]; } elsif ($type == 22) { push @r, [mark => $add, (&dec_U8 ? MARK_SMALL_W : MARK_SMALL_B), dec_U8, dec_U8]; } elsif ($type == 21) { push @r, [mark => $add, MARK_CIRCLE, dec_U8, dec_U8]; } elsif ($type == 17) { push @r, [set_timer => (dec_U8, dec_U32, dec_time)[0,2,1]]; } elsif ($type == 16) { push @r, [set_stone => $add, dec_U8, dec_U8, dec_U8]; } elsif ($type == 14) { push @r, [move => $add, dec_U8, dec_U8, dec_U8]; } elsif (($type >= 4 && $type <= 9) || ($type >= 11 && $type <= 13) || $type == 24) { push @r, [({ 4 => "date", 5 => "unknown_comment5", 6 => "unknown_comment6", 7 => "unknown_comment7", 8 => "unknown_comment8", 9 => "copyright", #? 11 => "unknown_comment11", 12 => "unknown_comment12", 13 => "unknown_comment13", 24 => "comment", })->{$type} => dec_STRING]; } elsif ($type == 3) { push @r, [rank => dec_U8, dec_U32]; } elsif ($type == 2) { push @r, [player => dec_U8, dec_STRING]; } elsif ($type == 0) { # as usual, wms finds yet another way to duplicate code... oh well, what a mess. # (no wonder he is so keen on keeping it a secret...) push @r, [rules => dec_rules]; # OLD } elsif (1) { print STDERR KGS::Listener::Debug::dumpval(\@r); open XTYPE, "|xtype"; print XTYPE $data; close XTYPE; die "unknown type $type"; } elsif ($type == 30) { push @r, [active_player => dec_U8]; } elsif ($type == 0) { # label(?) my $label; my $c = dec_U16; $label .= chr $c if $c; my $c = dec_U16; $label .= chr $c if $c; my $c = dec_U16; $label .= chr $c if $c; # empty label == remove label push @r, [label => $label, dec_U8, dec_U8]; } elsif ($type > 0 && $type < 9) { # 1 marker type triangle # 2 marker type square # 3 marker type circle # 4 small stone b # 5 small stone w # 6 grayed out # 7 move # 8 also move(?) or preset? # # $a1 is probably player again (2 == remove) # x is from left 0 to right boardsize-1 # y is from top 0 to bottom boardsize-1 push @r, [$code_marker{$type} => dec_U8, dec_U8, dec_U8]; } else { push @r, [unknown => $type]; } } \@r; } sub enc_TREE { for (@{$_[0]}) { my ($type, @arg) = @$_; if ($type eq "add_child") { enc_U8 255; enc_I32 $arg[0]; } elsif ($type eq "done") { enc_U8 254; } elsif ($type eq "more") { enc_U8 253; } elsif ($type eq "comment") { # handle other string params, too enc_U8 9; enc_STRING $arg[0]; } elsif ($type eq "label") { enc_U8 0; enc_U16 ord substr "$arg[0]\x00\x00", 0, 1; enc_U16 ord substr "$arg[0]\x00\x00", 1, 1; enc_U16 ord substr "$arg[0]\x00\x00", 2, 1; enc_U8 $arg[1]; enc_U8 $arg[2]; } elsif ($marker_code{$type}) { enc_U8 $marker_code{$type}; enc_U8 $arg[0]; enc_U8 $arg[1]; enc_U8 $arg[2]; } else { warn "unable to encode tree node type $type\n"; } } } ]]> ############################################################################# # messages } 1; sub dec_ { my @r = unpack "v a*", $data; $data = pop @r; join ":", map chr, @r; } sub enc_ { $data .= pack "v", map ord, split //, $_[0]; } sub dec_ { (my ($r), $data) = unpack "Z a*", $data; $r; } sub enc_ { $data .= pack "Z", $_[0]; } sub dec_ { (1 / ) * dec_; } sub enc_ { enc_ $_[0] * ; } $r->{} = (my $array = []); while (length $data) { push @$array, dec_ ; } $r->{} = dec_ if ($r->{} ) ; $_[0]{} =~ /^[A-Za-z][A-Za-z0-9]{0,11}$/ or Carp::confess "FATAL: tried to send illegal username '$_[0]{}'"; enc_ defined $_[0]{} ? $_[0]{ } : ( ); sub dec_ { my $r = {}; bless $r, ::; $r; } sub enc_ { } # $recv{0x} = sub { $data = $_[0]; my $r; $r->{type} = ""; $r; }; $send{} = sub { $data = ""; enc_U16 0x; $data; }; [ => " ", " ", " ;"],