path: root/src/lib/Gitolite/Test/Tsh.pm

#!/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;