view release on metacpan or  search on metacpan

t/prompt.t  view on Meta::CPAN

# Attempt to determine whether the shell is forking per prompt.
# Likely to be flaky.
#
# Likely outcomes,
#   broken: can't see pids
#   sequential=1 <n>: Perl eats one per line
#   promptburn=2 <n>: Bash & Perl each eat one per line
#   random: no discernable pattern (e.g. on OpenBSD)
#
# PID wrap should not cause problems.  Fast PID churn from other
# sources might require larger $N to get non-weird results.
sub pidseq_subtest {
  my ($N) = @_;
  my $retrying = defined $N;
  $N ||= 50;

  # print many prompts, examine pid issued to the process requested
  my $run = ". t/bashrc\n".("perl -e 'print qq{pid:\$\$\\n}'\n" x $N);
  my $txt = bash_interactive($run, maxt => $N / 5);

  my @pid = ($txt =~ m{^pid:(\d+)$}mg);
  if ($N != @pid) {
    return sprintf('broken: see %d/%d pid: lines', scalar @pid, $N);
  }

  # Very basic stats.  Output elements are
  #
  #   "$diff1 <$count_significant>"
  #   "($diff2 x$count_insignificant)"
  my %hist; # key = line-to-line difference in PID; value = event count
  while ($#pid) {
    my $diff = $pid[1] - (shift @pid);
    $hist{$diff} ++;
  }

  $N --; # we are now interested in differences between PIDs; sample of these is smaller
  my @hist; # output elements
  my @diff_sig; # $diff which are significant
  my $thres = sqrt($N);
  foreach my $diff (sort {$hist{$b} <=> $hist{$a}} keys %hist) {
    my $count = $hist{$diff};
    my $sig = $count / $thres;
    $count .= "/$N" if !@hist; # show total on first ele
    my $ele = $sig > 1 ? "$diff <$count>" : "($diff x$count)";
    push @diff_sig, $diff if $sig > 1;
    push @hist, $ele;
  }
  my $raw = join ', ', @hist;
  $raw .= sprintf('; thres=%.2f', $thres);

  # Summarise
  if (0 == @diff_sig) {
    return "random: $raw";
  } elsif (1 == @diff_sig) {
    my $diff = $diff_sig[0];
    my $type = { 1 => 'sequential', 2 => 'promptburn' }->{$diff} || 'weird';
    return "$type=$raw";
  } else {
    if ($retrying) {
      return "weird (not unimodal..  not enough trials? system busy?): $raw";
    } else {
      diag("weird pidseq ($raw) - going to try harder");
      return pidseq_subtest($N * 10);
    }
  }
}

sub deansi { # removes ANSI/vt100 codes we use
  my ($txt) = @_;
  $txt =~ s{\x1b\[([0-9;]*)m}{dv(c => $1)}eg; # colour
  $txt =~ s{\x1b\[([0-2]?)K}{dv(e => $1)."\n"}eg; # erase
  $txt =~ s{\x1b([78])}{dv(sr => $1)."\n"}eg; # save/restore
  $txt =~ s{\x1b\[(\d*[A-D])}{dv(udrl => $1)."\n"}eg; # up/down/right/left
  $txt =~ s{\r*\n+[\r\n]*}{\n}g; # compaction to visible linebreaks
  return $txt;
}
sub dv { # deansi: hackable verbosity, for debugging; breaks tests
  return $ENV{TEST_DEANSI_SHOW} ? "(($_[0] => $_[1]))" : '';
}

main();