);
#################################################################
+ # 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 = "\ f\ f";
-our $MESSAGE_END = "\ f";
+our $MESSAGE_START = 21; # Encodes as ^O^O using default_code_chars
+our $MESSAGE_END = 3; # Encodes as ^O using default_code_chars
#################################################################
# 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";
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;
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,
# ->tencode and ->tdecode instead.
'_tencoder' => $tencoder,
}, $class;
+
+ $$self{'msg_prefix'} = $self->tencode($msgprefix);
+ $$self{'msg_suffix'} = $self->tencode($msgsuffix);
+
+ return $self;
}
#################################################################
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);
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);
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;
# 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";
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", "!@#\$&*.-=" );
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;
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;
@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";
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;
#################################################################
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) = @_;
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) = @_;
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 . " \@";
projects / instirc / commitdiff