]> git.sthu.org Git - shutils.git/blob - dotfiles/irssi/scripts/adv_windowlist.pl
projects / shutils.git / blob
summary | shortlog | log | commit | commitdiff | tree
history | raw | HEAD
vim: add color scheme
[shutils.git] / 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 :
A collection of homebrewn tools.