File Coverage

blib/lib/Term/Clui.pm
Criterion Covered Total %
statement 9 1110 0.8
branch 2 594 0.3
condition 0 183 0.0
subroutine 4 59 6.7
pod 14 55 25.4
total 29 2001 1.4


line stmt bran cond sub pod time code
1             # Term::Clui.pm
2             #########################################################################
3             # This Perl module is Copyright (c) 2002, Peter J Billam #
4             # c/o P J B Computing, www.pjb.com.au #
5             # #
6             # This module is free software; you can redistribute it and/or #
7             # modify it under the same terms as Perl itself. #
8             #########################################################################
9              
10             package Term::Clui;
11             our $VERSION = '1.76';
12             my $stupid_bloody_warning = $VERSION; # circumvent -w warning
13             require Exporter;
14             @ISA = qw(Exporter);
15             @EXPORT = qw(ask ask_password ask_filename confirm
16             choose help_text edit sorry view inform);
17             @EXPORT_OK = qw(beep tiview back_up get_default set_default timestamp);
18             %EXPORT_TAGS = (ALL => [@EXPORT,@EXPORT_OK]);
19              
20 1     1   649 use 5.006;
  1         3  
21 1     1   4 no strict; no warnings;
  1     1   2  
  1         17  
  1         3  
  1         2  
  1         9794  
