summaryrefslogtreecommitdiffstats
path: root/src/lib/Gitolite/Test/Tsh.pm
diff options
context:
space:
mode:
Diffstat (limited to 'src/lib/Gitolite/Test/Tsh.pm')
-rw-r--r--src/lib/Gitolite/Test/Tsh.pm645
1 files changed, 645 insertions, 0 deletions
diff --git a/src/lib/Gitolite/Test/Tsh.pm b/src/lib/Gitolite/Test/Tsh.pm
new file mode 100644
index 0000000..6861960
--- /dev/null
+++ b/src/lib/Gitolite/Test/Tsh.pm
@@ -0,0 +1,645 @@
+#!/usr/bin/perl
+use 5.10.0;
+
+# Tsh -- non interactive Testing SHell in perl
+
+# TODO items:
+# - allow an RC file to be used to add basic and extended commands
+# - convert internal defaults to additions to the RC file
+# - implement shell commands as you go
+# - solve the "pass/fail" inconsistency between shell and perl
+# - solve the pipes problem (use 'overload'?)
+
+# ----------------------------------------------------------------------
+# modules
+
+package Tsh;
+
+use Exporter 'import';
+@EXPORT = qw(
+ try run cmp AUTOLOAD
+ rc error_count text lines error_list put
+ cd tsh_tempdir
+
+ $HOME $PWD $USER
+);
+@EXPORT_OK = qw();
+
+use Env qw(@PATH HOME PWD USER TSH_VERBOSE);
+# other candidates:
+# GL_ADMINDIR GL_BINDIR GL_RC GL_REPO_BASE_ABS GL_REPO GL_USER
+
+use strict;
+use warnings;
+
+use Text::Tabs; # only used for formatting the usage() message
+use Text::ParseWords;
+
+use File::Temp qw(tempdir);
+END { chdir( $ENV{HOME} ); }
+# we need this END handler *after* the 'use File::Temp' above. Without
+# this, if $PWD at exit was $tempdir, you get errors like "cannot remove
+# path when cwd is [...] at /usr/share/perl5/File/Temp.pm line 902".
+
+use Data::Dumper;
+
+# ----------------------------------------------------------------------
+# globals
+
+my $rc; # return code from backticked (external) programs
+my $text; # STDOUT+STDERR of backticked (external) programs
+my $lec; # the last external command (the rc and text are from this)
+my $cmd; # the current command
+
+my $testnum; # current test number, for info in TAP output
+my $testname; # current test name, for error info to user
+my $line; # current line number and text
+
+my $err_count; # count of test failures
+my @errors_in; # list of testnames that errored
+
+my $tick; # timestamp for git commits
+
+my %autoloaded;
+my $tempdir = '';
+
+# ----------------------------------------------------------------------
+# setup
+
+# unbuffer STDOUT and STDERR
+select(STDERR); $|++;
+select(STDOUT); $|++;
+
+# set the timestamp (needed only under harness)
+test_tick() if $ENV{HARNESS_ACTIVE};
+
+# ----------------------------------------------------------------------
+# this is for one-liner access from outside, using @ARGV, as in:
+# perl -MTsh -e 'tsh()' 'tsh command list'
+# or via STDIN
+# perl -MTsh -e 'tsh()' < file-containing-tsh-commands
+# NOTE: it **exits**!
+
+sub tsh {
+ my @lines;
+
+ if (@ARGV) {
+ # simple, single argument which is a readable filename
+ if ( @ARGV == 1 and $ARGV[0] !~ /\s/ and -r $ARGV[0] ) {
+ # take the contents of the file
+ @lines = <>;
+ } else {
+ # more than one argument *or* not readable filename
+ # just take the arguments themselves as the command list
+ @lines = @ARGV;
+ @ARGV = ();
+ }
+ } else {
+ # no arguments given, take STDIN
+ usage() if -t;
+ @lines = <>;
+ }
+
+ # and process them
+ try(@lines);
+
+ # print error summary by default
+ if ( not defined $TSH_VERBOSE ) {
+ say STDERR "$err_count error(s)" if $err_count;
+ }
+
+ exit $err_count;
+}
+
+# these two get called with series of tsh commands, while the autoload,
+# (later) handles single commands
+
+sub try {
+ $line = $rc = $err_count = 0;
+ @errors_in = ();
+
+ # break up multiline arguments into separate lines
+ my @lines = map { split /\n/ } @_;
+
+ # and process them
+ rc_lines(@lines);
+
+ # bump err_count if the last command had a non-0 rc (that was apparently not checked).
+ $err_count++ if $rc;
+
+ # finish up...
+ dbg( 1, "$err_count error(s)" ) if $err_count;
+ return ( not $err_count );
+}
+
+# run() differs from try() in that
+# - uses open(), not backticks
+# - takes only one command, not tsh-things like ok, /patt/ etc
+# - - if you pass it an array it uses the list form!
+
+sub run {
+ open( my $fh, "-|", @_ ) or die "tell sitaram $!";
+ local $/ = undef; $text = <$fh>;
+ close $fh; warn "tell sitaram $!" if $!;
+ $rc = ( $? >> 8 );
+ return $text;
+}
+
+sub put {
+ my ( $file, $data ) = @_;
+ die "probable quoting error in arguments to put: $file\n" if $file =~ /^\s*['"]/;
+ my $mode = ">";
+ $mode = "|-" if $file =~ s/^\s*\|\s*//;
+
+ $rc = 0;
+ my $fh;
+ open( $fh, $mode, $file )
+ and print $fh $data
+ and close $fh
+ and return 1;
+
+ $rc = 1;
+ dbg( 1, "put $file: $!" );
+ return '';
+}
+
+# ----------------------------------------------------------------------
+# TODO: AUTOLOAD and exportable convenience subs for common shell commands
+
+sub cd {
+ my $dir = shift || '';
+ _cd($dir);
+ dbg( 1, "cd $dir: $!" ) if $rc;
+ return ( not $rc );
+}
+
+# this is classic AUTOLOAD, almost from the perlsub manpage. Although, if
+# instead of `ls('bin');` you want to be able to say `ls 'bin';` you will need
+# to predeclare ls, with `sub ls;`.
+sub AUTOLOAD {
+ my $program = $Tsh::AUTOLOAD;
+ dbg( 4, "program = $program, arg=$_[0]" );
+ $program =~ s/.*:://;
+ $autoloaded{$program}++;
+
+ die "tsh's autoload support expects only one arg\n" if @_ > 1;
+ _sh("$program $_[0]");
+ return ( not $rc ); # perl truth
+}
+
+# ----------------------------------------------------------------------
+# exportable service subs
+
+sub rc {
+ return $rc || 0;
+}
+
+sub text {
+ return $text || '';
+}
+
+sub lines {
+ return split /\n/, $text;
+}
+
+sub error_count {
+ return $err_count;
+}
+
+sub error_list {
+ return (
+ wantarray
+ ? @errors_in
+ : join( "\n", @errors_in )
+ );
+}
+
+sub tsh_tempdir {
+ # create tempdir if not already done
+ $tempdir = tempdir( "tsh_tempdir.XXXXXXXXXX", TMPDIR => 1, CLEANUP => 1 ) unless $tempdir;
+ # XXX TODO that 'UNLINK' doesn't work for Ctrl_C
+
+ return $tempdir;
+}
+
+# ----------------------------------------------------------------------
+# internal (non-exportable) service subs
+
+sub print_plan {
+ return unless $ENV{HARNESS_ACTIVE};
+ local $_ = shift;
+ say "1..$_";
+}
+
+sub rc_lines {
+ my @lines = @_;
+
+ while (@lines) {
+ local $_ = shift @lines;
+ chomp; $_ = trim_ws($_);
+
+ no warnings;
+ $line++;
+ use warnings;
+
+ # this also sets $testname
+ next if is_comment_or_empty($_);
+
+ dbg( 2, "L: $_" );
+ $line .= ": $_"; # save line for printing with 'FAIL:'
+
+ # a DEF has to be on a line by itself
+ if (/^DEF\s+([-.\w]+)\s*=\s*(\S.*)$/) {
+ def( $1, $2 );
+ next;
+ }
+
+ my @cmds = cmds($_);
+
+ # process each command
+ # (note: some of the commands may put stuff back into @lines)
+ while (@cmds) {
+ # this needs to be the 'global' one, since fail() prints it
+ $cmd = shift @cmds;
+
+ # is the current command a "testing" command?
+ my $testing_cmd = (
+ $cmd =~ m(^ok(?:\s+or\s+(.*))?$)
+ or $cmd =~ m(^!ok(?:\s+or\s+(.*))?$)
+ or $cmd =~ m(^/(.*?)/(?:\s+or\s+(.*))?$)
+ or $cmd =~ m(^!/(.*?)/(?:\s+or\s+(.*))?$)
+ );
+
+ # warn if the previous command failed but rc is not being checked
+ if ( $rc and not $testing_cmd ) {
+ dbg( 1, "rc: $rc from cmd prior to '$cmd'\n" );
+ # count this as a failure, for exit status purposes
+ $err_count++;
+ # and reset the rc, otherwise for example 'ls foo; tt; tt; tt'
+ # will tell you there are 3 errors!
+ $rc = 0;
+ push @errors_in, $testname if $testname;
+ }
+
+ # prepare to run the command
+ dbg( 3, "C: $cmd" );
+ if ( def($cmd) ) {
+ # expand macro and replace head of @cmds (unshift)
+ dbg( 2, "DEF: $cmd" );
+ unshift @cmds, cmds( def($cmd) );
+ } else {
+ parse($cmd);
+ }
+ # reset rc if checking is done
+ $rc = 0 if $testing_cmd;
+ # assumes you will (a) never have *both* 'ok' and '!ok' after
+ # an action command, and (b) one of them will come immediately
+ # after the action command, with /patt/ only after it.
+ }
+ }
+}
+
+sub def {
+ my ( $cmd, $list ) = @_;
+ state %def;
+ %def = read_rc_file() unless %def;
+
+ if ($list) {
+ # set mode
+ die "attempt to redefine macro $cmd\n" if $def{$cmd};
+ $def{$cmd} = $list;
+ return;
+ }
+
+ # get mode: split the $cmd at spaces, see if there is a definition
+ # available, substitute any %1, %2, etc., in it and send it back
+ my ( $c, @d ) = shellwords($cmd);
+ my $e; # the expanded value
+ if ( $e = $def{$c} ) { # starting value
+ for my $i ( 1 .. 9 ) {
+ last unless $e =~ /%$i/; # no more %N's (we assume sanity)
+ die "$def{$c} requires more arguments\n" unless @d;
+ my $f = shift @d; # get the next datum
+ $e =~ s/%$i/$f/g; # and substitute %N all over
+ }
+ return join( " ", $e, @d ); # join up any remaining data
+ }
+ return '';
+}
+
+sub _cd {
+ my $dir = shift || $HOME;
+ # a directory name of 'tsh_tempdir' is special
+ $dir = tsh_tempdir() if $dir eq 'tsh_tempdir';
+ $rc = 0;
+ chdir($dir) or $rc = 1;
+}
+
+sub _sh {
+ my $cmd = shift;
+ # TODO: switch to IPC::Open3 or something...?
+
+ dbg( 4, " running: ( $cmd ) 2>&1" );
+ $text = `( $cmd ) 2>&1; /bin/echo -n RC=\$?`;
+ $lec = $cmd;
+ dbg( 4, " results:\n$text" );
+
+ if ( $text =~ /RC=(\d+)$/ ) {
+ $rc = $1;
+ $text =~ s/RC=\d+$//;
+ } else {
+ die "couldnt find RC= in result; this should not happen:\n$text\n\n...\n";
+ }
+}
+
+sub _perl {
+ my $perl = shift;
+ local $_;
+ $_ = $text;
+
+ dbg( 4, " eval: $perl" );
+ my $evrc = eval $perl;
+
+ if ($@) {
+ $rc = 1; # shell truth
+ dbg( 1, $@ );
+ # leave $text unchanged
+ } else {
+ $rc = not $evrc;
+ # $rc is always shell truth, so we need to cover the case where
+ # there was no error but it still returned a perl false
+ $text = $_;
+ }
+ dbg( 4, " eval-rc=$evrc, results:\n$text" );
+}
+
+sub parse {
+ my $cmd = shift;
+
+ if ( $cmd =~ /^sh (.*)/ ) {
+
+ _sh($1);
+
+ } elsif ( $cmd =~ /^perl (.*)/ ) {
+
+ _perl($1);
+
+ } elsif ( $cmd eq 'tt' or $cmd eq 'test-tick' ) {
+
+ test_tick();
+
+ } elsif ( $cmd =~ /^plan ?(\d+)$/ ) {
+
+ print_plan($1);
+
+ } elsif ( $cmd =~ /^cd ?(\S*)$/ ) {
+
+ _cd($1);
+
+ } elsif ( $cmd =~ /^ENV (\w+)=['"]?(.+?)['"]?$/ ) {
+
+ $ENV{$1} = $2;
+
+ } elsif ( $cmd =~ /^(?:tc|test-commit)\s+(\S.*)$/ ) {
+
+ # this is the only "git special" really; the default expansions are
+ # just that -- defaults. But this one is hardwired!
+ dummy_commits($1);
+
+ } elsif ( $cmd =~ '^put(?:\s+(\S.*))?$' ) {
+
+ if ($1) {
+ put( $1, $text );
+ } else {
+ print $text if defined $text;
+ }
+
+ } elsif ( $cmd =~ m(^ok(?:\s+or\s+(.*))?$) ) {
+
+ $rc ? fail( "ok, rc=$rc from $lec", $1 || '' ) : ok();
+
+ } elsif ( $cmd =~ m(^!ok(?:\s+or\s+(.*))?$) ) {
+
+ $rc ? ok() : fail( "!ok, rc=0 from $lec", $1 || '' );
+
+ } elsif ( $cmd =~ m(^/(.*?)/(?:\s+or\s+(.*))?$) ) {
+
+ expect( $1, $2 );
+
+ } elsif ( $cmd =~ m(^!/(.*?)/(?:\s+or\s+(.*))?$) ) {
+
+ not_expect( $1, $2 );
+
+ } else {
+
+ _sh($cmd);
+
+ }
+}
+
+# currently unused
+sub executable {
+ my $cmd = shift;
+ # path supplied
+ $cmd =~ m(/) and -x $cmd and return 1;
+ # barename; look up in $PATH
+ for my $p (@PATH) {
+ -x "$p/$cmd" and return 1;
+ }
+ return 0;
+}
+
+sub ok {
+ $testnum++;
+ say "ok ($testnum)" if $ENV{HARNESS_ACTIVE};
+}
+
+sub fail {
+ $testnum++;
+ say "not ok ($testnum)" if $ENV{HARNESS_ACTIVE};
+
+ my $die = 0;
+ my ( $msg1, $msg2 ) = @_;
+ if ($msg2) {
+ # if arg2 is non-empty, print it regardless of debug level
+ $die = 1 if $msg2 =~ s/^die //;
+ say STDERR "# $msg2";
+ }
+
+ local $TSH_VERBOSE = 1 if $ENV{TSH_ERREXIT};
+ dbg( 1, "FAIL: $msg1", $testname || '', "test number $testnum", "L: $line", "results:\n$text" );
+
+ # count the error and add the testname to the list if it is set
+ $err_count++;
+ push @errors_in, $testname if $testname;
+
+ return unless $die or $ENV{TSH_ERREXIT};
+ dbg( 1, "exiting at cmd $cmd\n" );
+
+ exit( $rc || 74 );
+}
+
+sub cmp {
+ # compare input string with second input string or text()
+ my $in = shift;
+ my $text = ( @_ ? +shift : text() );
+
+ if ( $text eq $in ) {
+ ok();
+ } else {
+ fail( 'cmp failed', '' );
+ dbg( 4, "\n\ntext = <<<$text>>>, in = <<<$in>>>\n\n" );
+ }
+}
+
+sub expect {
+ my ( $patt, $msg ) = @_;
+ $msg =~ s/^\s+// if $msg;
+ my $sm;
+ if ( $sm = sm($patt) ) {
+ dbg( 4, " M: $sm" );
+ ok();
+ } else {
+ fail( "/$patt/", $msg || '' );
+ }
+}
+
+sub not_expect {
+ my ( $patt, $msg ) = @_;
+ $msg =~ s/^\s+// if $msg;
+ my $sm;
+ if ( $sm = sm($patt) ) {
+ dbg( 4, " M: $sm" );
+ fail( "!/$patt/", $msg || '' );
+ } else {
+ ok();
+ }
+}
+
+sub sm {
+ # smart match? for now we just do regex match
+ my $patt = shift;
+
+ return ( $text =~ qr($patt) ? $& : "" );
+}
+
+sub trim_ws {
+ local $_ = shift;
+ s/^\s+//; s/\s+$//;
+ return $_;
+}
+
+sub is_comment_or_empty {
+ local $_ = shift;
+ chomp; $_ = trim_ws($_);
+ if (/^##\s(.*)/) {
+ $testname = $1;
+ say "# $1";
+ }
+ return ( /^#/ or /^$/ );
+}
+
+sub cmds {
+ local $_ = shift;
+ chomp; $_ = trim_ws($_);
+
+ # split on unescaped ';'s, then unescape the ';' in the results
+ my @cmds = map { s/\\;/;/g; $_ } split /(?<!\\);/;
+ @cmds = grep { $_ = trim_ws($_); /\S/; } @cmds;
+ return @cmds;
+}
+
+sub dbg {
+ return unless $TSH_VERBOSE;
+ my $level = shift;
+ return unless $TSH_VERBOSE >= $level;
+ my $all = join( "\n", grep( /./, @_ ) );
+ chomp($all);
+ $all =~ s/\n/\n\t/g;
+ say STDERR "# $all";
+}
+
+sub ddump {
+ for my $i (@_) {
+ print STDERR "DBG: " . Dumper($i);
+ }
+}
+
+sub usage {
+ # TODO
+ print "Please see documentation at:
+
+ https://github.com/sitaramc/tsh/blob/master/README.mkd
+
+Meanwhile, here are your local 'macro' definitions:
+
+";
+ my %m = read_rc_file();
+ my @m = map { "$_\t$m{$_}\n" } sort keys %m;
+ $tabstop = 16;
+ print join( "", expand(@m) );
+ exit 1;
+}
+
+# ----------------------------------------------------------------------
+# git-specific internal service subs
+
+sub dummy_commits {
+ for my $f ( split ' ', shift ) {
+ if ( $f eq 'tt' or $f eq 'test-tick' ) {
+ test_tick();
+ next;
+ }
+ my $ts = ( $tick ? gmtime( $tick + 19800 ) : gmtime() );
+ _sh("echo $f at $ts >> $f && git add $f && git commit -m '$f at $ts'");
+ }
+}
+
+sub test_tick {
+ unless ( $ENV{HARNESS_ACTIVE} ) {
+ sleep 1;
+ return;
+ }
+ $tick += 60 if $tick;
+ $tick ||= 1310000000;
+ $ENV{GIT_COMMITTER_DATE} = "$tick +0530";
+ $ENV{GIT_AUTHOR_DATE} = "$tick +0530";
+}
+
+# ----------------------------------------------------------------------
+# the internal macros, for easy reference and reading
+
+sub read_rc_file {
+ my $rcfile = "$HOME/.tshrc";
+ my $rctext;
+ if ( -r $rcfile ) {
+ local $/ = undef;
+ open( my $rcfh, "<", $rcfile ) or die "this should not happen: $!\n";
+ $rctext = <$rcfh>;
+ } else {
+ # this is the default "rc" content
+ $rctext = "
+ add = git add
+ branch = git branch
+ clone = git clone
+ checkout = git checkout
+ commit = git commit
+ fetch = git fetch
+ init = git init
+ push = git push
+ reset = git reset
+ tag = git tag
+
+ empty = git commit --allow-empty -m empty
+ push-om = git push origin master
+ reset-h = git reset --hard
+ reset-hu = git reset --hard \@{u}
+ "
+ }
+
+ # ignore everything except lines of the form "aa = bb cc dd"
+ my %commands = ( $rctext =~ /^\s*([-.\w]+)\s*=\s*(\S.*)$/gm );
+ return %commands;
+}
+
+1;
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-17 20:32:43 +0000