#!/usr/bin/env perl

# You can use this test program to grill rlwrap - I wrote it in perl because I'm lazy

# TODO: use Term::ReadKey if available


use utf8;      # so literals and identifiers can be in UTF-8
eval "require 5.012_001";     # or later to get "unicode_strings" feature
$@ and warn "Your perl version is rather antique; expect some problems.\n";
use strict;    # quote strings, declare variables
use warnings;  # on by default
use warnings  qw(FATAL utf8);    # fatalize encoding glitches
use open      qw(:std :utf8);    # undeclared streams in UTF-8
use charnames qw(:full :short);  # unneeded in v5.16
use Getopt::Std;
eval "use Term::ReadKey";
my $have_ReadKey = not $@;
my $interrupt_char = "^C";


my $opt_d;
getopts('d:');

my $debug_file = $opt_d;
if ($debug_file) {
  open DEBUG, ">$debug_file" or die "Couldn't not open $debug_file: $!\n";
}


use vars qw($prompting $prompt);
$|=1;


use POSIX qw(:termios_h  :signal_h setsid);
my ($term, $oterm, $fd_stdin, $errorcode, $sigset_blocked);
my $verbose = 1;


$prompt = (my $original_prompt = "pid %p, type :h for help > ");


sub lprint($);

init();
lprint "\n\n";
help();
while(1) {
  local $prompting = 1;
  prompt();
  $_ = <>;
  defined $_ or exit 0;
  /^:a(\s+(.*))/ and change_argv($2);
  /^:b/ and run_bash();
  /^:B/ and progress_bar();
  /^:c\b/ and change_prompt();
  /^:C/ and countdown();
  /^:cd(\s+(.*))?/  and chdir($2 ? $2 : $ENV{HOME});
  /^:d/ and die_eloquently();
  (/^:e\s*([+-]?\d+)?/) and exit ($1 || 0);
  /^:f/ and do_fork();
  /^:h/ and help();
  /^:H/ and hanky_panky();
  /^:i/ and toggle_interrupt_char();
  /^:l/ and long_and_difficult_string();
  /^:p/ and pass();
  /^:P/ and print_chunky(scalar `cat $0`);
  /^:r/ and reset_prompt();
  /^:R/ and raw();
  /^:s/ and segfault();
  /^:t/ and trickle();
  /^:S/ and trickle2();
  /^:u/ and utf8();
  /^:T/ and test_controlling_terminal();
  /^:v/ and toggle_verbosity();
  /^!!(.*)/ and perl($1);
  /^!([^!].*)/ and shell($1);
  /^:w/ and ridiculously_wide_prompt();
  /^(:|!)/ or show_input($_);
}

########################### subs ################################################


sub init {
  my (@signals_to_block);
  $fd_stdin = fileno(STDIN);
  # system ("reset");
  $sigset_blocked = POSIX::SigSet->new;
  $sigset_blocked -> fillset() or die "Could not fill \$sigset_blocked: $!\n";

  $term     = POSIX::Termios->new();
  $term->getattr($fd_stdin);
  $oterm     = $term->getlflag();

  install_signal_handlers();

}


sub help {
  print <<EOF;
This program accepts input lines and reports what you typed.  Input
lines that start with : or !  are special, and are useful to (stress-)test
rlwraps behaviour when the client does things like:

! <cmd> run <cmd> in shell
!!<exp> evaluate Perl expression <exp>
:a <new command line> change commandline
:b run ./bash or bash with current prompt (to compare readline behaviour with weird prompts)
:B show a progress bar using Unicode block elements
:c change prompt
:cd [<dir>] chdir to <dir> (or \$HOME)
:C countdown in prompt
:d die eloquently 
:e [N] exit (with error code N)
:f fork and let child take over (parent waits)
:h help
:H hanky-panky with backspace and carriage return
:i toggle interrupt char between CTRL C and CTRL G
:l print a long and difficult text
:p ask "passsword"
:P print chunky
:r reset prompt
:R raw mode (char-at-a-time)
:s and sefgault
:S and trickle slowly
:t trickle output (10 chars)
:T test controlling terminal
:u try some utf-8
:v toggle verbosity (e.g. when receiving a signal)
:w ridiculously wide prompt

EOF
}