22              
23             my $have_Term_ReadKey = 1;
24             my $have_Term_Size = 0;
25             eval 'require "Term/ReadKey.pm"';
26             if ($@) {
27             $have_Term_ReadKey = 0;
28             $have_Term_Size = 1;
29             eval 'require "Term/Size.pm"';
30             if ($@) { $have_Term_Size = 0; }
31             }
32              
33             my $Eflite;
34             my $Eflite_FH; # open here at top-level so one sub can silence the previous
35             my $Espeak;
36             my $Espeak_PID; # defined at top-level so one espeak can kill the previous
37             my $SpeakUpSilentFile; # 1.62
38             if ($ENV{'CLUI_SPEAK'}) { # 1.62 emacspeak not very relevant as a criterion
39             for my $d ('/sys/accessibility', '/proc') {
40             if (-w "$d/speakup/silent") {
41             $SpeakUpSilentFile = "$d/speakup/silent"; break;
42             }
43             }
44             $Eflite = &which('eflite');
45             $Espeak = &which('espeak');
46             if ($Eflite && !$Espeak) { # 1.68 Espeak should be the default
47             if (open($Eflite_FH,'|-',$Eflite)) {
48             select((select($Eflite_FH), $| = 1)[0]); print $Eflite_FH q{};
49             } else {
50             warn "can't run $Eflite: $!\n";
51             }
52             } elsif (! $Espeak) {
53             warn("Term::Clui warning: CLUI_SPEAK set; "
54             . "but can't find eflite or espeak\n");
55             }
56             }
57              
58              
59             # use open ':locale'; # the open pragma was introduced in 5.8.6
60             my $EncodingString = q{};
61             if (($ENV{LANG} =~ /utf-?8/i) || ($ENV{LC_TYPE} =~ /utf-?8/i)) {
62             $EncodingString = ':encoding(utf8)';
63             }
64              
65             # ------------------------ vt100 stuff -------------------------
66              
67             $A_NORMAL = 0;
68             $A_BOLD = 1;
69             $A_UNDERLINE = 2;
70             $A_REVERSE = 4;
71             $KEY_UP = 0403;
72             $KEY_LEFT = 0404;
73             $KEY_RIGHT = 0405;
74             $KEY_DOWN = 0402;
75             $KEY_ENTER = "\r";
76             $KEY_INSERT = 0525;
77             $KEY_DELETE = 0524;
78             $KEY_HOME = 0523;
79             $KEY_END = 0522;
80             $KEY_PPAGE = 0521;
81             $KEY_NPAGE = 0520;
82             $KEY_BTAB = 0541;
83             my $AbsCursX = 0; my $AbsCursY = 0; my $TopRow = 0; my $CursorRow;
84             my $LastEventWasPress = 0; # in order to ignore left-over button-ups
85             my %SpecialKey = map { $_, 1 } ( # 1.51, used by ask to ignore these
86             $KEY_UP, $KEY_LEFT, $KEY_RIGHT, $KEY_DOWN, $KEY_HOME, $KEY_END,
87             $KEY_PPAGE, $KEY_NPAGE, $KEY_BTAB, $KEY_INSERT, $KEY_DELETE
88             );
89              
90             my $irow; my $icol; # maintained by &puts, &up, &down, &left and &right
91 0     0 0   sub puts { my $s = join q{}, @_;
92 0           $irow += ($s =~ tr/\n/\n/);
93 0 0         if ($s =~ /\r\n?$/) { $icol = 0;
  0            
94 0           } else { $icol += length($s);
95             }
96 0           print TTY $s;
97             }
98             # could terminfo sgr0, bold, rev, cub1, cuu1, cuf1, cud1 ...
99 0     0 0   sub attrset { my $attr = $_[0];
100 0 0         if (! $attr) {
101 0           print TTY "\e[0m";
102             } else {
103 0 0         if ($attr & $A_BOLD) { print TTY "\e[1m" };
  0            
104 0 0         if ($attr & $A_REVERSE) { print TTY "\e[7m" };
  0            
105 0 0         if ($attr & $A_UNDERLINE) { print TTY "\e[4m" };
  0            
106             }
107             }
108 0     0 1   sub beep { print TTY "\07"; }
109 0     0 0   sub clear { print TTY "\e[H\e[J"; }
110 0     0 0   sub clrtoeol { print TTY "\e[K"; }
111 0     0 0   sub black { print TTY "\e[30m"; }
112 0     0 0   sub red { print TTY "\e[31m"; }
113 0     0 0   sub green { print TTY "\e[32m"; }
114 0     0 0   sub blue { print TTY "\e[34m"; }
115 0     0 0   sub violet { print TTY "\e[35m"; }
116              
117 0     0 0   sub getc_wrapper { my $timeout = 0 + $_[0];
118 0 0         if ($have_Term_ReadKey) {
119 0           return Term::ReadKey::ReadKey($timeout, *TTYIN);
120             } else {
121             #if ($timeout > 0.00001) { # doesn't seem to work on openbsd...
122             # my $rin = q{};
123             # vec($rin,fileno(TTYIN),1) = 1;
124             # my $nfound = select($rin, undef, undef, $timeout);
125             # if (!$nfound) { return undef; }
126             #}
127 0           return getc(TTYIN);
128             }
129             }
130              
131             sub getch {
132 0     0 0   my $c = getc_wrapper(0);
133 0 0         if ($c eq "\e") {
134 0           $c = getc_wrapper(0.10);
135              
136 0 0         if (! defined $c) { return("\e"); }
  0            
137 0 0         if ($c eq 'A') { return($KEY_UP); }
  0            
138 0 0         if ($c eq 'B') { return($KEY_DOWN); }
  0            
139 0 0         if ($c eq 'C') { return($KEY_RIGHT); }
  0            
140 0 0         if ($c eq 'D') { return($KEY_LEFT); }
  0            
141 0 0         if ($c eq '2') { getc_wrapper(0); return($KEY_INSERT); }
  0            
  0            
142 0 0         if ($c eq '3') { getc_wrapper(0); return($KEY_DELETE); } # 1.54
  0            
  0            
143 0 0         if ($c eq '5') { getc_wrapper(0); return($KEY_PPAGE); }
  0            
  0            
144 0 0         if ($c eq '6') { getc_wrapper(0); return($KEY_NPAGE); }
  0            
  0            
145 0 0         if ($c eq 'Z') { return($KEY_BTAB); }
  0            
146 0 0         if ($c eq 'O') { # 1.68 Haiku wierdness, inherited from an old Suse
147 0           $c = getc_wrapper(0);
148 0 0         if ($c eq 'A') { return($KEY_UP); } # 1.68
  0            
149 0 0         if ($c eq 'B') { return($KEY_DOWN); } # 1.68
  0            
150 0 0         if ($c eq 'C') { return($KEY_RIGHT); } # 1.68
  0            
151 0 0         if ($c eq 'D') { return($KEY_LEFT); } # 1.68
  0            
152 0 0         if ($c eq 'F') { return($KEY_END); } # 1.68
  0            
153 0 0         if ($c eq 'H') { return($KEY_HOME); } # 1.68
  0            
154 0           return($c);
155             }
156 0 0         if ($c eq '[') {
157 0           $c = getc_wrapper(0);
158 0 0         if ($c eq 'A') { return($KEY_UP); }
  0            
159 0 0         if ($c eq 'B') { return($KEY_DOWN); }
  0            
160 0 0         if ($c eq 'C') { return($KEY_RIGHT); }
  0            
161 0 0         if ($c eq 'D') { return($KEY_LEFT); }
  0            
162 0 0         if ($c eq 'F') { return($KEY_END); } # 1.67
  0            
163 0 0         if ($c eq 'H') { return($KEY_HOME); } # 1.67
  0            
164 0 0         if ($c eq 'M') { # mouse report - we must be in BYTES !
165             # http://invisible-island.net/xterm/ctlseqs/ctlseqs.html
166 0           my $event_type = ord(getc_wrapper(0))-32;
167 0           my $x = ord(getc_wrapper(0))-32;
168 0           my $y = ord(getc_wrapper(0))-32;
169             # my $shift = $event_type & 0x04; # used by wm
170             # my $meta = $event_type & 0x08; # used by wm
171             # my $control = $event_type & 0x10; # used by xterm
172 0           my $button_drag = ($event_type & 0x20) >> 5;
173 0           my $button_pressed;
174 0           my $low3bits = $event_type & 0x03;
175 0 0         if ($low3bits == 0x03) {
176 0           $button_pressed = 0;
177             } else { # button 4 means wheel-up, button 5 means wheel-down
178 0 0         if ($event_type & 0x40) { $button_pressed = $low3bits + 4;
  0            
179 0           } else { $button_pressed = $low3bits + 1;
180             }
181             }
182 0   0       return handle_mouse($x,$y,$button_pressed,$button_drag)
183             || getch();
184             }
185 0 0         if ($c =~ /\d/) { my $c1 = getc_wrapper(0);
  0            
186 0 0         if ($c1 eq '~') {
187 0 0         if ($c eq '2') { return($KEY_INSERT);
  0 0          
    0          
    0          
188 0           } elsif ($c eq '3') { return($KEY_DELETE);
189 0           } elsif ($c eq '5') { return($KEY_PPAGE);
190 0           } elsif ($c eq '6') { return($KEY_NPAGE);
191             }
192             } else { # cursor-position report, response to \e[6n
193 0           $AbsCursY = 0 + $c;
194 0           while (1) {
195 0 0         last if $c1 eq ';';
196 0           $AbsCursY = 10*$AbsCursY + $c1;
197             # debug("c1=$c1 AbsCursY=$AbsCursY");
198 0           $c1 = getc(TTYIN);
199             }
200 0           $AbsCursX = 0;
201 0           while (1) {
202 0           $c1 = getc(TTYIN);
203 0 0         last if $c1 eq 'R';
204 0           $AbsCursX = 10*$AbsCursX + $c1;
205             }
206 0           return getch();
207             }
208             }
209 0 0         if ($c eq 'Z') { return($KEY_BTAB); }
  0            
210 0           return($c);
211             }
212 0           return($c);
213             #} elsif ($c eq ord(0217)) { # 1.50 BUG what?? never gets here...
214             # $c = getc_wrapper(0);
215             # if ($c eq 'A') { return($KEY_UP); }
216             # if ($c eq 'B') { return($KEY_DOWN); }
217             # if ($c eq 'C') { return($KEY_RIGHT); }
218             # if ($c eq 'D') { return($KEY_LEFT); }
219             # return($c);
220             #} elsif ($c eq ord(0233)) { # 1.50 BUG what?? never gets here...
221             # $c = getc_wrapper(0);
222             # if ($c eq 'A') { return($KEY_UP); }
223             # if ($c eq 'B') { return($KEY_DOWN); }
224             # if ($c eq 'C') { return($KEY_RIGHT); }
225             # if ($c eq 'D') { return($KEY_LEFT); }
226             # if ($c eq '5') { getc_wrapper(0); return($KEY_PPAGE); }
227             # if ($c eq '6') { getc_wrapper(0); return($KEY_NPAGE); }
228             # if ($c eq 'Z') { return($KEY_BTAB); }
229             # return($c);
230             } else {
231 0           return($c);
232             }
233             }
234             sub up {
235             # if ($_[0] < 0) { &down(0 - $_[0]); return; }
236 0     0 0   print TTY "\e[A" x $_[0]; $irow -= $_[0];
  0            
237             }
238             sub down {
239             # if ($_[0] < 0) { &up(0 - $_[0]); return; }
240 0     0 0   print TTY "\n" x $_[0]; $irow += $_[0];
  0            
241             }
242             sub right {
243             # if ($_[0] < 0) { &left(0 - $_[0]); return; }
244 0     0 0   print TTY "\e[C" x $_[0]; $icol += $_[0];
  0            
245             }
246             sub left {
247             # if ($_[0] < 0) { &right(0 - $_[0]); return; }
248 0     0 0   print TTY "\e[D" x $_[0]; $icol -= $_[0];
  0            
249             }
250 0     0 0   sub goto { my $newcol = shift; my $newrow = shift;
  0            
251 0 0         if ($newcol == 0) { print TTY "\r" ; $icol = 0;
  0 0          
  0 0          
252 0           } elsif ($newcol > $icol) { &right($newcol-$icol);
253 0           } elsif ($newcol < $icol) { &left($icol-$newcol);
254             }
255 0 0         if ($newrow > $irow) { &down($newrow-$irow);
  0 0          
256 0           } elsif ($newrow < $irow) { &up($irow-$newrow);
257             }
258             }
259             # sub move { my ($ix,$iy) = @_; printf TTY "\e[%d;%dH",$iy+1,$ix+1; }
260              
261             my $InitscrAlreadyRun = 0;
262             my $IsMouseMode = 0;
263             my $WasMouseMode = 0;
264             my $IsSpeakUpSilent = 0; # 1.62
265             my $WasSpeakUpSilent = 0; # 1.62
266             my $Stty = q{};
267              
268             sub enter_mouse_mode { # 1.50
269 0 0   0 0   if ($ENV{'CLUI_MOUSE'} eq 'OFF') { return 0; } # 1.62
  0            
270 0 0         if ($IsMouseMode) {
271 0           warn "enter_mouse_mode but already IsMouseMode\r\n"; return 1 ;
  0            
272             }
273 0 0         if ($EncodingString) {
274 0           close TTYIN;
275 0 0         open(TTYIN, "<:bytes", '/dev/tty')
276             || (warn "Can't read /dev/tty: $!\n", return 0);
277             }
278 0           print TTY "\e[?1003h"; # sets SET_ANY_EVENT_MOUSE mode
279 0           $IsMouseMode = 1;
280 0           return 1;
281             }
282             sub leave_mouse_mode { # 1.50
283             # if ($ENV{'CLUI_MOUSE'} =~ /off/i) { return 0; } # 1.62
284 0 0   0 0   if (!$IsMouseMode) {
285 0           warn "leave_mouse_mode but not IsMouseMode\r\n"; return 1 ;
  0            
286             }
287 0 0         if ($EncodingString) {
288 0           close TTYIN;
289 0 0         open(TTYIN, "<$EncodingString", '/dev/tty')
290             || (warn "Can't read /dev/tty: $!\n", return 0);
291             }
292 0           print TTY "\e[?1003l"; # cancels SET_ANY_EVENT_MOUSE mode
293 0           $IsMouseMode = 0;
294 0           return 1;
295             }
296              
297             sub enter_speakup_silent { # 1.62
298             # echo 7 > /sys/accessibility/speakup/silent if it exists
299 0 0   0 0   if (!$SpeakUpSilentFile) { return 0; }
  0            
300 0 0         if ($IsSpeakUpSilent) {
301 0           warn "enter_speakup_silent but already IsSpeakUpSilent\r\n"; return 1 ;
  0            
302             }
303 0 0         if (open(S, '>', $SpeakUpSilentFile)) { print S "7\n"; close S; }
  0            
  0            
304 0           $IsSpeakUpSilent = 1;
305 0           return 1;
306             }
307             sub leave_speakup_silent { # 1.62
308             # echo 4 > /sys/accessibility/speakup/silent if it exists
309 0 0   0 0   if (!$SpeakUpSilentFile) { return 0; }
  0            
310 0 0         if (!$IsSpeakUpSilent) {
311 0           warn "leave_speakup_silent but not IsSpeakUpSilent\r\n"; return 1 ;
  0            
312             }
313 0 0         if (open(S, '>', $SpeakUpSilentFile)) { print S "4\n"; close S; }
  0            
  0            
314 0           $IsSpeakUpSilent = 0;
315 0           return 1;
316             }
317              
318 0     0 0   sub initscr { my %args = @_;
319 0           my $mouse_mode = $args{'mouse_mode'}; # for mouse-handling
320 0 0         if ($ENV{'CLUI_MOUSE'} eq 'OFF') { $mouse_mode = undef; } # 1.62
  0            
321 0           my $speakup_silent = $args{'speakup_silent'}; # to silence SpeakUp
322 0 0         if ($InitscrAlreadyRun) {
323 0           $InitscrAlreadyRun++;
324 0 0 0       if (!$mouse_mode and $IsMouseMode) {
    0 0        
325 0 0         leave_mouse_mode() or return 0;
326             } elsif ($mouse_mode and !$IsMouseMode) {
327 0 0         enter_mouse_mode() or return 0;
328             }
329 0           $WasMouseMode = $IsMouseMode;
330 0 0 0       if (!$speakup_silent and $IsSpeakUpSilent) { # 1.62
    0 0        
331 0 0         leave_speakup_silent() or return 0;
332             } elsif ($speakup_silent and !$IsSpeakUpSilent) {
333 0 0         enter_speakup_silent() or return 0;
334             }
335 0           $WasSpeakUpSilent = $IsSpeakUpSilent;
336 0           $icol = 0; $irow = 0;
  0            
337 0           return;
338             }
339 0 0         open(TTY, ">$EncodingString", '/dev/tty') # 1.43
340             || (warn "Can't write /dev/tty: $!\n", return 0);
341 0 0         if (!$have_Term_ReadKey) { $Stty = `stty -g`; chop $Stty; }
  0            
  0            
342 0           my $encoding_string;
343 0 0         if ($mouse_mode) {
344 0           $IsMouseMode = 1; $encoding_string = ':bytes';
  0            
345 0           print TTY "\e[?1003h"; # sets SET_ANY_EVENT_MOUSE mode
346             } else {
347 0           $IsMouseMode = 0; $encoding_string = $EncodingString;
  0            
348             }
349 0 0 0       if ($speakup_silent and !$IsSpeakUpSilent) { enter_speakup_silent(); }
  0            
350 0 0         open(TTYIN, "<$encoding_string", '/dev/tty')
351             || (warn "Can't read /dev/tty: $!\n", return 0);
352              
353 0 0         if ($have_Term_ReadKey) {
354 0           Term::ReadKey::ReadMode('ultra-raw', *TTYIN);
355             } else {
356 0 0         if ($^O =~ /^FreeBSD$/i) { system("stty -echo -icrnl raw
  0            
357 0           } else { system("stty -echo -icrnl raw /dev/tty");
358             }
359             }
360 0           select((select(TTY), $| = 1)[0]); print TTY q{};
  0            
361 0           $rin = q{}; vec($rin, fileno(TTYIN), 1) = 1;
  0            
362 0           $icol = 0; $irow = 0; $InitscrAlreadyRun = 1;
  0            
  0            
363             }
364              
365             sub endwin {
366 0     0 0   print TTY "\e[0m";
367 0 0         if ($InitscrAlreadyRun > 1) {
368 0 0 0       if ($IsMouseMode and !$WasMouseMode) { leave_mouse_mode();
  0 0 0        
369 0           } elsif (!$IsMouseMode and $WasMouseMode) { enter_mouse_mode();
370             }
371 0 0 0       if ($IsSpeakUpSilent and !$WasSpeakUpSilent) { # 1.62
    0 0        
372 0           leave_speakup_silent();
373             } elsif (!$IsSpeakUpSilent and $WasSpeakUpSilent) {
374 0           enter_speakup_silent();
375             }
376 0           $InitscrAlreadyRun--; return;
  0            
377             }
378 0           print TTY "\e[?1003l"; $IsMouseMode = 0;
  0            
379 0 0         if ($IsSpeakUpSilent) { leave_speakup_silent(); }
  0            
380 0 0         if ($have_Term_ReadKey) {
381 0           Term::ReadKey::ReadMode('restore', *TTYIN);
382 0           close TTY; close TTYIN;
  0            
383             } else {
384 0           close TTY; close TTYIN;
  0            
385 0 0         if ($^O =~ /^FreeBSD$/i) { system("stty $Stty
  0 0          
386 0 0         } else { system("stty $Stty /dev/tty") if $Stty;
387             }
388             }
389 0           $InitscrAlreadyRun = 0;
390             }
391              
392             # ----------------------- size handling ----------------------
393              
394             my ($maxcols, $maxrows); my $size_changed = 1;
395             my @OtherLines; # 20131002 $otherlines, $notherlines no longer global
396              
397             sub check_size {
398 0 0   0 0   if (! $size_changed) { return; }
  0            
399 0 0         if ($have_Term_ReadKey) {
    0          
400 0           ($maxcols, $maxrows) = Term::ReadKey::GetTerminalSize(*STDERR);
401             } elsif ($have_Term_Size) {
402 0           ($maxcols, $maxrows) = Term::Size::chars(*STDERR);
403             } else {
404 0           $maxcols = `tput cols`;
405 0   0       $maxrows = (`tput lines` + 0) || (`tput rows` + 0);
406             }
407 0   0       $maxcols = $maxcols || 80; $maxcols--;
  0            
408 0   0       $maxrows = $maxrows || 24;
409 0 0         if (@OtherLines) {
410 0           @OtherLines = &fmt(join("\n",@OtherLines));
411             }
412 0           $size_changed = 0;
413             }
414             $SIG{'WINCH'} = sub { $size_changed = 1; };
415              
416             # ------------------------ ask stuff -------------------------
417              
418             # Options such as integer, real, positive, >x, >=x,
419             # non-null, max-length, min-length, silent ...
420             # default could be just one more option, and backward compatibilty
421             # could be preserved by checking whether the 2nd arg is a hashref ...
422              
423 0     0 1   sub ask_filename { my ($question, $default) = @_; # 1.65 tab-completion
424 0 0         eval 'require Term::ReadLine'; if ($@) {
  0            
425 0           sorry("you should install Term::ReadLine::Gnu from www.cpan.org");
426 0           return ask($question, $default);
427             }
428 0           initscr(speakup_silent=>1);
429 0           endwin();
430 0           $term = Term::ReadLine->new('ProgramName');
431 0           my $filename = $term->readline($question.' '); # 1.70
432 0           print STDERR "\e[J";
433 0           $filename =~ s/ $//; # 1.66
434 0           return $filename;
435             }
436             sub ask_password { # no echo - use for passwords
437 0     0 1   local ($silent) = 'yes'; &ask($_[0]);
  0            
438             }
439 0     0 1   sub ask { my ($question, $default) = @_;
440 0 0         return q{} unless $question;
441 0           &initscr(speakup_silent=>1);
442 0           my $nol = &display_question($question);
443              
444 0           my $i = 0; my $n = 0; my @s = (); # cursor position, length, string
  0            
  0            
445 0 0         if (defined $default) { # 1.69 defined, to include 0
446 0           &speak("$question, default is $default");
447 0           $default =~ s/\t/ /g;
448 0           @s = split(q{}, $default); $n = scalar @s; $i = 0;
  0            
  0            
449 0           foreach $j (0 .. $#s) { &puts($s[$j]); }
  0            
450 0           &left($n);
451             } else {
452 0           &speak($question);
453             }
454              
455 0           while (1) {
456 0           my $c = &getch();
457 0 0         if ($c eq "\r") { &erase_lines(1); last; }
  0            
  0            
458 0 0         if ($size_changed) {
459 0           &erase_lines(0); $nol = &display_question($question);
  0            
460             }
461 0 0 0       if ($c == $KEY_LEFT) {
    0 0        
    0 0        
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
    0          
462 0 0         if ($i > 0) { $i--; &left(1); } # 1.44
  0            
  0            
463             } elsif ($c == $KEY_RIGHT) {
464 0 0         if ($i < $n) { &puts($silent ? "x" : $s[$i]); $i++; }
  0 0          
  0            
465             } elsif ($c == $KEY_DELETE) { # 1.54
466 0 0         if ($i < $n) {
467 0           $n--; splice(@s, $i, 1);
  0            
468 0 0         foreach $j ($i..$#s) { &puts($silent ? "x" : $s[$j]); } # 1.67
  0            
469 0           &clrtoeol(); &left($n-$i);
  0            
470             }
471             } elsif (($c eq "\cH") || ($c eq "\c?")) {
472 0 0         if ($i > 0) {
473 0           $n--; $i--;
  0            
474 0 0         if (! $silent) { &speak($s[$i]); } # 1.63
  0            
475 0           splice(@s, $i, 1); &left(1);
  0            
476 0 0         foreach $j ($i..$#s) { &puts($silent ? "x" : $s[$j]); } # 1.67
  0            
477 0           &clrtoeol(); &left($n-$i);
  0            
478             }
479             } elsif ($c eq "\cC") { # 1.56
480 0           &erase_lines(1); &endwin();
  0            
481 0           warn "^C\n"; kill('INT', $$); return undef;
  0            
  0            
482             } elsif ($c eq "\cX" || $c eq "\cD") { # clear ...
483 0           &left($i); $i = 0; $n = 0; &clrtoeol(); @s = ();
  0            
  0            
  0            
  0            
484 0           } elsif ($c eq "\cA" || $c == $KEY_HOME) { &left($i); $i = 0;
  0            
485 0           } elsif ($c eq "\cE" || $c == $KEY_END) { &right($n-$i); $i = $n;
  0            
486 0           } elsif ($c eq "\cL") { &speak(join("", @s)); # redraw ...
487 0           } elsif ($SpecialKey{$c}) { &beep();
488             } elsif (ord($c) >= 32) { # 1.51
489 0           splice(@s, $i, 0, $c);
490 0 0         &puts($silent ? "x" : $c);
491 0 0         if (! $silent) { &speak($c); }
  0            
492 0           $n++; $i++;
  0            
493 0 0         foreach $j ($i..$#s) { &puts($silent ? "x" : $s[$j]); } # 1.67
  0            
494 0           &clrtoeol(); &left($n-$i);
  0            
495 0           } else { &beep();
496             }
497             }
498 0           &speak(join("", @s), 'wait');
499 0           &endwin(); $silent = q{}; return join("", @s);
  0            
  0            
500             }
501              
502             # ----------------------- choose stuff -------------------------
503             sub debug {
504 0 0   0 0   if (! open (DEBUG, '>>/tmp/clui.log')) {
505 0           warn "can't open /tmp/clui.log: $!\n"; return;
  0            
506             }
507 0           print DEBUG "$_[0]\n"; close DEBUG;
  0            
508             }
509              
510             my (%irow, %icol, $nrows, $clue_has_been_given, $choice, $this_cell);
511             my @marked;
512             my $HOME = $ENV{'HOME'} || $ENV{'LOGDIR'} || (getpwuid($<))[7];
513             srand(time() ^ ($$+($$<15)));
514              
515 0     0 1   sub choose { my $question = shift; local @list = @_; # @list must be local
  0            
516             # As from 1.22, allows multiple choice if called in array context
517              
518 0 0         return unless @list;
519 0   0       grep (($_ =~ s/[\r\n]+$//) && 0, @list); # chop final newlines
520 0           my @biglist = @list; my $icell; @marked = ();
  0            
  0            
521              
522 0           $question =~ s/^[\n\r]+//; # strip initial newline(s)
523 0           $question =~ s/[\n\r]+$//; # strip final newline(s)
524 0           my ($firstline,$otherlines) = split(/\r?\n/, $question, 2);
525 0           my $firstlinelength = length $firstline;
526              
527 0           $choice = &get_default($firstline);
528             # If wantarray ? Is remembering multiple choices safe ?
529              
530 0           &initscr(mouse_mode=>1, speakup_silent=>1);
531 0           &size_and_layout(0);
532 0           @OtherLines = &fmt($otherlines);
533 0           my $speaktext = join(' ',$list[$this_cell],'. ',@OtherLines);
534 0 0         if (wantarray) {
535 0           $#marked = $#list;
536 0 0         if ($firstlinelength < $maxcols-30) {
    0          
    0          
537 0           &puts("$firstline (multiple choice with spacebar)\n\r");
538             } elsif ($firstlinelength < $maxcols-16) {
539 0           &puts("$firstline (multiple choice)\n\r");
540             } elsif ($firstlinelength < $maxcols-9) {
541 0           &puts("$firstline (multiple)\n\r");
542             } else {
543 0           &puts("$firstline\n\r");
544             }
545 0 0         if ($nrows >= $maxrows) { &speak("$firstline, ", 'wait');
  0            
546 0           } else { &speak("$firstline, multiple choice, $speaktext");
547             }
548             } else {
549 0           &puts("$firstline\n\r");
550 0 0         if ($nrows >= $maxrows) { &speak("$firstline, ", 'wait');
  0            
551 0           } else { &speak("$firstline, choose, $speaktext");
552             }
553             }
554 0 0         if ($nrows >= $maxrows) {
555 0           @list = &narrow_the_search(@list);
556 0 0         if (! @list) {
557 0           &up(1); &clrtoeol(); &endwin(); $clue_has_been_given = 0;
  0            
  0            
  0            
558 0 0         return wantarray ? () : undef;
559             }
560 0           my $speaktext = join(' ',$list[$this_cell],'. ',@OtherLines);
561 0           &speak("choose, $speaktext");
562             }
563 0           &wr_screen();
564             # the cursor is now on this_cell, not on the question
565 0           print TTY "\e[6n"; # terminfo u7, will set $AbsCursX,$AbsCursY
566 0           $CursorRow = $irow[$this_cell]; # global, needed by handle_mouse
567              
568 0           while (1) {
569 0           $c = &getch();
570 0 0         if ($size_changed) {
571 0           &size_and_layout($nrows);
572 0 0         if ($nrows >= $maxrows) {
573 0           @list = &narrow_the_search(@list);
574 0 0         if (! @list) {
575 0           &up(1); &clrtoeol(); &endwin(); $clue_has_been_given = 0;
  0            
  0            
  0            
576 0 0         return wantarray ? () : undef;
577             }
578             }
579 0           &wr_screen();
580 0           &speak("choose, $list[$this_cell]");
581             }
582 0 0 0       if ($c eq "q" || $c eq "\cD" || $c eq "\cX") {
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
      0        
      0        
      0        
583 0           &erase_lines(1);
584 0 0         if ($clue_has_been_given) {
585 0           my $re_clue = &confirm("Do you want to change your clue ?");
586 0           &up(1); &clrtoeol(); # erase the confirm
  0            
587 0 0         if ($re_clue) {
588 0           $irow = 1;
589 0           @list = &narrow_the_search(@biglist); &wr_screen();
  0            
590 0           &speak("choose, $list[$this_cell]");
591 0           next;
592             } else {
593 0           &up(1); &clrtoeol(); &endwin(); $clue_has_been_given = 0;
  0            
  0            
  0            
594 0 0         return wantarray ? () : undef;
595             }
596             }
597 0           &goto(0,0); &clrtoeol(); &endwin(); $clue_has_been_given = 0;
  0            
  0            
  0            
598 0 0         return wantarray ? () : undef;
599             } elsif (($c eq "\t") && ($this_cell < $#list)) {
600 0           $this_cell++; &wr_cell($this_cell-1); &wr_cell($this_cell);
  0            
  0            
601 0           &speak($list[$this_cell]);
602             } elsif ((($c eq "l") || ($c == $KEY_RIGHT)) && ($this_cell < $#list)
603             && ($irow[$this_cell] == $irow[$this_cell+1])) {
604 0           $this_cell++; &wr_cell($this_cell-1); &wr_cell($this_cell);
  0            
  0            
605 0           &speak($list[$this_cell]);
606             } elsif ((($c eq "\cH") || ($c == $KEY_BTAB)) && ($this_cell > 0)) {
607 0           $this_cell--; &wr_cell($this_cell+1); &wr_cell($this_cell);
  0            
  0            
608 0           &speak($list[$this_cell]);
609             } elsif ((($c eq "h") || ($c == $KEY_LEFT)) && ($this_cell > 0)
610             && ($irow[$this_cell] == $irow[$this_cell-1])) {
611 0           $this_cell--; &wr_cell($this_cell+1); &wr_cell($this_cell);
  0            
  0            
612 0           &speak($list[$this_cell]);
613             } elsif ((($c eq "j") || ($c == $KEY_DOWN)) && ($irow < $nrows)) {
614 0           my $mid_col = $icol[$this_cell] + 0.5 * length($list[$this_cell]);
615 0           my $left_of_target = 1000;
616 0           for ($inew=$this_cell+1; $inew < $#list; $inew++) {
617 0 0         last if $icol[$inew] < $mid_col; # skip rest of row
618             }
619 0           my $new_mid_col = 0;
620 0           for (; $inew < $#list; $inew++) {
621 0           $new_mid_col = $icol[$inew] + 0.5*length($list[$inew]);
622 0 0         last if $new_mid_col >= $mid_col; # we've reached it
623 0 0         last if $icol[$inew+1] <= $icol[$inew]; # we're at EOL
624 0           $left_of_target = $mid_col - $new_mid_col;
625             }
626 0 0         if (($new_mid_col - $mid_col) > $left_of_target) { $inew--; }
  0            
627 0           $iold = $this_cell; $this_cell = $inew;
  0            
628 0           &wr_cell($iold); &wr_cell($this_cell);
  0            
629 0           &speak($list[$this_cell]);
630             } elsif ((($c eq "k") || ($c == $KEY_UP)) && ($irow > 1)) {
631 0           my $mid_col = $icol[$this_cell] + 0.5*length($list[$this_cell]);
632 0           my $right_of_target = 1000;
633 0           for ($inew=$this_cell-1; $inew > 0; $inew--) {
634 0 0         last if $irow[$inew] < $irow[$this_cell]; # skip rest of row
635             }
636 0           my $new_mid_col = 0;
637 0           for (; $inew > 0; $inew--) {
638 0 0         last unless $icol[$inew];
639 0           $new_mid_col = $icol[$inew] + 0.5*length($list[$inew]);
640 0 0         last if $new_mid_col <= $mid_col; # we're past it
641 0           $right_of_target = $new_mid_col - $mid_col;
642             }
643 0 0         if (($mid_col - $new_mid_col) > $right_of_target) { $inew++; }
  0            
644 0           $iold = $this_cell; $this_cell = $inew;
  0            
645 0           &wr_cell($iold); &wr_cell($this_cell);
  0            
646 0           &speak($list[$this_cell]);
647             } elsif ($c eq "\cL") {
648 0 0         if ($size_changed) {
649 0           &size_and_layout($nrows);
650 0 0         if ($nrows >= $maxrows) {
651 0           @list = &narrow_the_search(@list);
652 0 0         if (! @list) {
653 0           &up(1); &clrtoeol(); &endwin();
  0            
  0            
654 0           $clue_has_been_given = 0;
655 0 0         return wantarray ? () : undef;
656             }
657             }
658             }
659 0           &wr_screen();
660             } elsif ($c eq "\cC") { # 1.56
661 0           &erase_lines(1); &endwin();
  0            
662 0           warn "^C\n"; kill('INT', $$); return undef;
  0            
  0            
663             } elsif ($c eq "\r") {
664 0           &erase_lines(1); &goto($firstlinelength+1, 0);
  0            
665 0           my @chosen;
666 0 0         if (wantarray) {
667 0           my $i; for ($i=0; $i<=$#list; $i++) {
  0            
668 0 0 0       if ($marked[$i] || $i==$this_cell) {
669 0           push @chosen, $list[$i];
670             }
671             }
672 0           &clrtoeol();
673 0           my $remaining = $maxcols-$firstlinelength;
674 0           my $last = pop @chosen;
675 0           my $dotsprinted;
676 0           foreach (@chosen) {
677 0 0         if (($remaining - length $_) < 4) {
678 0           $dotsprinted=1; &puts("..."); $remaining -= 3; last;
  0            
  0            
  0            
679             } else {
680 0           &puts("$_, "); $remaining -= (2 + length $_);
  0            
681             }
682             }
683 0 0         if (!$dotsprinted) {
684 0 0         if (($remaining - length $last)>0) { &puts($last);
  0 0          
685 0           } elsif ($remaining > 2) { &puts('...');
686             }
687             }
688 0           &puts("\n\r");
689 0           push @chosen, $last;
690             } else {
691 0           &puts($list[$this_cell]."\n\r");
692             }
693 0           &endwin();
694 0           &set_default($firstline, $list[$this_cell]); # join($,,@chosen) ?
695 0           $clue_has_been_given = 0;
696 0 0         if (wantarray) {
697 0           &speak(join(' and ',@chosen), 'wait'); return @chosen;
  0            
698             } else {
699 0           &speak($list[$this_cell], 'wait'); return $list[$this_cell];
  0            
700             }
701             } elsif ($c eq " ") {
702 0 0         if (wantarray) {
703 0           $marked[$this_cell] = !$marked[$this_cell];
704             #if ($this_cell < $#list) {
705             # $this_cell++; &wr_cell($this_cell-1); # 1.50
706 0           &wr_cell($this_cell);
707 0           &speak('marked');
708             #}
709             #} elsif ($this_cell < $#list) {
710             # $this_cell++; &wr_cell($this_cell-1); &wr_cell($this_cell);
711             }
712             } elsif ($c eq "?") {
713 0           warn "help\r\n";
714             }
715             }
716 0           &endwin();
717 0           warn "choose: shouldn't reach here ...\n";
718             }
719 0     0 0   sub layout { my @list = @_;
720 0           $this_cell = 0; my $irow = 1; my $icol = 0; my $i;
  0            
  0            
  0            
721 0           for ($i=0; $i<=$#list; $i++) {
722 0           $l[$i] = length($list[$i]) + 2;
723 0 0         if ($l[$i] > $maxcols-1) { $l[$i] = $maxcols-1; } # 1.42
  0            
724 0 0         if (($icol + $l[$i]) >= $maxcols ) { $irow++; $icol = 0; }
  0            
  0            
725 0 0         if ($irow > $maxrows) { return $irow; } # save time
  0            
726 0           $irow[$i] = $irow; $icol[$i] = $icol;
  0            
727 0           $icol += $l[$i];
728 0 0         if ($list[$i] eq $choice) { $this_cell = $i; }
  0            
729             }
730 0           return $irow;
731             }
732             sub wr_screen {
733 0     0 0   for (my $i=0; $i<=$#list; $i++) {
734 0 0         &wr_cell($i) unless $i==$this_cell;
735             }
736 0           my $notherlines = scalar @OtherLines;
737 0 0 0       if ($notherlines && ($nrows+$notherlines) < $maxrows) {
738 0           &puts("\r\n", join("\r\n", @OtherLines), "\r");
739             }
740 0           &wr_cell($this_cell);
741             }
742 0     0 0   sub wr_cell { my $i = shift;
743 0           my $no_tabs = $list[$i];
744 0           $no_tabs =~ s/\t/ /g;
745 0           &goto($icol[$i], $irow[$i]);
746 0 0         if ($marked[$i]) { &attrset($A_BOLD | $A_UNDERLINE); }
  0            
747 0 0         if ($i == $this_cell) { &attrset($A_REVERSE); }
  0            
748 0           &puts(substr " $no_tabs ", 0, $maxcols); # 1.42, 1.54
749 0 0 0       if ($marked[$i] || $i == $this_cell) { &attrset($A_NORMAL); }
  0            
750             }
751             sub size_and_layout {
752 0     0 0   my $erase_rows = shift;
753 0           &check_size();
754 0 0         if ($erase_rows) {
755 0 0         if ($erase_rows > $maxrows) { $erase_rows = $maxrows; } # XXX?
  0            
756 0           &erase_lines(1);
757             }
758 0           $nrows = &layout(@list);
759             }
760 0     0 0   sub narrow_the_search { my @biglist = @_;
761             # replaces the old ... require 'complete.pl';
762             # return &Complete("$firstline (TAB to complete, ^D to list) ", @list);
763 0           my $nchoices = scalar @_;
764 0           my $n; my $i; my @s; my $s; my @list = @biglist;
  0            
  0            
  0            
765 0           $clue_has_been_given = 1;
766 0 0         if ($IsMouseMode) { leave_mouse_mode(); }
  0            
767 0           &ask_for_clue($nchoices, $i, $s);
768 0           while (1) {
769 0           $c = &getch();
770 0 0         if ($size_changed) {
771 0           &size_and_layout(0);
772 0 0         if ($nrows < $maxrows) {
773 0           &erase_lines(1); enter_mouse_mode(); return @list;
  0            
  0            
774             }
775             }
776 0 0 0       if ($c == $KEY_LEFT && $i > 0) { $i--; &left(1); next;
  0 0 0        
  0 0 0        
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
777             } elsif ($c == $KEY_RIGHT) {
778 0 0         if ($i < $n) { &puts($s[$i]); $i++; next; }
  0            
  0            
  0            
779             } elsif (($c eq "\cH") || ($c eq "\c?")) {
780 0 0         if ($i > 0) {
781 0           $n--; $i--;
  0            
782 0           &speak($s[$i], 'wait'); # 1.63
783 0           splice(@s, $i, 1); &left(1);
  0            
784 0           foreach $j ($i..$n) { &puts($s[$j]); }
  0            
785 0           &clrtoeol(); &left($n-$i);
  0            
786             }
787             } elsif ($c eq "\cC") { # 1.56
788 0           &erase_lines(1); &endwin();
  0            
789 0           warn "^C\n"; kill('INT', $$); return undef;
  0            
  0            
790             } elsif ($c eq "\cX" || $c eq "\cD") { # clear ...
791 0 0         if (! @s) { # 20070305 ?
792 0           $clue_has_been_given = 0; &erase_lines(1);
  0            
793 0           enter_mouse_mode(); return ();
  0            
794             }
795 0           &left($i); $i = 0; $n = 0; @s = (); &clrtoeol();
  0            
  0            
  0            
  0            
796 0           } elsif ($c eq "\cA") { &left($i); $i = 0; next;
  0            
  0            
797 0           } elsif ($c eq "\cE") { &right($n-$i); $i = $n; next;
  0            
  0            
798             } elsif ($c eq "\cL") {
799 0           } elsif ($SpecialKey{$c}) { &beep();
800             } elsif (ord($c) >= 32) { # 1.51
801 0           splice(@s, $i, 0, $c);
802 0           $n++; $i++; &puts($c);
  0            
  0            
803 0           foreach $j ($i..$n) { &puts($s[$j]); } &clrtoeol(); &left($n-$i);
  0            
  0            
  0            
804 0           &speak($c, 'wait'); # 1.63
805 0           } else { &beep();
806             }
807             # grep, and if $nchoices=1 return
808 0           $s = join("", @s);
809 0           @list = grep(0 <= index($_,$s), @biglist);
810 0           $nchoices = scalar @list;
811 0           $nrows = &layout(@list);
812 0 0 0       if ($nchoices==1 || ($nchoices && ($nrows<$maxrows))) {
      0        
813 0           &puts("\r"); &clrtoeol(); &up(1); &clrtoeol();
  0            
  0            
  0            
814 0           enter_mouse_mode(); return @list;
  0            
815             }
816 0           &ask_for_clue($nchoices, $i, $s);
817             }
818 0           warn "narrow_the_search: shouldn't reach here ...\n";
819             }
820 0     0 0   sub ask_for_clue { my ($nchoices, $i, $s) = @_;
821 0 0         if ($nchoices) {
822 0 0         if ($s) {
823 0           my $headstr = "the choices won't fit; there are still";
824 0           &goto(0,1); &puts("$headstr $nchoices of them"); &clrtoeol();
  0            
  0            
825 0           &goto(0,2); &puts("lengthen the clue : "); &right($i);
  0            
  0            
826 0           &speak("still $nchoices choices, lengthen the clue");
827             } else {
828 0           my $headstr = "the choices won't fit; there are";
829 0           &goto(0,1); &puts("$headstr $nchoices of them"); &clrtoeol();
  0            
  0            
830 0           &goto(0,2);
831 0           &puts(" give me a clue : (or ctrl-X to quit)");
832 0           &left(31); # 1.62
833 0           &speak("$nchoices choices, give me a clue, or control-X to quit");
834             }
835             } else {
836 0           &goto(0,1); &puts("No choices fit this clue !"); &clrtoeol();
  0            
  0            
837 0           &goto(0,2); &puts(" shorten the clue : "); &right($i);
  0            
  0            
838 0           &speak("no choices fit, shorten the clue");
839             }
840             }
841 0     0 1   sub get_default { my ($question) = @_;
842 0 0         if ($ENV{CLUI_DIR} =~ /off/i) { return undef; }
  0            
843 0 0         if (! $question) { return undef; }
  0            
844 0           my @choices;
845 0           my $n_tries = 5;
846 0           while ($n_tries--) {
847 0 0         if (dbmopen (%CHOICES, &dbm_file(), 0600)) {
848 0           last;
849             } else {
850 0 0         if ($! eq 'Resource temporarily unavailable') {
851 0           my $wait = rand 0.45; select undef, undef, undef, $wait;
  0            
852 0           } else { return undef;
853             }
854             }
855             }
856 0           @choices = split ($; ,$CHOICES{$question}); dbmclose %CHOICES;
  0            
857 0 0         if (wantarray) { return @choices;
  0            
858 0           } else { return $choices[0];
859             }
860             }
861 0     0 1   sub set_default { my $question = shift; my $s = join($; , @_);
  0            
862 0 0         if ($ENV{CLUI_DIR} =~ /off/i) { return undef; }
  0            
863 0 0         if (! $question) { return undef; }
  0            
864 0           my $n_tries = 5;
865 0           while ($n_tries--) {
866 0 0         if (dbmopen(%CHOICES, &dbm_file(), 0600)) {
867 0           last;
868             } else {
869 0 0         if ($! eq 'Resource temporarily unavailable') {
870 0           my $wait = rand 0.50; select undef, undef, undef, $wait;
  0            
871 0           } else { return undef;
872             }
873             }
874             }
875 0           $CHOICES{$question} = $s; dbmclose %CHOICES;
  0            
876 0           return $s;
877             }
878             sub dbm_file {
879 0 0   0 0   if ($ENV{CLUI_DIR} =~ /off/i) { return undef; }
  0            
880 0           my $db_dir;
881 0 0         if ($ENV{CLUI_DIR}) {
882 0           $db_dir = $ENV{CLUI_DIR};
883 0           $db_dir =~ s#^~/#$HOME/#;
884 0           } else { $db_dir = "$HOME/.clui_dir";
885             }
886 0           mkdir ($db_dir,0750);
887 0           return "$db_dir/choices";
888             }
889 0     0 0   sub handle_mouse { my ($x, $y, $button_pressed, $button_drag) = @_; # 1.50
890 0           $TopRow = $AbsCursY - $CursorRow;
891 0 0         if ($LastEventWasPress) { $LastEventWasPress = 0; return(''); }
  0            
  0            
892 0 0         return('') unless $y >= $TopRow;
893 0           my $mouse_row = $y - $TopRow;
894 0           my $mouse_col = $x - 1;
895             # debug("x=$x y=$y TopRow=$TopRow mouse_row=$mouse_row");
896             # debug("button_pressed=$button_pressed button_drag=$button_drag");
897 0           my $found = 0;
898 0           my $i = 0; while ($i < @irow) {
  0            
899 0 0         if ($irow[$i] == $mouse_row) {
900             # debug("list[$i]=$list[$i] is the right row");
901 0 0 0       if ($icol[$i] < $mouse_col
902             and ($icol[$i]+length($list[$i]) >= $mouse_col)) {
903 0           $found = 1; last;
  0            
904             }
905 0 0         last if $irow[$i] > $mouse_row;
906             }
907 0           $i += 1;
908             }
909 0 0         return unless $found;
910             # if xterm doesn't receive a button-up event it thinks it's dragging
911 0           my $return_char = q{};
912 0 0 0       if ($button_pressed == 1 and !$button_drag) {
    0 0        
913 0           $LastEventWasPress = 1;
914 0           $return_char = $KEY_ENTER;
915             } elsif ($button_pressed == 3 and !$button_drag) {
916 0           $LastEventWasPress = 1;
917 0           $return_char = q{ };
918             }
919 0 0         if ($i != $this_cell) {
920 0           my $t = $this_cell; $this_cell = $i;
  0            
921 0           &wr_cell($t); &wr_cell($this_cell);
  0            
922             }
923 0           return $return_char;
924             }
925             sub help_text { # 1.54
926 0     0 1   my $text;
927 0 0         if ($_[0] eq 'ask') {
928 0           return "\nLeft and Right arrowkeys, Backspace, Delete; control-A = "
929             . " beginning; control-E = end; control-X = clear; then Return.";
930             }
931 0 0         if ($ENV{'CLUI_MOUSE'} eq 'OFF') {
932 0           $text = "\nmove around with Arrowkeys (or hjkl);";
933             } else {
934 0           $text = "\nmove around with Mouse or Arrowkeys (or hjkl);";
935             }
936 0 0         if ($_[0] =~ /^mult/) {
937 0           $text .= " multiselect with Rightclick or Spacebar;";
938             }
939 0           $text .= " then either q or ctrl-X for quit,";
940 0 0         if ($ENV{'CLUI_MOUSE'} eq 'OFF') {
941 0           $text .= " or Return to choose.";
942             } else {
943 0           $text .= " or choose with Leftclick or Return.";
944             }
945             }
946              
947             # ----------------------- confirm stuff -------------------------
948              
949 0     0 1   sub confirm { my $question = shift; # asks user Yes|No, returns 1|0
950 0 0         return(0) unless $question; return(0) unless -t STDERR;
  0 0          
951 0           &initscr(speakup_silent=>1);
952 0           my $nol = &display_question($question); &puts(" (y/n) ");
  0            
953 0           &speak($question . ', y or n');
954 0           while (1) {
955 0           $response=&getch();
956 0 0         if ($response eq "\cC") { # 1.56
957 0           &erase_lines(1); &endwin();
  0            
958 0           warn "^C\n"; kill('INT', $$); return undef;
  0            
  0            
959             }
960 0 0         last if ($response=~/[yYnN]/);
961 0           &beep();
962             }
963 0           &left(6); &clrtoeol();
  0            
964 0 0         if ($response=~/^[yY]/) {
965 0           &puts("Yes");
966 0           &speak('yess', 'wait');
967             } else {
968 0           &puts("No");
969 0           &speak('know', 'wait');
970             }
971 0           &erase_lines(1); &endwin();
  0            
972 0 0         if ($response =~ /^[yY]/) { return 1; } else { return 0 ; }
  0            
  0            
973             }
974              
975             # ----------------------- edit stuff -------------------------
976              
977 0     0 1   sub edit { my ($title, $text) = @_;
978 0           my $argc = $#_ - 0 +1;
979 0           my ($dirname, $basename, $rcsdir, $rcsfile, $rcs_ok);
980            
981 0 0         if ($argc == 0) { # start editor session with no preloaded file
    0          
    0          
982 0   0       system $ENV{EDITOR} || "vi"; # should also look in ~/db/choices.db
983             } elsif ($argc == 2) {
984             # must create tmp file with title embedded in name
985 0           my $tmpdir = '/tmp';
986 0           my $safename = $title;
987 0           $safename =~ s/[\W_]+/_/g;
988 0           my $file = "$tmpdir/$safename.$$";
989 0 0         if (!open(F,">$file")) {&sorry("can't open $file: $!\n");return q{};}
  0            
  0            
990 0           print F $text; close F;
  0            
991 0   0       $editor = $ENV{EDITOR} || "vi"; # should also look in ~/db/choices.db
992 0           system "$editor $file";
993 0 0         if (!open(F,"< $file")) {&sorry("can't open $file: $!\n");return 0;}
  0            
  0            
994 0           undef $/; $text = ; $/ = "\n";
  0            
  0            
995 0           close F; unlink $file; return $text;
  0            
  0            
996             } elsif ($argc == 1) { # its a file, we will try RCS ...
997 0           my $file = $title;
998              
999             # weed out no-go situations
1000 0 0         if (-d $file) {&sorry("$file is already a directory\n"); return 0;}
  0            
  0            
1001 0 0 0       if (-B _ && -s _) {&sorry("$file is not a text file\n"); return 0;}
  0            
  0            
1002 0 0 0       if (-T _ && !-w _) { &view($file); return 1; }
  0            
  0            
1003            
1004             # it's a writeable text file, so work out the locations
1005 0 0         if ($file =~ /\//) {
1006 0           ($dirname, $basename) = $file =~ /^(.*)\/([^\/]+)$/;
1007 0           $rcsdir = "$dirname/RCS";
1008 0           $rcsfile = "$rcsdir/$basename,v";
1009             } else {
1010 0           $basename = $file;
1011 0           $rcsdir = "RCS";
1012 0           $rcsfile = "$rcsdir/$basename,v";
1013             }
1014 0           $rcslog = "$rcsdir/log";
1015            
1016             # we no longer create the RCS directory if it doesn't exist,
1017             # so `mkdir RCS' to enable rcs in a directory ...
1018 0 0         $rcs_ok = 1; if (!-d $rcsdir) { $rcs_ok = 0; }
  0            
  0            
1019 0 0 0       if (-d _ && ! -w _) { $rcs_ok = 0; warn "can't write in $rcsdir\n"; }
  0            
  0            
1020            
1021             # if the file doesn't exist, but the RCS does, then check it out
1022 0 0 0       if ($rcs_ok && -f $rcsfile && !-f $file) {
      0        
1023 0           system "co -l $file $rcsfile";
1024             }
1025              
1026 0           my $starttime = time;
1027 0   0       $editor = $ENV{EDITOR} || "vi"; # should also look in ~/db/choices.db
1028 0           system "$editor $file";
1029 0           my $elapsedtime = time - $starttime;
1030             # could be output or logged, for worktime accounting
1031            
1032 0 0 0       if ($rcs_ok && -T $file) { # check it in
1033 0 0         if (!-f $rcsfile) {
1034 0           my $msg = &ask("$file is new. Please describe it:");
1035 0           my $quotedmsg = $msg; $quotedmsg =~ s/'/'"'"'/g;
  0            
1036 0 0         if ($msg) {
1037 0           system "ci -q -l -t-'$quotedmsg' -i $file $rcsfile";
1038 0           &logit($basename, $msg);
1039             }
1040             } else {
1041 0           my $msg = &ask("What changes have you made to $file ?");
1042 0           my $quotedmsg = $msg; $quotedmsg =~ s/'/'"'"'/g;
  0            
1043 0 0         if ($msg) {
1044 0           system "ci -q -l -m'$quotedmsg' $file $rcsfile";
1045 0           &logit($basename, $msg);
1046             }
1047             }
1048             }
1049             }
1050             }
1051 0     0 0   sub logit { my ($file, $msg) = @_;
1052 0 0         if (! open(LOG, ">> $rcslog")) { warn "can't open $rcslog: $!\n";
  0            
1053             } else {
1054 0           $pid = fork; # log in background for better response time
1055 0 0         if (! $pid) {
1056 0           ($user) = getpwuid($>);
1057 0           print LOG ×tamp, " $file $user $msg\n"; close LOG;
  0            
1058 0 0         if ($pid == 0) { exit 0; } # the child's end, if a fork occurred
  0            
1059             }
1060             }
1061             }
1062             sub timestamp {
1063             # returns current date and time in "199403011 113520" format
1064 0     0 1   my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime;
1065 0           $wday += 0; $yday += 0; $isdst += 0; # avoid bloody -w warning
  0            
  0            
1066 0           return sprintf("%4.4d%2.2d%2.2d %2.2d%2.2d%2.2d",
1067             $year+1900, $mon+1, $mday, $hour, $min, $sec);
1068             }
1069              
1070             # ----------------------- sorry stuff -------------------------
1071              
1072             sub sorry { # warns user of an error condition
1073 0     0 1   print STDERR "Sorry, $_[0]\n";
1074 0           &speak("Sorry, $_[0]", 'wait');
1075             }
1076 0     0 1   sub inform { my $text = $_[0];
1077 0           $text =~ s/([^\n])$/$1\n/s;
1078 0 0         if (open(TTY, ">$EncodingString", '/dev/tty')) { # 1.43
1079 0           print TTY $text; close TTY;
  0            
1080 0           } else { warn $text;
1081             }
1082 0           &speak($text, 'wait');
1083             }
1084              
1085             # ----------------------- view stuff -------------------------
1086              
1087             foreach $f ("/usr/bin/less", "/usr/bin/more") {
1088             if (-x $f) { $default_pager = $f; }
1089             }
1090 0     0 1   sub view { my ($title, $text) = @_; # or ($filename) =
1091 0   0       my $pager = $ENV{PAGER} || $default_pager;
1092 0 0 0       if (! $text and ($title =~ /\.doc$/i) and -r $title) { # 1.65
    0 0        
      0        
      0        
1093 0 0         my $wvText = which('wvText'); if ($wvText) {
  0            
1094 0           my $tmpf = "/tmp/wv$$";
1095 0           system "$wvText '$title' $tmpf"; system "$pager $tmpf";
  0            
1096 0           unlink $tmpf; return 1;
  0            
1097             }
1098 0 0         my $antiword = which('antiword'); if ($antiword) {
  0            
1099 0           system "$antiword -i 1 '$title' | $pager"; return 1;
  0            
1100             }
1101 0 0         my $catdoc = which('catdoc'); if ($catdoc) {
  0            
1102 0           system "$catdoc '$title' | $pager"; return 1;
  0            
1103             }
1104 0           sorry("it's a .doc file; you need to install wv, antiword or catdoc");
1105 0           return 0;
1106             } elsif (! $text && -T $title && open(F,"< $title")) {
1107 0           $nlines = 0;
1108 0 0         while () { last if ($nlines++ > $maxrows); } close F;
  0            
  0            
1109 0 0         if ($nlines > (0.6*$maxrows)) {
1110 0           system "$pager \'$title\'";
1111             } else {
1112 0           open(F,"< $title"); undef $/; $text=; $/="\n"; close F;
  0            
  0            
  0            
  0            
1113 0           &tiview($title, $text);
1114             }
1115             } else {
1116 0           local (@lines) = split(/\r?\n/, $text, $maxrows);
1117 0 0         if (($#lines) < 21) {
1118 0           &tiview($title, $text);
1119             } else {
1120 0           local ($safetitle); ($safetitle = $title) =~ s/[^a-zA-Z0-9]+/_/g;
  0            
1121 0           local ($tmp) = "/tmp/$safetitle.$$";
1122 0 0         if (!open(TMP, ">$tmp")) {warn "can't open $tmp: $!\n"; return;}
  0            
  0            
1123 0           print TMP $text; close TMP;
  0            
1124 0           system "$pager \'$tmp\'";
1125 0           unlink $tmp;
1126 0           return 1;
1127             }
1128             }
1129             }
1130 0     0 0   sub tiview { my ($title, $text) = @_;
1131 0 0         return unless $text;
1132 0           $title =~ s/\t/ /g; my $titlelength = length $title;
  0            
1133            
1134 0           &check_size();
1135 0           my @rows = &fmt($text, nofill=>1);
1136 0           &initscr();
1137 0 0         if (3 > scalar @rows) {
1138 0           &puts("$title\r\n".join("\r\n",@rows), "\r\n");
1139 0           &speak("$title, ".join(" ",@rows), 'wait');
1140 0           &endwin(); return 1;
  0            
1141             }
1142 0 0         if ($titlelength > ($maxcols-35)) { &puts("$title\r\n");
  0            
1143 0           } else { &puts("$title ( to continue, q to clear)\r\n");
1144             }
1145 0           &puts("\r", join("\e[K\r\n",@rows), "\r");
1146 0           &speak("$title, enter to continue, ".join(" ",@rows));
1147 0           $icol = 0; $irow = scalar @rows; &goto($titlelength+1, 0);
  0            
  0            
1148            
1149 0           while (1) {
1150 0           $c = &getch();
1151 0 0 0       if ($c eq 'q' || $c eq "\cX" || $c eq "\cW" || $c eq "\cZ"
    0 0        
    0 0        
      0        
      0        
1152             || $c eq "\cC" || $c eq "\c\\") {
1153 0           &erase_lines(0); &endwin(); return 1;
  0            
  0            
1154             } elsif ($c eq "\r") { # retains text on screen
1155 0           &clrtoeol(); &goto(0, @rows+1); &endwin(); return 1;
  0            
  0            
  0            
1156             } elsif ($c eq "\cL") {
1157 0           &puts("\r"); &endwin(); &tiview($title,$text); return 1;
  0            
  0            
  0            
1158             }
1159             }
1160 0           warn "tiview: shouldn't reach here\n";
1161             }
1162              
1163             # -------------------------- infrastructure -------------------------
1164              
1165             sub which {
1166 0     0 0   my $f;
1167 0 0         foreach $d (split(":",$ENV{'PATH'})) {$f="$d/$_[0]"; return $f if -x $f;}
  0            
  0            
1168             }
1169             %SpeakMode = ();
1170             sub END {
1171 1 50   1   2478 if ($Eflite_FH) { print $Eflite_FH "s\nq { }\n"; close $Eflite_FH;
  0 50          
  0            
1172 0           } elsif ($Espeak_PID) { kill SIGHUP, $Espeak_PID; wait;
  0            
1173             }
1174             }
1175 0     0 0   sub speak { my ($text, $wait) = @_;
1176 0           $text="$text";
1177 0 0         return unless length($text); # should clean up for exit: kill or wait
1178             # could replace the punctuation chars with descriptive words...
1179 0 0         if ($SpeakMode{'dot'}) {
1180 0           $text =~ s/\s*\.\s*/ dot /g;
1181 0           $text =~ s/\s*\.(\w)/ dot $1/g;
1182             }
1183 0 0         if ($Eflite_FH) {
    0          
1184 0 0         if (length($text) == 1) {
1185 0 0         if ($text eq '.') { print $Eflite_FH "s\nq { dot }\nd\n";
  0            
1186 0           } else { print $Eflite_FH "s\nl {$text}\n";
1187             }
1188 0 0         if ($wait) { select(undef,undef,undef,0.5); }
  0            
1189             } else {
1190 0           print $Eflite_FH "s\nq {$text}\nd\n";
1191             # useless emacspeak op: tts_sy nc_state all 0 0 1 225\nq {[:np ]}
1192 0 0         if ($wait) { select(undef,undef,undef,0.3+0.07*length($text)); }
  0            
1193             }
1194             } elsif ($Espeak) { # 1.68 should be using Speech::eSpeak !
1195 0 0         if ($Espeak_PID) { kill SIGHUP, $Espeak_PID; wait; $Espeak_PID = 0; }
  0            
  0            
  0            
1196 0           $Espeak_PID = fork();
1197 0 0         if ($Espeak_PID) {
1198 0 0         if ($wait) {
1199 0 0         if (length($text) == 1) { select(undef,undef,undef,0.5);
  0            
1200 0           } else { select(undef,undef,undef,0.3+0.07*length($text));
1201             }
1202             }
1203 0           return 1;
1204             } else {
1205 0           my $espeak_FH;
1206             my $espeak_PID;
1207 0 0         if ($espeak_PID = open($espeak_FH,'|-',$Espeak)) {
1208 0           select((select($espeak_FH), $| = 1)[0]); print $espeak_FH q{};
  0            
1209             } else {
1210 0           warn "can't run $Espeak: $!\n"; return;
  0            
1211             }
1212             # binmode($espeak_FH, ':unix');
1213 0     0 0   sub huphandler { kill 'KILL', $espeak_PID; }
1214 0           $SIG{HUP} = \&huphandler;
1215 0 0         if ($text eq '.') { print $espeak_FH "dot\n";
  0            
1216 0           } else { print $espeak_FH "$text\n";
1217             }
1218             # close $espeak_FH; # Must Not Close! close Hangs, unkillable !
1219 0           wait;
1220 0           exit 0;
1221             }
1222             }
1223             }
1224              
1225 0     0 0   sub display_question { my $question = shift; my %options = @_;
  0            
1226             # used by &ask and &confirm, but not by &choose ...
1227 0           &check_size();
1228 0           my ($firstline, $otherlines); # 20131002 @otherlines => $otherlines
1229 0 0         if ($options{nofirstline}) {
1230 0           @OtherLines = &fmt($question);
1231             } else {
1232 0           ($firstline,$otherlines) = split(/\r?\n/, $question, 2);
1233 0           @OtherLines = &fmt($otherlines);
1234 0 0         if ($firstline) { &puts("$firstline "); }
  0            
1235             }
1236 0 0         if (@OtherLines) {
1237 0           &puts("\r\n", join("\r\n", @OtherLines), "\r");
1238 0           &goto(1 + length $firstline, 0);
1239             }
1240 0           return scalar @OtherLines;
1241             }
1242             sub erase_lines { # leaves cursor at beginning of line $_[0]
1243 0     0 0   &goto(0, $_[0]); print TTY "\e[J";
  0            
1244             }
1245 0     0 0   sub fmt { my $text = shift; my %options = @_;
  0            
1246             # Used by tiview, ask and confirm; formats the text within $maxcols cols
1247 0           my (@i_words, $o_line, @o_lines, $o_length, $last_line_empty, $w_length);
1248 0           my (@i_lines, $initial_space);
1249 0           @i_lines = split(/\r?\n/, $text);
1250 0           foreach $i_line (@i_lines) {
1251 0 0         if ($i_line =~ /^\s*$/) { # blank line ?
1252 0 0         if ($o_line) { push @o_lines, $o_line; $o_line=q{}; $o_length=0; }
  0            
  0            
  0            
1253 0 0         if (! $last_line_empty) { push @o_lines,""; $last_line_empty=1; }
  0            
  0            
1254 0           next;
1255             }
1256 0           $last_line_empty = 0;
1257              
1258 0 0         if ($options{nofill}) {
1259 0           push @o_lines, substr($i_line, 0, $maxcols-1); next;
  0            
1260             }
1261 0 0         if ($i_line =~ s/^(\s+)//) { # line begins with space ?
1262 0           $initial_space = $1; $initial_space =~ s/\t/ /g;
  0            
1263 0 0         if ($o_line) { push @o_lines, $o_line; }
  0            
1264 0           $o_line = $initial_space; $o_length = length $initial_space;
  0            
1265             } else {
1266 0           $initial_space = q{};
1267             }
1268              
1269 0           @i_words = split(' ', $i_line);
1270 0           foreach $i_word (@i_words) {
1271 0           $w_length = length $i_word;
1272 0 0         if (($o_length + $w_length) >= $maxcols) {
1273 0           push @o_lines, $o_line;
1274 0           $o_line = $initial_space; $o_length = length $initial_space;
  0            
1275             }
1276 0 0         if ($w_length >= $maxcols) { # chop it !
1277 0           push @o_lines, substr($i_word,0,$maxcols-1); next;
  0            
1278             }
1279 0 0         if ($o_line) { $o_line .= ' '; $o_length += 1; }
  0            
  0            
1280 0           $o_line .= $i_word; $o_length += $w_length;
  0            
1281             }
1282             }
1283 0 0         if ($o_line) { push @o_lines, $o_line; }
  0            
1284 0 0         if ((scalar @o_lines) < $maxrows-2) { return(@o_lines);
  0            
1285 0           } else { return splice (@o_lines, 0, $maxrows-2);
1286             }
1287             }
1288             sub back_up {
1289 0 0   0 0   open(TTY, '>', '/dev/tty') # 1.43
1290             || (warn "Can't write /dev/tty: $!\n", return 0);
1291 0           print TTY "\r\e[K\e[A\e[K";
1292 0           close TTY;
1293             }
1294             1;
1295              
1296             __END__