package Test::Smoke::Smoker;
use strict;

# $Id: Smoker.pm 433 2003-09-23 18:26:59Z abeltje $
use vars qw( $VERSION );
$VERSION = '0.005';

use Cwd;
use File::Spec;
use Config;
use Test::Smoke::Util;
BEGIN { eval q{ use Time::HiRes qw( time ) } }

my %CONFIG = (
    df_ddir           => File::Spec->curdir(),
    df_v              => 0,
    df_run            => 1,
    df_fdir           => undef,
    df_is56x          => 0,
    df_locale         => '',
    df_force_c_locale => 0,
    df_defaultenv     => 0,

    df_is_win32       => $^O eq 'MSWin32',
    df_w32cc          => 'MSVC60',
    df_w32make        => 'nmake',
    df_w32args        => [ ],

    df_makeopt        => "",
    df_testmake       => 'make',
);

# Define some constants that we can use for
# specifying how far "make" got.
sub BUILD_MINIPERL() { -1 } # but no perl
sub BUILD_PERL    () {  1 } # ok
sub BUILD_NOTHING () {  0 } # not ok

=head1 NAME

Test::Smoke::Smoker - OO interface to do one smoke cycle.

=head1 SYNOPSIS

    use Test::Smoke;
    use Test::Smoke::Smoker;

    open LOGFILE, "> mktest.out" or die "Cannot create 'mktest.out': $!";
    my $buildcfg = Test::SmokeBuildCFG->new( $conf->{cfg} );
    my $policy = Test::Smoke::Policy->new( '../', $conf->{v} );
    my $smoker = Test::Smoke::Smoker->new( \*LOGFILE, $conf );

    foreach my $config ( $buildcfg->configurations ) {
        $smoker->smoke( $config, $policy );
    }

=head1 DESCRIPTION

=head1 METHODS

=over 4

=item Test::Smoke::Smoker->new( \*GLOB, %args )

C<new()> takes a mandatory (opened) filehandle and some other options:

    ddir            build directory
    fdir            The forest source
    v               verbose level: 0..2
    defaultenv      'make test' without $ENV{PERLIO}
    is56x           skip the PerlIO stuff?
    locale          do another testrun with $ENV{LC_ALL}
    force_c_locale  set $ENV{LC_ALL} = 'C' for all smoke runs

    is_win32        is this MSWin32?
    w32cc           the CCTYPE for MSWin32 (MSVCxx BORLAND GCC)
    w32make         the maker to use for CCTYPE

=cut

sub new {
    my $proto = shift;
    my $class = ref $proto || $proto;

    my $fh = shift;

    unless ( ref $fh eq 'GLOB' ) {
        require Carp;
        Carp::croak sprintf "Usage: %s->new( \\*FH, %%args )", __PACKAGE__;
    }

    my %args_raw = @_ ? UNIVERSAL::isa( $_[0], 'HASH' ) ? %{ $_[0] } : @_ : ();

    my %args = map {
        ( my $key = $_ ) =~ s/^-?(.+)$/lc $1/e;
        ( $key => $args_raw{ $_ } );
    } keys %args_raw;

    my %fields = map {
        my $value = exists $args{$_} ? $args{ $_ } : $CONFIG{ "df_$_" };
        ( $_ => $value )
    } keys %{ Test::Smoke::Smoker->config( 'all_defaults' ) };

    $fields{logfh}  = $fh;
    select( ( select( $fh ), $|++ )[0] );
    $fields{defaultenv} = 1 if $fields{is56x};

    bless { %fields }, $class;
}

sub mark_in {
    my $self = shift;
    $self->log( sprintf "Started smoke at %d\n", time() );
}

sub mark_out {
    my $self = shift;
    $self->log( sprintf "Stopped smoke at %d\n", time() );
}

=item Test::Smoke::Smoker->config( $key[, $value] )

C<config()> is an interface to the package lexical C<%CONFIG>, 
which holds all the default values for the C<new()> arguments.

With the special key B<all_defaults> this returns a reference
to a hash holding all the default values.

=cut

sub config {
    my $dummy = shift;

    my $key = lc shift;

    if ( $key eq 'all_defaults' ) {
        my %default = map {
            my( $pass_key ) = $_ =~ /^df_(.+)/;
            ( $pass_key => $CONFIG{ $_ } );
        } grep /^df_/ => keys %CONFIG;
        return \%default;
    }

    return undef unless exists $CONFIG{ "df_$key" };

    $CONFIG{ "df_$key" } = shift if @_;

    return $CONFIG{ "df_$key" };
}

=item $smoker->tty( $message )

Prints a message to the default filehandle.