sub prompt {
  my $sprompt = shift || $prompt;
  return unless $prompt;
  my $pid = $$;
  $sprompt =~ s/%p/$pid/g;
  $sprompt =~ s/%t/`tty`/eg;
  chomp(my $pwd = `pwd`);
  $pwd =~ s/^$ENV{HOME}/~/;
  $sprompt =~ s/%d/$pwd/eg;
  #$sprompt =~ s/\n//g;
  lprint $sprompt;
}


sub change_argv {
  my ($cmdline) = @_;
  $0=$cmdline;
}

sub run_bash {
  my $bashprompt = $prompt;
  $bashprompt =~ s/\e(\[[\d;]*m)/\\[\\e$1\\]/g;
  my $rcfile = "/tmp/bashprompt.$$";
  open OUT, ">$rcfile";
  print OUT "PS1=\"$bashprompt\"\n";
  close OUT;
  system "bash --rcfile $rcfile";
  unlink $rcfile;
}

sub progress_bar {
  for (my $i=0; $i < 200; $i++) {
    print "\N{FULL BLOCK}";
    select(undef, undef, undef, 0.02);
  }
  print "\n";
}

sub pass {
  noecho();
  prompt (local $prompt = "Password: ");
  my $input = <>;
  show_input($input);
  cooked();
}



sub do_fork {
  my $pid;
  return unless ($pid = fork);
  waitpid($pid,0);
  exit 0;
}

sub shell {
  local $prompting;
  my($command) = @_;
  system($command);
  cooked();
}

sub perl {
  local $prompting;

  my($exp) = @_;
  my $result = eval $exp;
  if ($@) {
    print "error: $@\n";
  } else {
    print "OK, result = $result\n";
  }
  cooked();
}

sub trickle {
  local $prompting;
  my $i;
  foreach my $c (split " ", ("trickle, trackle, trockle, " x 4) . ">") {
    print "$c ";
    print "\n" if ++$i % 2 == 0;
    sleep 1;
  }
  my $input = <>;
  show_input($input);
}

sub trickle2 {
  local $prompting;
  my $i;
  foreach my $c (split //, "trickle, trackle > ") {
    print $c;
    sleep 1;
  }
  my $input = <>;
  show_input($input);
}

sub hanky_panky {
  for (my $i = 99; $i > 95 ; $i--) {
    print "$i bottles of beer on the wall, $i bottles of beef";
    sleep 1; print "\br";
    sleep 1; print "\r";
  }
  print "\nYawn!\n"
}
    

sub toggle_interrupt_char {
  $interrupt_char = $interrupt_char eq "^C" ? "^G" : "^C";
  print "interrupt char is now '$interrupt_char'\n";
  system "stty intr '$interrupt_char'";
}

sub countdown {
  local $prompting;
  for (my $i = 9; $i >= 0; $i--) {
    print "\r countdown: $i >";
    sleep 1;
  }
  my $input = <>;
  show_input($input);
}

sub test_controlling_terminal {
  if (not open DEVTTY, ">/dev/tty") {
    print "I could not open /dev/tty, so there's no controlling terminal ($!)\n";
  } else {
    print DEVTTY  "found controlling terminal: /dev/tty speaking here!\n";
  }
}


sub show_input {
  my ($input) = @_;
  defined $input or exit;
  $input =~ s/\r?\n$//;
  my $comment = "";
  length $input or $comment = "(nothing)";
  lprint "\nYou typed '$input' $comment\n";
}

sub change_prompt {
  my $input;
  my ($termwidth) = eval "GetTerminalSize"; 
  { local $prompt = "New prompt here > ";
    my $redblah = red("blah");
    lprint "\%p -> pid, \%t -> tty, %d -> pwd, red{blah} -> $redblah, \\n -newline, 4*x -> xxxx" .($have_ReadKey ? ", %w -> termwidth\n" : "\n");
    prompt();
    $input = <>;
    $input =~ s/\r?\n$//;
    $input =~ s/\\n/\n/g;
    $input =~ s/\%w/$termwidth/ge;
    $input =~ s/\((\d.*?)\)/eval($1)/ge;
    $input =~ s/(\d+)\*([^ {}]+)/$2 x $1/ge;
    $input =~ s/red\{(.*?)\}/red($1)/eg;
  }
  $prompt = $input;
}

sub segfault {
  kill 'SEGV', $$;
}

sub red {
  my ($text) = @_;
  return colour($text,31);
}

sub blue {
  my ($text) = @_;
  return colour($text,34);
}

sub colour {
  my ($text, $colourcode) = @_;
  $text = "\e[1;${colourcode}m$text\e[0m"  if $ENV{TERM} =~ /ansi|xterm|rxvt|cygwin|linux|screen|tmux/;
  return $text;
}

sub long_and_difficult_string {
  my $text = (red("hot") . " and ". blue("cold"). ", ") x 3000;
  print "$text\n";
}

sub reset_prompt {
  $prompt = $original_prompt;
}

sub ridiculously_wide_prompt {
  $prompt = "Supercalifragilistic, " x 10; # 220
  $prompt .= "Expialidocious > ";         # + 17 = 237 
}

sub utf8 {
  $prompt = "Íslenska: ";
  printf "Ég get etið gler án þess að meiða mig\n";
}

sub raw {
  binmode(STDIN, ":raw");
  cbreak();
  my $key;
  prompt (local $prompt = "Press Any Key >");
  sysread(STDIN, $key, 1);
  my $c = ord $key;
  cooked();
  lprint "\nYou typed a '$key' (ASCII $c)\n";
  binmode(STDIN, ":utf8");

}

sub toggle_verbosity {
  $verbose = not $verbose;
  print ($verbose ? "verbose now\n" : "not verbose now\n");
}

sub die_eloquently {
  my $last_words =  <<EOF;
  Then, as the life ebbed out of you, you answered, O knight
Patroclus: "Hector, vaunt as you will, for Jove the son of Saturn
and Apollo have vouchsafed you victory; it is they who have vanquished
me so easily, and they who have stripped the armour from my shoulders;
had twenty such men as you attacked me, all of them would have
fallen before my spear. Fate and the son of Leto have overpowered
me, and among mortal men Euphorbus; you are yourself third only in the
killing of me. I say further, and lay my saying to your heart, you too
shall live but for a little season; death and the day of your doom are
close upon you, and they will lay you low by the hand of Achilles
son of Aeacus."
  When he had thus spoken his eyes were closed in death, his soul left
his body and flitted down to the house of Hades, mourning its sad fate
and bidding farewell to the youth and vigor of its manhood.
EOF
$last_words =~ s/\s+/ /g;
  print "\n$last_words\n";
  exit 0;
}

sub print_chunky {
  my ($text) = @_;
  binmode STDOUT, ':raw';
  local $| = undef;
  while ($text) {
    syswrite STDOUT, substr($text, 0, int(rand(20)), "");
    select(undef, undef, undef, 0.01);

  }
  binmode STDOUT,':utf8';
}
  
sub handle_signal {
  my ($sig) = @_;
  my ($old_sigset);
  sigprocmask(SIG_BLOCK, $sigset_blocked, $old_sigset) or die "Could not block signals: $!\n";
  print ($sig =~ /INT/ ? "Caught $sig (type :e to exit)\n" : "Caught $sig\n") if $verbose;
  prompt() if $prompting and $verbose;
  sigprocmask(SIG_UNBLOCK, $old_sigset)  or die "Could not unblock signals: $!\n";
}




sub install_signal_handlers {
  foreach my $signal (keys %SIG) {
      $SIG{$signal} = \&handle_signal unless ($signal =~ /CHLD|CLD|TSTP|NUM|_/);
    }
}


sub cbreak {
  $term->setlflag($oterm & ~(ECHO|ECHOK|ICANON));
  $term->setcc(VTIME, 1);
  $term->setattr($fd_stdin, TCSANOW);
}

sub cooked {
  return unless defined $fd_stdin;
  $term->setlflag($oterm);
  $term->setcc(VTIME, 0);
  $term->setattr($fd_stdin, TCSANOW);
}

sub noecho {
  $term->setlflag($oterm & ~(ECHO));
  $term->setcc(VTIME, 0);
  $term->setattr($fd_stdin, TCSANOW);
}

sub END {
   local $?; # because POSIX::Termios functions call system() and may thus reset $?
   cooked();
   lprint "\n";
 }


sub lprint($) {
  my ($text) = @_;

  eval '"a" =~ /[[:^print:]]/'; # check whether this perl knows (negated) POSIX character class syntax (not before perl 5.6.0?)
  if (! $@) {
    $text =~ s/([^[:print:]\s\e])/sprintf("\\x%02x", (unpack "c", $1))/eg; # show unprintable characters in hex;
  }
  if ($debug_file) {
    syswrite DEBUG, $text;
  }

  print $text;
}


# Local variables:
# mode:cperl
# End: