dotfiles/irssi/scripts/adv_windowlist.pl

   1 use strict; # use warnings;
   2
   3 # {{{ debug
   4
   5 #BEGIN {
   6 #       open STDERR, '>', '/home/ailin/wlstatwarnings';
   7 #};
   8
   9 # FIXME COULD SOMEONE PLEASE TELL ME HOW TO SHUT UP
  10 #
  11 # ...
  12 # Variable "*" will not stay shared at (eval *) line *.
  13 # Variable "*" will not stay shared at (eval *) line *.
  14 # ...
  15 # Can't locate package Irssi::Nick for @Irssi::Irc::Nick::ISA at (eval *) line *.
  16 # ...
  17 #
  18 # THANKS
  19
  20 # }}}
  21
  22 # if you don't know how to operate folds, type zn
  23
  24 # {{{ header
  25
  26 use Irssi (); # which is the minimum required version of Irssi ?
  27 use Irssi::TextUI;
  28
  29 use vars qw($VERSION %IRSSI);
  30
  31 $VERSION = '0.6ca';
  32 %IRSSI = (
  33         original_authors => q(BC-bd,        Veli,          Timo Sirainen, ).
  34                             q(Wouter Coekaerts,    Jean-Yves Lefort), # (decadix)
  35         original_contact => q(bd@bc-bd.org, veli@piipiip.net, tss@iki.fi, ).
  36                             q(wouter@coekaerts.be, jylefort@brutele.be),
  37         authors          => q(Nei),
  38         contact          => q(Nei @ anti@conference.jabber.teamidiot.de),
  39         url              =>  "http://anti.teamidiot.de/",
  40         name             => q(awl),
  41         description      => q(Adds a permanent advanced window list on the right or ).
  42                             q(in a statusbar.),
  43         description2     => q(Based on chanact.pl which was apparently based on ).
  44                             q(lightbar.c and nicklist.pl with various other ideas ).
  45                             q(from random scripts.),
  46         license          => q(GNU GPLv2 or later),
  47 );
  48
  49 # }}}
  50
  51 # {{{ *** D O C U M E N T A T I O N ***
  52
  53 # adapted by Nei
  54
  55 ###############
  56 # {{{ original comment
  57 # ###########
  58 # # Adds new powerful and customizable [Act: ...] item (chanelnames,modes,alias).
  59 # # Lets you give alias characters to windows so that you can select those with
  60 # # meta-<char>.
  61 # #
  62 # # for irssi 0.8.2 by bd@bc-bd.org
  63 # #
  64 # # inspired by chanlist.pl by 'cumol@hammerhart.de'
  65 # #
  66 # #########
  67 # # {{{ Contributors
  68 # #########
  69 # #
  70 # # veli@piipiip.net   /window_alias code
  71 # # qrczak@knm.org.pl  chanact_abbreviate_names
  72 # # qerub@home.se      Extra chanact_show_mode and chanact_chop_status
  73 # # }}}
  74 # }}}
  75 #
  76 # {{{ FURTHER THANKS TO
  77 # ############
  78 # # buu, fxn, Somni, Khisanth, integral, tybalt89   for much support in any aspect perl
  79 # # and the channel in general ( #perl @ freenode ) and especially the ir_* functions
  80 # #
  81 # # Valentin 'senneth' Batz ( vb@g-23.org ) for the pointer to grep.pl, continuous support
  82 # #                                         and help in digging up ir_strip_codes
  83 # #
  84 # # OnetrixNET technology networks for the debian environment
  85 # #
  86 # # Monkey-Pirate.com / Spaceman Spiff for the webspace
  87 # #
  88 # }}}
  89
  90 ######
  91 # {{{ M A I N    P R O B L E M
  92 #####
  93 #
  94 # It is impossible to place the awl on a statusbar together with other items,
  95 # because I do not know how to calculate the size that it is going to get
  96 # granted, and therefore I cannot do the linebreaks properly.
  97 # This is what is missing to make a nice script out of awl.
  98 # If you have any ideas, please contact me ASAP :).
  99 # }}}
 100 ######
 101
 102 ######
 103 # {{{ UTF-8 PROBLEM
 104 #####
 105 #
 106 # Please help me find a solution to this:
 107 # this be your statusbar, it is using up the maximum term size
 108 # [[1=1]#abc [2=2]#defghi]
 109 #
 110 # now consider this example:i
 111 # "ascii" characters are marked with ., utf-8 characters with *
 112 # [[1=1]#... [2=2]#...***]
 113 #
 114 # you should think that this is how it would be displayed? WRONG!
 115 # [[1=1]#... [2=2]#...***   ]
 116 #
 117 # this is what Irssi does.. I believe my length calculating code to be correct,
 118 # however, I'd love to be proven wrong (or receive any other fix, too, of
 119 # course!)
 120 # }}}
 121 ######
 122
 123 #########
 124 # {{{ USAGE
 125 ###
 126 #
 127 # copy the script to ~/.irssi/scripts/
 128 #
 129 # In irssi:
 130 #
 131 #               /script load awl
 132 #
 133 #
 134 # Hint: to get rid of the old [Act:] display
 135 #     /statusbar window remove act
 136 #
 137 # to get it back:
 138 #     /statusbar window add -after lag -priority 10 act
 139 # }}}
 140 ##########
 141 # {{{ OPTIONS
 142 ########
 143 #
 144 # {{{ /set awl_display_nokey <string>
 145 #     /set awl_display_key <string>
 146 #     /set awl_display_nokey_active <string>
 147 #     /set awl_display_key_active <string>
 148 #     * string : Format String for one window. The following $'s are expanded:
 149 #         $C : Name
 150 #         $N : Number of the Window
 151 #         $Q : meta-Keymap
 152 #         $H : Start highlighting
 153 #         $S : Stop highlighting
 154 #             /+++++++++++++++++++++++++++++++++,
 155 #            | ****  I M P O R T A N T :  ****  |
 156 #            |                                  |
 157 #            | don't forget  to use  $S  if you |
 158 #            | used $H before!                  |
 159 #            |                                  |
 160 #            '+++++++++++++++++++++++++++++++++/
 161 #       XXX NOTE ON *_active: there is a BUG somewhere in the length
 162 #       XXX calculation. currently it's best to NOT remove $H/$S from those
 163 #       XXX settings if you use it in the non-active settings.
 164 # }}}
 165 # {{{ /set awl_separator <string>
 166 #     * string : Charater to use between the channel entries
 167 #     you'll need to escape " " space and "$" like this:
 168 #     "/set awl_separator \ "
 169 #     "/set awl_separator \$"
 170 #     and {}% like this:
 171 #     "/set awl_separator %{"
 172 #     "/set awl_separator %}"
 173 #     "/set awl_separator %%"
 174 #     (reason being, that the separator is used inside a {format })
 175 # }}}
 176 # {{{ /set awl_prefer_name <ON|OFF>
 177 #     * this setting decides whether awl will use the active_name (OFF) or the
 178 #       window name as the name/caption in awl_display_*.
 179 #       That way you can rename windows using /window name myownname.
 180 # }}}
 181 # {{{ /set awl_hide_data <num>
 182 #     * num : hide the window if its data_level is below num
 183 #     set it to 0 to basically disable this feature,
 184 #               1 if you don't want windows without activity to be shown
 185 #               2 to show only those windows with channel text or hilight
 186 #               3 to show only windows with hilight
 187 # }}}
 188 # {{{ /set awl_maxlines <num>
 189 #     * num : number of lines to use for the window list (0 to disable, negative
 190 #       lock)
 191 # }}}
 192 # {{{ /set awl_columns <num>
 193 #     * num : number of columns to use in screen mode (0 for unlimited)
 194 # }}}
 195 # {{{ /set awl_block <num>
 196 #     * num : width of a column in screen mode (negative values = block display)
 197 #             /+++++++++++++++++++++++++++++++++,
 198 #            | ******  W A R N I N G !  ******  |
 199 #            |                                  |
 200 #            | If  your  block  display  looks  |
 201 #            | DISTORTED,  you need to add the  |
 202 #            | following  line to your  .theme  |
 203 #            | file under                       |
 204 #            |     abstracts = {             :  |
 205 #            |                                  |
 206 #            |       sb_act_none = "%n$*";      |
 207 #            |                                  |
 208 #            '+++++++++++++++++++++++++++++++++/
 209 #.02:08:26. < shi>  Irssi::current_theme()->get_format <.. can this be used?
 210 # }}}
 211 # {{{ /set awl_sbar_maxlength <ON|OFF>
 212 #     * if you enable the maxlength setting, the block width will be used as a
 213 #       maximum length for the non-block statusbar mode too.
 214 # }}}
 215 # {{{ /set awl_height_adjust <num>
 216 #     * num : how many lines to leave empty in screen mode
 217 # }}}
 218 # {{{ /set awl_sort <-data_level|-last_line|refnum>
 219 #     * you can change the window sort order with this variable
 220 #         -data_level : sort windows with hilight first
 221 #         -last_line  : sort windows in order of activity
 222 #         refnum      : sort windows by window number
 223 # }}}
 224 # {{{ /set awl_placement <top|bottom>
 225 #     /set awl_position <num>
 226 #     * these settings correspond to /statusbar because awl will create
 227 #       statusbars for you
 228 #     (see /help statusbar to learn more)
 229 # }}}
 230 # {{{ /set awl_all_disable <ON|OFF>
 231 #     * if you set awl_all_disable to ON, awl will also remove the
 232 #       last statusbar it created if it is empty.
 233 #       As you might guess, this only makes sense with awl_hide_data > 0 ;)
 234 # }}}
 235 # {{{ /set awl_automode <sbar|screen|emulate_lightbar>
 236 #     * this setting defines whether the window list is shown in statusbars or
 237 #       whether the screen hack is used (from nicklist.pl)
 238 # }}}
 239 # }}}
 240 ##########
 241 # {{{ COMMANDS
 242 ########
 243 # {{{ /awl paste <ON|OFF|TOGGLE>
 244 #     * enables or disables the screen hack windowlist. This is useful when you
 245 #       want to mark & copy text that you want to paste somewhere (hence the
 246 #       name). (ON means AWL disabled!)
 247 #       This is nicely bound to a function key for example.
 248 # }}}
 249 # {{{ /awl redraw
 250 #     * redraws the screen hack windowlist. There are many occasions where the
 251 #       screen hack windowlist can get destroyed so you can use this command to
 252 #       fix it.
 253 # }}}
 254 # }}}
 255 ###
 256 # {{{ WISHES
 257 ####
 258 #
 259 # if you fiddle with my mess, provide me with your fixes so I can benefit as well
 260 #
 261 # Nei =^.^= ( anti@conference.jabber.teamidiot.de )
 262 # }}}
 263
 264 # }}}
 265
 266 # {{{ modules
 267
 268 #use Class::Classless;
 269 #use Term::Info;
 270
 271 # }}}
 272
 273 # {{{ global variables
 274
 275 my $replaces = '[=]'; # AARGH!!! (chars that are always surrounded by weird
 276                       # colour codes by Irssi)
 277
 278 my $actString = [];   # statusbar texts
 279 my $currentLines = 0;
 280 my $resetNeeded;      # layout/screen has changed, redo everything
 281 my $needRemake;       # "normal" changes
 282 #my $callcount = 0;
 283 sub GLOB_QUEUE_TIMER () { 100 }
 284 my $globTime = undef; # timer to limit remake() calls
 285
 286
 287 my $SCREEN_MODE;
 288 my $DISABLE_SCREEN_TEMP;
 289 my $currentColumns = 0;
 290 my $screenResizing;
 291 my ($screenHeight, $screenWidth);
 292 my $screenansi = bless {
 293         NAME => 'Screen::ANSI',
 294         PARENTS => [],
 295         METHODS => {
 296                 dcs   => sub { "\033P" },
 297                 st    => sub { "\033\\"},
 298         }
 299 }, 'Class::Classless::X';
 300 #my $terminfo = new Term::Info 'xterm'; # xterm here, make this modular
 301 # {{{{{{{{{{{{{{{
 302 my $terminfo = bless { # xterm here, make this modular
 303         NAME => 'Term::Info::xterm',
 304         PARENTS => [],
 305         METHODS => {
 306  #      civis=\E[?25l,
 307                 civis => sub { "\033[?25l" },
 308  #      sc=\E7,
 309                 sc    => sub { "\0337" },
 310  #      cup=\E[%i%p1%d;%p2%dH,
 311                 cup   => sub { shift;shift; "\033[" . ($_[0] + 1) . ';' . ($_[1] + 1) . 'H' },
 312  #      el=\E[K,
 313                 el    => sub { "\033[K" },
 314  #      rc=\E8,
 315                 rc    => sub { "\0338" },
 316  #      cnorm=\E[?25h,
 317                 cnorm => sub { "\033[?25h" },
 318  #      setab=\E[4%p1%dm,
 319                 setab => sub { shift;shift; "\033[4" . $_[0] . 'm' },
 320  #      setaf=\E[3%p1%dm,
 321                 setaf => sub { shift;shift; "\033[3" . $_[0] . 'm' },
 322  #      bold=\E[1m,
 323                 bold  => sub { "\033[1m" },
 324  #      blink=\E[5m,
 325                 blink => sub { "\033[5m" },
 326  #      rev=\E[7m,
 327                 rev   => sub { "\033[7m" },
 328  #      op=\E[39;49m,
 329                 op    => sub { "\033[39;49m" },
 330         }
 331 }, 'Class::Classless::X';
 332 # }}}}}}}}}}}}}}}
 333
 334
 335 sub setc () {
 336         $IRSSI{'name'}
 337 }
 338 sub set ($) {
 339         setc . '_' . shift
 340 }
 341
 342 # }}}
 343
 344
 345 # {{{ sbar mode
 346
 347 my %statusbars;       # currently active statusbars
 348
 349 # maybe I should just tie the array ?
 350 sub add_statusbar {
 351         for (@_) {
 352                 # add subs
 353                 for my $l ($_) { {
 354                         no strict 'refs'; # :P
 355                         *{set$l} = sub { awl($l, @_) };
 356                 }; }
 357                 Irssi::command('statusbar ' . (set$_) . ' reset');
 358                 Irssi::command('statusbar ' . (set$_) . ' enable');
 359                 if (lc Irssi::settings_get_str(set 'placement') eq 'top') {
 360                         Irssi::command('statusbar ' . (set$_) . ' placement top');
 361                 }
 362                 if ((my $x = int Irssi::settings_get_int(set 'position')) != 0) {
 363                         Irssi::command('statusbar ' . (set$_) . ' position ' . $x);
 364                 }
 365                 Irssi::command('statusbar ' . (set$_) . ' add -priority 100 -alignment left barstart');
 366                 Irssi::command('statusbar ' . (set$_) . ' add ' . (set$_));
 367                 Irssi::command('statusbar ' . (set$_) . ' add -priority 100 -alignment right barend');
 368                 Irssi::command('statusbar ' . (set$_) . ' disable');
 369                 Irssi::statusbar_item_register(set$_, '$0', set$_);
 370                 $statusbars{$_} = {};
 371         }
 372 }
 373
 374 sub remove_statusbar {
 375         for (@_) {
 376                 Irssi::command('statusbar ' . (set$_) . ' reset');
 377                 Irssi::statusbar_item_unregister(set$_); # XXX does this actually work ?
 378                 # DO NOT REMOVE the sub before you have unregistered it :))
 379                 for my $l ($_) { {
 380                         no strict 'refs';
 381                         undef &{set$l};
 382                 }; }
 383                 delete $statusbars{$_};
 384         }
 385 }
 386
 387 sub syncLines {
 388         my $temp = $currentLines;
 389         $currentLines = @$actString;
 390         #Irssi::print("current lines: $temp new lines: $currentLines");
 391         my $currMaxLines = Irssi::settings_get_int(set 'maxlines');
 392         if ($currMaxLines > 0 and @$actString > $currMaxLines) {
 393                 $currentLines = $currMaxLines;
 394         }
 395         elsif ($currMaxLines < 0) {
 396                 $currentLines = abs($currMaxLines);
 397         }
 398         return if ($temp == $currentLines);
 399         if ($currentLines > $temp) {
 400                 for ($temp .. ($currentLines - 1)) {
 401                         add_statusbar($_);
 402                         Irssi::command('statusbar ' . (set$_) . ' enable');
 403                 }
 404         }
 405         else {
 406                 for ($_ = ($temp - 1); $_ >= $currentLines; $_--) {
 407                         Irssi::command('statusbar ' . (set$_) . ' disable');
 408                         remove_statusbar($_);
 409                 }
 410         }
 411 }
 412
 413 # FIXME implement $get_size_only check, and user $item->{min|max-size} ??
 414 sub awl {
 415         my ($line, $item, $get_size_only) = @_;
 416
 417         if ($needRemake) {
 418                 $needRemake = undef;
 419                 remake();
 420         }
 421
 422         my $text = $actString->[$line];  # DO NOT set the actual $actString->[$line] to '' here or
 423         $text = '' unless defined $text; # you'll screw up the statusbar counter ($currentLines)
 424         $item->default_handler($get_size_only, $text, '', 1);
 425 }
 426
 427 # remove old statusbars
 428 my %killBar;
 429 sub get_old_status {
 430         my ($textDest, $cont, $cont_stripped) = @_;
 431         if ($textDest->{'level'} == 524288 and $textDest->{'target'} eq ''
 432                         and !defined($textDest->{'server'})
 433         ) {
 434                 my $name = quotemeta(set '');
 435                 if ($cont_stripped =~ m/^$name(\d+)\s/) { $killBar{$1} = {}; }
 436                 Irssi::signal_stop();
 437         }
 438 }
 439 sub killOldStatus {
 440         %killBar = ();
 441         Irssi::signal_add_first('print text' => 'get_old_status');
 442         Irssi::command('statusbar');
 443         Irssi::signal_remove('print text' => 'get_old_status');
 444         remove_statusbar(keys %killBar);
 445 }
 446 #killOldStatus();
 447
 448 # end sbar mode }}}
 449
 450
 451 # {{{ keymaps
 452
 453 my %keymap;
 454
 455 sub get_keymap {
 456         my ($textDest, undef, $cont_stripped) = @_;
 457         if ($textDest->{'level'} == 524288 and $textDest->{'target'} eq ''
 458                         and !defined($textDest->{'server'})
 459         ) {
 460                 if ($cont_stripped =~ m/((?:meta-)+)(.)\s+change_window (\d+)/) {
 461                         my ($level, $key, $window) = ($1, $2, $3);
 462                         my $numlevel = ($level =~ y/-//) - 1;
 463                         $keymap{$window} = ('-' x $numlevel) . "$key";
 464                 }
 465                 Irssi::signal_stop();
 466         }
 467 }
 468
 469 sub update_keymap {
 470         %keymap = ();
 471         Irssi::signal_remove('command bind' => 'watch_keymap');
 472         Irssi::signal_add_first('print text' => 'get_keymap');
 473         Irssi::command('bind'); # stolen from grep
 474         Irssi::signal_remove('print text' => 'get_keymap');
 475         Irssi::signal_add('command bind' => 'watch_keymap');
 476         Irssi::timeout_add_once(100, 'eventChanged', undef);
 477 }
 478
 479 # watch keymap changes
 480 sub watch_keymap {
 481         Irssi::timeout_add_once(1000, 'update_keymap', undef);
 482 }
 483
 484 update_keymap();
 485
 486 # end keymaps }}}
 487
 488 # {{{ format handling
 489
 490 # a bad way do do expansions but who cares
 491 sub expand {
 492         my ($string, %format) = @_;
 493         my ($exp, $repl);
 494         $string =~ s/\$$exp/$repl/g while (($exp, $repl) = each(%format));
 495         return $string;
 496 }
 497
 498 my %strip_table = (
 499         # fe-common::core::formats.c:format_expand_styles
 500         #      delete                format_backs  format_fores bold_fores   other stuff
 501         (map { $_ => '' } (split //, '04261537' .  'kbgcrmyw' . 'KBGCRMYW' . 'U9_8:|FnN>#[')),
 502         #      escape
 503         (map { $_ => $_ } (split //, '{}%')),
 504 );
 505 sub ir_strip_codes { # strip %codes
 506         my $o = shift;
 507         $o =~ s/(%(.))/exists $strip_table{$2} ? $strip_table{$2} : $1/gex;
 508         $o
 509 }
 510
 511 sub ir_parse_special {
 512         my $o; my $i = shift;
 513         #if ($_[0]) { # for the future?!?
 514         #       eval {
 515         #               $o = $_[0]->parse_special($i);
 516         #       };
 517         #       unless ($@) {
 518         #               return $o;
 519         #       }
 520         #}
 521         my $win = shift || Irssi::active_win();
 522         my $server = Irssi::active_server();
 523         if (ref $win and ref $win->{'active'}) {
 524                 $o = $win->{'active'}->parse_special($i);
 525         }
 526         elsif (ref $win and ref $win->{'active_server'}) {
 527                 $o = $win->{'active_server'}->parse_special($i);
 528         }
 529         elsif (ref $server) {
 530                 $o =  $server->parse_special($i);
 531         }
 532         else {
 533                 $o = Irssi::parse_special($i);
 534         }
 535         $o
 536 }
 537 sub ir_parse_special_protected {
 538         my $o; my $i = shift;
 539         $i =~ s/
 540                 ( \\. ) | # skip over escapes (maybe)
 541                 ( \$[^% $\]+ ) # catch special variables
 542         /
 543                 if ($1) { $1 }
 544                 elsif ($2) { my $i2 = $2; ir_fe(ir_parse_special($i2, @_)) }
 545                 else { $& }
 546         /gex;
 547         $i
 548 }
 549
 550
 551 sub sb_ctfe { # Irssi::current_theme->format_expand wrapper
 552         Irssi::current_theme->format_expand(
 553                 shift,
 554                 (
 555                         Irssi::EXPAND_FLAG_IGNORE_REPLACES
 556                                 |
 557                         ($_[0]?0:Irssi::EXPAND_FLAG_IGNORE_EMPTY)
 558                 )
 559         )
 560 }
 561 sub sb_expand { # expand {format }s (and apply parse_special for $vars)
 562         ir_parse_special(
 563                 sb_ctfe(shift)
 564         )
 565 }
 566 sub sb_strip {
 567         ir_strip_codes(
 568                 sb_expand(shift)
 569         ); # does this get us the actual length of that s*ty bar :P ?
 570 }
 571 sub sb_length {
 572         # unicode cludge, d*mn broken Irssi
 573         # screw it, this will fail from broken joining anyway (and cause warnings)
 574         my $term_type = 'term_type';
 575         if (Irssi::version > 20040819) { # this is probably wrong, but I don't know
 576                                               # when the setting name got changed
 577                 $term_type = 'term_charset';
 578         }
 579         #if (lc Irssi::settings_get_str($term_type) eq '8bit'
 580         #               or Irssi::settings_get_str($term_type) =~ /^iso/i
 581         #) {
 582         #       length(sb_strip(shift))
 583         #}
 584         #else {
 585         my $temp = sb_strip(shift);
 586         # try to get the displayed width
 587         my $length;
 588         eval {
 589                 require Text::CharWidth;
 590                 $length = Text::CharWidth::mbswidth($temp);
 591         };
 592         unless ($@) {
 593                 return $length;
 594         }
 595         else {
 596                 if (lc Irssi::settings_get_str($term_type) eq 'utf-8') {
 597                         # try to switch on utf8
 598                         eval {
 599                                 no warnings;
 600                                 require Encode;
 601                                 #$temp = Encode::decode_utf8($temp); # thanks for the hint, but I have my
 602                                 #                                    # reasons for _utf8_on
 603                                 Encode::_utf8_on($temp);
 604                         };
 605                 }
 606                 # there is nothing more I can do
 607                 length($temp)
 608         }
 609         #}
 610 }
 611
 612 # !!! G*DD*MN Irssi is adding an additional layer of backslashitis per { } layer
 613 # !!! AND I still don't know what I need to escape.
 614 # !!! and NOONE else seems to know or care either.
 615 # !!! f*ck open source. I mean it.
 616 # XXX any Irssi::print debug statement leads to SEGFAULT - why ?
 617
 618 # major parts of the idea by buu (#perl @ freenode)
 619 # thanks to fxn and Somni for debugging
 620 #       while ($_[0] =~ /(.)/g) {
 621 #               my $c = $1; # XXX sooo... goto kills $1
 622 #               if ($q eq '%') { goto ESC; }
 623
 624 ## <freenode:#perl:tybalt89> s/%(.)|(\{)|(\})|(\\|\$)/$1?$1:$2?($level++,$2):$3?($level>$min_level&&$level--,$3):'\\'x(2**$level-1).$4/ge;  # untested...
 625 sub ir_escape {
 626         my $min_level = $_[1] || 0; my $level = $min_level;
 627         my $o = shift;
 628         $o =~ s/
 629                 (       %.      )       | # $1
 630                 (       \{      )       | # $2
 631                 (       \}      )       | # $3
 632                 (       \\      )       | # $4
 633                 (       \$(?=[^\\])     )       | # $5
 634                 (       \$      ) # $6
 635         /
 636                 if ($1) { $1 } # %. escape
 637                 elsif ($2) { $level++; $2 } # { nesting start
 638                 elsif ($3) { if ($level > $min_level) { $level--; } $3 } # } nesting end
 639                 elsif ($4) { '\\'x(2**$level) } # \ needs \\escaping
 640                 elsif ($5) { '\\'x(2**$level-1) . '$' . '\\'x(2**$level-1) } # and $ needs even more because of "parse_special"
 641                 else { '\\'x(2**$level-1) . '$' } # $ needs \$ escaping
 642         /gex;
 643         $o
 644 }
 645 #sub ir_escape {
 646 #       my $min_level = $_[1] || 0; my $level = $min_level;
 647 #       my $o = shift;
 648 #       $o =~ s/
 649 #               (       %.      )       | # $1
 650 #               (       \{      )       | # $2
 651 #               (       \}      )       | # $3
 652 #               (       \\      |       \$      )       # $4
 653 #       /
 654 #               if ($1) { $1 } # %. escape
 655 #               elsif ($2) { $level++; $2 } # { nesting start
 656 #               elsif ($3) { if ($level > $min_level) { $level--; } $3 } # } nesting end
 657 #               else { '\\'x(2**($level-1)-1) . $4 } # \ or $ needs \\escaping
 658 #       /gex;
 659 #       $o
 660 #}
 661
 662 sub ir_fe { # try to fix format stuff
 663         my $x = shift;
 664         # XXX why do I have to use two/four % here instead of one/two ??
 665         # answer: you screwed up in ir_escape
 666         $x =~ s/([%{}])/%$1/g;
 667         #$x =~ s/(\\|\$|[ ])/\\$1/g; # XXX HOW CAN I HANDLE THE SPACES CORRECTLY XXX
 668         $x =~ s/(\\|\$)/\\$1/g;
 669         #$x =~ s/(\$(?=.))|(\$)/$1?"\\\$\\":"\\\$"/ge; # I think this should be here
 670         #                                              # (logic), but it doesn't work
 671         #                                              # that way :P
 672         #$x =~ s/\\/\\\\/g; # that's right, escape escapes
 673         $x
 674 }
 675 sub ir_ve { # escapes special vars but leave colours alone
 676         my $x = shift;
 677         #$x =~ s/([%{}])/%$1/g;
 678         $x =~ s/(\\|\$|[ ])/\\$1/g;
 679         $x
 680 }
 681
 682 my %ansi_table;
 683 {
 684         my ($i, $j, $k) = (0, 0, 0);
 685         %ansi_table = (
 686                 # fe-common::core::formats.c:format_expand_styles
 687                 #      do                                              format_backs
 688                 (map { $_ => $terminfo->setab($i++) } (split //, '01234567' )),
 689                 #      do                                              format_fores
 690                 (map { $_ => $terminfo->setaf($j++) } (split //, 'krgybmcw' )),
 691                 #      do                                              bold_fores
 692                 (map { $_ => $terminfo->bold() .
 693                              $terminfo->setaf($k++) } (split //, 'KRGYBMCW')),
 694                 # reset
 695                 #(map { $_ => $terminfo->op() } (split //, 'nN')),
 696                 (map { $_ => $terminfo->op() } (split //, 'n')),
 697                 (map { $_ => "\033[0m" } (split //, 'N')), # XXX quick and DIRTY
 698                 # flash/bright
 699                 F => $terminfo->blink(),
 700                 # reverse
 701                 8 => $terminfo->rev(),
 702                 # bold
 703                 (map { $_ => $terminfo->bold() } (split //, '9_')),
 704                 #      delete                other stuff
 705                 (map { $_ => '' } (split //, ':|>#[')),
 706                 #      escape
 707                 (map { $_ => $_ } (split //, '{}%')),
 708         )
 709 }
 710 sub formats_to_ansi_basic {
 711         my $o = shift;
 712         $o =~ s/(%(.))/exists $ansi_table{$2} ? $ansi_table{$2} : $1/gex;
 713         $o
 714 }
 715
 716 sub lc1459 ($) { my $x = shift; $x =~ y/A-Z][\^/a-z}{|~/; $x }
 717 Irssi::settings_add_str(setc, 'banned_channels', '');
 718 Irssi::settings_add_bool(setc, 'banned_channels_on', 0);
 719 my %banned_channels = map { lc1459($_) => undef }
 720 split ' ', Irssi::settings_get_str('banned_channels');
 721 Irssi::settings_add_str(setc, 'fancy_abbrev', 'fancy');
 722
 723 # }}}
 724
 725 # {{{ main
 726
 727 sub remake () {
 728         #$callcount++;
 729         #my $xx = $callcount; Irssi::print("starting remake [ $xx ]");
 730         my ($hilight, $number, $display);
 731         my $separator = '{sb_act_sep ' . Irssi::settings_get_str(set 'separator') .
 732                 '}';
 733         my $custSort = Irssi::settings_get_str(set 'sort');
 734         my $custSortDir = 1;
 735         if ($custSort =~ /^[-!](.*)/) {
 736                 $custSortDir = -1;
 737                 $custSort = $1;
 738         }
 739
 740         my @wins =
 741                 sort {
 742                         (
 743                                 ( (int($a->{$custSort}) <=> int($b->{$custSort})) * $custSortDir )
 744                                         ||
 745                                 ($a->{'refnum'} <=> $b->{'refnum'})
 746                         )
 747                 } Irssi::windows;
 748         my $block = Irssi::settings_get_int(set 'block');
 749         my $columns = $currentColumns;
 750         my $oldActString = $actString if $SCREEN_MODE;
 751         $actString = $SCREEN_MODE ? ['   A W L'] : [];
 752         my $line = $SCREEN_MODE ? 1 : 0;
 753         my $width = $SCREEN_MODE
 754                         ?
 755                 $screenWidth - abs($block)*$columns + 1
 756                         :
 757                 ([Irssi::windows]->[0]{'width'} - sb_length('{sb x}'));
 758         my $height = $screenHeight - abs(Irssi::settings_get_int(set
 759                         'height_adjust'));
 760         my ($numPad, $keyPad) = (0, 0);
 761         my %abbrevList;
 762         if ($SCREEN_MODE or Irssi::settings_get_bool(set 'sbar_maxlength')
 763                         or ($block < 0)
 764         ) {
 765                 %abbrevList = ();
 766                 if (Irssi::settings_get_str('fancy_abbrev') !~ /^(no|off|head)/i) {
 767                         my @nameList = map { ref $_ ? $_->get_active_name : '' } @wins;
 768                         for (my $i = 0; $i < @nameList - 1; ++$i) {
 769                                 my ($x, $y) = ($nameList[$i], $nameList[$i + 1]);
 770                                 for ($x, $y) { s/^[+#!=]// }
 771                                 my $res = Algorithm::LCSS::LCSS($x, $y);
 772                                 if (defined $res) {
 773                                         #Irssi::print("common pattern $x $y : $res");
 774                                         #Irssi::print("found at $nameList[$i] ".index($nameList[$i],
 775                                         #               $res));
 776                                         $abbrevList{$nameList[$i]} = int (index($nameList[$i], $res) +
 777                                                 (length($res) / 2));
 778                                         #Irssi::print("found at ".$nameList[$i+1]." ".index($nameList[$i+1],
 779                                         #               $res));
 780                                         $abbrevList{$nameList[$i+1]} = int (index($nameList[$i+1], $res) +
 781                                                 (length($res) / 2));
 782                                 }
 783                         }
 784                 }
 785                 if ($SCREEN_MODE or ($block < 0)) {
 786                         $numPad = length((sort { length($b) <=> length($a) } keys %keymap)[0]);
 787                         $keyPad = length((sort { length($b) <=> length($a) } values %keymap)[0]);
 788                 }
 789         }
 790         if ($SCREEN_MODE) {
 791                 print STDERR $screenansi->dcs().
 792                              $terminfo->civis().
 793                                                  $terminfo->sc().
 794                                                  $screenansi->st();
 795                 if (@$oldActString < 1) {
 796                         print STDERR $screenansi->dcs().
 797                                                          $terminfo->cup(0, $width).
 798                                      $actString->[0].
 799                                                          $terminfo->el().
 800                                      $screenansi->st();
 801                 }
 802         }
 803         foreach my $win (@wins) {
 804                 unless ($SCREEN_MODE) {
 805                         $actString->[$line] = '' unless defined $actString->[$line]
 806                                         or Irssi::settings_get_bool(set 'all_disable');
 807                 }
 808
 809                 # all stolen from chanact, what does this code do and why do we need it ?
 810                 !ref($win) && next;
 811
 812                 my $name = $win->get_active_name;
 813                 $name = '*' if (Irssi::settings_get_bool('banned_channels_on') and exists
 814                         $banned_channels{lc1459($name)});
 815                 $name = $win->{'name'} if $name ne '*' and $win->{'name'} ne ''
 816                         and Irssi::settings_get_bool(set 'prefer_name');
 817                 my $active = $win->{'active'};
 818                 my $colour = $win->{'hilight_color'};
 819                 if (!defined $colour) { $colour = ''; }
 820
 821                 if ($win->{'data_level'} < Irssi::settings_get_int(set 'hide_data')) {
 822                         next; } # for Geert
 823                 if    ($win->{'data_level'} == 0) { $hilight = '{sb_act_none '; }
 824                 elsif ($win->{'data_level'} == 1) { $hilight = '{sb_act_text '; }
 825                 elsif ($win->{'data_level'} == 2) { $hilight = '{sb_act_msg '; }
 826                 elsif ($colour             ne '') { $hilight = "{sb_act_hilight_color $colour "; }
 827                 elsif ($win->{'data_level'} == 3) { $hilight = '{sb_act_hilight '; }
 828                 else                              { $hilight = '{sb_act_special '; }
 829
 830                 $number = $win->{'refnum'};
 831                 my @display = ('display_nokey');
 832                 if (defined $keymap{$number} and $keymap{$number} ne '') {
 833                         unshift @display, map { (my $cpy = $_) =~ s/_no/_/; $cpy } @display;
 834                 }
 835                 if (Irssi::active_win->{'refnum'} == $number) {
 836                         unshift @display, map { my $cpy = $_; $cpy .= '_active'; $cpy } @display;
 837                 }
 838                 #Irssi::print("win $number [@display]: " . join '.', split //, join '<<', map {
 839                         #               Irssi::settings_get_str(set $_) } @display);
 840                 $display = (grep { $_ }
 841                         map { Irssi::settings_get_str(set $_) }
 842                         @display)[0];
 843                         #Irssi::print("win $number : " . join '.', split //, $display);
 844
 845                 if ($SCREEN_MODE or Irssi::settings_get_bool(set 'sbar_maxlength')
 846                                 or ($block < 0)
 847                 ) {
 848                         my $baseLength = sb_length(ir_escape(ir_ve(ir_parse_special_protected(sb_ctfe(
 849                                 '{sb_background}' . expand($display,
 850                                 C => ir_fe('x'),
 851                                 N => $number . (' 'x($numPad - length($number))),
 852                                 Q => ir_fe((' 'x($keyPad - length($keymap{$number}))) . $keymap{$number}),
 853                                 H => $hilight,
 854                                 S => '}{sb_background}'
 855                         ), 1), $win)))) - 1;
 856                         my $diff = abs($block) - (length($name) + $baseLength);
 857                         if ($diff < 0) { # too long
 858                                 if (abs($diff) >= length($name)) { $name = '' } # forget it
 859                                 elsif (abs($diff) + 1 >= length($name)) { $name = substr($name,
 860                                                 0, 1); }
 861                                 else {
 862                                         my $middle = exists $abbrevList{$name} ?
 863                                         (($abbrevList{$name} + (2*(length($name) / 2)))/3) :
 864                                                 ((Irssi::settings_get_str('fancy_abbrev') =~ /^head/i) ?
 865                                                                 length($name) :
 866                                                 (length($name) / 2));
 867                                         my $cut = int($middle - (abs($diff) / 2) + .55);
 868                                         $cut = 1 if $cut < 1;
 869                                         $cut = length($name) - abs($diff) - 1 if $cut > (length($name) -
 870                                                 abs($diff) - 1);
 871                                         $name = substr($name, 0, $cut) . '~' . substr($name, $cut +
 872                                                 abs($diff) + 1);
 873                                 }
 874                         }
 875                         elsif ($SCREEN_MODE or ($block < 0)) {
 876                                 $name .= (' ' x $diff);
 877                         }
 878                 }
 879
 880                 my $add = ir_ve(ir_parse_special_protected(sb_ctfe('{sb_background}' . expand($display,
 881                         C => ir_fe($name),
 882                         N => $number . (' 'x($numPad - length($number))),
 883                         Q => ir_fe((' 'x($keyPad - length($keymap{$number}))) . $keymap{$number}),
 884                         H => $hilight,
 885                         S => '}{sb_background}'
 886                 ), 1), $win));
 887                 if ($SCREEN_MODE) {
 888                         $actString->[$line] = $add;
 889                         if ((!defined $oldActString->[$line]
 890                                         or $oldActString->[$line] ne $actString->[$line])
 891                                         and
 892                                 $line <= ($columns * $height)
 893                         ) {
 894                                 print STDERR $screenansi->dcs().
 895                                                                  $terminfo->cup(($line-1) % $height+1, $width + (
 896                                                                          abs($block) * int(($line-1) / $height))).
 897                                 formats_to_ansi_basic(sb_expand(ir_escape($actString->[$line]))).
 898                                                                 #$terminfo->el().
 899                                                                  $screenansi->st();
 900                         }
 901                         $line++;
 902                 }
 903                 else {
 904                         #$temp =~ s/\{\S+?(?:\s(.*?))?\}/$1/g;
 905                         #$temp =~ s/\\\\\\\\/\\/g; # XXX I'm actually guessing here, someone point me
 906                         #                          # XXX to docs please
 907                         $actString->[$line] = '' unless defined $actString->[$line];
 908
 909                         # XXX how can I check whether the content still fits in the bar? this would
 910                         # XXX allow awlstatus to reside on a statusbar together with other items...
 911                         if (sb_length(ir_escape($actString->[$line] . $add)) >= $width) {
 912                                 # XXX doesn't correctly handle utf-8 multibyte ... help !!?
 913                                 $actString->[$line] .= ' ' x ($width - sb_length(ir_escape(
 914                                         $actString->[$line])));
 915                                 $line++;
 916                         }
 917                         $actString->[$line] .= $add . $separator;
 918                         # XXX if I use these prints, output layout gets screwed up... why ?
 919                         #Irssi::print("line $line: ".$actString->[$line]);
 920                         #Irssi::print("temp $line: ".$temp);
 921                 }
 922         }
 923
 924         if ($SCREEN_MODE) {
 925                 while ($line <= ($columns * $height)) {
 926                         print STDERR $screenansi->dcs().
 927                                                          $terminfo->cup(($line-1) % $height+1, $width + (
 928                                                                  abs($block) * int(($line-1) / $height))).
 929                                                          $terminfo->el().
 930                                                          $screenansi->st();
 931                         $line++;
 932                 }
 933                 print STDERR $screenansi->dcs().
 934                                                  $terminfo->rc().
 935                              $terminfo->cnorm().
 936                                                  $screenansi->st();
 937         }
 938         else {
 939                 # XXX the Irssi::print statements lead to the MOST WEIRD results
 940                 # e.g.: the loop gets executed TWICE for p > 0 ?!?
 941                 for (my $p = 0; $p < @$actString; $p++) { # wrap each line in {sb }, escape it
 942                         my $x = $actString->[$p];              # properly, etc.
 943                         $x =~ s/\Q$separator\E([ ]*)$/$1/;
 944                         #Irssi::print("[$p]".'current:'.join'.',split//,sb_strip(ir_escape($x,0)));
 945                         #Irssi::print("assumed length before:".sb_length(ir_escape($x,0)));
 946                         $x = "{sb $x}";
 947                         #Irssi::print("[$p]".'new:'.join'.',split//,sb_expand(ir_escape($x,0)));
 948                         #Irssi::print("[$p]".'new:'.join'.',split//,ir_escape($x,0));
 949                         #Irssi::print("assumed length after:".sb_length(ir_escape($x,0)));
 950                         $x = ir_escape($x);
 951                         #Irssi::print("[$p]".'REALnew:'.join'.',split//,sb_strip($x));
 952                         $actString->[$p] = $x;
 953                         # XXX any Irssi::print debug statement leads to SEGFAULT (sometimes) - why ?
 954                 }
 955         }
 956         #Irssi::print("remake [ $xx ] finished");
 957 }
 958
 959 sub awlHasChanged () {
 960         $globTime = undef;
 961         my $temp = ($SCREEN_MODE ?
 962                 "\\\n" . Irssi::settings_get_int(set 'block').
 963                 Irssi::settings_get_int(set 'height_adjust')
 964                 : "!\n" . Irssi::settings_get_str(set 'placement').
 965                 Irssi::settings_get_int(set 'position')).
 966                 Irssi::settings_get_str(set 'automode');
 967         if ($temp ne $resetNeeded) { wlreset(); return; }
 968         #Irssi::print("awl has changed, calls to remake so far: $callcount");
 969         $needRemake = 1;
 970
 971         #remake();
 972         if (
 973                 ($SCREEN_MODE and !$DISABLE_SCREEN_TEMP)
 974                         or
 975                 ($needRemake and Irssi::settings_get_bool(set 'all_disable'))
 976                         or
 977                 (!Irssi::settings_get_bool(set 'all_disable') and $currentLines < 1)
 978         ) {
 979                 $needRemake = undef;
 980                 remake();
 981         }
 982
 983         unless ($SCREEN_MODE) {
 984                 # XXX Irssi crashes if I try to do this without timer, why ? What's the minimum
 985                 # XXX delay I need to use in the timer ?
 986                 Irssi::timeout_add_once(100, 'syncLines', undef);
 987
 988                 for (keys %statusbars) {
 989                         Irssi::statusbar_items_redraw(set$_);
 990                 }
 991         }
 992         else {
 993                 Irssi::timeout_add_once(100, 'syncColumns', undef);
 994         }
 995 }
 996
 997 sub eventChanged () { # Implement a change queue/blocker -.-)
 998         if (defined $globTime) {
 999                 Irssi::timeout_remove($globTime);
1000         } # delay the update further
1001         $globTime = Irssi::timeout_add_once(GLOB_QUEUE_TIMER, 'awlHasChanged', undef);
1002 }
1003
1004 # }}}
1005
1006
1007 # {{{ screen mode
1008
1009 sub screenFullRedraw {
1010         my ($window) = @_;
1011         if (!ref $window or $window->{'refnum'} == Irssi::active_win->{'refnum'}) {
1012                 $actString = [];
1013                 eventChanged();
1014         }
1015 }
1016
1017 sub screenSize { # from nicklist.pl
1018         $screenResizing = 1;
1019         # fit screen
1020         system 'screen -x '.$ENV{'STY'}.' -X fit';
1021         # get size
1022         my ($row, $col) = split ' ', `stty size`;
1023         # set screen width
1024         $screenWidth = $col-1;
1025         $screenHeight = $row-1;
1026
1027         # on some recent systems, "screen -X fit; screen -X width -w 50" doesn't work, needs a sleep in between the 2 commands
1028         # so we wait a second before setting the width
1029         Irssi::timeout_add_once(100, sub {
1030                 my ($new_irssi_width) = @_;
1031                 $new_irssi_width -= abs(Irssi::settings_get_int(set
1032                                 'block'))*$currentColumns - 1;
1033                 system 'screen -x '.$ENV{'STY'}.' -X width -w ' . $new_irssi_width;
1034                 # and then we wait another second for the resizing, and then redraw.
1035                 Irssi::timeout_add_once(10,sub {$screenResizing = 0; screenFullRedraw()}, []);
1036         }, $screenWidth);
1037 }
1038
1039 sub screenOff {
1040         my ($unloadMode) = @_;
1041         Irssi::signal_remove('gui print text finished' => 'screenFullRedraw');
1042         Irssi::signal_remove('gui page scrolled' => 'screenFullRedraw');
1043         Irssi::signal_remove('window changed' => 'screenFullRedraw');
1044         Irssi::signal_remove('window changed automatic' => 'screenFullRedraw');
1045         if ($unloadMode) {
1046                 Irssi::signal_remove('terminal resized' => 'resizeTerm');
1047         }
1048         system 'screen -x '.$ENV{'STY'}.' -X fit';
1049 }
1050
1051 sub syncColumns {
1052         return if (@$actString == 0);
1053         my $temp = $currentColumns;
1054         #Irssi::print("current columns $temp");
1055         my $height = $screenHeight - abs(Irssi::settings_get_int(set
1056                         'height_adjust'));
1057         $currentColumns = int(($#$actString-1) / $height) + 1;
1058         #Irssi::print("objects in actstring:".scalar(@$actString).", screen height:".
1059         #       $height);
1060         my $currMaxColumns = Irssi::settings_get_int(set 'columns');
1061         if ($currMaxColumns > 0 and $currentColumns > $currMaxColumns) {
1062                 $currentColumns = $currMaxColumns;
1063         }
1064         elsif ($currMaxColumns < 0) {
1065                 $currentColumns = abs($currMaxColumns);
1066         }
1067         return if ($temp == $currentColumns);
1068         screenSize();
1069 }
1070
1071 #$needRemake = 1;
1072 sub resizeTerm () {
1073         if ($SCREEN_MODE and !$screenResizing) {
1074                 $screenResizing = 1;
1075                 Irssi::timeout_add_once(10, 'screenSize', undef);
1076         }
1077         Irssi::timeout_add_once(100, 'eventChanged', undef);
1078 }
1079
1080 # }}}
1081
1082
1083 # {{{ settings add
1084
1085 Irssi::settings_add_str(setc, set 'display_nokey', '[$N]$H$C$S');
1086 Irssi::settings_add_str(setc, set 'display_key', '[$Q=$N]$H$C$S');
1087 Irssi::settings_add_str(setc, set 'display_nokey_active', '');
1088 Irssi::settings_add_str(setc, set 'display_key_active', '');
1089 Irssi::settings_add_str(setc, set 'separator', "\\ ");
1090 Irssi::settings_add_bool(setc, set 'prefer_name', 0);
1091 Irssi::settings_add_int(setc, set 'hide_data', 0);
1092 Irssi::settings_add_int(setc, set 'maxlines', 9);
1093 Irssi::settings_add_int(setc, set 'columns', 1);
1094 Irssi::settings_add_int(setc, set 'block', 20);
1095 Irssi::settings_add_bool(setc, set 'sbar_maxlength', 0);
1096 Irssi::settings_add_int(setc, set 'height_adjust', 2);
1097 Irssi::settings_add_str(setc, set 'sort', 'refnum');
1098 Irssi::settings_add_str(setc, set 'placement', 'bottom');
1099 Irssi::settings_add_int(setc, set 'position', 0);
1100 Irssi::settings_add_bool(setc, set 'all_disable', 0);
1101 Irssi::settings_add_str(setc, set 'automode', 'sbar');
1102
1103 # }}}
1104
1105
1106 # {{{ init
1107
1108 sub wlreset {
1109         $actString = [];
1110         $currentLines = 0; # 1; # mhmmmm .. we actually enable one line down there so
1111                                 # let's try this.
1112         #update_keymap();
1113         killOldStatus();
1114         # Register statusbar
1115         #add_statusbar(0);
1116         #Irssi::command('statusbar wl0 enable');
1117         my $was_screen_mode = $SCREEN_MODE;
1118         if ($SCREEN_MODE = (Irssi::settings_get_str(set 'automode') =~ /screen/i)
1119                         and
1120                 !$was_screen_mode
1121         ) {
1122                 if (!defined $ENV{'STY'}) {
1123                         Irssi::print('Screen mode can only be used in GNU screen but no '.
1124                                 'screen was found.', MSGLEVEL_CLIENTERROR);
1125                         $SCREEN_MODE = undef;
1126                 }
1127                 else {
1128                         Irssi::signal_add_last('gui print text finished' => 'screenFullRedraw');
1129                         Irssi::signal_add_last('gui page scrolled' => 'screenFullRedraw');
1130                         Irssi::signal_add('window changed' => 'screenFullRedraw');
1131                         Irssi::signal_add('window changed automatic' => 'screenFullRedraw');
1132                 }
1133         }
1134         elsif ($was_screen_mode and !$SCREEN_MODE) {
1135                 screenOff();
1136         }
1137         $resetNeeded = ($SCREEN_MODE ?
1138                 "\\\n" . Irssi::settings_get_int(set 'block').
1139                 Irssi::settings_get_int(set 'height_adjust')
1140                 : "!\n" . Irssi::settings_get_str(set 'placement').
1141                 Irssi::settings_get_int(set 'position')).
1142                 Irssi::settings_get_str(set 'automode');
1143         resizeTerm();
1144 }
1145
1146 wlreset();
1147
1148 # }}}
1149
1150
1151 # {{{ unload/deinit
1152
1153 my $Unload;
1154 sub unload ($$$) {
1155         $Unload = 1;
1156         # pretend we didn't do anything ASAP
1157         Irssi::timeout_add_once(10, sub { $Unload = undef; }, undef);
1158 }
1159 # last try to catch a sigsegv
1160 Irssi::signal_add_first('gui exit' => sub { $Unload = undef; });
1161 sub UNLOAD {
1162         # this might well crash Irssi... try /eval /script unload someotherscript ;
1163         # /quit (= SEGFAULT !)
1164         if ($Unload) {
1165                 $actString = ['']; # syncLines(); # XXX Irssi crashes when trying to disable
1166                 killOldStatus();                  # XXX all statusbars ?
1167                 if ($SCREEN_MODE) {
1168                         screenOff('unload mode');
1169                 }
1170         }
1171 }
1172
1173 # }}}
1174
1175
1176 # {{{ signals
1177
1178 sub addPrintTextHook { # update on print text
1179         return if $_[0]->{'level'} == 262144 and $_[0]->{'target'} eq ''
1180                         and !defined($_[0]->{'server'});
1181         if (Irssi::settings_get_str(set 'sort') =~ /^[-!]?last_line$/) {
1182                 Irssi::timeout_add_once(100, 'eventChanged', undef);
1183         }
1184 }
1185
1186 #sub _x { my ($x, $y) = @_; ($x, sub { Irssi::print('-->signal '.$x); eval "$y();"; }) }
1187 #sub _x { @_ }
1188 Irssi::signal_add_first(
1189         'command script unload' => 'unload'
1190 );
1191 Irssi::signal_add_last({
1192         'setup changed' => 'eventChanged',
1193         'print text' => 'addPrintTextHook',
1194         'terminal resized' => 'resizeTerm',
1195         'setup reread' => 'wlreset',
1196         'window hilight' => 'eventChanged',
1197 });
1198 Irssi::signal_add({
1199         'window created' => 'eventChanged',
1200         'window destroyed' => 'eventChanged',
1201         'window name changed' => 'eventChanged',
1202         'window refnum changed' => 'eventChanged',
1203         'window changed' => 'eventChanged',
1204         'window changed automatic' => 'eventChanged',
1205 });
1206
1207 #Irssi::signal_add('nick mode changed', 'chanactHasChanged'); # relicts
1208
1209 # }}}
1210
1211 # {{{ commands
1212
1213
1214 sub runsub {
1215         my ($cmd) = @_;
1216         sub {
1217                 my ($data, $server, $item) = @_;
1218                 Irssi::command_runsub($cmd, $data, $server, $item);
1219         };
1220 }
1221 Irssi::command_bind( setc() => runsub(setc()) );
1222 Irssi::command_bind( setc() . ' paste' => runsub(setc() . ' paste') );
1223 Irssi::command_bind(
1224         setc() . ' paste on' => sub {
1225                 return unless $SCREEN_MODE;
1226                 my $was_disabled = $DISABLE_SCREEN_TEMP;
1227                 $DISABLE_SCREEN_TEMP = 1;
1228                 Irssi::print('Paste mode is now ON, '.uc(setc()).' is temporarily '.
1229                              'disabled.');
1230                 if (!$was_disabled) {
1231                         $screenResizing = 1;
1232                         screenOff();
1233                 }
1234         }
1235 );
1236 Irssi::command_bind(
1237         setc() . ' paste off' => sub {
1238                 return unless $SCREEN_MODE;
1239                 my $was_disabled = $DISABLE_SCREEN_TEMP;
1240                 $DISABLE_SCREEN_TEMP = undef;
1241                 Irssi::print('Paste mode is now OFF, '.uc(setc()).' is enabled.');
1242                 if ($was_disabled) {
1243                         $SCREEN_MODE = undef;
1244                         $screenResizing = 0;
1245                         wlreset();
1246                 }
1247         }
1248 );
1249 Irssi::command_bind(
1250         setc() . ' paste toggle' => sub {
1251                 if ($DISABLE_SCREEN_TEMP) {
1252                         Irssi::command(setc() . ' paste off');
1253                 }
1254                 else {
1255                         Irssi::command(setc() . ' paste on');
1256                 }
1257         }
1258 );
1259 Irssi::command_bind(
1260         setc() . ' redraw' => sub {
1261                 return unless $SCREEN_MODE;
1262                 screenFullRedraw();
1263         }
1264 );
1265
1266
1267 # }}}
1268
1269 # {{{ Algorithm::LCSS module
1270 {
1271         package Algorithm::Diff;
1272         # Skip to first "=head" line for documentation.
1273         use strict;
1274
1275         use integer;    # see below in _replaceNextLargerWith() for mod to make
1276                                                  # if you don't use this
1277
1278         # McIlroy-Hunt diff algorithm
1279         # Adapted from the Smalltalk code of Mario I. Wolczko, <mario@wolczko.com>
1280         # by Ned Konz, perl@bike-nomad.com
1281         # Updates by Tye McQueen, http://perlmonks.org/?node=tye
1282
1283         # Create a hash that maps each element of $aCollection to the set of
1284         # positions it occupies in $aCollection, restricted to the elements
1285         # within the range of indexes specified by $start and $end.
1286         # The fourth parameter is a subroutine reference that will be called to
1287         # generate a string to use as a key.
1288         # Additional parameters, if any, will be passed to this subroutine.
1289         #
1290         # my $hashRef = _withPositionsOfInInterval( \@array, $start, $end, $keyGen );
1291
1292         sub _withPositionsOfInInterval
1293         {
1294                  my $aCollection = shift;    # array ref
1295                  my $start       = shift;
1296                  my $end         = shift;
1297                  my $keyGen      = shift;
1298                  my %d;
1299                  my $index;
1300                  for ( $index = $start ; $index <= $end ; $index++ )
1301                  {
1302                           my $element = $aCollection->[$index];
1303                           my $key = &$keyGen( $element, @_ );
1304                           if ( exists( $d{$key} ) )
1305                           {
1306                                         unshift ( @{ $d{$key} }, $index );
1307                           }
1308                           else
1309                           {
1310                                         $d{$key} = [$index];
1311                           }
1312                  }
1313                  return wantarray ? %d : \%d;
1314         }
1315
1316         # Find the place at which aValue would normally be inserted into the
1317         # array. If that place is already occupied by aValue, do nothing, and
1318         # return undef. If the place does not exist (i.e., it is off the end of
1319         # the array), add it to the end, otherwise replace the element at that
1320         # point with aValue.  It is assumed that the array's values are numeric.
1321         # This is where the bulk (75%) of the time is spent in this module, so
1322         # try to make it fast!
1323
1324         sub _replaceNextLargerWith
1325         {
1326                  my ( $array, $aValue, $high ) = @_;
1327                  $high ||= $#$array;
1328
1329                  # off the end?
1330                  if ( $high == -1 || $aValue > $array->[-1] )
1331                  {
1332                           push ( @$array, $aValue );
1333                           return $high + 1;
1334                  }
1335
1336                  # binary search for insertion point...
1337                  my $low = 0;
1338                  my $index;
1339                  my $found;
1340                  while ( $low <= $high )
1341                  {
1342                           $index = ( $high + $low ) / 2;
1343
1344                           # $index = int(( $high + $low ) / 2);  # without 'use integer'
1345                           $found = $array->[$index];
1346
1347                           if ( $aValue == $found )
1348                           {
1349                                         return undef;
1350                           }
1351                           elsif ( $aValue > $found )
1352                           {
1353                                         $low = $index + 1;
1354                           }
1355                           else
1356                           {
1357                                         $high = $index - 1;
1358                           }
1359                  }
1360
1361                  # now insertion point is in $low.
1362                  $array->[$low] = $aValue;    # overwrite next larger
1363                  return $low;
1364         }
1365
1366         # This method computes the longest common subsequence in $a and $b.
1367
1368         # Result is array or ref, whose contents is such that
1369         #   $a->[ $i ] == $b->[ $result[ $i ] ]
1370         # foreach $i in ( 0 .. $#result ) if $result[ $i ] is defined.
1371
1372         # An additional argument may be passed; this is a hash or key generating
1373         # function that should return a string that uniquely identifies the given
1374         # element.  It should be the case that if the key is the same, the elements
1375         # will compare the same. If this parameter is undef or missing, the key
1376         # will be the element as a string.
1377
1378         # By default, comparisons will use "eq" and elements will be turned into keys
1379         # using the default stringizing operator '""'.
1380
1381         # Additional parameters, if any, will be passed to the key generation
1382         # routine.
1383
1384         sub _longestCommonSubsequence
1385         {
1386                  my $a        = shift;    # array ref or hash ref
1387                  my $b        = shift;    # array ref or hash ref
1388                  my $counting = shift;    # scalar
1389                  my $keyGen   = shift;    # code ref
1390                  my $compare;             # code ref
1391
1392                  if ( ref($a) eq 'HASH' )
1393                  {                        # prepared hash must be in $b
1394                           my $tmp = $b;
1395                           $b = $a;
1396                           $a = $tmp;
1397                  }
1398
1399                  # Check for bogus (non-ref) argument values
1400                  if ( !ref($a) || !ref($b) )
1401                  {
1402                           my @callerInfo = caller(1);
1403                           die 'error: must pass array or hash references to ' . $callerInfo[3];
1404                  }
1405
1406                  # set up code refs
1407                  # Note that these are optimized.
1408                  if ( !defined($keyGen) )    # optimize for strings
1409                  {
1410                           $keyGen = sub { $_[0] };
1411                           $compare = sub { my ( $a, $b ) = @_; $a eq $b };
1412                  }
1413                  else
1414                  {
1415                           $compare = sub {
1416                                         my $a = shift;
1417                                         my $b = shift;
1418                                         &$keyGen( $a, @_ ) eq &$keyGen( $b, @_ );
1419                           };
1420                  }
1421
1422                  my ( $aStart, $aFinish, $matchVector ) = ( 0, $#$a, [] );
1423                  my ( $prunedCount, $bMatches ) = ( 0, {} );
1424
1425                  if ( ref($b) eq 'HASH' )    # was $bMatches prepared for us?
1426                  {
1427                           $bMatches = $b;
1428                  }
1429                  else
1430                  {
1431                           my ( $bStart, $bFinish ) = ( 0, $#$b );
1432
1433                           # First we prune off any common elements at the beginning
1434                           while ( $aStart <= $aFinish
1435                                         and $bStart <= $bFinish
1436                                         and &$compare( $a->[$aStart], $b->[$bStart], @_ ) )
1437                           {
1438                                         $matchVector->[ $aStart++ ] = $bStart++;
1439                                         $prunedCount++;
1440                           }
1441
1442                           # now the end
1443                           while ( $aStart <= $aFinish
1444                                         and $bStart <= $bFinish
1445                                         and &$compare( $a->[$aFinish], $b->[$bFinish], @_ ) )
1446                           {
1447                                         $matchVector->[ $aFinish-- ] = $bFinish--;
1448                                         $prunedCount++;
1449                           }
1450
1451                           # Now compute the equivalence classes of positions of elements
1452                           $bMatches =
1453                                  _withPositionsOfInInterval( $b, $bStart, $bFinish, $keyGen, @_ );
1454                  }
1455                  my $thresh = [];
1456                  my $links  = [];
1457
1458                  my ( $i, $ai, $j, $k );
1459                  for ( $i = $aStart ; $i <= $aFinish ; $i++ )
1460                  {
1461                           $ai = &$keyGen( $a->[$i], @_ );
1462                           if ( exists( $bMatches->{$ai} ) )
1463                           {
1464                                         $k = 0;
1465                                         for $j ( @{ $bMatches->{$ai} } )
1466                                         {
1467
1468                                                  # optimization: most of the time this will be true
1469                                                  if ( $k and $thresh->[$k] > $j and $thresh->[ $k - 1 ] < $j )
1470                                                  {
1471                                                           $thresh->[$k] = $j;
1472                                                  }
1473                                                  else
1474                                                  {
1475                                                           $k = _replaceNextLargerWith( $thresh, $j, $k );
1476                                                  }
1477
1478                                                  # oddly, it's faster to always test this (CPU cache?).
1479                                                  if ( defined($k) )
1480                                                  {
1481                                                           $links->[$k] =
1482                                                                  [ ( $k ? $links->[ $k - 1 ] : undef ), $i, $j ];
1483                                                  }
1484                                         }
1485                           }
1486                  }
1487
1488                  if (@$thresh)
1489                  {
1490                           return $prunedCount + @$thresh if $counting;
1491                           for ( my $link = $links->[$#$thresh] ; $link ; $link = $link->[0] )
1492                           {
1493                                         $matchVector->[ $link->[1] ] = $link->[2];
1494                           }
1495                  }
1496                  elsif ($counting)
1497                  {
1498                           return $prunedCount;
1499                  }
1500
1501                  return wantarray ? @$matchVector : $matchVector;
1502         }
1503
1504         sub traverse_sequences
1505         {
1506                  my $a                 = shift;          # array ref
1507                  my $b                 = shift;          # array ref
1508                  my $callbacks         = shift || {};
1509                  my $keyGen            = shift;
1510                  my $matchCallback     = $callbacks->{'MATCH'} || sub { };
1511                  my $discardACallback  = $callbacks->{'DISCARD_A'} || sub { };
1512                  my $finishedACallback = $callbacks->{'A_FINISHED'};
1513                  my $discardBCallback  = $callbacks->{'DISCARD_B'} || sub { };
1514                  my $finishedBCallback = $callbacks->{'B_FINISHED'};
1515                  my $matchVector = _longestCommonSubsequence( $a, $b, 0, $keyGen, @_ );
1516
1517                  # Process all the lines in @$matchVector
1518                  my $lastA = $#$a;
1519                  my $lastB = $#$b;
1520                  my $bi    = 0;
1521                  my $ai;
1522
1523                  for ( $ai = 0 ; $ai <= $#$matchVector ; $ai++ )
1524                  {
1525                           my $bLine = $matchVector->[$ai];
1526                           if ( defined($bLine) )    # matched
1527                           {
1528                                         &$discardBCallback( $ai, $bi++, @_ ) while $bi < $bLine;
1529                                         &$matchCallback( $ai,    $bi++, @_ );
1530                           }
1531                           else
1532                           {
1533                                         &$discardACallback( $ai, $bi, @_ );
1534                           }
1535                  }
1536
1537                  # The last entry (if any) processed was a match.
1538                  # $ai and $bi point just past the last matching lines in their sequences.
1539
1540                  while ( $ai <= $lastA or $bi <= $lastB )
1541                  {
1542
1543                           # last A?
1544                           if ( $ai == $lastA + 1 and $bi <= $lastB )
1545                           {
1546                                         if ( defined($finishedACallback) )
1547                                         {
1548                                                  &$finishedACallback( $lastA, @_ );
1549                                                  $finishedACallback = undef;
1550                                         }
1551                                         else
1552                                         {
1553                                                  &$discardBCallback( $ai, $bi++, @_ ) while $bi <= $lastB;
1554                                         }
1555                           }
1556
1557                           # last B?
1558                           if ( $bi == $lastB + 1 and $ai <= $lastA )
1559                           {
1560                                         if ( defined($finishedBCallback) )
1561                                         {
1562                                                  &$finishedBCallback( $lastB, @_ );
1563                                                  $finishedBCallback = undef;
1564                                         }
1565                                         else
1566                                         {
1567                                                  &$discardACallback( $ai++, $bi, @_ ) while $ai <= $lastA;
1568                                         }
1569                           }
1570
1571                           &$discardACallback( $ai++, $bi, @_ ) if $ai <= $lastA;
1572                           &$discardBCallback( $ai, $bi++, @_ ) if $bi <= $lastB;
1573                  }
1574
1575                  return 1;
1576         }
1577
1578         sub traverse_balanced
1579         {
1580                  my $a                 = shift;              # array ref
1581                  my $b                 = shift;              # array ref
1582                  my $callbacks         = shift || {};
1583                  my $keyGen            = shift;
1584                  my $matchCallback     = $callbacks->{'MATCH'} || sub { };
1585                  my $discardACallback  = $callbacks->{'DISCARD_A'} || sub { };
1586                  my $discardBCallback  = $callbacks->{'DISCARD_B'} || sub { };
1587                  my $changeCallback    = $callbacks->{'CHANGE'};
1588                  my $matchVector = _longestCommonSubsequence( $a, $b, 0, $keyGen, @_ );
1589
1590                  # Process all the lines in match vector
1591                  my $lastA = $#$a;
1592                  my $lastB = $#$b;
1593                  my $bi    = 0;
1594                  my $ai    = 0;
1595                  my $ma    = -1;
1596                  my $mb;
1597
1598                  while (1)
1599                  {
1600
1601                           # Find next match indices $ma and $mb
1602                           do {
1603                                         $ma++;
1604                           } while(
1605                                                  $ma <= $#$matchVector
1606                                         &&  !defined $matchVector->[$ma]
1607                           );
1608
1609                           last if $ma > $#$matchVector;    # end of matchVector?
1610                           $mb = $matchVector->[$ma];
1611
1612                           # Proceed with discard a/b or change events until
1613                           # next match
1614                           while ( $ai < $ma || $bi < $mb )
1615                           {
1616
1617                                         if ( $ai < $ma && $bi < $mb )
1618                                         {
1619
1620                                                  # Change
1621                                                  if ( defined $changeCallback )
1622                                                  {
1623                                                           &$changeCallback( $ai++, $bi++, @_ );
1624                                                  }
1625                                                  else
1626                                                  {
1627                                                           &$discardACallback( $ai++, $bi, @_ );
1628                                                           &$discardBCallback( $ai, $bi++, @_ );
1629                                                  }
1630                                         }
1631                                         elsif ( $ai < $ma )
1632                                         {
1633                                                  &$discardACallback( $ai++, $bi, @_ );
1634                                         }
1635                                         else
1636                                         {
1637
1638                                                  # $bi < $mb
1639                                                  &$discardBCallback( $ai, $bi++, @_ );
1640                                         }
1641                           }
1642
1643                           # Match
1644                           &$matchCallback( $ai++, $bi++, @_ );
1645                  }
1646
1647                  while ( $ai <= $lastA || $bi <= $lastB )
1648                  {
1649                           if ( $ai <= $lastA && $bi <= $lastB )
1650                           {
1651
1652                                         # Change
1653                                         if ( defined $changeCallback )
1654                                         {
1655                                                  &$changeCallback( $ai++, $bi++, @_ );
1656                                         }
1657                                         else
1658                                         {
1659                                                  &$discardACallback( $ai++, $bi, @_ );
1660                                                  &$discardBCallback( $ai, $bi++, @_ );
1661                                         }
1662                           }
1663                           elsif ( $ai <= $lastA )
1664                           {
1665                                         &$discardACallback( $ai++, $bi, @_ );
1666                           }
1667                           else
1668                           {
1669
1670                                         # $bi <= $lastB
1671                                         &$discardBCallback( $ai, $bi++, @_ );
1672                           }
1673                  }
1674
1675                  return 1;
1676         }
1677
1678         sub prepare
1679         {
1680                  my $a       = shift;    # array ref
1681                  my $keyGen  = shift;    # code ref
1682
1683                  # set up code ref
1684                  $keyGen = sub { $_[0] } unless defined($keyGen);
1685
1686                  return scalar _withPositionsOfInInterval( $a, 0, $#$a, $keyGen, @_ );
1687         }
1688
1689         sub LCS
1690         {
1691                  my $a = shift;                  # array ref
1692                  my $b = shift;                  # array ref or hash ref
1693                  my $matchVector = _longestCommonSubsequence( $a, $b, 0, @_ );
1694                  my @retval;
1695                  my $i;
1696                  for ( $i = 0 ; $i <= $#$matchVector ; $i++ )
1697                  {
1698                           if ( defined( $matchVector->[$i] ) )
1699                           {
1700                                         push ( @retval, $a->[$i] );
1701                           }
1702                  }
1703                  return wantarray ? @retval : \@retval;
1704         }
1705
1706         sub LCS_length
1707         {
1708                  my $a = shift;                          # array ref
1709                  my $b = shift;                          # array ref or hash ref
1710                  return _longestCommonSubsequence( $a, $b, 1, @_ );
1711         }
1712
1713         sub LCSidx
1714         {
1715                  my $a= shift @_;
1716                  my $b= shift @_;
1717                  my $match= _longestCommonSubsequence( $a, $b, 0, @_ );
1718                  my @am= grep defined $match->[$_], 0..$#$match;
1719                  my @bm= @{$match}[@am];
1720                  return \@am, \@bm;
1721         }
1722
1723         sub compact_diff
1724         {
1725                  my $a= shift @_;
1726                  my $b= shift @_;
1727                  my( $am, $bm )= LCSidx( $a, $b, @_ );
1728                  my @cdiff;
1729                  my( $ai, $bi )= ( 0, 0 );
1730                  push @cdiff, $ai, $bi;
1731                  while( 1 ) {
1732                           while(  @$am  &&  $ai == $am->[0]  &&  $bi == $bm->[0]  ) {
1733                                         shift @$am;
1734                                         shift @$bm;
1735                                         ++$ai, ++$bi;
1736                           }
1737                           push @cdiff, $ai, $bi;
1738                           last   if  ! @$am;
1739                           $ai = $am->[0];
1740                           $bi = $bm->[0];
1741                           push @cdiff, $ai, $bi;
1742                  }
1743                  push @cdiff, 0+@$a, 0+@$b
1744                           if  $ai < @$a || $bi < @$b;
1745                  return wantarray ? @cdiff : \@cdiff;
1746         }
1747
1748         sub diff
1749         {
1750                  my $a      = shift;    # array ref
1751                  my $b      = shift;    # array ref
1752                  my $retval = [];
1753                  my $hunk   = [];
1754                  my $discard = sub {
1755                           push @$hunk, [ '-', $_[0], $a->[ $_[0] ] ];
1756                  };
1757                  my $add = sub {
1758                           push @$hunk, [ '+', $_[1], $b->[ $_[1] ] ];
1759                  };
1760                  my $match = sub {
1761                           push @$retval, $hunk
1762                                         if 0 < @$hunk;
1763                           $hunk = []
1764                  };
1765                  traverse_sequences( $a, $b,
1766                           { MATCH => $match, DISCARD_A => $discard, DISCARD_B => $add }, @_ );
1767                  &$match();
1768                  return wantarray ? @$retval : $retval;
1769         }
1770
1771         sub sdiff
1772         {
1773                  my $a      = shift;    # array ref
1774                  my $b      = shift;    # array ref
1775                  my $retval = [];
1776                  my $discard = sub { push ( @$retval, [ '-', $a->[ $_[0] ], "" ] ) };
1777                  my $add = sub { push ( @$retval, [ '+', "", $b->[ $_[1] ] ] ) };
1778                  my $change = sub {
1779                           push ( @$retval, [ 'c', $a->[ $_[0] ], $b->[ $_[1] ] ] );
1780                  };
1781                  my $match = sub {
1782                           push ( @$retval, [ 'u', $a->[ $_[0] ], $b->[ $_[1] ] ] );
1783                  };
1784                  traverse_balanced(
1785                           $a,
1786                           $b,
1787                           {
1788                                         MATCH     => $match,
1789                                         DISCARD_A => $discard,
1790                                         DISCARD_B => $add,
1791                                         CHANGE    => $change,
1792                           },
1793                           @_
1794                  );
1795                  return wantarray ? @$retval : $retval;
1796         }
1797
1798         ########################################
1799         my $Root= __PACKAGE__;
1800         package Algorithm::Diff::_impl;
1801         use strict;
1802
1803         sub _Idx()  { 0 } # $me->[_Idx]: Ref to array of hunk indices
1804                                         # 1   # $me->[1]: Ref to first sequence
1805                                         # 2   # $me->[2]: Ref to second sequence
1806         sub _End()  { 3 } # $me->[_End]: Diff between forward and reverse pos
1807         sub _Same() { 4 } # $me->[_Same]: 1 if pos 1 contains unchanged items
1808         sub _Base() { 5 } # $me->[_Base]: Added to range's min and max
1809         sub _Pos()  { 6 } # $me->[_Pos]: Which hunk is currently selected
1810         sub _Off()  { 7 } # $me->[_Off]: Offset into _Idx for current position
1811         sub _Min() { -2 } # Added to _Off to get min instead of max+1
1812
1813         sub Die
1814         {
1815                  require Carp;
1816                  Carp::confess( @_ );
1817         }
1818
1819         sub _ChkPos
1820         {
1821                  my( $me )= @_;
1822                  return   if  $me->[_Pos];
1823                  my $meth= ( caller(1) )[3];
1824                  Die( "Called $meth on 'reset' object" );
1825         }
1826
1827         sub _ChkSeq
1828         {
1829                  my( $me, $seq )= @_;
1830                  return $seq + $me->[_Off]
1831                           if  1 == $seq  ||  2 == $seq;
1832                  my $meth= ( caller(1) )[3];
1833                  Die( "$meth: Invalid sequence number ($seq); must be 1 or 2" );
1834         }
1835
1836         sub getObjPkg
1837         {
1838                  my( $us )= @_;
1839                  return ref $us   if  ref $us;
1840                  return $us . "::_obj";
1841         }
1842
1843         sub new
1844         {
1845                  my( $us, $seq1, $seq2, $opts ) = @_;
1846                  my @args;
1847                  for( $opts->{keyGen} ) {
1848                           push @args, $_   if  $_;
1849                  }
1850                  for( $opts->{keyGenArgs} ) {
1851                           push @args, @$_   if  $_;
1852                  }
1853                  my $cdif= Algorithm::Diff::compact_diff( $seq1, $seq2, @args );
1854                  my $same= 1;
1855                  if(  0 == $cdif->[2]  &&  0 == $cdif->[3]  ) {
1856                           $same= 0;
1857                           splice @$cdif, 0, 2;
1858                  }
1859                  my @obj= ( $cdif, $seq1, $seq2 );
1860                  $obj[_End] = (1+@$cdif)/2;
1861                  $obj[_Same] = $same;
1862                  $obj[_Base] = 0;
1863                  my $me = bless \@obj, $us->getObjPkg();
1864                  $me->Reset( 0 );
1865                  return $me;
1866         }
1867
1868         sub Reset
1869         {
1870                  my( $me, $pos )= @_;
1871                  $pos= int( $pos || 0 );
1872                  $pos += $me->[_End]
1873                           if  $pos < 0;
1874                  $pos= 0
1875                           if  $pos < 0  ||  $me->[_End] <= $pos;
1876                  $me->[_Pos]= $pos || !1;
1877                  $me->[_Off]= 2*$pos - 1;
1878                  return $me;
1879         }
1880
1881         sub Base
1882         {
1883                  my( $me, $base )= @_;
1884                  my $oldBase= $me->[_Base];
1885                  $me->[_Base]= 0+$base   if  defined $base;
1886                  return $oldBase;
1887         }
1888
1889         sub Copy
1890         {
1891                  my( $me, $pos, $base )= @_;
1892                  my @obj= @$me;
1893                  my $you= bless \@obj, ref($me);
1894                  $you->Reset( $pos )   if  defined $pos;
1895                  $you->Base( $base );
1896                  return $you;
1897         }
1898
1899         sub Next {
1900                  my( $me, $steps )= @_;
1901                  $steps= 1   if  ! defined $steps;
1902                  if( $steps ) {
1903                           my $pos= $me->[_Pos];
1904                           my $new= $pos + $steps;
1905                           $new= 0   if  $pos  &&  $new < 0;
1906                           $me->Reset( $new )
1907                  }
1908                  return $me->[_Pos];
1909         }
1910
1911         sub Prev {
1912                  my( $me, $steps )= @_;
1913                  $steps= 1   if  ! defined $steps;
1914                  my $pos= $me->Next(-$steps);
1915                  $pos -= $me->[_End]   if  $pos;
1916                  return $pos;
1917         }
1918
1919         sub Diff {
1920                  my( $me )= @_;
1921                  $me->_ChkPos();
1922                  return 0   if  $me->[_Same] == ( 1 & $me->[_Pos] );
1923                  my $ret= 0;
1924                  my $off= $me->[_Off];
1925                  for my $seq ( 1, 2 ) {
1926                           $ret |= $seq
1927                                         if  $me->[_Idx][ $off + $seq + _Min ]
1928                                         <   $me->[_Idx][ $off + $seq ];
1929                  }
1930                  return $ret;
1931         }
1932
1933         sub Min {
1934                  my( $me, $seq, $base )= @_;
1935                  $me->_ChkPos();
1936                  my $off= $me->_ChkSeq($seq);
1937                  $base= $me->[_Base] if !defined $base;
1938                  return $base + $me->[_Idx][ $off + _Min ];
1939         }
1940
1941         sub Max {
1942                  my( $me, $seq, $base )= @_;
1943                  $me->_ChkPos();
1944                  my $off= $me->_ChkSeq($seq);
1945                  $base= $me->[_Base] if !defined $base;
1946                  return $base + $me->[_Idx][ $off ] -1;
1947         }
1948
1949         sub Range {
1950                  my( $me, $seq, $base )= @_;
1951                  $me->_ChkPos();
1952                  my $off = $me->_ChkSeq($seq);
1953                  if( !wantarray ) {
1954                           return  $me->[_Idx][ $off ]
1955                                         -   $me->[_Idx][ $off + _Min ];
1956                  }
1957                  $base= $me->[_Base] if !defined $base;
1958                  return  ( $base + $me->[_Idx][ $off + _Min ] )
1959                           ..  ( $base + $me->[_Idx][ $off ] - 1 );
1960         }
1961
1962         sub Items {
1963                  my( $me, $seq )= @_;
1964                  $me->_ChkPos();
1965                  my $off = $me->_ChkSeq($seq);
1966                  if( !wantarray ) {
1967                           return  $me->[_Idx][ $off ]
1968                                         -   $me->[_Idx][ $off + _Min ];
1969                  }
1970                  return
1971                           @{$me->[$seq]}[
1972                                                  $me->[_Idx][ $off + _Min ]
1973                                         ..  ( $me->[_Idx][ $off ] - 1 )
1974                           ];
1975         }
1976
1977         sub Same {
1978                  my( $me )= @_;
1979                  $me->_ChkPos();
1980                  return wantarray ? () : 0
1981                           if  $me->[_Same] != ( 1 & $me->[_Pos] );
1982                  return $me->Items(1);
1983         }
1984
1985         my %getName;
1986                  %getName= (
1987                           same => \&Same,
1988                           diff => \&Diff,
1989                           base => \&Base,
1990                           min  => \&Min,
1991                           max  => \&Max,
1992                           range=> \&Range,
1993                           items=> \&Items, # same thing
1994                  );
1995
1996         sub Get
1997         {
1998                  my $me= shift @_;
1999                  $me->_ChkPos();
2000                  my @value;
2001                  for my $arg (  @_  ) {
2002                           for my $word (  split ' ', $arg  ) {
2003                                         my $meth;
2004                                         if(     $word !~ /^(-?\d+)?([a-zA-Z]+)([12])?$/
2005                                                  ||  not  $meth= $getName{ lc $2 }
2006                                         ) {
2007                                                  Die( $Root, ", Get: Invalid request ($word)" );
2008                                         }
2009                                         my( $base, $name, $seq )= ( $1, $2, $3 );
2010                                         push @value, scalar(
2011                                                  4 == length($name)
2012                                                           ? $meth->( $me )
2013                                                           : $meth->( $me, $seq, $base )
2014                                         );
2015                           }
2016                  }
2017                  if(  wantarray  ) {
2018                           return @value;
2019                  } elsif(  1 == @value  ) {
2020                           return $value[0];
2021                  }
2022                  Die( 0+@value, " values requested from ",
2023                           $Root, "'s Get in scalar context" );
2024         }
2025
2026
2027         my $Obj= getObjPkg($Root);
2028         no strict 'refs';
2029
2030         for my $meth (  qw( new getObjPkg )  ) {
2031                  *{$Root."::".$meth} = \&{$meth};
2032                  *{$Obj ."::".$meth} = \&{$meth};
2033         }
2034         for my $meth (  qw(
2035                  Next Prev Reset Copy Base Diff
2036                  Same Items Range Min Max Get
2037                  _ChkPos _ChkSeq
2038         )  ) {
2039                  *{$Obj."::".$meth} = \&{$meth};
2040         }
2041
2042 };
2043 {
2044         package Algorithm::LCSS;
2045
2046         use strict;
2047         {
2048                 no strict 'refs';
2049                 *traverse_sequences = \&Algorithm::Diff::traverse_sequences;
2050         }
2051
2052         sub _tokenize { [split //, $_[0]] }
2053
2054         sub CSS {
2055                  my $is_array = ref $_[0] eq 'ARRAY' ? 1 : 0;
2056                  my ( $seq1, $seq2, @match, $from_match );
2057                  my $i = 0;
2058                  if ( $is_array ) {
2059                           $seq1 = $_[0];
2060                           $seq2 = $_[1];
2061                           traverse_sequences( $seq1, $seq2, {
2062                                         MATCH => sub { push @{$match[$i]}, $seq1->[$_[0]]; $from_match = 1 },
2063                                         DISCARD_A => sub { do{$i++; $from_match = 0} if $from_match },
2064                                         DISCARD_B => sub { do{$i++; $from_match = 0} if $from_match },
2065                           });
2066                  }
2067                  else {
2068                           $seq1 = _tokenize($_[0]);
2069                           $seq2 = _tokenize($_[1]);
2070                           traverse_sequences( $seq1, $seq2, {
2071                                         MATCH => sub { $match[$i] .= $seq1->[$_[0]]; $from_match = 1 },
2072                                         DISCARD_A => sub { do{$i++; $from_match = 0} if $from_match },
2073                                         DISCARD_B => sub { do{$i++; $from_match = 0} if $from_match },
2074                           });
2075                  }
2076           return \@match;
2077         }
2078
2079         sub CSS_Sorted {
2080                  my $match = CSS(@_);
2081                  if ( ref $_[0] eq 'ARRAY' ) {
2082                          @$match = map{$_->[0]}sort{$b->[1]<=>$a->[1]}map{[$_,scalar(@$_)]}@$match
2083                  }
2084                  else {
2085                          @$match = map{$_->[0]}sort{$b->[1]<=>$a->[1]}map{[$_,length($_)]}@$match
2086                  }
2087           return $match;
2088         }
2089
2090         sub LCSS {
2091                  my $is_array = ref $_[0] eq 'ARRAY' ? 1 : 0;
2092                  my $css = CSS(@_);
2093                  my $index;
2094                  my $length = 0;
2095                  if ( $is_array ) {
2096                           for( my $i = 0; $i < @$css; $i++ ) {
2097                                         next unless @{$css->[$i]}>$length;
2098                                         $index = $i;
2099                                         $length = @{$css->[$i]};
2100                           }
2101                  }
2102                  else {
2103                           for( my $i = 0; $i < @$css; $i++ ) {
2104                                         next unless length($css->[$i])>$length;
2105                                         $index = $i;
2106                                         $length = length($css->[$i]);
2107                           }
2108                  }
2109           return $css->[$index];
2110         }
2111
2112 };
2113 # }}}
2114 #{{{ Class::Classless module
2115 {
2116         package Class::Classless;
2117         use strict;
2118         use vars qw(@ISA);
2119         use Carp;
2120
2121         @ISA = ();
2122
2123         ###########################################################################
2124
2125         @Class::Classless::X::ISA = ();
2126
2127         ###########################################################################
2128         ###########################################################################
2129
2130         sub Class::Classless::X::AUTOLOAD {
2131           # This's the big dispatcher.
2132
2133           my $it = shift @_;
2134           my $m =  ($Class::Classless::X::AUTOLOAD =~ m/([^:]+)$/s )
2135                                          ? $1 : $Class::Classless::X::AUTOLOAD;
2136
2137           croak "Can't call Class::Classless methods (like $m) without an object"
2138                  unless ref $it;  # sanity, basically.
2139
2140           my $prevstate;
2141           $prevstate = ${shift @_}
2142                 if scalar(@_) && defined($_[0]) &&
2143                         ref($_[0]) eq 'Class::Classless::CALLSTATE::SHIMMY'
2144           ;   # A shim!  we were called via $callstate->NEXT
2145
2146           my $no_fail = $prevstate ? $prevstate->[3] : undef;
2147           my $i       = $prevstate ? ($prevstate->[1] + 1) : 0;
2148                 # where to start scanning
2149           my $lineage;
2150
2151           # Get the linearization of the ISA tree
2152           if($prevstate) {
2153                  $lineage = $prevstate->[2];
2154           } elsif(defined $it->{'ISA_CACHE'} and ref $it->{'ISA_CACHE'} ){
2155                  $lineage = $it->{'ISA_CACHE'};
2156           } else {
2157                  $lineage = [ &Class::Classless::X::ISA_TREE($it) ];
2158           }
2159
2160           # Was:
2161           #my @lineage =
2162           #  $prevstate ? @{$prevstate->[2]}
2163           #             : &Class::Classless::X::ISA_TREE($it);
2164           # # Get the linearization of the ISA tree
2165           # # ISA-memoization happens in the ISA_TREE function.
2166
2167           for(; $i < @$lineage; ++$i) {
2168
2169                  if( !defined($no_fail) and exists($lineage->[$i]{'NO_FAIL'}) ) {
2170                         $no_fail = ($lineage->[$i]{'NO_FAIL'} || 0);
2171                         # so the first NO_FAIL sets it
2172                  }
2173
2174                  if(     ref($lineage->[$i]{'METHODS'}     || 0)  # sanity
2175                         && exists($lineage->[$i]{'METHODS'}{$m})
2176                  ){
2177                         # We found what we were after.  Now see what to do with it.
2178                         my $v = $lineage->[$i]{'METHODS'}{$m};
2179                         return $v unless defined $v and ref $v;
2180
2181                         if(ref($v) eq 'CODE') { # normal case, I expect!
2182                           # Used to have copying of the arglist here.
2183                           #  But it was apparently useless, so I deleted it
2184                           unshift @_,
2185                                  $it,                   # $_[0]    -- target object
2186                                  # a NEW callstate
2187                                  bless([$m, $i, $lineage, $no_fail, $prevstate ? 1 : 0],
2188                                                  'Class::Classless::CALLSTATE'
2189                                                 ),                # $_[1]    -- the callstate
2190                           ;
2191                           goto &{ $v }; # yes, magic goto!  bimskalabim!
2192                         }
2193                         return @$v if ref($v) eq '_deref_array';
2194                         return $$v if ref($v) eq '_deref_scalar';
2195                         return $v; # fallthru
2196                  }
2197           }
2198
2199           if($m eq 'DESTROY') { # mitigate DESTROY-lookup failure at global destruction
2200                  # should be impossible
2201           } else {
2202                  if($no_fail || 0) {
2203                         return;
2204                  }
2205                  croak "Can't find ", $prevstate ? 'NEXT method' : 'method',
2206                                  " $m in ", $it->{'NAME'} || $it,
2207                                  " or any ancestors\n";
2208           }
2209         }
2210
2211         ###########################################################################
2212         ###########################################################################
2213
2214         sub Class::Classless::X::DESTROY {
2215           # noop
2216         }
2217
2218         ###########################################################################
2219         sub Class::Classless::X::ISA_TREE {
2220           # The linearizer!
2221           # Returns the search path for $_[0], starting with $_[0]
2222           # Possibly memoized.
2223
2224           # I stopped being able to understand this algorithm about five
2225           #  minutes after I wrote it.
2226           use strict;
2227
2228           my $set_cache = 0; # flag to set the cache on the way out
2229
2230           if(exists($_[0]{'ISA_CACHE'})) {
2231                  return    @{$_[0]{'ISA_CACHE'}}
2232                   if defined $_[0]{'ISA_CACHE'}
2233                           and ref $_[0]{'ISA_CACHE'};
2234
2235                  # Otherwise, if exists but is not a ref, it's a signal that it should
2236                  #  be replaced at the earliest, with a listref
2237                  $set_cache = 1;
2238           }
2239
2240           my $has_mi = 0; # set to 0 on the first node we see with 2 parents!
2241           # First, just figure out what's in the tree.
2242           my %last_child = ($_[0] => 1); # as if already seen
2243
2244           # if $last_child{$x} == $y, that means:
2245           #  1) incidentally, we've passed the node $x before.
2246           #  2) $x is the last child of $y,
2247           #     so that means that $y can be pushed to the stack only after
2248           #      we've pushed $x to the stack.
2249
2250           my @tree_nodes;
2251           {
2252                  my $current;
2253                  my @in_stack = ($_[0]);
2254                  while(@in_stack) {
2255                         next unless
2256                          defined($current = shift @in_stack)
2257                          && ref($current) # sanity
2258                          && ref($current->{'PARENTS'} || 0) # sanity
2259                         ;
2260
2261                         push @tree_nodes, $current;
2262
2263                         $has_mi = 1 if @{$current->{'PARENTS'}} > 1;
2264                         unshift
2265                           @in_stack,
2266                           map {
2267                                  if(exists $last_child{$_}) { # seen before!
2268                                         $last_child{$_} = $current;
2269                                         (); # seen -- don't re-explore
2270                                  } else { # first time seen
2271                                         $last_child{$_} = $current;
2272                                         $_; # first time seen -- explore now
2273                                  }
2274                           }
2275                           @{$current->{'PARENTS'}}
2276                         ;
2277                  }
2278
2279                  # If there was no MI, then that first scan was sufficient.
2280                  unless($has_mi) {
2281                         $_[0]{'ISA_CACHE'} = \@tree_nodes if $set_cache;
2282                         return @tree_nodes;
2283                  }
2284
2285                  # Otherwise, toss this list and rescan, consulting %last_child
2286           }
2287
2288           # $last_child{$parent} holds the last (or only) child of $parent
2289           # in this tree.  When walking the tree this time, only that
2290           # child is authorized to put its parent on the @in_stack.
2291           # And that's the only way a node can get added to @in_stack,
2292           # except for $_[0] (the start node) being there at the beginning.
2293
2294           # Now, walk again, but this time exploring parents the LAST
2295           # time seen in the tree, not the first.
2296
2297           my @out;
2298           {
2299                  my $current;
2300                  my @in_stack = ($_[0]);
2301                  while(@in_stack) {
2302                         next unless defined($current = shift @in_stack) && ref($current);
2303                         push @out, $current; # finally.
2304                         unshift
2305                           @in_stack,
2306                           grep(
2307                                  (
2308                                         defined($_) # sanity
2309                                         && ref($_)  # sanity
2310                                         && $last_child{$_} eq $current,
2311                                  ),
2312                                  # I'm lastborn (or onlyborn) of this parent
2313                                  # so it's OK to explore now
2314                                  @{$current->{'PARENTS'}}
2315                           )
2316                          if ref($current->{'PARENTS'} || 0) # sanity
2317                         ;
2318                  }
2319
2320                  unless(scalar(@out) == scalar(keys(%last_child))) {
2321                         # the counts should be equal
2322                         my %good_ones;
2323                         @good_ones{@out} = ();
2324                         croak
2325                           "ISA tree for " .
2326                           ($_[0]{'NAME'} || $_[0]) .
2327                           " is apparently cyclic, probably involving the nodes " .
2328                           nodelist( grep { ref($_) && !exists $good_ones{$_} }
2329                                  values(%last_child) )
2330                           . "\n";
2331                  }
2332           }
2333           #print "Contents of out: ", nodelist(@out), "\n";
2334
2335           $_[0]{'ISA_CACHE'} = \@out if $set_cache;
2336           return @out;
2337         }
2338
2339         ###########################################################################
2340
2341         sub Class::Classless::X::can { # NOT like UNIVERSAL::can ...
2342           # return 1 if $it is capable of the method given -- otherwise 0
2343           my($it, $m) = @_[0,1];
2344           return undef unless ref $it;
2345
2346           croak "undef is not a valid method name"       unless defined($m);
2347           croak "null-string is not a valid method name" unless length($m);
2348
2349           foreach my $o (&Class::Classless::X::ISA_TREE($it)) {
2350                  return 1
2351                   if  ref($o->{'METHODS'} || 0)   # sanity
2352                         && exists $o->{'METHODS'}{$m};
2353           }
2354
2355           return 0;
2356         }
2357
2358
2359         ###########################################################################
2360
2361         sub Class::Classless::X::isa { # Like UNIVERSAL::isa
2362           # Returns true for $X->isa($Y) iff $Y is $X or is an ancestor of $X.
2363
2364           return unless ref($_[0]) && ref($_[1]);
2365           return scalar(grep {$_ eq $_[1]} &Class::Classless::X::ISA_TREE($_[0]));
2366         }
2367
2368         ###########################################################################
2369
2370         sub nodelist { join ', ', map { "" . ($_->{'NAME'} || $_) . ""} @_ }
2371
2372         ###########################################################################
2373         ###########################################################################
2374         ###########################################################################
2375         # Methods for the CALLSTATE class.
2376         #  Basically, CALLSTATE objects represent the state of the dispatcher,
2377         #   frozen at the moment when the method call was dispatched to the
2378         #   appropriate sub.
2379         #  In the grand scheme of things, this needn't be a class -- I could
2380         #   have just made the callstate data-object be a hash with documented
2381         #   keys, or a closure that responded to only certain parameters,
2382         #   etc.  But I like it this way.  And I like being able to say simply
2383         #   $cs->NEXT
2384         #  Yes, these are a bit cryptically written, but it's behoovy for
2385         #   them to be very very efficient.
2386
2387         @Class::Classless::ISA = ();
2388         sub Class::Classless::CALLSTATE::found_name { $_[0][0] }
2389                 #  the method name called and found
2390         sub Class::Classless::CALLSTATE::found_depth { $_[0][1] }
2391                 #  my depth in the lineage
2392         sub Class::Classless::CALLSTATE::lineage { @{$_[0][2]} }
2393                 #  my lineage
2394         sub Class::Classless::CALLSTATE::target { $_[0][2][  0          ] }
2395                 #  the object that's the target -- same as $_[0] for the method called
2396         sub Class::Classless::CALLSTATE::home   { $_[0][2][  $_[0][1]   ] }
2397                 #  the object I was found in
2398         sub Class::Classless::CALLSTATE::sub_found {
2399           $_[0][2][  $_[0][1]   ]{'METHODS'}{ $_[0][0] }
2400         }  #  the routine called
2401
2402         sub Class::Classless::CALLSTATE::no_fail          {  $_[0][3]         }
2403         sub Class::Classless::CALLSTATE::set_no_fail_true {  $_[0][3] = 1     }
2404         sub Class::Classless::CALLSTATE::set_fail_false   {  $_[0][3] = 0     }
2405         sub Class::Classless::CALLSTATE::set_fail_undef   {  $_[0][3] = undef }
2406
2407         sub Class::Classless::CALLSTATE::via_next         {  $_[0][4] }
2408
2409         sub Class::Classless::CALLSTATE::NEXT {
2410           #croak "NEXT needs at least one argument: \$cs->NEXT('method'...)"
2411           # unless @_ > 1;
2412                 # no longer true.
2413           my $cs = shift @_;
2414           my $m  = shift @_; # which may be (or come out) undef...
2415           $m = $cs->[0] unless defined $m; #  the method name called and found
2416
2417           ($cs->[2][0])->$m(
2418                  bless( \$cs, 'Class::Classless::CALLSTATE::SHIMMY' ),
2419                  @_
2420           );
2421         }
2422
2423         ###########################################################################
2424 };
2425 #}}}
2426
2427 ###############
2428 ###
2429 #
2430 # {{{ *** C h a n g e l o g ***
2431 #
2432 # 0.6ca
2433 # - add screen support (from nicklist.pl)
2434 # - rename to adv_windowlist.pl (advanced window list) since it isn't just a
2435 #   window list status bar (wlstat) anymore
2436 # - names can now have a max length and window names can be used
2437 # - fixed a bug with block display in screen mode and statusbar mode
2438 # - added space handling to ir_fe and removed it again
2439 # - now handling formats on my own
2440 # - added warning about missing sb_act_none abstract leading to
2441 # - display*active settings
2442 # - added warning about the bug in awl_display_(no)key_active settings
2443 #
2444 # 0.5d
2445 # - add setting to also hide the last statusbar if empty (awl_all_disable)
2446 # - reverted to old utf8 code to also calculate broken utf8 length correctly
2447 # - simplified dealing with statusbars in wlreset
2448 # - added a little tweak for the renamed term_type somewhere after Irssi 0.8.9
2449 # - fixed bug in handling channel #$$
2450 # - typo on line 200 spotted by f0rked
2451 # - reset background colour at the beginning of an entry
2452 #
2453 # 0.4d
2454 # - fixed order of disabling statusbars
2455 # - several attempts at special chars, without any real success
2456 #   and much more weird new bugs caused by this
2457 # - setting to specify sort order
2458 # - reduced timeout values
2459 # - added awl_hide_data for Geert Hauwaerts ( geert@irssi.org ) :)
2460 # - make it so the dynamic sub is actually deleted
2461 # - fix a bug with removing of the last separator
2462 # - take into consideration parse_special
2463 #
2464 # 0.3b
2465 # - automatically kill old statusbars
2466 # - reset on /reload
2467 # - position/placement settings
2468 #
2469 # 0.2
2470 # - automated retrieval of key bindings (thanks grep.pl authors)
2471 # - improved removing of statusbars
2472 # - got rid of status chop
2473 #
2474 # 0.1
2475 # - rewritten to suit my needs
2476 # - based on chanact 0.5.5
2477 # }}}
2478 # vim: se fdm=marker tw=80 :