From: nwf <nwf@cs.jhu.edu>
Date: Wed, 27 Aug 2008 09:17:37 +0000 (-0400)
Subject: Move TLV to MasterCoder, and fallout from that.
X-Git-Url: https://hydra-www.ietfng.org/gitweb/?a=commitdiff_plain;h=309ba75367a94e9b8edb47ab6e4c3d8293c7a662;p=instirc

Move TLV to MasterCoder, and fallout from that.

darcs-hash:20080827091737-4d648-0c5924a02e8f28d068ddc9657031a7a3af70db72.gz
---

diff --git a/Definitions.pm b/Definitions.pm
index e2a1874..ec1fad0 100644
--- a/Definitions.pm
+++ b/Definitions.pm
@@ -17,9 +17,12 @@ require Exporter;
 );
 
 #################################################################
+    # We specify these as numbers which MasterCoder will T-encode for
+    # us so that we can see them when we switch to using debug code
+    # sets.  Somewhat cheesy, I suppose, but nevertheless handy.
 
-our $MESSAGE_START = "";
-our $MESSAGE_END = "";
+our $MESSAGE_START = 21;    # Encodes as ^O^O using default_code_chars
+our $MESSAGE_END = 3;       # Encodes as ^O   using default_code_chars
 
 #################################################################
 
diff --git a/HuffmanCoder_test.pl b/HuffmanCoder_test.pl
index 0c21f82..57521b5 100644
--- a/HuffmanCoder_test.pl
+++ b/HuffmanCoder_test.pl
@@ -5,9 +5,10 @@ use strict;
 # use Irssi::Scripts::Instance::Mastercode; ### XXX
 require MasterCoder;
 require HuffmanCoder;
-use Definitions qw( @debug_code_chars $instance_huffman_table1 );
+use Definitions qw( @debug_code_chars $instance_huffman_table1 
+                    $MESSAGE_START $MESSAGE_END );
 
-my $mastercoder = MasterCoder->new(\@debug_code_chars);
+my $mastercoder = MasterCoder->new(\@debug_code_chars, $MESSAGE_START, $MESSAGE_END);
 my $huffmancoder = HuffmanCoder->new($mastercoder, $instance_huffman_table1);
 
 #print "Dumping encoding table:\n";
diff --git a/MasterCoder.pm b/MasterCoder.pm
index de57c09..dbc2f8d 100644
--- a/MasterCoder.pm
+++ b/MasterCoder.pm
@@ -4,14 +4,16 @@ use strict;
 use Math::BaseCalc;
 use POSIX qw( floor );
 
-#package Irssi::Scripts::Instance::Mastercoder;
+#package Irssi::Scripts::Instance::MasterCoder;
 package MasterCoder;
 
 #################################################################
 