=cut

sub tty {
    my $self = shift;
    my $message = join "", @_;
    print $message;
}

=item $smoker->log( $message )

Prints a message to the logfile, filehandle.

=cut

sub log {
    my $self = shift;
    my $message = join "", @_;
    print { $self->{logfh} } $message;
}

=item $smoker->ttylog( $message )

Prints a message to both the default and the logfile filehandles.

=cut

sub ttylog {
    my $self = shift;
    $self->log( @_ );
    $self->tty( @_ );
}

=item $smoker->smoke( $config[, $policy] )

C<smoke()> takes a B<Test::Smoke::BuildCFG::Config> object and runs all 
the basic steps as (private) object methods.

=cut

sub smoke {
    my( $self, $config, $policy ) = @_;

    $self->make_distclean;

    $self->handle_policy( $policy, $config->policy );

    $self->Configure( $config ) or do {
        $self->ttylog( "Unable to configure perl in this configuration\n" );
        return 0;
    };

    my $build_stat = $self->make_;
  
    $build_stat == BUILD_MINIPERL and do {
        $self->ttylog( "Unable to make anything but miniperl",
                       " in this configuration\n" );
        return $self->make_minitest( "$config" );
    };
       
    $build_stat == BUILD_NOTHING and do {
        $self->ttylog( "Unable to make perl in this configuration\n" );
        return 0;
    };

    $self->make_test_prep or do {
        $self->ttylog( "Unable to test perl in this configuration\n" );
        return 0;
    };

    $self->make_test( "$config" );

    return 1;
}

=item $smoker->make_distclean( )

C<make_distclean()> runs C<< make -i distclean 2>/dev/null >>

=cut

sub make_distclean {
    my $self = shift;
    
    $self->tty( "make distclean ..." );
    if ( $self->{fdir} && -d $self->{fdir} ) {
        require Test::Smoke::Syncer;
        my %options = (
            hdir => $self->{fdir},
            ddir => cwd(),
            v    => 0,
        );
        my $distclean = Test::Smoke::Syncer->new( hardlink => %options );
        $distclean->clean_from_directory( $self->{fdir}, 'mktest.out' );
    } else {
        $self->_make( "-i distclean 2>/dev/null" );
    }
}

=item $smoker->handle_policy( $policy, @substs );

C<handle_policy()> will try to apply the substition rules and then 
write the file F<Policy.sh>.

=cut

sub handle_policy {
    my $self = shift;
    my( $policy, @substs ) = @_;

    return unless UNIVERSAL::isa( $policy, 'Test::Smoke::Policy' );

    $self->tty( "\nCopy Policy.sh ..." );
    $policy->reset_rules;
    if ( @substs ) {
        $policy->set_rules( $_ ) foreach @substs;
    }
    $policy->write;
}

=item $smoker->Configure( $config )

C<Configure()> sorts out the MSWin32 mess and calls F<./Configure>

returns true if a makefile was created

=cut

