File Coverage

blib/lib/Test/C2FIT.pm

Criterion	Covered	Total	%
statement	27	172	15.7
branch	0	70	0.0
condition	0	9	0.0
subroutine	9	33	27.2
pod	2	3	66.6
total	38	287	13.2

package Test::C2FIT;

#use 5.008006;
use Test::C2FIT::FileRunner;
use Test::C2FIT::WikiRunner;
use Exporter();
use Getopt::Std;
@ISA    = qw(Exporter);
@EXPORT = qw(file_runner wiki_runner fit_shell);
use strict;
use warnings;

our $VERSION = '0.08';

sub file_runner {
    my $param = {};
    die "unsupported param!" unless getopt( "L:", $param );
    local $SIG{'__WARN__'} = _commonLogging( $param->{L} );

    unshift( @INC, '.' ) unless grep { /^\.$/ } @INC;
    Test::C2FIT::FileRunner->new()->run(@ARGV);
}

sub wiki_runner {
    my $param = {};
    die "unsupported param!" unless getopt( "L:", $param );
    local $SIG{'__WARN__'} = _commonLogging( $param->{L} );

    unshift( @INC, '.' ) unless grep { /^\.$/ } @INC;
    Test::C2FIT::WikiRunner->new()->run(@ARGV);
}

sub fit_shell {
    my $shell = Test::C2FIT::_Shell->new();
    $shell->init;
    $shell->runShell(*STDIN);
}

sub _commonLogging {
    my $loglevel = shift;
    $loglevel = 3 unless defined($loglevel);

    return sub {
        local ( $_, $&, $1 );

        if ( defined( $_[0] ) && $_[0] =~ /^(\d+)/ ) {
            return unless $1 >= $loglevel;
        }

# my ($sec,$min,$hour,$mday,$mon,$year,undef,undef,undef) = localtime(time);
# $mon++;
# $year = $year + 1900;
# print STDERR sprintf("%02d.%02d.%04d %02d:%02d:%02d ",$mday,$mon,$year,$hour,$min,$sec);
        print STDERR @_;
    };
}

