|
148
|
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([email protected], [email protected], [email protected], ).
|
|
|
36 q([email protected], [email protected]),
|
|
|
37 authors => q(Nei),
|
|
|
38 contact => q(Nei @ [email protected]),
|
|
|
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 [email protected]
|
|
|
63 # #
|
|
|
64 # # inspired by chanlist.pl by '[email protected]'
|
|
|
65 # #
|
|
|
66 # #########
|
|
|
67 # # {{{ Contributors
|
|
|
68 # #########
|
|
|
69 # #
|
|
|
70 # # [email protected] /window_alias code
|
|
|
71 # # [email protected] chanact_abbreviate_names
|
|
|
72 # # [email protected] 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 ( [email protected] ) 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 =^.^= ( [email protected] )
|
|
|
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, <[email protected]>
|
|
|
1280 # by Ned Konz, [email protected]
|
|
|
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 ( [email protected] ) :)
|
|
|
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 :
|
