Add Protoutils module

darcs-hash:20080827063928-4d648-d6e6e148e7a40c35c94cb6dc13107d3eed36c94f.gz

diff --git a/Protoutils.pm b/Protoutils.pm
new file mode 100644 (file)
index 0000000..12c5624
--- /dev/null
+++ b/Protoutils.pm
@@ -0,0 +1,86 @@
+use warnings;
+use strict;
+
+#package Irssi::Scripts::Instance::Protoutils;
+package Protoutils;
+
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
+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) = @_;
+
+    return if (0 ne index $msg, $MESSAGE_START);
+    $msg = substr($msg, length $MESSAGE_START);
+
+    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 "";
+}
+
+sub dump_message($$) {
+    my ($coder, $msg) = @_;
+    run_callbacks($coder,
+                  {'default' => sub {
+                                  my ($t,$v) = @_;
+                                  print "T=$t, V=$v\n";
+                                }},
+                  $msg);
+}
+
+#################################################################
+
+1;

diff --git a/Protoutils_test.pl b/Protoutils_test.pl
new file mode 100644 (file)
index 0000000..08913fa
--- /dev/null
+++ b/Protoutils_test.pl
@@ -0,0 +1,51 @@
+use warnings;
+use strict;
+
+use Definitions qw( %known_types
+                    @debug_code_chars
+                    $instance_huffman_table1 );
+require MasterCoder;
+require HuffmanCoder;
+use Protoutils qw( tlv_wrap tlvs_to_message dump_message run_callbacks );
+
+my $mc = MasterCoder->new(\@debug_code_chars);
+my $hc = HuffmanCoder->new($mc, $instance_huffman_table1);
+
+my @test_strings = ( "hi", "there", "coin", "test", "!@#\$&*.-=" );
+my @tlvs = ();
+
+foreach my $ts (@test_strings) {
+  my $enc = $hc->encode($ts);
+  my $tlv = tlv_wrap( $mc, $known_types{'InstanceLabelHuffman1'}, $enc);
+
+  push @tlvs, $tlv;
+
+  print "ENCODED '", $ts, "' into hc ", $enc, " and tlv ", $tlv, "\n";
+}
+
+my $mesg = tlvs_to_message(\@tlvs);
+
+dump_message($mc, $mesg);
+
+my $i = 0;
+sub ilf_cb ($$) {
+    my ($t,$v) = @_;
+
+    die unless $t = $known_types{'InstanceLabelHuffman1'};
+
+    my $dcv = $hc->decode($v);
+    print "Decoded message: $dcv\n";
+
+    die unless $test_strings[$i++] eq $dcv;
+}
+
+sub def_cb ($$) {
+    my ($t,$v) = @_;
+    die "Unanticipated message of type $t: $v";
+}
+
+run_callbacks($mc,
+              { 'default' => \&def_cb,
+                $known_types{'InstanceLabelHuffman1'} => \&ilf_cb,
+              },
+              $mesg );