#
#   (help-) Package implementing an interactive shell
#
{

    package Test::C2FIT::_Shell;
    use Config;
    use strict;
    use warnings;

    sub new {
        my $pkg  = shift;
        my $self = {
            lastCmd    => undef,
            perlBinary => $Config{perlpath},
            options    => {
                input     => ".",
                output    => ".",
                inc       => ".",
                perl_opt  => undef,
                log_level => undef,
                runner    => 'file_runner',
                verbose   => 0,
            },
            cmdDispatch => {
                help   => \&Test::C2FIT::_Shell::help,
                show   => \&Test::C2FIT::_Shell::show,
                set    => \&Test::C2FIT::_Shell::set,
                run    => \&Test::C2FIT::_Shell::run,
                runall => \&Test::C2FIT::_Shell::runall,
                nop    => sub { 1 },
                quit   => sub { undef },
            },
            parseRunDispatch => {
                rerun  => \&Test::C2FIT::_Shell::rerun,
                infile => \&Test::C2FIT::_Shell::runInfile,
                files  => \&Test::C2FIT::_Shell::runFiles,
                inout  => \&Test::C2FIT::_Shell::runInOut,
            }
        };
        return bless $self, $pkg;
    }

    sub init {
        my $self = shift;

        #
        #   check if input/output/lib exists
        #
        my $v = {};

        $v->{input}  = "input"  if ( -d "./input" );
        $v->{output} = "output" if ( -d "./output" );
        $v->{inc}    = "lib"    if ( -d "./lib" );

        if ( scalar(%$v) ) {
            while ( my ( $ik, $iv ) = each(%$v) ) {
                $self->{options}->{$ik} = $iv;
            }
            $self->msg(
                "INFO: input/ouptut/lib diretories found, using them!\n");
            $self->show;
        }
    }

    sub help {
        print <<'_EOH_'; return 1;
# Supported commands:
# help      - show this help
# show      - show variables
# set   - set operational variables
#   input                - directory where html files are searched
#   output               - directory where result html will be written
#   inc                  - INC path. This will be added to the perl-process
#                          upon creation (perl -Ip1 -Ip2 etc.)
#                          multiple Entries should be separated either by
#                          colon (:) or by semicolon, e.g. lib:.:../test
#                          if @ is given, then then contents of @INC of the
#                          fit_shell-process will be set
#   perl_opt             - optional perl-parameters to the perl process.
#                          e.g. -d for debugging
#   log_level            - will be passed to the runner
#   runner               - either file_runner or wiki_runner
#   verbose              - either 0 or 1. When 1, then the command actually
#                          run will be printed too
# run      - run a document. There are different ways to specify it:
#   run BinaryChop       - runs a file named $input/BinaryChop.html
#                          output goes to $output/BinaryChop.html
#   run BinaryChop out   - runs a file named $input/BinaryChop
#                          (without extension!!!)
#                          output goes to $output/out (without extension!)
#
#   run                  - rerun last run command
#
#   run *.htm*           - run all files $input/*.htm*
#                          (same as runall)
#   run a*.html b*.html  - run all files $input/a*.html $input/b*.html
#                          (Difference to the other two-Param run-call:
#                           here, wildcards are used)
#   runall               - same as run *.htm*
#
#   quit                 - terminate this shell
#
#   For each run, a new perl process is started.
#
#   There are some shortcuts/aliases too:
#
#   !                   is an alias for "run"
#   [EMPTY LINE]        (i.e. just pressing the enter key) rerun last run
#
#   Lines starting with # will be ignored
#
#   All output of the fit_shell starts with "#", so you can easily eliminate
#   it (e.g. grep -v "^#")
#
_EOH_
    }

    sub msg {
        my $self = shift;
        print "# ", @_;
        1;
    }

    sub show {
        my $self = shift;
        my @k    = sort keys %{ $self->{options} };

        for my $k (@k) {
            my $v = $self->{options}->{$k};
            $v = "" unless defined($v);
            print sprintf( "# %10s: %s\n", $k, $v );
        }
        1;
    }

    sub set {
        my ( $self, $rest ) = @_;
        return $self->msg("WARN: wrong syntax for set!\n")
          unless $rest =~ /(\S+)(?:\s+(\S.*))?$/;

        my $key = $1;
        my $val = $2;

        return $self->msg("WARN: invalid variable $key!\n")
          unless exists $self->{options}->{$key};

        if ( $key eq "inc" && $val eq "@" ) {
            $val = join( ":", @INC );
        }

        $self->{options}->{$key} = $val;
        $self->{lastCmd} = undef;
        1;
    }

    sub runall {
        my $self = shift;
        $self->run("*.htm*");
    }

    sub run {
        my ( $self, $rest ) = @_;
        my $dispatch = $self->{parseRunDispatch};

        my ( $key, @vals ) = $self->parseRunCmd($rest);
        die "internal error. unknown state: $key\n"
          unless exists $dispatch->{$key};

        my $code = $dispatch->{$key};
        return $code->( $self, @vals );
    }

    sub rerun {
        my $self = shift;
        return $self->msg("WARN: no cmd to rerun!\n")
          unless defined( $self->{lastCmd} );
        return $self->_run( $self->{lastCmd} );
    }

    #
    #   runInOut($in,$out) - both filenames with path and suffix
    #
    sub runInOut {
        my ( $self, $in, $out ) = @_;

        return $self->msg("WARN: in and out identical: $in Will be ignored!\n'")
          if $in eq $out;

        my $cmd = $self->_buildCmd;
        $cmd .= " $in $out";
        return $self->_run($cmd);
    }

    #
    #   runInfile (path+filename) * optionally without the .html suffix
    #
    sub runInfile {
        my ( $self, $in ) = @_;
        my $input  = quotemeta( $self->{options}->{input} );
        my $output = $self->{options}->{output};

        $in .= ".html" unless $in =~ /\.html$/i;
        my $out = $in;
        $out =~ s/^$input/$output/;

        return $self->runInOut( $in, $out );
    }

    #
    #   runFiles(@files) - list of input file names with path and extension
    #
    sub runFiles {
        my ( $self, @files ) = @_;
        for my $f (@files) {
            $self->runInfile($f);
        }
        1;
    }

    sub _run {
        my ( $self, $cmd ) = @_;
        die "no cmd given!" unless defined($cmd);
        $self->{lastCmd} = $cmd;
        $self->msg("# CMD:$cmd\n") if $self->{options}->{verbose};
        system($cmd);
        1;
    }

    sub _buildCmd {    # setup the command up to ARGV
        my $self    = shift;
        my $cmd     = $self->{perlBinary};
        my $options = $self->{options};

        $cmd .= " " . $options->{perl_opt} . " "
          if defined( $options->{perl_opt} );

        if ( defined( $options->{inc} ) ) {
            my @inc = split( /[:;]/, $options->{inc} );
            my $inc = " -I" . join( " -I", @inc );
            $cmd .= $inc;
        }

        $cmd .= " -MTest::C2FIT -e " . $options->{runner} . " -- ";

        my $logLevel = $options->{log_level};
        $cmd .= " -L $logLevel " if defined($logLevel);

        return $cmd;
    }

    sub parseRunCmd {
        my ( $self, $rest ) = @_;
        my $input        = $self->{options}->{input};
        my $output       = $self->{options}->{output};
        my $hasWildcards = 0;
        my @files        = ();

        return ("rerun") unless defined($rest);

        my @items = map { /\*/ && $hasWildcards++; $_ } split /\s+/, $rest;

        if ($hasWildcards) {
            for my $item (@items) {
                push( @files, glob("$input/$item") );
            }
            return ( "files", @files );
        }
        if ( 2 == @items ) {
            return ( "inout", "$input/$items[0]", "$output/$items[1]" );
        }
        return ( "infile", "$input/$items[0]" );
    }

    sub runShell {    # main loop of fit_shell
        my ( $self, $inFH ) = @_;
        my $line;
        my $dispatch = $self->{cmdDispatch};
        my $prompt   = ( -t "$inFH" ) ? "fit> " : "";

        $| = 1;

        print $prompt;
        while ( $line = <$inFH> ) {
            $line =~ s/(\012\015?|\015\012?)$//;
            my ( $cmd, $rest ) = $self->parseCmd($line);

            die "internal error. Unknown command/state: $cmd\n"
              unless exists $dispatch->{$cmd};

            my $code = $dispatch->{$cmd};
            my $rv = $code->( $self, $rest );
            last unless $rv;
            print $prompt;
        }
    }

    sub parseCmd {
        my ( $self, $line ) = @_;

        return ( "run", undef ) if !defined($line) || $line eq "";
        return ("nop") if $line =~ /^\s*#/;

        $line =~ s/^\s+//;
        $line =~ s/\s+$//;

        if ( $line =~ /^!\s*(\S.*)?$/ ) {    # ! is alias for "run"
            return ( "run", $1 );
        }
        if ( $line =~ /^(\w+)\b\s*(\S.*)?$/ ) {
            return ( $1, $2 );
        }
        return ("nop");
    }

    1;
};

1;

__END__