1#!/usr/bin/env perl
2
3# You can use this test program to grill rlwrap - I wrote it in perl because I'm lazy
4
5# TODO: use Term::ReadKey if available
6
7
8use utf8;      # so literals and identifiers can be in UTF-8
9eval "require 5.012_001";     # or later to get "unicode_strings" feature
10$@ and warn "Your perl version is rather antique; expect some problems.\n";
11use strict;    # quote strings, declare variables
12use warnings;  # on by default
13use warnings  qw(FATAL utf8);    # fatalize encoding glitches
14use open      qw(:std :utf8);    # undeclared streams in UTF-8
15use charnames qw(:full :short);  # unneeded in v5.16
16use Getopt::Std;
17eval "use Term::ReadKey";
18my $have_ReadKey = not $@;
19my $interrupt_char = "^C";
20
21
22my $opt_d;
23getopts('d:');
24
25my $debug_file = $opt_d;
26if ($debug_file) {
27  open DEBUG, ">$debug_file" or die "Couldn't not open $debug_file: $!\n";
28}
29
30
31use vars qw($prompting $prompt);
32$|=1;
33
34
35use POSIX qw(:termios_h  :signal_h setsid);
36my ($term, $oterm, $fd_stdin, $errorcode, $sigset_blocked);
37my $verbose = 1;
38
39
40$prompt = (my $original_prompt = "pid %p, type :h for help > ");
41
42
43sub lprint($);
44
45init();
46lprint "\n\n";
47help();
48while(1) {
49  local $prompting = 1;
50  prompt();
51  $_ = <>;
52  defined $_ or exit 0;
53  /^:a(\s+(.*))/ and change_argv($2);
54  /^:b/ and run_bash();
55  /^:B/ and progress_bar();
56  /^:c\b/ and change_prompt();
57  /^:C/ and countdown();
58  /^:cd(\s+(.*))?/  and chdir($2 ? $2 : $ENV{HOME});
59  /^:d/ and die_eloquently();
60  (/^:e\s*([+-]?\d+)?/) and exit ($1 || 0);
61  /^:f/ and do_fork();
62  /^:h/ and help();
63  /^:H/ and hanky_panky();
64  /^:i/ and toggle_interrupt_char();
65  /^:l/ and long_and_difficult_string();
66  /^:p/ and pass();
67  /^:P/ and print_chunky(scalar `cat $0`);
68  /^:r/ and reset_prompt();
69  /^:R/ and raw();
70  /^:s/ and segfault();
71  /^:t/ and trickle();
72  /^:S/ and trickle2();
73  /^:u/ and utf8();
74  /^:T/ and test_controlling_terminal();
75  /^:v/ and toggle_verbosity();
76  /^!!(.*)/ and perl($1);
77  /^!([^!].*)/ and shell($1);
78  /^:w/ and ridiculously_wide_prompt();
79  /^(:|!)/ or show_input($_);
80}
81
82########################### subs ################################################
83
84
85sub init {
86  my (@signals_to_block);
87  $fd_stdin = fileno(STDIN);
88  # system ("reset");
89  $sigset_blocked = POSIX::SigSet->new;
90  $sigset_blocked -> fillset() or die "Could not fill \$sigset_blocked: $!\n";
91
92  $term     = POSIX::Termios->new();
93  $term->getattr($fd_stdin);
94  $oterm     = $term->getlflag();
95
96  install_signal_handlers();
97
98}
99
100
101sub help {
102  print <<EOF;
103This program accepts input lines and reports what you typed.  Input
104lines that start with : or !  are special, and are useful to (stress-)test
105rlwraps behaviour when the client does things like:
106
107! <cmd> run <cmd> in shell
108!!<exp> evaluate Perl expression <exp>
109:a <new command line> change commandline
110:b run ./bash or bash with current prompt (to compare readline behaviour with weird prompts)
111:B show a progress bar using Unicode block elements
112:c change prompt
113:cd [<dir>] chdir to <dir> (or \$HOME)
114:C countdown in prompt
115:d die eloquently
116:e [N] exit (with error code N)
117:f fork and let child take over (parent waits)
118:h help
119:H hanky-panky with backspace and carriage return
120:i toggle interrupt char between CTRL C and CTRL G
121:l print a long and difficult text
122:p ask "passsword"
123:P print chunky
124:r reset prompt
125:R raw mode (char-at-a-time)
126:s and sefgault
127:S and trickle slowly
128:t trickle output (10 chars)
129:T test controlling terminal
130:u try some utf-8
131:v toggle verbosity (e.g. when receiving a signal)
132:w ridiculously wide prompt
133
134EOF
135}
136
137sub prompt {
138  my $sprompt = shift || $prompt;
139  return unless $prompt;
140  my $pid = $$;
141  $sprompt =~ s/%p/$pid/g;
142  $sprompt =~ s/%t/`tty`/eg;
143  chomp(my $pwd = `pwd`);
144  $pwd =~ s/^$ENV{HOME}/~/;
145  $sprompt =~ s/%d/$pwd/eg;
146  #$sprompt =~ s/\n//g;
147  lprint $sprompt;
148}
149
150
151sub change_argv {
152  my ($cmdline) = @_;
153  $0=$cmdline;
154}
155
156sub run_bash {
157  my $bashprompt = $prompt;
158  $bashprompt =~ s/\e(\[[\d;]*m)/\\[\\e$1\\]/g;
159  my $rcfile = "/tmp/bashprompt.$$";
160  open OUT, ">$rcfile";
161  print OUT "PS1=\"$bashprompt\"\n";
162  close OUT;
163  system "bash --rcfile $rcfile";
164  unlink $rcfile;
165}
166
167sub progress_bar {
168  for (my $i=0; $i < 200; $i++) {
169    print "\N{FULL BLOCK}";
170    select(undef, undef, undef, 0.02);
171  }
172  print "\n";
173}
174
175sub pass {
176  noecho();
177  prompt (local $prompt = "Password: ");
178  my $input = <>;
179  show_input($input);
180  cooked();
181}
182
183
184
185sub do_fork {
186  my $pid;
187  return unless ($pid = fork);
188  waitpid($pid,0);
189  exit 0;
190}
191
192sub shell {
193  local $prompting;
194  my($command) = @_;
195  system($command);
196  cooked();
197}
198
199sub perl {
200  local $prompting;
201
202  my($exp) = @_;
203  my $result = eval $exp;
204  if ($@) {
205    print "error: $@\n";
206  } else {
207    print "OK, result = $result\n";
208  }
209  cooked();
210}
211
212sub trickle {
213  local $prompting;
214  my $i;
215  foreach my $c (split " ", ("trickle, trackle, trockle, " x 4) . ">") {
216    print "$c ";
217    print "\n" if ++$i % 2 == 0;
218    sleep 1;
219  }
220  my $input = <>;
221  show_input($input);
222}
223
224sub trickle2 {
225  local $prompting;
226  my $i;
227  foreach my $c (split //, "trickle, trackle > ") {
228    print $c;
229    sleep 1;
230  }
231  my $input = <>;
232  show_input($input);
233}
234
235sub hanky_panky {
236  for (my $i = 99; $i > 95 ; $i--) {
237    print "$i bottles of beer on the wall, $i bottles of beef";
238    sleep 1; print "\br";
239    sleep 1; print "\r";
240  }
241  print "\nYawn!\n"
242}
243
244
245sub toggle_interrupt_char {
246  $interrupt_char = $interrupt_char eq "^C" ? "^G" : "^C";
247  print "interrupt char is now '$interrupt_char'\n";
248  system "stty intr '$interrupt_char'";
249}
250
251sub countdown {
252  local $prompting;
253  for (my $i = 9; $i >= 0; $i--) {
254    print "\r countdown: $i >";
255    sleep 1;
256  }
257  my $input = <>;
258  show_input($input);
259}
260
261sub test_controlling_terminal {
262  if (not open DEVTTY, ">/dev/tty") {
263    print "I could not open /dev/tty, so there's no controlling terminal ($!)\n";
264  } else {
265    print DEVTTY  "found controlling terminal: /dev/tty speaking here!\n";
266  }
267}
268
269
270sub show_input {
271  my ($input) = @_;
272  defined $input or exit;
273  $input =~ s/\r?\n$//;
274  my $comment = "";
275  length $input or $comment = "(nothing)";
276  lprint "\nYou typed '$input' $comment\n";
277}
278
279sub change_prompt {
280  my $input;
281  my ($termwidth) = eval "GetTerminalSize";
282  { local $prompt = "New prompt here > ";
283    my $redblah = red("blah");
284    lprint "\%p -> pid, \%t -> tty, %d -> pwd, red{blah} -> $redblah, \\n -newline, 4*x -> xxxx" .($have_ReadKey ? ", %w -> termwidth\n" : "\n");
285    prompt();
286    $input = <>;
287    $input =~ s/\r?\n$//;
288    $input =~ s/\\n/\n/g;
289    $input =~ s/\%w/$termwidth/ge;
290    $input =~ s/\((\d.*?)\)/eval($1)/ge;
291    $input =~ s/(\d+)\*([^ {}]+)/$2 x $1/ge;
292    $input =~ s/red\{(.*?)\}/red($1)/eg;
293  }
294  $prompt = $input;
295}
296
297sub segfault {
298  kill 'SEGV', $$;
299}
300
301sub red {
302  my ($text) = @_;
303  return colour($text,31);
304}
305
306sub blue {
307  my ($text) = @_;
308  return colour($text,34);
309}
310
311sub colour {
312  my ($text, $colourcode) = @_;
313  $text = "\e[1;${colourcode}m$text\e[0m"  if $ENV{TERM} =~ /ansi|xterm|rxvt|cygwin|linux|screen|tmux/;
314  return $text;
315}
316
317sub long_and_difficult_string {
318  my $text = (red("hot") . " and ". blue("cold"). ", ") x 3000;
319  print "$text\n";
320}
321
322sub reset_prompt {
323  $prompt = $original_prompt;
324}
325
326sub ridiculously_wide_prompt {
327  $prompt = "Supercalifragilistic, " x 10; # 220
328  $prompt .= "Expialidocious > ";         # + 17 = 237
329}
330
331sub utf8 {
332  $prompt = "Íslenska: ";
333  printf "Ég get etið gler án þess að meiða mig\n";
334}
335
336sub raw {
337  binmode(STDIN, ":raw");
338  cbreak();
339  my $key;
340  prompt (local $prompt = "Press Any Key >");
341  sysread(STDIN, $key, 1);
342  my $c = ord $key;
343  cooked();
344  lprint "\nYou typed a '$key' (ASCII $c)\n";
345  binmode(STDIN, ":utf8");
346
347}
348
349sub toggle_verbosity {
350  $verbose = not $verbose;
351  print ($verbose ? "verbose now\n" : "not verbose now\n");
352}
353
354sub die_eloquently {
355  my $last_words =  <<EOF;
356  Then, as the life ebbed out of you, you answered, O knight
357Patroclus: "Hector, vaunt as you will, for Jove the son of Saturn
358and Apollo have vouchsafed you victory; it is they who have vanquished
359me so easily, and they who have stripped the armour from my shoulders;
360had twenty such men as you attacked me, all of them would have
361fallen before my spear. Fate and the son of Leto have overpowered
362me, and among mortal men Euphorbus; you are yourself third only in the
363killing of me. I say further, and lay my saying to your heart, you too
364shall live but for a little season; death and the day of your doom are
365close upon you, and they will lay you low by the hand of Achilles
366son of Aeacus."
367  When he had thus spoken his eyes were closed in death, his soul left
368his body and flitted down to the house of Hades, mourning its sad fate
369and bidding farewell to the youth and vigor of its manhood.
370EOF
371$last_words =~ s/\s+/ /g;
372  print "\n$last_words\n";
373  exit 0;
374}
375
376sub print_chunky {
377  my ($text) = @_;
378  binmode STDOUT, ':raw';
379  local $| = undef;
380  while ($text) {
381    syswrite STDOUT, substr($text, 0, int(rand(20)), "");
382    select(undef, undef, undef, 0.01);
383
384  }
385  binmode STDOUT,':utf8';
386}
387
388sub handle_signal {
389  my ($sig) = @_;
390  my ($old_sigset);
391  sigprocmask(SIG_BLOCK, $sigset_blocked, $old_sigset) or die "Could not block signals: $!\n";
392  print ($sig =~ /INT/ ? "Caught $sig (type :e to exit)\n" : "Caught $sig\n") if $verbose;
393  prompt() if $prompting and $verbose;
394  sigprocmask(SIG_UNBLOCK, $old_sigset)  or die "Could not unblock signals: $!\n";
395}
396
397
398
399
400sub install_signal_handlers {
401  foreach my $signal (keys %SIG) {
402      $SIG{$signal} = \&handle_signal unless ($signal =~ /CHLD|CLD|TSTP|NUM|_/);
403    }
404}
405
406
407sub cbreak {
408  $term->setlflag($oterm & ~(ECHO|ECHOK|ICANON));
409  $term->setcc(VTIME, 1);
410  $term->setattr($fd_stdin, TCSANOW);
411}
412
413sub cooked {
414  return unless defined $fd_stdin;
415  $term->setlflag($oterm);
416  $term->setcc(VTIME, 0);
417  $term->setattr($fd_stdin, TCSANOW);
418}
419
420sub noecho {
421  $term->setlflag($oterm & ~(ECHO));
422  $term->setcc(VTIME, 0);
423  $term->setattr($fd_stdin, TCSANOW);
424}
425
426sub END {
427   local $?; # because POSIX::Termios functions call system() and may thus reset $?
428   cooked();
429   lprint "\n";
430 }
431
432
433sub lprint($) {
434  my ($text) = @_;
435
436  eval '"a" =~ /[[:^print:]]/'; # check whether this perl knows (negated) POSIX character class syntax (not before perl 5.6.0?)
437  if (! $@) {
438    $text =~ s/([^[:print:]\s\e])/sprintf("\\x%02x", (unpack "c", $1))/eg; # show unprintable characters in hex;
439  }
440  if ($debug_file) {
441    syswrite DEBUG, $text;
442  }
443
444  print $text;
445}
446
447
448# Local variables:
449# mode:cperl
450# End:
451