-sub new ($$) {
+sub new ($$$$) {
   my $class = shift @_;
   my $code_chars = shift @_;
+  my $msgprefix = shift @_;
+  my $msgsuffix = shift @_;
 
   return undef if not defined $code_chars;
 
@@ -23,7 +25,7 @@ sub new ($$) {
 
   my $tencoder = new Math::BaseCalc(digits => $code_chars);
 
-  bless {
+  my $self = bless {
     # Treat as read only exports, please
    'code_chars' => $code_chars,
    'code_chars_rev' => $code_chars_rev,
@@ -33,6 +35,11 @@ sub new ($$) {
     # ->tencode and ->tdecode instead.
    '_tencoder' => $tencoder,
   }, $class;
+
+  $$self{'msg_prefix'} = $self->tencode($msgprefix);
+  $$self{'msg_suffix'} = $self->tencode($msgsuffix);
+
+  return $self;
 }
 
 #################################################################
@@ -78,8 +85,8 @@ sub lencode ($$) {
 
     my $ccc = $$self{'code_chars_count'};
 
-    die "Can't encode numbers that big!" if $enclen >= $ccc - 1;
-
+    warn "Can't encode numbers that big!" if $enclen >= $ccc - 1;
+    return undef if $enclen >= $ccc - 1;
     return $self->tencode($enclen) if $in == 0;
 
     $in -= $self->_lenc_correction($enclen);
@@ -96,9 +103,9 @@ sub ldecode($$) {
 
     my $ccc = $$self{'code_chars_count'};
 
-    die "Can't decode numbers that big!" if $reallen >= $ccc - 1;
+    warn "Can't decode numbers that big!" if $reallen >= $ccc - 1;
 
-    return (undef, undef) if length $in < $reallen;
+    return (undef, undef) if length $in < $reallen or $reallen >= $ccc - 1;
 
     my $encval = substr($in, 1, $reallen);
 
@@ -108,6 +115,97 @@ sub ldecode($$) {
     return ( $realval, $reallen+1 )
 }
 
+#################################################################
+
+    # Takes an already encoded message (encoded somehow by the
+    # outside, e.g. with a HuffmanCoder or by using tencode or
+    # lencode directly) and wraps it inside a TLV record.
+sub tlv_wrap($$$) {
+    my ($self, $type, $message) = @_;
+
+    ### XXX We really ought ensure that the T-encoded forms are
+    ### exactly, rather than just at least, two symbols wide.
+
+    return $self->tencode_padded($type,2)
+         . $self->lencode(length $message)
+         . $message;
+}
+
+    # Takes a reference to an array of TLVs and concatenates them,
+    # framing the whole result as required by protocol.
+sub tlvs_to_message($$){
+    my ($self, $tlvs) = @_;
+
+    my $mesg = "";
+
+    foreach my $tlv (@$tlvs) {
+       $mesg = $mesg . $tlv; 
+    }
+
+    my $lenc = $self->lencode(length $mesg);
+
+    return $$self{'msg_prefix'}.$lenc.$mesg.$$self{'msg_suffix'};
+}
+
+sub tlv_run_callbacks($$$) {
+    my ($self, $cbs, $msg) = @_;
+
+        # Note how this regex works: it will greedily consume into
+        # what we think is the message, and may have to backtrack out
+        # to find msg_suffix.  It will never prematurely terminate
+        # the encoded message if it sees msg_prefix inside the message.
+    my $regex = "^".$$self{'msg_prefix'}."(["
+              . (join ("",@{$$self{'code_chars'}}))
+              ."]+)".$$self{'msg_suffix'}."(.*)\$";
+
+    my $rest;
+    if ( $msg =~ /$regex/ ) {
+        $rest = $2;
+            # That's meta-l, not the conductive solid.
+        my ($metal, $metallen) = $self->ldecode($1);
+        return (0, $msg) if (length $1) < $metallen + $metal;
+            # So here's an interesting connundrum.  It might be that
+            # the additional text we insert after ours looks like a
+            # message end.  Therefore, once we have extracted metal,
+            # we need to check that there's a msg_suffix where there
+            # should be.
+        if ((length $1) > $metallen + $metal) {
+            my $ssws = substr($1, $metallen + $metal);
+            return (0, $msg) if (index $ssws, $$self{'msg_suffix'});
+
+            # Now put what should be on $rest back on it.
+            $rest = substr($1, $metallen + $metal) . $rest;
+        }
+        $msg = substr($1, $metallen, $metal);
+    } else {
+        return (0, $msg);
+    }
+
+    while( $msg ne "" )
+    {
+        last if length $msg < 2;
+        my $tenc = substr($msg, 0, 2);
+        my $msg2 = substr($msg, 2); 
+        my $t = $self->tdecode($tenc);
+
+        my ($l, $lenclen) = $self->ldecode($msg2);
+        last if not defined $l;
+        my $msg3 = substr($msg2, $lenclen);
+
+        last if length $msg3 < $l;
+        my $v = substr($msg3, 0, $l);
+        $msg = substr($msg3, $l);
+
+        if (exists $$cbs{$t}) {
+            $$cbs{$t}($t, $v);
+        } elsif (exists $$cbs{'default'}) {
+            $$cbs{'default'}($t, $v);
+        }
+    }
+
+    return ($msg eq "", $rest);
+} 
+ 
 #################################################################
 
 1;
diff --git a/MasterCoder_test.pl b/MasterCoder_test.pl
index 5c7a0a3..8b0583d 100644
--- a/MasterCoder_test.pl
+++ b/MasterCoder_test.pl
@@ -3,9 +3,12 @@ use strict;
 
 # use Irssi::Scripts::Instance::Mastercode; ### XXX
 require MasterCoder;
-use Definitions qw( @debug_code_chars );
+use Definitions qw( @debug_code_chars $MESSAGE_START $MESSAGE_END );
 
-my $coder = MasterCoder->new(\@debug_code_chars);
+my $coder = MasterCoder->new(\@debug_code_chars, $MESSAGE_START, $MESSAGE_END );
+
+print "Some handy quick tests... \n";
+die unless $coder->tencode_padded($MESSAGE_START,2) eq "OO";
 
 print "Checking T encoding machinery... \n";
 
diff --git a/Protoutils_test.pl b/MasterCoder_tlv_test.pl
similarity index 65%
rename from Protoutils_test.pl
rename to MasterCoder_tlv_test.pl
index 73c53ae..a0cde02 100644
--- a/Protoutils_test.pl
+++ b/MasterCoder_tlv_test.pl
@@ -3,12 +3,13 @@ use strict;
 
 use Definitions qw( %known_types
                     @debug_code_chars
-                    $instance_huffman_table1 );
+                    $instance_huffman_table1
+                    $MESSAGE_START $MESSAGE_END );
 require MasterCoder;
 require HuffmanCoder;
-use Protoutils qw( tlv_wrap tlvs_to_message dump_message run_callbacks );
+use Protoutils qw( dump_message );
 
-my $mc = MasterCoder->new(\@debug_code_chars);
+my $mc = MasterCoder->new(\@debug_code_chars, $MESSAGE_START, $MESSAGE_END);
 my $hc = HuffmanCoder->new($mc, $instance_huffman_table1);
 
 my @test_strings = ( "hi", "there", "coin", "test", "!@#\$&*.-=" );
@@ -16,16 +17,17 @@ my @tlvs = ();
 
 foreach my $ts (@test_strings) {
   my $enc = $hc->encode($ts);
-  my $tlv = tlv_wrap( $mc, $known_types{'InstanceLabelHuffman1'}, $enc);
+  my $tlv = $mc->tlv_wrap( $known_types{'InstanceLabelHuffman1'}, $enc);
 
   push @tlvs, $tlv;
 
   print "ENCODED '", $ts, "' into hc ", $enc, " and tlv ", $tlv, "\n";
 }
 
-my $mesg_suffix = "This is some normal text.";
-my $mesg = tlvs_to_message(\@tlvs) . $mesg_suffix;
+my $mesg_suffix = "OOOOOh, This is some normal text, designed to be confusing.";
+my $mesg = $mc->tlvs_to_message(\@tlvs) . $mesg_suffix;
 
+print "Full encoded message is '$mesg'\n";
 dump_message($mc, $mesg);
 
 my $i = 0;
@@ -45,11 +47,13 @@ sub def_cb ($$) {
     die "Unanticipated message of type $t: $v";
 }
 
-my ($res, $rest) = run_callbacks($mc,
+my ($res, $rest) = $mc->tlv_run_callbacks(
               { 'default' => \&def_cb,
                 $known_types{'InstanceLabelHuffman1'} => \&ilf_cb,
               },
               $mesg );
 
+#print $mesg_suffix,"\n",$rest,"\n";
+
 die unless $res eq 1;
 die unless $rest eq $mesg_suffix;
diff --git a/Protoutils.pm b/Protoutils.pm
index 9364121..70f487c 100644
--- a/Protoutils.pm
+++ b/Protoutils.pm
@@ -9,84 +9,14 @@ require Exporter;
 @ISA = qw(Exporter);
 
 @EXPORT_OK = qw(
-    tlv_wrap tlvs_to_message
-    run_callbacks
     dump_message
 );
 
-
-
-use Definitions qw( $MESSAGE_START $MESSAGE_END );
-
 #################################################################
 
-sub tlv_wrap($$$) {
-    my ($coder, $type, $message) = @_;
-
-    return $coder->tencode_padded($type,2)
-         . $coder->lencode(length $message)
-         . $message;
-}
-
-sub tlvs_to_message($){
-    my ($tlvs) = @_;
-
-    my $mesg = $MESSAGE_START;
-
-    foreach my $tlv (@$tlvs) {
-       $mesg = $mesg . $tlv; 
-    }
-
-    return $mesg . $MESSAGE_END;
-}
-
-sub run_callbacks($$$) {
-    my ($coder, $cbs, $msg) = @_;
-
-    my $regex = "^$MESSAGE_START(["
-              . (join ("",@{$$coder{'code_chars'}}))
-              ."]+)$MESSAGE_END(.*)\$";
-
-    my $rest;
-        # Note how this regex works: it will greedily consume into
-        # what we think is the message, and may have to backtrack out
-        # to find MESSAGE_END.  It will never prematurely terminate
-        # the encoded message if it sees MESSAGE_END inside the message.
-    if ( $msg =~ /$regex/ ) {
-        $msg = $1;
-        $rest = $2;
-    } else {
-        return (0, $msg);
-    }
-
-    while( $msg ne "" )
-    {
-        last if length $msg < 2;
-        my $tenc = substr($msg, 0, 2);
-        my $msg2 = substr($msg, 2); 
-        my $t = $coder->tdecode($tenc);
-
-        my ($l, $lenclen) = $coder->ldecode($msg2);
-        last if not defined $l;
-        my $msg3 = substr($msg2, $lenclen);
-
-        last if length $msg3 < $l;
-        my $v = substr($msg3, 0, $l);
-        $msg = substr($msg3, $l);
-
-        if (exists $$cbs{$t}) {
-            $$cbs{$t}($t, $v);
-        } elsif (exists $$cbs{'default'}) {
-            $$cbs{'default'}($t, $v);
-        }
-    }
-
-    return ($msg eq "", $rest);
-}
-
 sub dump_message($$) {
     my ($coder, $msg) = @_;
-    run_callbacks($coder,
+    $coder->tlv_run_callbacks(
                   {'default' => sub {
                                   my ($t,$v) = @_;
                                   print "T=$t, V=$v\n";
diff --git a/irssi_test_new.pl b/irssi_test_new.pl
index b2c885a..9ed3cc6 100644
--- a/irssi_test_new.pl
+++ b/irssi_test_new.pl
@@ -24,12 +24,18 @@ $VERSION = 'irssi-test v0.01';
 require MasterCoder;
 require HuffmanCoder;
 use Definitions qw( %known_types
-                    @default_code_chars
-                    $instance_huffman_table1 );
-use Protoutils qw( tlv_wrap tlvs_to_message run_callbacks );
+                    @debug_code_chars @default_code_chars
+                    $instance_huffman_table1
+                    $MESSAGE_START $MESSAGE_END );
 
-my $mc = MasterCoder->new(\@default_code_chars);
-my $hc = HuffmanCoder->new($mc, $instance_huffman_table1);
+my $mc_dbg = MasterCoder->new(\@debug_code_chars,   $MESSAGE_START, $MESSAGE_END);
+my $mc_dfl = MasterCoder->new(\@default_code_chars, $MESSAGE_START, $MESSAGE_END);
+my $hc_dbg = HuffmanCoder->new($mc_dbg, $instance_huffman_table1);
+my $hc_dfl = HuffmanCoder->new($mc_dfl, $instance_huffman_table1);
+
+# XXX Allow some kind of runtime switch between these?
+my $mc = $mc_dfl;
+my $hc = $hc_dfl;
 
 #################################################################
 
@@ -44,7 +50,7 @@ sub test_filter_in {
   Irssi::print("Filter_in: text is $text; ($d, $d1, $d2, $d3)");
 
   my $instance_label = undef;
-  my ($res, $rest) = run_callbacks($mc,
+  my ($res, $rest) = $mc->tlv_run_callbacks(
               { $known_types{'InstanceLabelHuffman1'} => 
                 sub ($$) {
                   my ($t,$v) = @_;
@@ -82,7 +88,7 @@ sub test_filter_in_2 {
   Irssi::print("Filter_in_2: text is $text; ($d, $target)");
 
   my $instance_label = undef;
-  my ($res, $rest) = run_callbacks($mc,
+  my ($res, $rest) = $mc->tlv_run_callbacks(
               { $known_types{'InstanceLabelHuffman1'} => 
                 sub ($$) {
                   my ($t,$v) = @_;
@@ -123,7 +129,7 @@ sub test_filter_out {
   return if $a == 0 || $b == 0; # XXX
   Irssi::print("Filter_out: text is $text; ($a, $b)");
 
-  $text = tlvs_to_message([tlv_wrap($mc,
+  $text = $mc->tlvs_to_message([$mc->tlv_wrap(
                            $known_types{'InstanceLabelHuffman1'},
                            $hc->encode(Irssi::settings_get_str("current_instance")))
                            ] ) . $text . " \@";