sub Configure {
    my $self = shift;
    my( $config, $policy ) = @_;

    $self->tty( "\nConfigure ..." );
    my $makefile = '';
    if ( $self->{is_win32} ) {
        my @w32args = @{ $self->{w32args} };
        @w32args = @w32args[ 4 .. $#w32args ];
        $makefile = $self->_run( "./Configure $config", 
                                 \&Test::Smoke::Util::Configure_win32,
                                 $self->{w32make}, @w32args  );
    } else {
        $self->_run( "./Configure -des $config" );
        $makefile = 'Makefile';
    }
    return -f $makefile;
}

=item $smoker->make_( )

C<make_()> will run make.

returns true if a perl executable is found

=cut

sub make_ {
    my $self = shift;

    $self->tty( "\nmake ..." );
    $self->_make( "" );

    my $exe_ext  = $Config{_exe} || $Config{exe_ext};
    my $miniperl = "miniperl$exe_ext";
    my $perl     = "perl$exe_ext";
    -x $miniperl or return BUILD_NOTHING;
    return -x $perl ? BUILD_PERL : BUILD_MINIPERL;
}

=item make_test_prep( )

Run C<< I<make test-perp> >> and check if F<t/perl> exists.

=cut

sub make_test_prep {
    my $self = shift;

    my $exe_ext = $Config{_exe} || $Config{exe_ext};
    my $perl = File::Spec->catfile( "t", "perl$exe_ext" );

    $self->{run} and unlink $perl;
    $self->_make( "test-prep" );

    return $self->{is_win32} ? -f $perl : -l $perl;
}

=item $smoker->make_test( )

=cut

sub make_test {
    my $self = shift;
    my( $config_args ) = @_;

    $self->tty( "\n Tests start here:\n" );

    # No use testing different io layers without PerlIO
    # just output 'stdio' for mkovz.pl
    my @layers = ( ($config_args =~ /-Uuseperlio\b/) || $self->{defaultenv} )
               ? qw( stdio ) : qw( stdio perlio );

    if ( !($config_args =~ /-Uuseperlio\b/ || $self->{defaultenv}) && 
         $self->{locale} ) {
        push @layers, 'locale';
    }

    foreach my $perlio ( @layers ) {
        my $had_LC_ALL = exists $ENV{LC_ALL};
        local( $ENV{PERLIO}, $ENV{LC_ALL}, $ENV{PERL_UNICODE} ) =
             ( "", defined $ENV{LC_ALL} ? $ENV{LC_ALL} : "", "" );
        my $perlio_logmsg = $perlio;
        if ( $perlio ne 'locale' ) {
            $ENV{PERLIO} = $perlio;
            $self->{is_win32} and $ENV{PERLIO} .= " :crlf";
            $ENV{LC_ALL} = 'C' if $self->{force_c_locale};
            $ENV{LC_ALL} or delete $ENV{LC_ALL};
            delete $ENV{PERL_UNICODE};
            # make default 'make test' runs possible
            delete $ENV{PERLIO} if $self->{defaultenv};
        } else {
            $ENV{PERL_UNICODE} = ""; # See -C in perlrun
            $ENV{LC_ALL} = $self->{locale};
            $perlio_logmsg .= ":$self->{locale}";
        }
        $self->ttylog( "PERLIO = $perlio_logmsg\t" );

        unless ( $self->{run} ) {
            $self->ttylog( "bailing out (--norun)...\n" );
            next;
	}

        my $test_target = $self->{is56x} ? 'test' : '_test';
        local *TST;
        # MSWin32 builds from its own directory
        if ( $self->{is_win32} ) {
            chdir "win32" or die "unable to chdir () into 'win32'";
            # Same as in make ()
            open TST, "$self->{w32make} -f smoke.mk $test_target |";
            chdir ".." or die "unable to chdir () out of 'win32'";
        } else {
            local $ENV{PERL} = "./perl";
            open TST, "$self->{testmake} $test_target |" or do {
                use Carp;
                Carp::carp "Cannot fork 'make _test': $!";
                next;
            };
        }

        my @nok = ();
        select ((select (TST), $| = 1)[0]);
        while (<TST>) {
            $self->{v} > 2 and $self->tty( $_ );
            skip_filter( $_ ) and next;

            # make mkovz.pl's life easier
            s/(.)(PERLIO\s+=\s+\w+)/$1\n$2/;

            if (m/^u=.*tests=/) {
                s/(\d\.\d*) /sprintf "%.2f ", $1/ge;
                $self->log( $_ );
            } else {
                push @nok, $_;
            }
            $self->tty( $_ );
        }
        close TST or do {
            my $error = $! || ( $? >> 8);
            require Carp;
            Carp::carp "\nError while reading test-results: $error";
        };
#        $self->log( map { "    $_" } @nok );
        if (grep m/^All tests successful/, @nok) {
            $self->log( "All tests successful.\n" );
            $self->tty( "\nOK, archive results ..." );
            $self->{patch} and $nok[0] =~ s/\./ for .patch = $self->{patch}./;
        } else {
            $self->extend_with_harness( @nok );
        }
        $self->tty( "\n" );
        !$had_LC_ALL && exists $ENV{LC_ALL} and delete $ENV{LC_ALL};
    }

    return 1;
}

=item $self->extend_with_harness( @nok )

=cut

sub extend_with_harness {
    my( $self, @nok ) = @_;
    my @harness;
    for ( @nok ) {
        m!^(?:\.\.[\\/])?(\w+/[-\w/]+).*! or next;
        # Remeber, we chdir into t, so -f is false for op/*.t etc
        my $test_name = "$1.t";
        push @harness, (-f $test_name) 
            ? File::Spec->catdir( File::Spec->updir, $test_name )
            : $test_name;
    }
    if ( @harness ) {
        local $ENV{PERL_SKIP_TTY_TEST} = 1;
	        $self->tty( "\nExtending failures with Harness\n" );
        my $harness = $self->{is_win32} ?
        join " ", map { 
            s{^\.\.[/\\]}{};
	            m/^(?:lib|ext)/ and $_ = "../$_";
            $_;
        } @harness : "@harness";
        my $changed_dir;
        chdir 't' and $changed_dir = 1;
        my $harness_all_ok = 0;
        my $harness_out = join "", map {
            my( $name, $fail ) = 
                m/(\S+\.t)\s+.+%\s+([\d?]+(?:[-\s]+\d+)*)/;
            if ( $name ) {
                my $dots = '.' x (40 - length $name );
                "    $name${dots}FAILED $fail\n";
            } else {
                ( $fail ) = m/^\s+(\d+(?:[-\s]+\d+)*)/;
                " " x 41 . "$fail\n";
            }
        } grep m/^\s+\d+(?:[-\s]+\d+)/ ||
               m/\S+\.t\s+.+%\s+[\d?]+(?:[-\s+]\d+)*/ => map {
            /All tests successful/ && $harness_all_ok++;
            $self->{v} > 1 and $self->tty( $_ );
            $_;
        } $self->_run( "./perl harness $harness" );
        $harness_out =~ s/^\s*$//;
        if ( $harness_all_ok ) {
            $harness_out ||= @nok
                ? "Inconsistent test results (between _test and harness):\n" . 
                  join "", map "    $_" => @nok
                : "All tests successful.";
        } else {
            $harness_out ||= join "", map "    $_" => @nok;
        }
        $self->ttylog("\n", $harness_out, "\n" );
        $changed_dir and chdir File::Spec->updir;
    }
}

=item $self->make_minitest( $cfgargs )

C<make> was unable to build a I<perl> executable, but managed to build
I<miniperl>, so we do C<< S<make minitest> >>.

=cut

sub make_minitest {
    my $self = shift;

    $self->ttylog( "PERLIO = minitest\t" );
    local *TST;
    # MSWin32 builds from its own directory
    if ( $self->{is_win32} ) {
        chdir "win32" or die "unable to chdir () into 'win32'";
        # Same as in make ()
        open TST, "$self->{w32make} -f smoke.mk minitest |";
        chdir ".." or die "unable to chdir () out of 'win32'";
    } else {
        local $ENV{PERL} = "./perl";
        open TST, "make minitest |" or do {
            use Carp;
            Carp::carp "Cannot fork 'make _test': $!";
            return 0;
        };
    }

    my @nok = ();
    select ((select (TST), $| = 1)[0]);
    while (<TST>) {
        $self->{v} >= 2 and $self->tty( $_ );
        skip_filter( $_ ) and next;
        # make mkovz.pl's life easier
        s/(.)(PERLIO\s+=\s+\w+)/$1\n$2/;

        if (m/^u=.*tests=/) {
            s/(\d\.\d*) /sprintf "%.2f ", $1/ge;
            $self->log( $_ );
        } else {
            push @nok, $_;
        }
        $self->tty( $_ );
    }
    close TST or do {
        require Carp;
        Carp::carp "Error while reading pipe: $!";
    };
    $self->ttylog( map { "    $_" } @nok );

    $self->tty( "\nOK, archive results ..." );
    $self->tty( "\n" );
    return 1;
}

=item $self->_run( $command[, $sub[, @args]] )

C<run()> returns C<< qx( $command ) >> unless C<$sub> is specified.
If C<$sub> is defined (and a coderef) C<< $sub->( $command, @args ) >> will
be called.

=cut

sub _run {
    my $self = shift;
    my( $command, $sub, @args ) = @_;

    defined $sub and return &$sub( $command, @args );

    return qx( $command );
}

=item $self->_make( $command )

C<_make()> calls C<< run( "make $command" ) >>, and does some extra
stuff to help MSWin32 (the right maker, the directory).

=cut

sub _make {
    my $self = shift;
    my $cmd = shift;
    $self->{makeopt} and $cmd = "$self->{makeopt} $cmd";

    $self->{is_win32} or return $self->_run( "make $cmd" );

    my $kill_err;
    # don't capture STDERR
    # @ But why? and what if we do it DOSish? 2>NUL:

    my $win32_maker = $self->{w32make};
    $cmd =~ s|2\s*>\s*/dev/null\s*$|| and $kill_err = 1;

    $cmd = "$win32_maker -f smoke.mk $cmd";
    chdir "win32" or die "unable to chdir () into 'win32'";
    $self->_run( $kill_err ? qq{$^X -e "close STDERR; system '$cmd'"} : $cmd );
    chdir ".." or die "unable to chdir() out of 'win32'";
}

1;

=back

=head1 SEE ALSO

L<Test::Smoke>

=head1 COPYRIGHT

(c) 2002-2003, All rights reserved.

  * Abe Timmerman <abeltje@cpan.org>

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

See:

=over 4

=item * http://www.perl.com/perl/misc/Artistic.html

=item * http://www.gnu.org/copyleft/gpl.html

=back

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

=cut