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