Initial checkin

darcs-hash:20080725111809-7dbc8-c078692c210c94a9c780587122530f33b37ed131.gz

diff --git a/irssi_test.pl b/irssi_test.pl
new file mode 100644 (file)
index 0000000..bd73a80
--- /dev/null
+++ b/irssi_test.pl
@@ -0,0 +1,306 @@
+use strict;
+use warnings;
+no warnings 'closure';
+
+use vars qw($VERSION %IRSSI);
+$| = 1;
+
+use Irssi;
+$VERSION = 'irssi-test v0.01';
+%IRSSI = (
+    authors => 'Glenn Willen',
+    contact => 'gwillen@nerdnet.org',
+    name => 'irssi-test',
+    description => 'Heh.',
+    license => 'Public domain');
+
+# Sometimes, for some unknown reason, perl emits warnings like the following:
+#   Can't locate package Irssi::Nick for @Irssi::Irc::Nick::ISA
+# This package statement is here to suppress it.
+{ package Irssi::Nick }
+
+# XXX Do we want to make any guarantees about the appearance of this delimiter
+# in our encoded message?
+my $MAGIC_DELIM = "\ f\ f";
+my $END_CODE = "\ f";
+
+#################################################################
+
+my @code_chars = ("\ f", "\16", "\ 3", "\a", "\ 2", "\1f");
+my %code_chars_rev = ();
+my $i = 0;
+foreach (@code_chars) {
+  $code_chars_rev{$_} = $i++;
+}
+
+#################################################################
+
+my $decode_table = [
+  "abcdef",
+  "ghijkl",
+  "mnopqr",
+  "stuvwx",
+  [ "y",
+    "z",
+    "-",
+    "_", 
+    ".+=&\@!",
+    "*^/\$#?" ],
+  [ "ABCDEF",
+    "GHIJKL",
+    "MNOPQR",
+    "STUVWX",
+    "YZ1234",
+    "567890"] ];
+
+sub build_encoding_table($$$);
+sub build_encoding_table($$$) {
+  my ($dec_tbl, $enc_tbl, $prefix) = @_;
+
+  if (ref $dec_tbl eq "") {
+    if (length $dec_tbl == 1) {
+      $enc_tbl->{$dec_tbl} = $prefix;
+    } else {
+      my $i = 0;
+      foreach my $char (split(//, $dec_tbl)) {
+        build_encoding_table($char, $enc_tbl, $prefix.$code_chars[$i++]);
+      }
+    }
+  } else {
+    my $i = 0;
+    foreach my $tbl (@$dec_tbl) {
+      build_encoding_table($tbl, $enc_tbl, $prefix.$code_chars[$i++]);
+    }
+  }
+}
+
+my $encode_table = {};
+build_encoding_table($decode_table, $encode_table, "");
+
+sub dump_decode_table($);
+sub dump_decode_table($) {
+  my ($tbl) = @_;
+
+  if (ref $tbl eq "") {
+    if (length $tbl == 1) {
+      print $tbl;
+    } else {
+      print "\"$tbl\"";
+    }
+  } else {
+    print "[";
+    for my $i (0 .. 5) {
+      dump_decode_table($tbl->[$i]);
+    }
+    print "]";
+  }
+}
+
+#################################################################
+
+sub encode_instance($) {
+  my ($inst) = @_;
+
+  my $result = "";
+  foreach my $char (split(//, $inst)) {
+    my $code = $encode_table->{$char};
+    $result .= $code;
+  }
+  return $result.$END_CODE;
+}
+
+sub decode_char($$) {
+  my ($char, $tbl) = @_;
+  
+  if (ref $tbl eq "") {
+    return substr($tbl, $code_chars_rev{$char}, 1);
+  } else {
+    return $tbl->[$code_chars_rev{$char}];
+  }
+}
+
+sub is_char($) {
+  my ($char) = @_;
+  return (ref $char eq "") && (length $char == 1);
+}
+
+sub decode_instance($) {
+  my ($inst) = @_;
+
+  my $lastchar = substr($inst, length($inst) - 1);
+  return "" if $lastchar ne $END_CODE;
+  $inst = substr($inst, 0, length($inst) - 1);
+
+  my $result = "";
+  while ($inst ne "") {
+    my $tbl = $decode_table;
+    while (!is_char($tbl)) {
+      my $code = substr($inst, 0, 1);
+      $inst = substr($inst, 1);
+      $tbl = decode_char($code, $tbl);
+    }
+    $result .= $tbl;
+  }
+  return $result;
+}
+
+#################################################################
+
+my $suppress = 0;
+my $suppress2 = 0;
+
+sub test_filter_in {
+  if ($suppress) { return; }
+  my $sendmsg = 1;
+
+  my ($d, $text, $d1, $d2, $d3) = @_;
+  Irssi::print("Filter_in: text is $text; ($d, $d1, $d2, $d3)");
+  if ($text =~ /$MAGIC_DELIM/) {
+    Irssi::print("Contains magic delimiter!");
+    my ($msg, $inst) = split("$MAGIC_DELIM", $text, 2);
+    my $instance = decode_instance($inst);
+    my @puntlist = split(",", Irssi::settings_get_str("punt_list"));
+    my $match = scalar grep { $_ eq $instance } @puntlist;
+    if ($match) {
+      $sendmsg = 0;
+    }
+    $text = "[$instance] $msg";
+  }
+
+  if ($sendmsg) {
+    my $emitted_signal = Irssi::signal_get_emitted();
+
+    $suppress = 1;
+    Irssi::signal_emit("$emitted_signal", $d, $text, $d1, $d2, $d3);
+    $suppress = 0;
+  }
+  Irssi::signal_stop();
+}
+
+sub test_filter_in_2 {
+  if ($suppress2) { return; } # XXX
+  my $sendmsg = 1;
+
+  my ($d, $text, $target) = @_;
+  Irssi::print("Filter_in_2: text is $text; ($d, $target)");
+  if ($text =~ /$MAGIC_DELIM/) {
+    Irssi::print("Contains magic delimiter!");
+    my ($msg, $inst) = split("$MAGIC_DELIM", $text, 2);
+    my $instance = decode_instance($inst);
+    if (inst_punted($instance)) {
+      $sendmsg = 0;
+    }
+    $text = "[$instance] $msg";
+  }
+
+  if ($sendmsg) {
+    my $emitted_signal = Irssi::signal_get_emitted();
+
+    $suppress2 = 1;
+    Irssi::signal_emit("$emitted_signal", $d, $text, $target);
+    $suppress2 = 0;
+  }
+  Irssi::signal_stop();
+}
+
+sub test_filter_out {
+  if ($suppress) { return; }
+
+  my $emitted_signal = Irssi::signal_get_emitted();
+
+  my ($text, $a, $b) = @_;
+  # If they lack a server or a channel, trying to resend the message will cause
+  # a crash, strangely. So we don't do that.
+  return if $a == 0 || $b == 0; # XXX
+  Irssi::print("Filter_out: text is $text; ($a, $b)");
+  $text .= " \@".$MAGIC_DELIM.encode_instance(Irssi::settings_get_str("current_instance"));
+
+  $suppress = 1;
+  Irssi::signal_emit("$emitted_signal", $text, $a, $b);
+  Irssi::signal_stop();
+  $suppress = 0;
+}
+
+#sub current_instance {
+#  my ($item, $get_size_only) = @_;
+#
+#  $item->default_handler($get_size_only, "message", 0, 1);
+#}
+
+#################################################################
+
+sub inst_punted($) {
+  my ($inst) = @_;
+
+  my @puntlist = split(",", Irssi::settings_get_str("punt_list"));
+  my $match = scalar grep { $_ eq $inst } @puntlist;
+
+  return ($match > 0);
+}
+
+sub punt_inst($) {
+  my ($inst) = @_;
+
+  Irssi::print("punting: $inst");
+
+  if ($inst =~ /,/) {
+    Irssi::print("Warning: Can't punt comma!");
+    return;
+  }
+  my @puntlist = split(",", Irssi::settings_get_str('punt_list'));
+  push @puntlist, $inst;
+  Irssi::settings_set_str('punt_list', join(",", @puntlist));
+}
+
+sub unpunt_inst($) {
+  my ($inst) = @_;
+
+  Irssi::print("unpunting: $inst");
+
+  if ($inst =~ /,/) {
+    Irssi::print("Warning: Can't unpunt comma!");
+    return;
+  }
+
+  my @puntlist = split(",", Irssi::settings_get_str('punt_list'));
+  @puntlist = grep { $_ ne $inst } @puntlist;
+  Irssi::settings_set_str('punt_list', join(",", @puntlist));
+}
+
+#################################################################
+
+sub cmd_instance {
+  pop @_;
+  pop @_; # XXX
+  Irssi::print("instance: $_[0]");
+  Irssi::settings_set_str('current_instance', $_[0]);
+}
+
+sub cmd_punt {
+  my ($unk1, $unk2, $inst) = @_;
+  punt_inst($inst);
+}
+
+sub cmd_unpunt {
+  my ($unk1, $unk2, $inst) = @_;
+  unpunt_inst($inst);
+} 
+
+#################################################################
+
+Irssi::signal_add_first('message public', 'test_filter_in');
+Irssi::signal_add_first('message own_public', 'test_filter_in_2');
+Irssi::signal_add_first('send text', 'test_filter_out');
+Irssi::command_bind('instance', 'cmd_instance');
+Irssi::command_bind('punt', 'cmd_punt');
+Irssi::command_bind('unpunt', 'cmd_unpunt');
+Irssi::settings_add_str('lookandfeel', 'current_instance', "default");
+Irssi::settings_add_str('lookandfeel', 'punt_list', "");
+# XXX :-(
+#Irssi::statusbar_item_register('current_instance', undef, 'current_instance');
+#Irssi::statusbars_recreate_items();
+#Irssi::statusbar_items_redraw('current_instance');
+    
+#################################################################
+
+Irssi::print("Instancing module vNO.JUST.NO - Glenn Willen");