diff options
Diffstat (limited to 'fixery/adv_windowlist.pl')
| -rw-r--r-- | fixery/adv_windowlist.pl | 2564 |
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 : |