aboutsummaryrefslogtreecommitdiffstats
path: root/fixery
diff options
context:
space:
mode:
Diffstat (limited to 'fixery')
-rw-r--r--fixery/adv_windowlist.pl2564
1 files changed, 0 insertions, 2564 deletions
diff --git a/fixery/adv_windowlist.pl b/fixery/adv_windowlist.pl
deleted file mode 100644
index 4ca18fe..0000000
--- a/fixery/adv_windowlist.pl
+++ /dev/null
@@ -1,2564 +0,0 @@
-# {{{ debug
-
-#BEGIN {
-# open STDERR, '>', '/home/ailin/wlstatwarnings';
-#};
-
-# FIXME COULD SOMEONE PLEASE TELL ME HOW TO SHUT UP
-#
-# ...
-# Variable "*" will not stay shared at (eval *) line *.
-# Variable "*" will not stay shared at (eval *) line *.
-# ...
-# Can't locate package Irssi::Nick for @Irssi::Irc::Nick::ISA at (eval *) line *.
-# ...
-#
-# THANKS
-
-# }}}
-
-# if you don't know how to operate folds, type zn
-
-# {{{ header
-
-use strict;
-use warnings;
-
-use Irssi (); # which is the minimum required version of Irssi ?
-use Irssi::TextUI;
-
-our $VERSION = '0.7';
-our %IRSSI = (
- original_authors => q(BC-bd, Veli, Timo Sirainen, ).
- q(Wouter Coekaerts, Jean-Yves Lefort), # (decadix)
- original_contact => q(bd@bc-bd.org, veli@piipiip.net, tss@iki.fi, ).
- q(wouter@coekaerts.be, jylefort@brutele.be),
- authors => q(Nei),
- contact => q(Nei@QuakeNet),
- url => "http://ai.onetrix.net/",
- name => q(awl),
- description => q(Adds a permanent advanced window list on the right or ).
- q(in a statusbar.),
- description2 => q(Based on chanact.pl which was apparently based on ).
- q(lightbar.c and nicklist.pl with various other ideas ).
- q(from random scripts.),
- license => q(GNU GPLv2 or later),
-);
-
-# }}}
-
-# {{{ *** D O C U M E N T A T I O N ***
-
-# adapted by Nei
-
-###############
-# {{{ original comment
-# ###########
-# # Adds new powerful and customizable [Act: ...] item (chanelnames,modes,alias).
-# # Lets you give alias characters to windows so that you can select those with
-# # meta-<char>.
-# #
-# # for irssi 0.8.2 by bd@bc-bd.org
-# #
-# # inspired by chanlist.pl by 'cumol@hammerhart.de'
-# #
-# #########
-# # {{{ Contributors
-# #########
-# #
-# # veli@piipiip.net /window_alias code
-# # qrczak@knm.org.pl chanact_abbreviate_names
-# # qerub@home.se Extra chanact_show_mode and chanact_chop_status
-# # }}}
-# }}}
-#
-# {{{ FURTHER THANKS TO
-# ############
-# # buu, fxn, Somni, Khisanth, integral, tybalt89 for much support in any aspect perl
-# # and the channel in general ( #perl @ freenode ) and especially the ir_* functions
-# #
-# # Valentin 'senneth' Batz ( vb@g-23.org ) for the pointer to grep.pl, continuous support
-# # and help in digging up ir_strip_codes
-# #
-# # OnetrixNET technology networks for the debian environment
-# #
-# # Monkey-Pirate.com / Spaceman Spiff for the webspace
-# #
-# }}}
-
-######
-# {{{ M A I N P R O B L E M
-#####
-#
-# It is impossible to place the awl on a statusbar together with other items,
-# because I do not know how to calculate the size that it is going to get
-# granted, and therefore I cannot do the linebreaks properly.
-# This is what is missing to make a nice script out of awl.
-# If you have any ideas, please contact me ASAP :).
-# }}}
-######
-
-######
-# {{{ UTF-8 PROBLEM
-#####
-#
-# Please help me find a solution to this:
-# this be your statusbar, it is using up the maximum term size
-# [[1=1]#abc [2=2]#defghi]
-#
-# now consider this example:i
-# "ascii" characters are marked with ., utf-8 characters with *
-# [[1=1]#... [2=2]#...***]
-#
-# you should think that this is how it would be displayed? WRONG!
-# [[1=1]#... [2=2]#...*** ]
-#
-# this is what Irssi does.. I believe my length calculating code to be correct,
-# however, I'd love to be proven wrong (or receive any other fix, too, of
-# course!)
-# }}}
-######
-
-#########
-# {{{ USAGE
-###
-#
-# copy the script to ~/.irssi/scripts/
-#
-# In irssi:
-#
-# /script load awl
-#
-#
-# Hint: to get rid of the old [Act:] display
-# /statusbar window remove act
-#
-# to get it back:
-# /statusbar window add -after lag -priority 10 act
-# }}}
-##########
-# {{{ OPTIONS
-########
-#
-# {{{ /set awl_display_nokey <string>
-# /set awl_display_key <string>
-# /set awl_display_nokey_active <string>
-# /set awl_display_key_active <string>
-# * string : Format String for one window. The following $'s are expanded:
-# $C : Name
-# $N : Number of the Window
-# $Q : meta-Keymap
-# $H : Start highlighting
-# $S : Stop highlighting
-# /+++++++++++++++++++++++++++++++++,
-# | **** I M P O R T A N T : **** |
-# | |
-# | don't forget to use $S if you |
-# | used $H before! |
-# | |
-# '+++++++++++++++++++++++++++++++++/
-# XXX NOTE ON *_active: there is a BUG somewhere in the length
-# XXX calculation. currently it's best to NOT remove $H/$S from those
-# XXX settings if you use it in the non-active settings.
-# }}}
-# {{{ /set awl_separator <string>
-# * string : Charater to use between the channel entries
-# you'll need to escape " " space and "$" like this:
-# "/set awl_separator \ "
-# "/set awl_separator \$"
-# and {}% like this:
-# "/set awl_separator %{"
-# "/set awl_separator %}"
-# "/set awl_separator %%"
-# (reason being, that the separator is used inside a {format })
-# }}}
-# {{{ /set awl_prefer_name <ON|OFF>
-# * this setting decides whether awl will use the active_name (OFF) or the
-# window name as the name/caption in awl_display_*.
-# That way you can rename windows using /window name myownname.
-# }}}
-# {{{ /set awl_hide_data <num>
-# * num : hide the window if its data_level is below num
-# set it to 0 to basically disable this feature,
-# 1 if you don't want windows without activity to be shown
-# 2 to show only those windows with channel text or hilight
-# 3 to show only windows with hilight
-# }}}
-# {{{ /set awl_maxlines <num>
-# * num : number of lines to use for the window list (0 to disable, negative
-# lock)
-# }}}
-# {{{ /set awl_columns <num>
-# * num : number of columns to use in screen mode (0 for unlimited)
-# }}}
-# {{{ /set awl_block <num>
-# * num : width of a column in screen mode (negative values = block display)
-# /+++++++++++++++++++++++++++++++++,
-# | ****** W A R N I N G ! ****** |
-# | |
-# | If your block display looks |
-# | DISTORTED, you need to add the |
-# | following line to your .theme |
-# | file under |
-# | abstracts = { : |
-# | |
-# | sb_act_none = "%n$*"; |
-# | |
-# '+++++++++++++++++++++++++++++++++/
-#.02:08:26. < shi> Irssi::current_theme()->get_format <.. can this be used?
-# }}}
-# {{{ /set awl_sbar_maxlength <ON|OFF>
-# * if you enable the maxlength setting, the block width will be used as a
-# maximum length for the non-block statusbar mode too.
-# }}}
-# {{{ /set awl_height_adjust <num>
-# * num : how many lines to leave empty in screen mode
-# }}}
-# {{{ /set awl_sort <-data_level|-last_line|refnum>
-# * you can change the window sort order with this variable
-# -data_level : sort windows with hilight first
-# -last_line : sort windows in order of activity
-# refnum : sort windows by window number
-# }}}
-# {{{ /set awl_placement <top|bottom>
-# /set awl_position <num>
-# * these settings correspond to /statusbar because awl will create
-# statusbars for you
-# (see /help statusbar to learn more)
-# }}}
-# {{{ /set awl_all_disable <ON|OFF>
-# * if you set awl_all_disable to ON, awl will also remove the
-# last statusbar it created if it is empty.
-# As you might guess, this only makes sense with awl_hide_data > 0 ;)
-# }}}
-# {{{ /set awl_automode <sbar|screen|emulate_lightbar>
-# * this setting defines whether the window list is shown in statusbars or
-# whether the screen hack is used (from nicklist.pl)
-# }}}
-# }}}
-##########
-# {{{ COMMANDS
-########
-# {{{ /awl paste <ON|OFF|TOGGLE>
-# * enables or disables the screen hack windowlist. This is useful when you
-# want to mark & copy text that you want to paste somewhere (hence the
-# name). (ON means AWL disabled!)
-# This is nicely bound to a function key for example.
-# }}}
-# {{{ /awl redraw
-# * redraws the screen hack windowlist. There are many occasions where the
-# screen hack windowlist can get destroyed so you can use this command to
-# fix it.
-# }}}
-# }}}
-###
-# {{{ WISHES
-####
-#
-# if you fiddle with my mess, provide me with your fixes so I can benefit as well
-#
-# Nei =^.^= ( QuakeNet accountname: ailin )
-# }}}
-
-# }}}
-
-# {{{ modules
-
-#use Class::Classless;
-#use Term::Info;
-
-# }}}
-
-# {{{ global variables
-
-my $replaces = '[=]'; # AARGH!!! (chars that are always surrounded by weird
- # colour codes by Irssi)
-
-my $actString = []; # statusbar texts
-my $currentLines = 0;
-my $resetNeeded; # layout/screen has changed, redo everything
-my $needRemake; # "normal" changes
-#my $callcount = 0;
-sub GLOB_QUEUE_TIMER () { 100 }
-my $globTime = undef; # timer to limit remake() calls
-
-my $EXTRA_HILIGHTS_STR = '';
-my $EXTRA_HILIGHTS = {};
-
-my $SCREEN_MODE;
-my $DISABLE_SCREEN_TEMP;
-my $currentColumns = 0;
-my $screenResizing;
-my ($screenHeight, $screenWidth);
-my $screenansi = bless {
- NAME => 'Screen::ANSI',
- PARENTS => [],
- METHODS => {
- dcs => sub { "\033P" },
- st => sub { "\033\\"},
- }
-}, 'Class::Classless::X';
-#my $terminfo = new Term::Info 'xterm'; # xterm here, make this modular
-# {{{{{{{{{{{{{{{
-my $terminfo = bless { # xterm here, make this modular
- NAME => 'Term::Info::xterm',
- PARENTS => [],
- METHODS => {
- # civis=\E[?25l,
- civis => sub { "\033[?25l" },
- # sc=\E7,
- sc => sub { "\0337" },
- # cup=\E[%i%p1%d;%p2%dH,
- cup => sub { shift;shift; "\033[" . ($_[0] + 1) . ';' . ($_[1] + 1) . 'H' },
- # el=\E[K,
- el => sub { "\033[K" },
- # rc=\E8,
- rc => sub { "\0338" },
- # cnorm=\E[?25h,
- cnorm => sub { "\033[?25h" },
- # setab=\E[4%p1%dm,
- setab => sub { shift;shift; "\033[4" . $_[0] . 'm' },
- # setaf=\E[3%p1%dm,
- setaf => sub { shift;shift; "\033[3" . $_[0] . 'm' },
- # bold=\E[1m,
- bold => sub { "\033[1m" },
- # blink=\E[5m,
- blink => sub { "\033[5m" },
- # rev=\E[7m,
- rev => sub { "\033[7m" },
- # op=\E[39;49m,
- op => sub { "\033[39;49m" },
- }
-}, 'Class::Classless::X';
-# }}}}}}}}}}}}}}}
-
-
-sub setc () {
- $IRSSI{name}
-}
-
-sub set ($) {
- setc . '_' . shift
-}
-
-# }}}
-
-
-# {{{ sbar mode
-
-my %statusbars; # currently active statusbars
-
-# maybe I should just tie the array ?
-sub add_statusbar {
- for (@_) {
- # add subs
- for my $l ($_) { {
- no strict 'refs'; # :P
- *{set$l} = sub { awl($l, @_) };
- }; }
- Irssi::command('statusbar ' . (set$_) . ' reset');
- Irssi::command('statusbar ' . (set$_) . ' enable');
- if (lc Irssi::settings_get_str(set 'placement') eq 'top') {
- Irssi::command('statusbar ' . (set$_) . ' placement top');
- }
- if ((my $x = int Irssi::settings_get_int(set 'position')) != 0) {
- Irssi::command('statusbar ' . (set$_) . ' position ' . $x);
- }
- Irssi::command('statusbar ' . (set$_) . ' add -priority 100 -alignment left barstart');
- Irssi::command('statusbar ' . (set$_) . ' add ' . (set$_));
- Irssi::command('statusbar ' . (set$_) . ' add -priority 100 -alignment right barend');
- Irssi::command('statusbar ' . (set$_) . ' disable');
- Irssi::statusbar_item_register(set$_, '$0', set$_);
- $statusbars{$_} = {};
- }
-}
-
-sub remove_statusbar {
- for (@_) {
- Irssi::command('statusbar ' . (set$_) . ' reset');
- Irssi::statusbar_item_unregister(set$_); # XXX does this actually work ?
- # DO NOT REMOVE the sub before you have unregistered it :))
- for my $l ($_) { {
- no strict 'refs';
- undef &{set$l};
- }; }
- delete $statusbars{$_};
- }
-}
-
-sub syncLines {
- my $temp = $currentLines;
- $currentLines = @$actString;
- #Irssi::print("current lines: $temp new lines: $currentLines");
- my $currMaxLines = Irssi::settings_get_int(set 'maxlines');
- if ($currMaxLines > 0 and @$actString > $currMaxLines) {
- $currentLines = $currMaxLines;
- }
- elsif ($currMaxLines < 0) {
- $currentLines = abs($currMaxLines);
- }
- return if ($temp == $currentLines);
- if ($currentLines > $temp) {
- for ($temp .. ($currentLines - 1)) {
- add_statusbar($_);
- Irssi::command('statusbar ' . (set$_) . ' enable');
- }
- }
- else {
- for ($_ = ($temp - 1); $_ >= $currentLines; $_--) {
- Irssi::command('statusbar ' . (set$_) . ' disable');
- remove_statusbar($_);
- }
- }
-}
-
-# FIXME implement $get_size_only check, and user $item->{min|max-size} ??
-sub awl {
- my ($line, $item, $get_size_only) = @_;
-
- if ($needRemake) {
- $needRemake = undef;
- remake();
- }
-
- my $text = $actString->[$line]; # DO NOT set the actual $actString->[$line] to '' here or
- $text = '' unless defined $text; # you'll screw up the statusbar counter ($currentLines)
- $item->default_handler($get_size_only, $text, '', 1);
-}
-
-# remove old statusbars
-my %killBar;
-sub get_old_status {
- my ($textDest, $cont, $cont_stripped) = @_;
- if ($textDest->{'level'} == 524288 and $textDest->{'target'} eq ''
- and !defined($textDest->{'server'})
- ) {
- my $name = quotemeta(set '');
- if ($cont_stripped =~ m/^$name(\d+)\s/) { $killBar{$1} = {}; }
- Irssi::signal_stop();
- }
-}
-sub killOldStatus {
- %killBar = ();
- Irssi::signal_add_first('print text' => 'get_old_status');
- Irssi::command('statusbar');
- Irssi::signal_remove('print text' => 'get_old_status');
- remove_statusbar(keys %killBar);
-}
-#killOldStatus();
-
-# end sbar mode }}}
-
-
-# {{{ keymaps
-
-my %keymap;
-
-sub get_keymap {
- my ($textDest, undef, $stripped_text) = @_;
- #if ($textDest->{'level'} == 524288 and $textDest->{'target'} eq '') {
- if ($textDest->{level} == Irssi::MSGLEVEL_CLIENTCRAP and
- $textDest->{target} eq '') {
- if (not defined($textDest->{server})) {
-
- my $bind = $stripped_text;
- if ($bind =~ m/((?:meta-)+)(.)\s+change_window (\d+)/) {
-
- my ($level, $key, $window) = ($1, $2, $3);
- my $numlevel = ($level =~ y/-//) - 1;
-
- $keymap{$window} = ('-' x $numlevel) . "$key";
-
- } elsif ($bind =~ m/((?:meta-)+)(.)\s+window goto (\d+|(?:#\w+))/) {
- # TODO: make this work moar better
- my ($level, $key, $window) = ($1, $2, $3);
- my $numlevel = ($level =~ y/-//) - 1;
-
- $keymap{$window} = ('-' x $numlevel) . "$key";
- }
-
- Irssi::signal_stop();
- }
-
- }
-}
-
-sub update_keymap {
- %keymap = ();
- Irssi::signal_remove('command bind' => 'watch_keymap');
- Irssi::signal_add_first('print text' => 'get_keymap');
- Irssi::command('bind'); # stolen from grep
- Irssi::signal_remove('print text' => 'get_keymap');
- Irssi::signal_add('command bind' => 'watch_keymap');
- Irssi::timeout_add_once(100, 'eventChanged', undef);
-}
-
-# watch keymap changes
-sub watch_keymap {
- Irssi::timeout_add_once(1000, 'update_keymap', undef);
-}
-
-update_keymap();
-
-# end keymaps }}}
-
-# {{{ format handling
-
-# a bad way do do expansions but who cares
-sub expand {
- my ($string, %format) = @_;
- my ($exp, $repl);
- $string =~ s/\$$exp/$repl/g while (($exp, $repl) = each(%format));
- return $string;
-}
-
-my %strip_table = (
- # fe-common::core::formats.c:format_expand_styles
- # delete format_backs format_fores bold_fores other stuff
- (map { $_ => '' } (split //, '04261537' . 'kbgcrmyw' . 'KBGCRMYW' . 'U9_8:|FnN>#[')),
- # escape
- (map { $_ => $_ } (split //, '{}%')),
-);
-sub ir_strip_codes { # strip %codes
- my $o = shift;
- $o =~ s/(%(.))/exists $strip_table{$2} ? $strip_table{$2} : $1/gex;
- $o
-}
-
-sub ir_parse_special {
- my $o; my $i = shift;
- #if ($_[0]) { # for the future?!?
- # eval {
- # $o = $_[0]->parse_special($i);
- # };
- # unless ($@) {
- # return $o;
- # }
- #}
- my $win = shift || Irssi::active_win();
- my $server = Irssi::active_server();
- if (ref $win and ref $win->{'active'}) {
- $o = $win->{'active'}->parse_special($i);
- }
- elsif (ref $win and ref $win->{'active_server'}) {
- $o = $win->{'active_server'}->parse_special($i);
- }
- elsif (ref $server) {
- $o = $server->parse_special($i);
- }
- else {
- $o = Irssi::parse_special($i);
- }
- $o
-}
-sub ir_parse_special_protected {
- my $o; my $i = shift;
- $i =~ s/
- ( \\. ) | # skip over escapes (maybe)
- ( \$[^% $\]+ ) # catch special variables
- /
- if ($1) { $1 }
- elsif ($2) { my $i2 = $2; ir_fe(ir_parse_special($i2, @_)) }
- else { $& }
- /gex;
- $i
-}
-
-
-sub sb_ctfe { # Irssi::current_theme->format_expand wrapper
- Irssi::current_theme->format_expand(
- shift,
- (
- Irssi::EXPAND_FLAG_IGNORE_REPLACES
- |
- ($_[0]?0:Irssi::EXPAND_FLAG_IGNORE_EMPTY)
- )
- )
-}
-sub sb_expand { # expand {format }s (and apply parse_special for $vars)
- ir_parse_special(
- sb_ctfe(shift)
- )
-}
-sub sb_strip {
- ir_strip_codes(
- sb_expand(shift)
- ); # does this get us the actual length of that s*ty bar :P ?
-}
-sub sb_length {
- # unicode cludge, d*mn broken Irssi
- # screw it, this will fail from broken joining anyway (and cause warnings)
- my $term_type = 'term_type';
- if (Irssi::version > 20040819) { # this is probably wrong, but I don't know
- # when the setting name got changed
- $term_type = 'term_charset';
- }
- #if (lc Irssi::settings_get_str($term_type) eq '8bit'
- # or Irssi::settings_get_str($term_type) =~ /^iso/i
- #) {
- # length(sb_strip(shift))
- #}
- #else {
- my $temp = sb_strip(shift);
- # try to get the displayed width
- my $length;
- eval {
- require Text::CharWidth;
- $length = Text::CharWidth::mbswidth($temp);
- };
- unless ($@) {
- return $length;
- }
- else {
- if (lc Irssi::settings_get_str($term_type) eq 'utf-8') {
- # try to switch on utf8
- eval {
- no warnings;
- require Encode;
- #$temp = Encode::decode_utf8($temp); # thanks for the hint, but I have my
- # # reasons for _utf8_on
- Encode::_utf8_on($temp);
- };
- }
- # there is nothing more I can do
- length($temp)
- }
- #}
-}
-
-# !!! G*DD*MN Irssi is adding an additional layer of backslashitis per { } layer
-# !!! AND I still don't know what I need to escape.
-# !!! and NOONE else seems to know or care either.
-# !!! f*ck open source. I mean it.
-# XXX any Irssi::print debug statement leads to SEGFAULT - why ?
-
-# major parts of the idea by buu (#perl @ freenode)
-# thanks to fxn and Somni for debugging
-# while ($_[0] =~ /(.)/g) {
-# my $c = $1; # XXX sooo... goto kills $1
-# if ($q eq '%') { goto ESC; }
-
-## <freenode:#perl:tybalt89> s/%(.)|(\{)|(\})|(\\|\$)/$1?$1:$2?($level++,$2):$3?($level>$min_level&&$level--,$3):'\\'x(2**$level-1).$4/ge; # untested...
-sub ir_escape {
- my $min_level = $_[1] || 0; my $level = $min_level;
- my $o = shift;
- $o =~ s/
- ( %. ) | # $1
- ( \{ ) | # $2
- ( \} ) | # $3
- ( \\ ) | # $4
- ( \$(?=[^\\]) ) | # $5
- ( \$ ) # $6
- /
- if ($1) { $1 } # %. escape
- elsif ($2) { $level++; $2 } # { nesting start
- elsif ($3) { if ($level > $min_level) { $level--; } $3 } # } nesting end
- elsif ($4) { '\\'x(2**$level) } # \ needs \\escaping
- elsif ($5) { '\\'x(2**$level-1) . '$' . '\\'x(2**$level-1) } # and $ needs even more because of "parse_special"
- else { '\\'x(2**$level-1) . '$' } # $ needs \$ escaping
- /gex;
- $o
-}
-#sub ir_escape {
-# my $min_level = $_[1] || 0; my $level = $min_level;
-# my $o = shift;
-# $o =~ s/
-# ( %. ) | # $1
-# ( \{ ) | # $2
-# ( \} ) | # $3
-# ( \\ | \$ ) # $4
-# /
-# if ($1) { $1 } # %. escape
-# elsif ($2) { $level++; $2 } # { nesting start
-# elsif ($3) { if ($level > $min_level) { $level--; } $3 } # } nesting end
-# else { '\\'x(2**($level-1)-1) . $4 } # \ or $ needs \\escaping
-# /gex;
-# $o
-#}
-
-sub ir_fe { # try to fix format stuff
- my $x = shift;
- # XXX why do I have to use two/four % here instead of one/two ??
- # answer: you screwed up in ir_escape
- $x =~ s/([%{}])/%$1/g;
- #$x =~ s/(\\|\$|[ ])/\\$1/g; # XXX HOW CAN I HANDLE THE SPACES CORRECTLY XXX
- $x =~ s/(\\|\$)/\\$1/g;
- #$x =~ s/(\$(?=.))|(\$)/$1?"\\\$\\":"\\\$"/ge; # I think this should be here
- # # (logic), but it doesn't work
- # # that way :P
- #$x =~ s/\\/\\\\/g; # that's right, escape escapes
- $x
-}
-sub ir_ve { # escapes special vars but leave colours alone
- my $x = shift;
- #$x =~ s/([%{}])/%$1/g;
- $x =~ s/(\\|\$|[ ])/\\$1/g;
- $x
-}
-
-my %ansi_table;
-{
- my ($i, $j, $k) = (0, 0, 0);
- %ansi_table = (
- # fe-common::core::formats.c:format_expand_styles
- # do format_backs
- (map { $_ => $terminfo->setab($i++) } (split //, '01234567' )),
- # do format_fores
- (map { $_ => $terminfo->setaf($j++) } (split //, 'krgybmcw' )),
- # do bold_fores
- (map { $_ => $terminfo->bold() .
- $terminfo->setaf($k++) } (split //, 'KRGYBMCW')),
- # reset
- #(map { $_ => $terminfo->op() } (split //, 'nN')),
- (map { $_ => $terminfo->op() } (split //, 'n')),
- (map { $_ => "\033[0m" } (split //, 'N')), # XXX quick and DIRTY
- # flash/bright
- F => $terminfo->blink(),
- # reverse
- 8 => $terminfo->rev(),
- # bold
- (map { $_ => $terminfo->bold() } (split //, '9_')),
- # delete other stuff
- (map { $_ => '' } (split //, ':|>#[')),
- # escape
- (map { $_ => $_ } (split //, '{}%')),
- )
-}
-sub formats_to_ansi_basic {
- my $o = shift;
- $o =~ s/(%(.))/exists $ansi_table{$2} ? $ansi_table{$2} : $1/gex;
- $o
-}
-
-sub lc1459 ($) { my $x = shift; $x =~ y/A-Z][\^/a-z}{|~/; $x }
-Irssi::settings_add_str(setc, 'banned_channels', '');
-Irssi::settings_add_bool(setc, 'banned_channels_on', 0);
-my %banned_channels = map { lc1459($_) => undef }
-split ' ', Irssi::settings_get_str('banned_channels');
-Irssi::settings_add_str(setc, 'fancy_abbrev', 'fancy');
-
-sub _error {
- my $msg = join '', @_;
- Irssi::print(setc . ':', Irssi::MSGLEVEL_CLIENTERROR);
-}
-
-# }}}
-
-# {{{ extra channel hilights
-
-sub rereadChanHilights {
- my $hilight_str = Irssi::settings_get_str(set 'extra_hilights');
-
- # only update if changed.
- return if $hilight_str eq $EXTRA_HILIGHTS_STR;
-
- $EXTRA_HILIGHTS_STR = $hilight_str
-
- return unless length $hilight_str;
-
- # kill all existing entries
- $EXTRA_HILIGHTS = {};
-
- my @entries = split /\s+/, $hilight_str;
-
- my $pattern = qr|^ (?:([^/]*)/) # $1: optional '$tag/' capturing $tag
- ([^:]+): # $2: required '$target:', capturing $target
- (%.+) # $3: required '%$colour'
- $|xo;
-
- foreach my $entry (@entries) {
-
- if ($entry =~ $pattern) {
- my ($tag, $target, $colour) = ($1, $2, $3);
- my $components = ;
-
- my $target_match_str = $target;
- if (length $tag) {
- $target_match_str = $tag . '/' . $target_match_str;
- }
-
- $EXTRA_HILIGHTS->{$target_match_str}
- = { tag => $tag, target => $target, colour => $colour };
-
- } else {
- _error("malformed hilight entry: '$entry'");
- }
- }
-}
-
-sub matchExtraHilight {
- my ($target, $tag) = @_;
- my $match = $target;
- if (length $tag) {
- $match = $tag . '/' . $tag;
- }
- if (exists $EXTRA_HILIGHTS->{$match}) {
- return $EXTRA_HILIGHTS->{$match}->{colour};
- } else {
- return '';
- }
-}
-
-# }}}
-
-# {{{
-# {{{ main
-
-sub remake () {
- #$callcount++;
- #my $xx = $callcount; Irssi::print("starting remake [ $xx ]");
- my ($hilight, $number, $display);
- my $separator = '{sb_act_sep ' . Irssi::settings_get_str(set 'separator') .
- '}';
- my $custSort = Irssi::settings_get_str(set 'sort');
- my $custSortDir = 1;
- if ($custSort =~ /^[-!](.*)/) {
- $custSortDir = -1;
- $custSort = $1;
- }
-
- my @wins =
- sort {
- (
- ( (int($a->{$custSort}) <=> int($b->{$custSort})) * $custSortDir )
- ||
- ($a->{'refnum'} <=> $b->{'refnum'})
- )
- } Irssi::windows;
- my $block = Irssi::settings_get_int(set 'block');
- my $columns = $currentColumns;
- my $oldActString = $actString if $SCREEN_MODE;
- $actString = $SCREEN_MODE ? [' A W L'] : [];
- my $line = $SCREEN_MODE ? 1 : 0;
- my $width = $SCREEN_MODE
- ?
- $screenWidth - abs($block)*$columns + 1
- :
- ([Irssi::windows]->[0]{'width'} - sb_length('{sb x}'));
- my $height = $screenHeight - abs(Irssi::settings_get_int(set
- 'height_adjust'));
- my ($numPad, $keyPad) = (0, 0);
- my %abbrevList;
- if ($SCREEN_MODE or Irssi::settings_get_bool(set 'sbar_maxlength')
- or ($block < 0)
- ) {
- %abbrevList = ();
- if (Irssi::settings_get_str('fancy_abbrev') !~ /^(no|off|head)/i) {
- my @nameList = map { ref $_ ? $_->get_active_name : '' } @wins;
- for (my $i = 0; $i < @nameList - 1; ++$i) {
- my ($x, $y) = ($nameList[$i], $nameList[$i + 1]);
- for ($x, $y) { s/^[+#!=]// }
- my $res = Algorithm::LCSS::LCSS($x, $y);
- if (defined $res) {
- #Irssi::print("common pattern $x $y : $res");
- #Irssi::print("found at $nameList[$i] ".index($nameList[$i],
- # $res));
- $abbrevList{$nameList[$i]} = int (index($nameList[$i], $res) +
- (length($res) / 2));
- #Irssi::print("found at ".$nameList[$i+1]." ".index($nameList[$i+1],
- # $res));
- $abbrevList{$nameList[$i+1]} = int (index($nameList[$i+1], $res) +
- (length($res) / 2));
- }
- }
- }
- if ($SCREEN_MODE or ($block < 0)) {
- $numPad = length((sort { length($b) <=> length($a) } keys %keymap)[0]);
- $keyPad = length((sort { length($b) <=> length($a) } values %keymap)[0]);
- }
- }
- if ($SCREEN_MODE) {
- print STDERR $screenansi->dcs().
- $terminfo->civis().
- $terminfo->sc().
- $screenansi->st();
- if (@$oldActString < 1) {
- print STDERR $screenansi->dcs().
- $terminfo->cup(0, $width).
- $actString->[0].
- $terminfo->el().
- $screenansi->st();
- }
- }
- foreach my $win (@wins) {
- unless ($SCREEN_MODE) {
- $actString->[$line] = '' unless defined $actString->[$line]
- or Irssi::settings_get_bool(set 'all_disable');
- }
-
- # all stolen from chanact, what does this code do and why do we need it ?
- !ref($win) && next;
-
- my $name = $win->get_active_name;
- $name = '*' if (Irssi::settings_get_bool('banned_channels_on') and exists
- $banned_channels{lc1459($name)});
- $name = $win->{'name'} if $name ne '*' and $win->{'name'} ne ''
- and Irssi::settings_get_bool(set 'prefer_name');
- my $active = $win->{'active'};
- my $colour = $win->{'hilight_color'};
- if (!defined $colour) { $colour = ''; }
-
- if ($win->{'data_level'} < Irssi::settings_get_int(set 'hide_data')) {
- next; } # for Geert
- if ($win->{'data_level'} == 0) { $hilight = '{sb_act_none '; }
- elsif ($win->{'data_level'} == 1) { $hilight = '{sb_act_text '; }
- elsif ($win->{'data_level'} == 2) { $hilight = '{sb_act_msg '; }
- elsif ($colour ne '') { $hilight = "{sb_act_hilight_color $colour "; }
- elsif ($win->{'data_level'} == 3) { $hilight = '{sb_act_hilight '; }
- else { $hilight = '{sb_act_special '; }
-
- $number = $win->{'refnum'};
- my @display = ('display_nokey');
- if (defined $keymap{$number} and $keymap{$number} ne '') {
- unshift @display, map { (my $cpy = $_) =~ s/_no/_/; $cpy } @display;
- }
- if (Irssi::active_win->{'refnum'} == $number) {
- unshift @display, map { my $cpy = $_; $cpy .= '_active'; $cpy } @display;
- }
- #Irssi::print("win $number [@display]: " . join '.', split //, join '<<', map {
- # Irssi::settings_get_str(set $_) } @display);
- $display = (grep { $_ }
- map { Irssi::settings_get_str(set $_) }
- @display)[0];
- #Irssi::print("win $number : " . join '.', split //, $display);
-
- if ($SCREEN_MODE or Irssi::settings_get_bool(set 'sbar_maxlength')
- or ($block < 0)
- ) {
- my $baseLength = sb_length(ir_escape(ir_ve(ir_parse_special_protected(sb_ctfe(
- '{sb_background}' . expand($display,
- C => ir_fe('x'),
- N => $number . (' 'x($numPad - length($number))),
- Q => ir_fe((' 'x($keyPad - length($keymap{$number}))) . $keymap{$number}),
- H => $hilight,
- S => '}{sb_background}'
- ), 1), $win)))) - 1;
- my $diff = abs($block) - (length($name) + $baseLength);
- if ($diff < 0) { # too long
- if (abs($diff) >= length($name)) { $name = '' } # forget it
- elsif (abs($diff) + 1 >= length($name)) { $name = substr($name,
- 0, 1); }
- else {
- my $middle = exists $abbrevList{$name} ?
- (($abbrevList{$name} + (2*(length($name) / 2)))/3) :
- ((Irssi::settings_get_str('fancy_abbrev') =~ /^head/i) ?
- length($name) :
- (length($name) / 2));
- my $cut = int($middle - (abs($diff) / 2) + .55);
- $cut = 1 if $cut < 1;
- $cut = length($name) - abs($diff) - 1 if $cut > (length($name) -
- abs($diff) - 1);
- $name = substr($name, 0, $cut) . '~' . substr($name, $cut +
- abs($diff) + 1);
- }
- }
- elsif ($SCREEN_MODE or ($block < 0)) {
- $name .= (' ' x $diff);
- }
- }
-
- my $add = ir_ve(ir_parse_special_protected(sb_ctfe('{sb_background}' . expand($display,
- C => ir_fe($name),
- N => $number . (' 'x($numPad - length($number))),
- Q => ir_fe((' 'x($keyPad - length($keymap{$number}))) . $keymap{$number}),
- H => $hilight,
- S => '}{sb_background}'
- ), 1), $win));
- if ($SCREEN_MODE) {
- $actString->[$line] = $add;
- if ((!defined $oldActString->[$line]
- or $oldActString->[$line] ne $actString->[$line])
- and
- $line <= ($columns * $height)
- ) {
- print STDERR $screenansi->dcs().
- $terminfo->cup(($line-1) % $height+1, $width + (
- abs($block) * int(($line-1) / $height))).
- formats_to_ansi_basic(sb_expand(ir_escape($actString->[$line]))).
- #$terminfo->el().
- $screenansi->st();
- }
- $line++;
- }
- else {
- #$temp =~ s/\{\S+?(?:\s(.*?))?\}/$1/g;
- #$temp =~ s/\\\\\\\\/\\/g; # XXX I'm actually guessing here, someone point me
- # # XXX to docs please
- $actString->[$line] = '' unless defined $actString->[$line];
-
- # XXX how can I check whether the content still fits in the bar? this would
- # XXX allow awlstatus to reside on a statusbar together with other items...
- if (sb_length(ir_escape($actString->[$line] . $add)) >= $width) {
- # XXX doesn't correctly handle utf-8 multibyte ... help !!?
- $actString->[$line] .= ' ' x ($width - sb_length(ir_escape(
- $actString->[$line])));
- $line++;
- }
- $actString->[$line] .= $add . $separator;
- # XXX if I use these prints, output layout gets screwed up... why ?
- #Irssi::print("line $line: ".$actString->[$line]);
- #Irssi::print("temp $line: ".$temp);
- }
- }
-
- if ($SCREEN_MODE) {
- while ($line <= ($columns * $height)) {
- print STDERR $screenansi->dcs().
- $terminfo->cup(($line-1) % $height+1, $width + (
- abs($block) * int(($line-1) / $height))).
- $terminfo->el().
- $screenansi->st();
- $line++;
- }
- print STDERR $screenansi->dcs().
- $terminfo->rc().
- $terminfo->cnorm().
- $screenansi->st();
- }
- else {
- # XXX the Irssi::print statements lead to the MOST WEIRD results
- # e.g.: the loop gets executed TWICE for p > 0 ?!?
- for (my $p = 0; $p < @$actString; $p++) { # wrap each line in {sb }, escape it
- my $x = $actString->[$p]; # properly, etc.
- $x =~ s/\Q$separator\E([ ]*)$/$1/;
- #Irssi::print("[$p]".'current:'.join'.',split//,sb_strip(ir_escape($x,0)));
- #Irssi::print("assumed length before:".sb_length(ir_escape($x,0)));
- $x = "{sb $x}";
- #Irssi::print("[$p]".'new:'.join'.',split//,sb_expand(ir_escape($x,0)));
- #Irssi::print("[$p]".'new:'.join'.',split//,ir_escape($x,0));
- #Irssi::print("assumed length after:".sb_length(ir_escape($x,0)));
- $x = ir_escape($x);
- #Irssi::print("[$p]".'REALnew:'.join'.',split//,sb_strip($x));
- $actString->[$p] = $x;
- # XXX any Irssi::print debug statement leads to SEGFAULT (sometimes) - why ?
- }
- }
- #Irssi::print("remake [ $xx ] finished");
-}
-
-sub awlHasChanged () {
- $globTime = undef;
-
- rereadChanHilights();
-
- my $temp = ($SCREEN_MODE ?
- "\\\n" . Irssi::settings_get_int(set 'block').
- Irssi::settings_get_int(set 'height_adjust')
- : "!\n" . Irssi::settings_get_str(set 'placement').
- Irssi::settings_get_int(set 'position')).
- Irssi::settings_get_str(set 'automode');
- if ($temp ne $resetNeeded) { wlreset(); return; }
- #Irssi::print("awl has changed, calls to remake so far: $callcount");
- $needRemake = 1;
-
- #remake();
- if (
- ($SCREEN_MODE and !$DISABLE_SCREEN_TEMP)
- or
- ($needRemake and Irssi::settings_get_bool(set 'all_disable'))
- or
- (!Irssi::settings_get_bool(set 'all_disable') and $currentLines < 1)
- ) {
- $needRemake = undef;
- remake();
- }
-
- unless ($SCREEN_MODE) {
- # XXX Irssi crashes if I try to do this without timer, why ? What's the minimum
- # XXX delay I need to use in the timer ?
- Irssi::timeout_add_once(100, 'syncLines', undef);
-
- for (keys %statusbars) {
- Irssi::statusbar_items_redraw(set$_);
- }
- }
- else {
- Irssi::timeout_add_once(100, 'syncColumns', undef);
- }
-}
-
-sub eventChanged () { # Implement a change queue/blocker -.-)
- if (defined $globTime) {
- Irssi::timeout_remove($globTime);
- } # delay the update further
- $globTime = Irssi::timeout_add_once(GLOB_QUEUE_TIMER, 'awlHasChanged', undef);
-}
-
-# }}}
-
-
-# {{{ screen mode
-
-sub screenFullRedraw {
- my ($window) = @_;
- if (!ref $window or $window->{'refnum'} == Irssi::active_win->{'refnum'}) {
- $actString = [];
- eventChanged();
- }
-}
-
-sub screenSize { # from nicklist.pl
- $screenResizing = 1;
- # fit screen
- system 'screen -x '.$ENV{'STY'}.' -X fit';
- # get size
- my ($row, $col) = split ' ', `stty size`;
- # set screen width
- $screenWidth = $col-1;
- $screenHeight = $row-1;
-
- # on some recent systems, "screen -X fit; screen -X width -w 50" doesn't work, needs a sleep in between the 2 commands
- # so we wait a second before setting the width
- Irssi::timeout_add_once(100, sub {
- my ($new_irssi_width) = @_;
- $new_irssi_width -= abs(Irssi::settings_get_int(set
- 'block'))*$currentColumns - 1;
- system 'screen -x '.$ENV{'STY'}.' -X width -w ' . $new_irssi_width;
- # and then we wait another second for the resizing, and then redraw.
- Irssi::timeout_add_once(10,sub {$screenResizing = 0; screenFullRedraw()}, []);
- }, $screenWidth);
-}
-
-sub screenOff {
- my ($unloadMode) = @_;
- Irssi::signal_remove('gui print text finished' => 'screenFullRedraw');
- Irssi::signal_remove('gui page scrolled' => 'screenFullRedraw');
- Irssi::signal_remove('window changed' => 'screenFullRedraw');
- Irssi::signal_remove('window changed automatic' => 'screenFullRedraw');
- if ($unloadMode) {
- Irssi::signal_remove('terminal resized' => 'resizeTerm');
- }
- system 'screen -x '.$ENV{'STY'}.' -X fit';
-}
-
-sub syncColumns {
- return if (@$actString == 0);
- my $temp = $currentColumns;
- #Irssi::print("current columns $temp");
- my $height = $screenHeight - abs(Irssi::settings_get_int(set
- 'height_adjust'));
- $currentColumns = int(($#$actString-1) / $height) + 1;
- #Irssi::print("objects in actstring:".scalar(@$actString).", screen height:".
- # $height);
- my $currMaxColumns = Irssi::settings_get_int(set 'columns');
- if ($currMaxColumns > 0 and $currentColumns > $currMaxColumns) {
- $currentColumns = $currMaxColumns;
- }
- elsif ($currMaxColumns < 0) {
- $currentColumns = abs($currMaxColumns);
- }
- return if ($temp == $currentColumns);
- screenSize();
-}
-
-#$needRemake = 1;
-sub resizeTerm () {
- if ($SCREEN_MODE and !$screenResizing) {
- $screenResizing = 1;
- Irssi::timeout_add_once(10, 'screenSize', undef);
- }
- Irssi::timeout_add_once(100, 'eventChanged', undef);
-}
-
-# }}}
-
-
-# {{{ settings add
-
-Irssi::settings_add_str(setc, set 'display_nokey', '[$N]$H$C$S');
-Irssi::settings_add_str(setc, set 'display_key', '[$Q=$N]$H$C$S');
-Irssi::settings_add_str(setc, set 'display_nokey_active', '');
-Irssi::settings_add_str(setc, set 'display_key_active', '');
-Irssi::settings_add_str(setc, set 'separator', "\\ ");
-Irssi::settings_add_bool(setc, set 'prefer_name', 0);
-Irssi::settings_add_int(setc, set 'hide_data', 0);
-Irssi::settings_add_int(setc, set 'maxlines', 9);
-Irssi::settings_add_int(setc, set 'columns', 1);
-Irssi::settings_add_int(setc, set 'block', 20);
-Irssi::settings_add_bool(setc, set 'sbar_maxlength', 0);
-Irssi::settings_add_int(setc, set 'height_adjust', 2);
-Irssi::settings_add_str(setc, set 'sort', 'refnum');
-Irssi::settings_add_str(setc, set 'placement', 'bottom');
-Irssi::settings_add_int(setc, set 'position', 0);
-Irssi::settings_add_bool(setc, set 'all_disable', 0);
-Irssi::settings_add_str(setc, set 'automode', 'sbar');
-
-# format is '[$tag/]#channel:%colour1 [$tag/]#channel:%colour2 ...' list.
-Irssi::settings_add_str(setc, set 'extra_hilights', '');
-
-# }}}
-
-
-# {{{ init
-
-sub wlreset {
- $actString = [];
- $currentLines = 0; # 1; # mhmmmm .. we actually enable one line down there so
- # let's try this.
- #update_keymap();
- killOldStatus();
- # Register statusbar
- #add_statusbar(0);
- #Irssi::command('statusbar wl0 enable');
- my $was_screen_mode = $SCREEN_MODE;
- if ($SCREEN_MODE = (Irssi::settings_get_str(set 'automode') =~ /screen/i)
- and
- !$was_screen_mode
- ) {
- if (!defined $ENV{'STY'}) {
- Irssi::print('Screen mode can only be used in GNU screen but no '.
- 'screen was found.', MSGLEVEL_CLIENTERROR);
- $SCREEN_MODE = undef;
- }
- else {
- Irssi::signal_add_last('gui print text finished' => 'screenFullRedraw');
- Irssi::signal_add_last('gui page scrolled' => 'screenFullRedraw');
- Irssi::signal_add('window changed' => 'screenFullRedraw');
- Irssi::signal_add('window changed automatic' => 'screenFullRedraw');
- }
- }
- elsif ($was_screen_mode and !$SCREEN_MODE) {
- screenOff();
- }
- $resetNeeded = ($SCREEN_MODE ?
- "\\\n" . Irssi::settings_get_int(set 'block').
- Irssi::settings_get_int(set 'height_adjust')
- : "!\n" . Irssi::settings_get_str(set 'placement').
- Irssi::settings_get_int(set 'position')).
- Irssi::settings_get_str(set 'automode');
- resizeTerm();
-}
-
-wlreset();
-
-# }}}
-
-
-# {{{ unload/deinit
-
-my $Unload;
-sub unload ($$$) {
- $Unload = 1;
- # pretend we didn't do anything ASAP
- Irssi::timeout_add_once(10, sub { $Unload = undef; }, undef);
-}
-# last try to catch a sigsegv
-Irssi::signal_add_first('gui exit' => sub { $Unload = undef; });
-sub UNLOAD {
- # this might well crash Irssi... try /eval /script unload someotherscript ;
- # /quit (= SEGFAULT !)
- if ($Unload) {
- $actString = ['']; # syncLines(); # XXX Irssi crashes when trying to disable
- killOldStatus(); # XXX all statusbars ?
- if ($SCREEN_MODE) {
- screenOff('unload mode');
- }
- }
-}
-
-# }}}
-
-
-# {{{ signals
-
-sub addPrintTextHook { # update on print text
- return if $_[0]->{'level'} == 262144 and $_[0]->{'target'} eq ''
- and !defined($_[0]->{'server'});
- if (Irssi::settings_get_str(set 'sort') =~ /^[-!]?last_line$/) {
- Irssi::timeout_add_once(100, 'eventChanged', undef);
- }
-}
-
-#sub _x { my ($x, $y) = @_; ($x, sub { Irssi::print('-->signal '.$x); eval "$y();"; }) }
-#sub _x { @_ }
-Irssi::signal_add_first(
- 'command script unload' => 'unload'
-);
-Irssi::signal_add_last({
- 'setup changed' => 'eventChanged',
- 'print text' => 'addPrintTextHook',
- 'terminal resized' => 'resizeTerm',
- 'setup reread' => 'wlreset',
- 'window hilight' => 'eventChanged',
-});
-Irssi::signal_add({
- 'window created' => 'eventChanged',
- 'window destroyed' => 'eventChanged',
- 'window name changed' => 'eventChanged',
- 'window refnum changed' => 'eventChanged',
- 'window changed' => 'eventChanged',
- 'window changed automatic' => 'eventChanged',
-});
-
-#Irssi::signal_add('nick mode changed', 'chanactHasChanged'); # relicts
-
-# }}}
-
-# {{{ commands
-
-
-sub runsub {
- my ($cmd) = @_;
- sub {
- my ($data, $server, $item) = @_;
- Irssi::command_runsub($cmd, $data, $server, $item);
- };
-}
-Irssi::command_bind( setc() => runsub(setc()) );
-Irssi::command_bind( setc() . ' paste' => runsub(setc() . ' paste') );
-Irssi::command_bind(
- setc() . ' paste on' => sub {
- return unless $SCREEN_MODE;
- my $was_disabled = $DISABLE_SCREEN_TEMP;
- $DISABLE_SCREEN_TEMP = 1;
- Irssi::print('Paste mode is now ON, '.uc(setc()).' is temporarily '.
- 'disabled.');
- if (!$was_disabled) {
- $screenResizing = 1;
- screenOff();
- }
- }
-);
-Irssi::command_bind(
- setc() . ' paste off' => sub {
- return unless $SCREEN_MODE;
- my $was_disabled = $DISABLE_SCREEN_TEMP;
- $DISABLE_SCREEN_TEMP = undef;
- Irssi::print('Paste mode is now OFF, '.uc(setc()).' is enabled.');
- if ($was_disabled) {
- $SCREEN_MODE = undef;
- $screenResizing = 0;
- wlreset();
- }
- }
-);
-Irssi::command_bind(
- setc() . ' paste toggle' => sub {
- if ($DISABLE_SCREEN_TEMP) {
- Irssi::command(setc() . ' paste off');
- }
- else {
- Irssi::command(setc() . ' paste on');
- }
- }
-);
-Irssi::command_bind(
- setc() . ' redraw' => sub {
- return unless $SCREEN_MODE;
- screenFullRedraw();
- }
-);
-
-
-# }}}
-
-# {{{ Algorithm::LCSS module
-{
- package Algorithm::Diff;
- # Skip to first "=head" line for documentation.
- use strict;
-
- use integer; # see below in _replaceNextLargerWith() for mod to make
- # if you don't use this
-
- # McIlroy-Hunt diff algorithm
- # Adapted from the Smalltalk code of Mario I. Wolczko, <mario@wolczko.com>
- # by Ned Konz, perl@bike-nomad.com
- # Updates by Tye McQueen, http://perlmonks.org/?node=tye
-
- # Create a hash that maps each element of $aCollection to the set of
- # positions it occupies in $aCollection, restricted to the elements
- # within the range of indexes specified by $start and $end.
- # The fourth parameter is a subroutine reference that will be called to
- # generate a string to use as a key.
- # Additional parameters, if any, will be passed to this subroutine.
- #
- # my $hashRef = _withPositionsOfInInterval( \@array, $start, $end, $keyGen );
-
- sub _withPositionsOfInInterval
- {
- my $aCollection = shift; # array ref
- my $start = shift;
- my $end = shift;
- my $keyGen = shift;
- my %d;
- my $index;
- for ( $index = $start ; $index <= $end ; $index++ )
- {
- my $element = $aCollection->[$index];
- my $key = &$keyGen( $element, @_ );
- if ( exists( $d{$key} ) )
- {
- unshift ( @{ $d{$key} }, $index );
- }
- else
- {
- $d{$key} = [$index];
- }
- }
- return wantarray ? %d : \%d;
- }
-
- # Find the place at which aValue would normally be inserted into the
- # array. If that place is already occupied by aValue, do nothing, and
- # return undef. If the place does not exist (i.e., it is off the end of
- # the array), add it to the end, otherwise replace the element at that
- # point with aValue. It is assumed that the array's values are numeric.
- # This is where the bulk (75%) of the time is spent in this module, so
- # try to make it fast!
-
- sub _replaceNextLargerWith
- {
- my ( $array, $aValue, $high ) = @_;
- $high ||= $#$array;
-
- # off the end?
- if ( $high == -1 || $aValue > $array->[-1] )
- {
- push ( @$array, $aValue );
- return $high + 1;
- }
-
- # binary search for insertion point...
- my $low = 0;
- my $index;
- my $found;
- while ( $low <= $high )
- {
- $index = ( $high + $low ) / 2;
-
- # $index = int(( $high + $low ) / 2); # without 'use integer'
- $found = $array->[$index];
-
- if ( $aValue == $found )
- {
- return undef;
- }
- elsif ( $aValue > $found )
- {
- $low = $index + 1;
- }
- else
- {
- $high = $index - 1;
- }
- }
-
- # now insertion point is in $low.
- $array->[$low] = $aValue; # overwrite next larger
- return $low;
- }
-
- # This method computes the longest common subsequence in $a and $b.
-
- # Result is array or ref, whose contents is such that
- # $a->[ $i ] == $b->[ $result[ $i ] ]
- # foreach $i in ( 0 .. $#result ) if $result[ $i ] is defined.
-
- # An additional argument may be passed; this is a hash or key generating
- # function that should return a string that uniquely identifies the given
- # element. It should be the case that if the key is the same, the elements
- # will compare the same. If this parameter is undef or missing, the key
- # will be the element as a string.
-
- # By default, comparisons will use "eq" and elements will be turned into keys
- # using the default stringizing operator '""'.
-
- # Additional parameters, if any, will be passed to the key generation
- # routine.
-
- sub _longestCommonSubsequence
- {
- my $a = shift; # array ref or hash ref
- my $b = shift; # array ref or hash ref
- my $counting = shift; # scalar
- my $keyGen = shift; # code ref
- my $compare; # code ref
-
- if ( ref($a) eq 'HASH' )
- { # prepared hash must be in $b
- my $tmp = $b;
- $b = $a;
- $a = $tmp;
- }
-
- # Check for bogus (non-ref) argument values
- if ( !ref($a) || !ref($b) )
- {
- my @callerInfo = caller(1);
- die 'error: must pass array or hash references to ' . $callerInfo[3];
- }
-
- # set up code refs
- # Note that these are optimized.
- if ( !defined($keyGen) ) # optimize for strings
- {
- $keyGen = sub { $_[0] };
- $compare = sub { my ( $a, $b ) = @_; $a eq $b };
- }
- else
- {
- $compare = sub {
- my $a = shift;
- my $b = shift;
- &$keyGen( $a, @_ ) eq &$keyGen( $b, @_ );
- };
- }
-
- my ( $aStart, $aFinish, $matchVector ) = ( 0, $#$a, [] );
- my ( $prunedCount, $bMatches ) = ( 0, {} );
-
- if ( ref($b) eq 'HASH' ) # was $bMatches prepared for us?
- {
- $bMatches = $b;
- }
- else
- {
- my ( $bStart, $bFinish ) = ( 0, $#$b );
-
- # First we prune off any common elements at the beginning
- while ( $aStart <= $aFinish
- and $bStart <= $bFinish
- and &$compare( $a->[$aStart], $b->[$bStart], @_ ) )
- {
- $matchVector->[ $aStart++ ] = $bStart++;
- $prunedCount++;
- }
-
- # now the end
- while ( $aStart <= $aFinish
- and $bStart <= $bFinish
- and &$compare( $a->[$aFinish], $b->[$bFinish], @_ ) )
- {
- $matchVector->[ $aFinish-- ] = $bFinish--;
- $prunedCount++;
- }
-
- # Now compute the equivalence classes of positions of elements
- $bMatches =
- _withPositionsOfInInterval( $b, $bStart, $bFinish, $keyGen, @_ );
- }
- my $thresh = [];
- my $links = [];
-
- my ( $i, $ai, $j, $k );
- for ( $i = $aStart ; $i <= $aFinish ; $i++ )
- {
- $ai = &$keyGen( $a->[$i], @_ );
- if ( exists( $bMatches->{$ai} ) )
- {
- $k = 0;
- for $j ( @{ $bMatches->{$ai} } )
- {
-
- # optimization: most of the time this will be true
- if ( $k and $thresh->[$k] > $j and $thresh->[ $k - 1 ] < $j )
- {
- $thresh->[$k] = $j;
- }
- else
- {
- $k = _replaceNextLargerWith( $thresh, $j, $k );
- }
-
- # oddly, it's faster to always test this (CPU cache?).
- if ( defined($k) )
- {
- $links->[$k] =
- [ ( $k ? $links->[ $k - 1 ] : undef ), $i, $j ];
- }
- }
- }
- }
-
- if (@$thresh)
- {
- return $prunedCount + @$thresh if $counting;
- for ( my $link = $links->[$#$thresh] ; $link ; $link = $link->[0] )
- {
- $matchVector->[ $link->[1] ] = $link->[2];
- }
- }
- elsif ($counting)
- {
- return $prunedCount;
- }
-
- return wantarray ? @$matchVector : $matchVector;
- }
-
- sub traverse_sequences
- {
- my $a = shift; # array ref
- my $b = shift; # array ref
- my $callbacks = shift || {};
- my $keyGen = shift;
- my $matchCallback = $callbacks->{'MATCH'} || sub { };
- my $discardACallback = $callbacks->{'DISCARD_A'} || sub { };
- my $finishedACallback = $callbacks->{'A_FINISHED'};
- my $discardBCallback = $callbacks->{'DISCARD_B'} || sub { };
- my $finishedBCallback = $callbacks->{'B_FINISHED'};
- my $matchVector = _longestCommonSubsequence( $a, $b, 0, $keyGen, @_ );
-
- # Process all the lines in @$matchVector
- my $lastA = $#$a;
- my $lastB = $#$b;
- my $bi = 0;
- my $ai;
-
- for ( $ai = 0 ; $ai <= $#$matchVector ; $ai++ )
- {
- my $bLine = $matchVector->[$ai];
- if ( defined($bLine) ) # matched
- {
- &$discardBCallback( $ai, $bi++, @_ ) while $bi < $bLine;
- &$matchCallback( $ai, $bi++, @_ );
- }
- else
- {
- &$discardACallback( $ai, $bi, @_ );
- }
- }
-
- # The last entry (if any) processed was a match.
- # $ai and $bi point just past the last matching lines in their sequences.
-
- while ( $ai <= $lastA or $bi <= $lastB )
- {
-
- # last A?
- if ( $ai == $lastA + 1 and $bi <= $lastB )
- {
- if ( defined($finishedACallback) )
- {
- &$finishedACallback( $lastA, @_ );
- $finishedACallback = undef;
- }
- else
- {
- &$discardBCallback( $ai, $bi++, @_ ) while $bi <= $lastB;
- }
- }
-
- # last B?
- if ( $bi == $lastB + 1 and $ai <= $lastA )
- {
- if ( defined($finishedBCallback) )
- {
- &$finishedBCallback( $lastB, @_ );
- $finishedBCallback = undef;
- }
- else
- {
- &$discardACallback( $ai++, $bi, @_ ) while $ai <= $lastA;
- }
- }
-
- &$discardACallback( $ai++, $bi, @_ ) if $ai <= $lastA;
- &$discardBCallback( $ai, $bi++, @_ ) if $bi <= $lastB;
- }
-
- return 1;
- }
-
- sub traverse_balanced
- {
- my $a = shift; # array ref
- my $b = shift; # array ref
- my $callbacks = shift || {};
- my $keyGen = shift;
- my $matchCallback = $callbacks->{'MATCH'} || sub { };
- my $discardACallback = $callbacks->{'DISCARD_A'} || sub { };
- my $discardBCallback = $callbacks->{'DISCARD_B'} || sub { };
- my $changeCallback = $callbacks->{'CHANGE'};
- my $matchVector = _longestCommonSubsequence( $a, $b, 0, $keyGen, @_ );
-
- # Process all the lines in match vector
- my $lastA = $#$a;
- my $lastB = $#$b;
- my $bi = 0;
- my $ai = 0;
- my $ma = -1;
- my $mb;
-
- while (1)
- {
-
- # Find next match indices $ma and $mb
- do {
- $ma++;
- } while(
- $ma <= $#$matchVector
- && !defined $matchVector->[$ma]
- );
-
- last if $ma > $#$matchVector; # end of matchVector?
- $mb = $matchVector->[$ma];
-
- # Proceed with discard a/b or change events until
- # next match
- while ( $ai < $ma || $bi < $mb )
- {
-
- if ( $ai < $ma && $bi < $mb )
- {
-
- # Change
- if ( defined $changeCallback )
- {
- &$changeCallback( $ai++, $bi++, @_ );
- }
- else
- {
- &$discardACallback( $ai++, $bi, @_ );
- &$discardBCallback( $ai, $bi++, @_ );
- }
- }
- elsif ( $ai < $ma )
- {
- &$discardACallback( $ai++, $bi, @_ );
- }
- else
- {
-
- # $bi < $mb
- &$discardBCallback( $ai, $bi++, @_ );
- }
- }
-
- # Match
- &$matchCallback( $ai++, $bi++, @_ );
- }
-
- while ( $ai <= $lastA || $bi <= $lastB )
- {
- if ( $ai <= $lastA && $bi <= $lastB )
- {
-
- # Change
- if ( defined $changeCallback )
- {
- &$changeCallback( $ai++, $bi++, @_ );
- }
- else
- {
- &$discardACallback( $ai++, $bi, @_ );
- &$discardBCallback( $ai, $bi++, @_ );
- }
- }
- elsif ( $ai <= $lastA )
- {
- &$discardACallback( $ai++, $bi, @_ );
- }
- else
- {
-
- # $bi <= $lastB
- &$discardBCallback( $ai, $bi++, @_ );
- }
- }
-
- return 1;
- }
-
- sub prepare
- {
- my $a = shift; # array ref
- my $keyGen = shift; # code ref
-
- # set up code ref
- $keyGen = sub { $_[0] } unless defined($keyGen);
-
- return scalar _withPositionsOfInInterval( $a, 0, $#$a, $keyGen, @_ );
- }
-
- sub LCS
- {
- my $a = shift; # array ref
- my $b = shift; # array ref or hash ref
- my $matchVector = _longestCommonSubsequence( $a, $b, 0, @_ );
- my @retval;
- my $i;
- for ( $i = 0 ; $i <= $#$matchVector ; $i++ )
- {
- if ( defined( $matchVector->[$i] ) )
- {
- push ( @retval, $a->[$i] );
- }
- }
- return wantarray ? @retval : \@retval;
- }
-
- sub LCS_length
- {
- my $a = shift; # array ref
- my $b = shift; # array ref or hash ref
- return _longestCommonSubsequence( $a, $b, 1, @_ );
- }
-
- sub LCSidx
- {
- my $a= shift @_;
- my $b= shift @_;
- my $match= _longestCommonSubsequence( $a, $b, 0, @_ );
- my @am= grep defined $match->[$_], 0..$#$match;
- my @bm= @{$match}[@am];
- return \@am, \@bm;
- }
-
- sub compact_diff
- {
- my $a= shift @_;
- my $b= shift @_;
- my( $am, $bm )= LCSidx( $a, $b, @_ );
- my @cdiff;
- my( $ai, $bi )= ( 0, 0 );
- push @cdiff, $ai, $bi;
- while( 1 ) {
- while( @$am && $ai == $am->[0] && $bi == $bm->[0] ) {
- shift @$am;
- shift @$bm;
- ++$ai, ++$bi;
- }
- push @cdiff, $ai, $bi;
- last if ! @$am;
- $ai = $am->[0];
- $bi = $bm->[0];
- push @cdiff, $ai, $bi;
- }
- push @cdiff, 0+@$a, 0+@$b
- if $ai < @$a || $bi < @$b;
- return wantarray ? @cdiff : \@cdiff;
- }
-
- sub diff
- {
- my $a = shift; # array ref
- my $b = shift; # array ref
- my $retval = [];
- my $hunk = [];
- my $discard = sub {
- push @$hunk, [ '-', $_[0], $a->[ $_[0] ] ];
- };
- my $add = sub {
- push @$hunk, [ '+', $_[1], $b->[ $_[1] ] ];
- };
- my $match = sub {
- push @$retval, $hunk
- if 0 < @$hunk;
- $hunk = []
- };
- traverse_sequences( $a, $b,
- { MATCH => $match, DISCARD_A => $discard, DISCARD_B => $add }, @_ );
- &$match();
- return wantarray ? @$retval : $retval;
- }
-
- sub sdiff
- {
- my $a = shift; # array ref
- my $b = shift; # array ref
- my $retval = [];
- my $discard = sub { push ( @$retval, [ '-', $a->[ $_[0] ], "" ] ) };
- my $add = sub { push ( @$retval, [ '+', "", $b->[ $_[1] ] ] ) };
- my $change = sub {
- push ( @$retval, [ 'c', $a->[ $_[0] ], $b->[ $_[1] ] ] );
- };
- my $match = sub {
- push ( @$retval, [ 'u', $a->[ $_[0] ], $b->[ $_[1] ] ] );
- };
- traverse_balanced(
- $a,
- $b,
- {
- MATCH => $match,
- DISCARD_A => $discard,
- DISCARD_B => $add,
- CHANGE => $change,
- },
- @_
- );
- return wantarray ? @$retval : $retval;
- }
-
- ########################################
- my $Root= __PACKAGE__;
- package Algorithm::Diff::_impl;
- use strict;
-
- sub _Idx() { 0 } # $me->[_Idx]: Ref to array of hunk indices
- # 1 # $me->[1]: Ref to first sequence
- # 2 # $me->[2]: Ref to second sequence
- sub _End() { 3 } # $me->[_End]: Diff between forward and reverse pos
- sub _Same() { 4 } # $me->[_Same]: 1 if pos 1 contains unchanged items
- sub _Base() { 5 } # $me->[_Base]: Added to range's min and max
- sub _Pos() { 6 } # $me->[_Pos]: Which hunk is currently selected
- sub _Off() { 7 } # $me->[_Off]: Offset into _Idx for current position
- sub _Min() { -2 } # Added to _Off to get min instead of max+1
-
- sub Die
- {
- require Carp;
- Carp::confess( @_ );
- }
-
- sub _ChkPos
- {
- my( $me )= @_;
- return if $me->[_Pos];
- my $meth= ( caller(1) )[3];
- Die( "Called $meth on 'reset' object" );
- }
-
- sub _ChkSeq
- {
- my( $me, $seq )= @_;
- return $seq + $me->[_Off]
- if 1 == $seq || 2 == $seq;
- my $meth= ( caller(1) )[3];
- Die( "$meth: Invalid sequence number ($seq); must be 1 or 2" );
- }
-
- sub getObjPkg
- {
- my( $us )= @_;
- return ref $us if ref $us;
- return $us . "::_obj";
- }
-
- sub new
- {
- my( $us, $seq1, $seq2, $opts ) = @_;
- my @args;
- for( $opts->{keyGen} ) {
- push @args, $_ if $_;
- }
- for( $opts->{keyGenArgs} ) {
- push @args, @$_ if $_;
- }
- my $cdif= Algorithm::Diff::compact_diff( $seq1, $seq2, @args );
- my $same= 1;
- if( 0 == $cdif->[2] && 0 == $cdif->[3] ) {
- $same= 0;
- splice @$cdif, 0, 2;
- }
- my @obj= ( $cdif, $seq1, $seq2 );
- $obj[_End] = (1+@$cdif)/2;
- $obj[_Same] = $same;
- $obj[_Base] = 0;
- my $me = bless \@obj, $us->getObjPkg();
- $me->Reset( 0 );
- return $me;
- }
-
- sub Reset
- {
- my( $me, $pos )= @_;
- $pos= int( $pos || 0 );
- $pos += $me->[_End]
- if $pos < 0;
- $pos= 0
- if $pos < 0 || $me->[_End] <= $pos;
- $me->[_Pos]= $pos || !1;
- $me->[_Off]= 2*$pos - 1;
- return $me;
- }
-
- sub Base
- {
- my( $me, $base )= @_;
- my $oldBase= $me->[_Base];
- $me->[_Base]= 0+$base if defined $base;
- return $oldBase;
- }
-
- sub Copy
- {
- my( $me, $pos, $base )= @_;
- my @obj= @$me;
- my $you= bless \@obj, ref($me);
- $you->Reset( $pos ) if defined $pos;
- $you->Base( $base );
- return $you;
- }
-
- sub Next {
- my( $me, $steps )= @_;
- $steps= 1 if ! defined $steps;
- if( $steps ) {
- my $pos= $me->[_Pos];
- my $new= $pos + $steps;
- $new= 0 if $pos && $new < 0;
- $me->Reset( $new )
- }
- return $me->[_Pos];
- }
-
- sub Prev {
- my( $me, $steps )= @_;
- $steps= 1 if ! defined $steps;
- my $pos= $me->Next(-$steps);
- $pos -= $me->[_End] if $pos;
- return $pos;
- }
-
- sub Diff {
- my( $me )= @_;
- $me->_ChkPos();
- return 0 if $me->[_Same] == ( 1 & $me->[_Pos] );
- my $ret= 0;
- my $off= $me->[_Off];
- for my $seq ( 1, 2 ) {
- $ret |= $seq
- if $me->[_Idx][ $off + $seq + _Min ]
- < $me->[_Idx][ $off + $seq ];
- }
- return $ret;
- }
-
- sub Min {
- my( $me, $seq, $base )= @_;
- $me->_ChkPos();
- my $off= $me->_ChkSeq($seq);
- $base= $me->[_Base] if !defined $base;
- return $base + $me->[_Idx][ $off + _Min ];
- }
-
- sub Max {
- my( $me, $seq, $base )= @_;
- $me->_ChkPos();
- my $off= $me->_ChkSeq($seq);
- $base= $me->[_Base] if !defined $base;
- return $base + $me->[_Idx][ $off ] -1;
- }
-
- sub Range {
- my( $me, $seq, $base )= @_;
- $me->_ChkPos();
- my $off = $me->_ChkSeq($seq);
- if( !wantarray ) {
- return $me->[_Idx][ $off ]
- - $me->[_Idx][ $off + _Min ];
- }
- $base= $me->[_Base] if !defined $base;
- return ( $base + $me->[_Idx][ $off + _Min ] )
- .. ( $base + $me->[_Idx][ $off ] - 1 );
- }
-
- sub Items {
- my( $me, $seq )= @_;
- $me->_ChkPos();
- my $off = $me->_ChkSeq($seq);
- if( !wantarray ) {
- return $me->[_Idx][ $off ]
- - $me->[_Idx][ $off + _Min ];
- }
- return
- @{$me->[$seq]}[
- $me->[_Idx][ $off + _Min ]
- .. ( $me->[_Idx][ $off ] - 1 )
- ];
- }
-
- sub Same {
- my( $me )= @_;
- $me->_ChkPos();
- return wantarray ? () : 0
- if $me->[_Same] != ( 1 & $me->[_Pos] );
- return $me->Items(1);
- }
-
- my %getName;
- %getName= (
- same => \&Same,
- diff => \&Diff,
- base => \&Base,
- min => \&Min,
- max => \&Max,
- range=> \&Range,
- items=> \&Items, # same thing
- );
-
- sub Get
- {
- my $me= shift @_;
- $me->_ChkPos();
- my @value;
- for my $arg ( @_ ) {
- for my $word ( split ' ', $arg ) {
- my $meth;
- if( $word !~ /^(-?\d+)?([a-zA-Z]+)([12])?$/
- || not $meth= $getName{ lc $2 }
- ) {
- Die( $Root, ", Get: Invalid request ($word)" );
- }
- my( $base, $name, $seq )= ( $1, $2, $3 );
- push @value, scalar(
- 4 == length($name)
- ? $meth->( $me )
- : $meth->( $me, $seq, $base )
- );
- }
- }
- if( wantarray ) {
- return @value;
- } elsif( 1 == @value ) {
- return $value[0];
- }
- Die( 0+@value, " values requested from ",
- $Root, "'s Get in scalar context" );
- }
-
-
- my $Obj= getObjPkg($Root);
- no strict 'refs';
-
- for my $meth ( qw( new getObjPkg ) ) {
- *{$Root."::".$meth} = \&{$meth};
- *{$Obj ."::".$meth} = \&{$meth};
- }
- for my $meth ( qw(
- Next Prev Reset Copy Base Diff
- Same Items Range Min Max Get
- _ChkPos _ChkSeq
- ) ) {
- *{$Obj."::".$meth} = \&{$meth};
- }
-
-};
-{
- package Algorithm::LCSS;
-
- use strict;
- {
- no strict 'refs';
- *traverse_sequences = \&Algorithm::Diff::traverse_sequences;
- }
-
- sub _tokenize { [split //, $_[0]] }
-
- sub CSS {
- my $is_array = ref $_[0] eq 'ARRAY' ? 1 : 0;
- my ( $seq1, $seq2, @match, $from_match );
- my $i = 0;
- if ( $is_array ) {
- $seq1 = $_[0];
- $seq2 = $_[1];
- traverse_sequences( $seq1, $seq2, {
- MATCH => sub { push @{$match[$i]}, $seq1->[$_[0]]; $from_match = 1 },
- DISCARD_A => sub { do{$i++; $from_match = 0} if $from_match },
- DISCARD_B => sub { do{$i++; $from_match = 0} if $from_match },
- });
- }
- else {
- $seq1 = _tokenize($_[0]);
- $seq2 = _tokenize($_[1]);
- traverse_sequences( $seq1, $seq2, {
- MATCH => sub { $match[$i] .= $seq1->[$_[0]]; $from_match = 1 },
- DISCARD_A => sub { do{$i++; $from_match = 0} if $from_match },
- DISCARD_B => sub { do{$i++; $from_match = 0} if $from_match },
- });
- }
- return \@match;
- }
-
- sub CSS_Sorted {
- my $match = CSS(@_);
- if ( ref $_[0] eq 'ARRAY' ) {
- @$match = map{$_->[0]}sort{$b->[1]<=>$a->[1]}map{[$_,scalar(@$_)]}@$match
- }
- else {
- @$match = map{$_->[0]}sort{$b->[1]<=>$a->[1]}map{[$_,length($_)]}@$match
- }
- return $match;
- }
-
- sub LCSS {
- my $is_array = ref $_[0] eq 'ARRAY' ? 1 : 0;
- my $css = CSS(@_);
- my $index;
- my $length = 0;
- if ( $is_array ) {
- for( my $i = 0; $i < @$css; $i++ ) {
- next unless @{$css->[$i]}>$length;
- $index = $i;
- $length = @{$css->[$i]};
- }
- }
- else {
- for( my $i = 0; $i < @$css; $i++ ) {
- next unless length($css->[$i])>$length;
- $index = $i;
- $length = length($css->[$i]);
- }
- }
- return $css->[$index];
- }
-
-};
-# }}}
-#{{{ Class::Classless module
-{
- package Class::Classless;
- use strict;
- use vars qw(@ISA);
- use Carp;
-
- @ISA = ();
-
- ###########################################################################
-
- @Class::Classless::X::ISA = ();
-
- ###########################################################################
- ###########################################################################
-
- sub Class::Classless::X::AUTOLOAD {
- # This's the big dispatcher.
-
- my $it = shift @_;
- my $m = ($Class::Classless::X::AUTOLOAD =~ m/([^:]+)$/s )
- ? $1 : $Class::Classless::X::AUTOLOAD;
-
- croak "Can't call Class::Classless methods (like $m) without an object"
- unless ref $it; # sanity, basically.
-
- my $prevstate;
- $prevstate = ${shift @_}
- if scalar(@_) && defined($_[0]) &&
- ref($_[0]) eq 'Class::Classless::CALLSTATE::SHIMMY'
- ; # A shim! we were called via $callstate->NEXT
-
- my $no_fail = $prevstate ? $prevstate->[3] : undef;
- my $i = $prevstate ? ($prevstate->[1] + 1) : 0;
- # where to start scanning
- my $lineage;
-
- # Get the linearization of the ISA tree
- if($prevstate) {
- $lineage = $prevstate->[2];
- } elsif(defined $it->{'ISA_CACHE'} and ref $it->{'ISA_CACHE'} ){
- $lineage = $it->{'ISA_CACHE'};
- } else {
- $lineage = [ &Class::Classless::X::ISA_TREE($it) ];
- }
-
- # Was:
- #my @lineage =
- # $prevstate ? @{$prevstate->[2]}
- # : &Class::Classless::X::ISA_TREE($it);
- # # Get the linearization of the ISA tree
- # # ISA-memoization happens in the ISA_TREE function.
-
- for(; $i < @$lineage; ++$i) {
-
- if( !defined($no_fail) and exists($lineage->[$i]{'NO_FAIL'}) ) {
- $no_fail = ($lineage->[$i]{'NO_FAIL'} || 0);
- # so the first NO_FAIL sets it
- }
-
- if( ref($lineage->[$i]{'METHODS'} || 0) # sanity
- && exists($lineage->[$i]{'METHODS'}{$m})
- ){
- # We found what we were after. Now see what to do with it.
- my $v = $lineage->[$i]{'METHODS'}{$m};
- return $v unless defined $v and ref $v;
-
- if(ref($v) eq 'CODE') { # normal case, I expect!
- # Used to have copying of the arglist here.
- # But it was apparently useless, so I deleted it
- unshift @_,
- $it, # $_[0] -- target object
- # a NEW callstate
- bless([$m, $i, $lineage, $no_fail, $prevstate ? 1 : 0],
- 'Class::Classless::CALLSTATE'
- ), # $_[1] -- the callstate
- ;
- goto &{ $v }; # yes, magic goto! bimskalabim!
- }
- return @$v if ref($v) eq '_deref_array';
- return $$v if ref($v) eq '_deref_scalar';
- return $v; # fallthru
- }
- }
-
- if($m eq 'DESTROY') { # mitigate DESTROY-lookup failure at global destruction
- # should be impossible
- } else {
- if($no_fail || 0) {
- return;
- }
- croak "Can't find ", $prevstate ? 'NEXT method' : 'method',
- " $m in ", $it->{'NAME'} || $it,
- " or any ancestors\n";
- }
- }
-
- ###########################################################################
- ###########################################################################
-
- sub Class::Classless::X::DESTROY {
- # noop
- }
-
- ###########################################################################
- sub Class::Classless::X::ISA_TREE {
- # The linearizer!
- # Returns the search path for $_[0], starting with $_[0]
- # Possibly memoized.
-
- # I stopped being able to understand this algorithm about five
- # minutes after I wrote it.
- use strict;
-
- my $set_cache = 0; # flag to set the cache on the way out
-
- if(exists($_[0]{'ISA_CACHE'})) {
- return @{$_[0]{'ISA_CACHE'}}
- if defined $_[0]{'ISA_CACHE'}
- and ref $_[0]{'ISA_CACHE'};
-
- # Otherwise, if exists but is not a ref, it's a signal that it should
- # be replaced at the earliest, with a listref
- $set_cache = 1;
- }
-
- my $has_mi = 0; # set to 0 on the first node we see with 2 parents!
- # First, just figure out what's in the tree.
- my %last_child = ($_[0] => 1); # as if already seen
-
- # if $last_child{$x} == $y, that means:
- # 1) incidentally, we've passed the node $x before.
- # 2) $x is the last child of $y,
- # so that means that $y can be pushed to the stack only after
- # we've pushed $x to the stack.
-
- my @tree_nodes;
- {
- my $current;
- my @in_stack = ($_[0]);
- while(@in_stack) {
- next unless
- defined($current = shift @in_stack)
- && ref($current) # sanity
- && ref($current->{'PARENTS'} || 0) # sanity
- ;
-
- push @tree_nodes, $current;
-
- $has_mi = 1 if @{$current->{'PARENTS'}} > 1;
- unshift
- @in_stack,
- map {
- if(exists $last_child{$_}) { # seen before!
- $last_child{$_} = $current;
- (); # seen -- don't re-explore
- } else { # first time seen
- $last_child{$_} = $current;
- $_; # first time seen -- explore now
- }
- }
- @{$current->{'PARENTS'}}
- ;
- }
-
- # If there was no MI, then that first scan was sufficient.
- unless($has_mi) {
- $_[0]{'ISA_CACHE'} = \@tree_nodes if $set_cache;
- return @tree_nodes;
- }
-
- # Otherwise, toss this list and rescan, consulting %last_child
- }
-
- # $last_child{$parent} holds the last (or only) child of $parent
- # in this tree. When walking the tree this time, only that
- # child is authorized to put its parent on the @in_stack.
- # And that's the only way a node can get added to @in_stack,
- # except for $_[0] (the start node) being there at the beginning.
-
- # Now, walk again, but this time exploring parents the LAST
- # time seen in the tree, not the first.
-
- my @out;
- {
- my $current;
- my @in_stack = ($_[0]);
- while(@in_stack) {
- next unless defined($current = shift @in_stack) && ref($current);
- push @out, $current; # finally.
- unshift
- @in_stack,
- grep(
- (
- defined($_) # sanity
- && ref($_) # sanity
- && $last_child{$_} eq $current,
- ),
- # I'm lastborn (or onlyborn) of this parent
- # so it's OK to explore now
- @{$current->{'PARENTS'}}
- )
- if ref($current->{'PARENTS'} || 0) # sanity
- ;
- }
-
- unless(scalar(@out) == scalar(keys(%last_child))) {
- # the counts should be equal
- my %good_ones;
- @good_ones{@out} = ();
- croak
- "ISA tree for " .
- ($_[0]{'NAME'} || $_[0]) .
- " is apparently cyclic, probably involving the nodes " .
- nodelist( grep { ref($_) && !exists $good_ones{$_} }
- values(%last_child) )
- . "\n";
- }
- }
- #print "Contents of out: ", nodelist(@out), "\n";
-
- $_[0]{'ISA_CACHE'} = \@out if $set_cache;
- return @out;
- }
-
- ###########################################################################
-
- sub Class::Classless::X::can { # NOT like UNIVERSAL::can ...
- # return 1 if $it is capable of the method given -- otherwise 0
- my($it, $m) = @_[0,1];
- return undef unless ref $it;
-
- croak "undef is not a valid method name" unless defined($m);
- croak "null-string is not a valid method name" unless length($m);
-
- foreach my $o (&Class::Classless::X::ISA_TREE($it)) {
- return 1
- if ref($o->{'METHODS'} || 0) # sanity
- && exists $o->{'METHODS'}{$m};
- }
-
- return 0;
- }
-
-
- ###########################################################################
-
- sub Class::Classless::X::isa { # Like UNIVERSAL::isa
- # Returns true for $X->isa($Y) iff $Y is $X or is an ancestor of $X.
-
- return unless ref($_[0]) && ref($_[1]);
- return scalar(grep {$_ eq $_[1]} &Class::Classless::X::ISA_TREE($_[0]));
- }
-
- ###########################################################################
-
- sub nodelist { join ', ', map { "" . ($_->{'NAME'} || $_) . ""} @_ }
-
- ###########################################################################
- ###########################################################################
- ###########################################################################
- # Methods for the CALLSTATE class.
- # Basically, CALLSTATE objects represent the state of the dispatcher,
- # frozen at the moment when the method call was dispatched to the
- # appropriate sub.
- # In the grand scheme of things, this needn't be a class -- I could
- # have just made the callstate data-object be a hash with documented
- # keys, or a closure that responded to only certain parameters,
- # etc. But I like it this way. And I like being able to say simply
- # $cs->NEXT
- # Yes, these are a bit cryptically written, but it's behoovy for
- # them to be very very efficient.
-
- @Class::Classless::ISA = ();
- sub Class::Classless::CALLSTATE::found_name { $_[0][0] }
- # the method name called and found
- sub Class::Classless::CALLSTATE::found_depth { $_[0][1] }
- # my depth in the lineage
- sub Class::Classless::CALLSTATE::lineage { @{$_[0][2]} }
- # my lineage
- sub Class::Classless::CALLSTATE::target { $_[0][2][ 0 ] }
- # the object that's the target -- same as $_[0] for the method called
- sub Class::Classless::CALLSTATE::home { $_[0][2][ $_[0][1] ] }
- # the object I was found in
- sub Class::Classless::CALLSTATE::sub_found {
- $_[0][2][ $_[0][1] ]{'METHODS'}{ $_[0][0] }
- } # the routine called
-
- sub Class::Classless::CALLSTATE::no_fail { $_[0][3] }
- sub Class::Classless::CALLSTATE::set_no_fail_true { $_[0][3] = 1 }
- sub Class::Classless::CALLSTATE::set_fail_false { $_[0][3] = 0 }
- sub Class::Classless::CALLSTATE::set_fail_undef { $_[0][3] = undef }
-
- sub Class::Classless::CALLSTATE::via_next { $_[0][4] }
-
- sub Class::Classless::CALLSTATE::NEXT {
- #croak "NEXT needs at least one argument: \$cs->NEXT('method'...)"
- # unless @_ > 1;
- # no longer true.
- my $cs = shift @_;
- my $m = shift @_; # which may be (or come out) undef...
- $m = $cs->[0] unless defined $m; # the method name called and found
-
- ($cs->[2][0])->$m(
- bless( \$cs, 'Class::Classless::CALLSTATE::SHIMMY' ),
- @_
- );
- }
-
- ###########################################################################
-};
-#}}}
-
-###############
-###
-#
-# {{{ *** C h a n g e l o g ***
-#
-# 0.6ca
-# - add screen support (from nicklist.pl)
-# - rename to adv_windowlist.pl (advanced window list) since it isn't just a
-# window list status bar (wlstat) anymore
-# - names can now have a max length and window names can be used
-# - fixed a bug with block display in screen mode and statusbar mode
-# - added space handling to ir_fe and removed it again
-# - now handling formats on my own
-# - added warning about missing sb_act_none abstract leading to
-# - display*active settings
-# - added warning about the bug in awl_display_(no)key_active settings
-#
-# 0.5d
-# - add setting to also hide the last statusbar if empty (awl_all_disable)
-# - reverted to old utf8 code to also calculate broken utf8 length correctly
-# - simplified dealing with statusbars in wlreset
-# - added a little tweak for the renamed term_type somewhere after Irssi 0.8.9
-# - fixed bug in handling channel #$$
-# - typo on line 200 spotted by f0rked
-# - reset background colour at the beginning of an entry
-#
-# 0.4d
-# - fixed order of disabling statusbars
-# - several attempts at special chars, without any real success
-# and much more weird new bugs caused by this
-# - setting to specify sort order
-# - reduced timeout values
-# - added awl_hide_data for Geert Hauwaerts ( geert@irssi.org ) :)
-# - make it so the dynamic sub is actually deleted
-# - fix a bug with removing of the last separator
-# - take into consideration parse_special
-#
-# 0.3b
-# - automatically kill old statusbars
-# - reset on /reload
-# - position/placement settings
-#
-# 0.2
-# - automated retrieval of key bindings (thanks grep.pl authors)
-# - improved removing of statusbars
-# - got rid of status chop
-#
-# 0.1
-# - rewritten to suit my needs
-# - based on chanact 0.5.5
-# }}}
-# vim: se fdm=marker tw=80 :
generated by cgit v1.2.3 (git 2.25.1) at 2025-10-31 05:11:45 +0000