Test::Smoke::Util - Take out some of the functions of the smoke suite.

  * H. Merijn Brand <h.m.brand@hccnet.nl>
  * Nicholas Clark <nick@unfortu.net>
  * Jarkko Hietaniemi <jhi@iki.fi>
  * Abe Timmerman <abeltje@cpan.org>

  * <http://www.perl.com/perl/misc/Artistic.html>,
  * <http://www.gnu.org/copyleft/gpl.html>

package Test::Smoke::Util;
use strict;

# $Id: Util.pm 1246 2009-10-21 16:54:39Z abeltje $
use vars qw( $VERSION @EXPORT @EXPORT_OK $NOCASE );
$VERSION = '0.58';

use base 'Exporter';
@EXPORT = qw( 
    &Configure_win32
    &get_cfg_filename &get_config
    &get_patch
    &skip_config &skip_filter
);

@EXPORT_OK = qw(
    &grepccmsg &get_local_patches &set_local_patch
    &get_ncpu &get_smoked_Config &parse_report_Config 
    &get_regen_headers &run_regen_headers
    &whereis &clean_filename
    &calc_timeout &time_in_hhmm
    &do_pod2usage
    &set_vms_rooted_logical
);

use Text::ParseWords;
use File::Spec::Functions;
use File::Find;
use Cwd;

$NOCASE = $^O eq 'VMS';

my %win32_makefile_map = (
    nmake => "Makefile",
    dmake => "makefile.mk",
);

sub Configure_win32 {
    my($command, $win32_maker, @args ) = @_;
    $win32_maker ||= 'nmake'; $win32_maker = lc $win32_maker;
    my $is_dmake = $win32_maker eq 'dmake';
    my $is_nmake = $win32_maker eq 'nmake';

    local $_;
    my %opt_map = (
	"-Dusethreads"		=> "USE_ITHREADS",
	"-Duseithreads"		=> "USE_ITHREADS",
	"-Duseperlio"		=> "USE_PERLIO",
	"-Dusemultiplicity"	=> "USE_MULTI",
	"-Duseimpsys"		=> "USE_IMP_SYS",
	"-Uuseimpsys"		=> "USE_IMP_SYS",
        "-Dusemymalloc"         => "PERL_MALLOC",
        "-Duselargefiles"       => "USE_LARGE_FILES",
        "-Uuseshrplib"          => "BUILD_STATIC",
	"-DDEBUGGING"		=> "USE_DEBUGGING",
        "-DINST_DRV"            => "INST_DRV",
        "-DINST_TOP"            => "INST_TOP",
        "-DINST_VER"            => "INST_VER",
        "-DINST_ARCH"           => "INST_ARCH",
        "-Dcf_email"            => "EMAIL",
        "-DCCTYPE"              => "CCTYPE",
        "-Dgcc_v3_2"            => "USE_GCC_V3_2",
        "-Dbccold"              => "BCCOLD",
        "-DCCHOME"              => "CCHOME",
        "-DIS_WIN95"            => "IS_WIN95",
        "-DCRYPT_SRC"           => "CRYPT_SRC",
        "-DCRYPT_LIB"           => "CRYPT_LIB",
    );
# %opts hash-values:
# undef  => leave option as-is when no override (makefile default)
# 0      => disable option when no override  (forced default)
# (true) => enable option when no override (change value, unless
#           $key =~ /^(?:PERL|USE)_/) (forced default)
    my %opts = (
	USE_MULTI	=> 0,
	USE_ITHREADS	=> 0,
	USE_IMP_SYS	=> 0,
	USE_PERLIO	=> 1, # useperlio should be the default!
        PERL_MALLOC     => 0,
        USE_LARGE_FILES => 0,
        BUILD_STATIC    => 0,
	USE_DEBUGGING	=> 0,
        INST_DRV        => undef,
        INST_TOP        => undef,
        INST_VER        => '',
        INST_ARCH       => '',
        EMAIL           => undef,  # used to be $smoker,
        CCTYPE          => undef,  # used to be $win32_cctype,
        USE_GCC_V3_2    => 0,
        BCCOLD          => 0,
        CCHOME          => undef,
        IS_WIN95        => 0,
        CRYPT_SRC       => undef,
        CRYPT_LIB       => undef,
    );
#    my $def_re = qr/((?:(?:PERL|USE|IS)_\w+)|BCCOLD)/;
    my $def_re = '((?:(?:PERL|USE|IS)_\w+)|BCCOLD)';
    my @w32_opts = grep ! /^$def_re/, keys %opts;
    my $config_args = join " ", 
        grep /^-[DU][a-z_]+/, quotewords( '\s+', 1, $command );
    push @args, "config_args=$config_args";

    my @buildopt;
    $command =~ m{^\s*\./Configure\s+(.*)} or die "unable to parse command";
    my $cmdln = $1;
    foreach ( quotewords( '\s+', 1, $cmdln ) ) {
	m/^-[des]{1,3}$/ and next;
	m/^-Dusedevel$/  and next;
        if ( /^-Accflags=(['"]?)(.+)\1/ ) { #emacs' syntaxhighlite
           push @buildopt, $2;
           next;
        }
        my( $option, $value ) = /^(-[DU]\w+)(?:=(.+))?$/;
	die "invalid option '$_'" unless exists $opt_map{$option};
	$opts{$opt_map{$option}} = $value ? $value : 1;
        $option =~ /^-U/ and $opts{$opt_map{$option}} = 0;
    }

    # If you set one, we do all, so you can have fork()
    # unless you set -Uuseimpsys
    unless ( $cmdln =~ /-Uuseimpsys\b/ ) {
        if ( $opts{USE_MULTI} || $opts{USE_ITHREADS} || $opts{USE_IMP_SYS} ) {
            $opts{USE_MULTI} = $opts{USE_ITHREADS} = $opts{USE_IMP_SYS} = 1;
        }
    } else {
        if ( $opts{USE_MULTI} || $opts{USE_ITHREADS} ) {
            $opts{USE_MULTI} = $opts{USE_ITHREADS} = 1;
        }
    }

    # If you -Dgcc_v3_2 you 'll *want* CCTYPE = GCC
    $opts{CCTYPE} = "GCC" if $opts{USE_GCC_V3_2};

    # If you -Dbccold you 'll *want* CCTYPE = BORLAND
    $opts{CCTYPE} = "BORLAND" if $opts{BCCOLD};

    local (*ORG, *NEW);
    my $in =  "win32/$win32_makefile_map{ $win32_maker }";
    my $out = "win32/smoke.mk";

    open ORG, "< $in"  or die "unable to open '$in': $!";
    open NEW, "> $out" or die "unable to open '$out': $!";
    binmode NEW;
    my $donot_change = 0;
    while (<ORG>) {
        if ( $donot_change ) {
            # need to help the Win95 build
            $is_dmake and s/\b$win32_makefile_map{ $win32_maker }\b/smoke.mk/;
            if (m/^\s*CFG_VARS\s*=/) {
                my( $extra_char, $quote ) = $is_nmake
                    ? ( "\t", '"' ) : ("~", "" );
                $_ .= join "", map "\t\t$quote$_$quote\t${extra_char}\t\\\n", 
                                   grep /\w+=/, @args;
            }
            print NEW $_;
            next;
        } else {
            if ( $donot_change = /^#+ CHANGE THESE ONLY IF YOU MUST #+$/ ) {
                # We will now insert the BULDOPT lines
                my $bo_tmpl = $win32_maker eq 'nmake'
                    ? "BUILDOPT\t= \$(BUILDOPT) %s" : "BUILDOPT\t+= %s";
                my $buildopt = join "\n", 
                                    map sprintf( $bo_tmpl, $_ ) => @buildopt;
                $buildopt and $_ = "$buildopt\n$_\n"
            };
        }

        # Only change config stuff _above_ that line!
        if ( m/^\s*#?\s*$def_re(\s*\*?=\s*define)$/ ) {
            $_ = ($opts{$1} ? "" : "#") . $1 . $2 . "\n";
        } elsif (m/^\s*#?\s*(CFG\s*\*?=\s*Debug)$/) {
            $_ = ($opts{USE_DEBUGGING} ? "" : "#") . $1 . "\n";
        } elsif (m/^\s*#?\s*(BUILD_STATIC)\s*=\s*(.*)$/) {
            my( $macro, $mval ) = ( $1, $2 );
            if ( $config_args =~ /-([UD])useshrplib\b/ ) {
                $_ = ( $1 eq 'D' ? "#" : "" ) . "$macro = $mval\n";
            }
        } else {
            foreach my $cfg_var ( grep defined $opts{ $_ }, @w32_opts ) {
                if (  m/^\s*#?\s*($cfg_var\s*\*?=)\s*(.*)$/ ) {
                    $_ =  $opts{ $cfg_var } ?
                        "$1 $opts{ $cfg_var }\n":
                        "#$1 $2\n";
                    last;
                }
            }
        }
	print NEW $_;
    }
    close ORG;
    close NEW;
    return $out;
} # Configure_win32

sub set_vms_rooted_logical {
    my( $logical, $dir ) = @_;
    return unless $^O eq 'VMS';

    my $cwd = cwd();
    $dir ||= $cwd;

    -d $dir or do {
        require File::Path;
        File::Path::mkpath( $dir );
    };
    chdir $dir or die "Cannot chdir($dir): $!";

    # On older systems we might exceed the 8-level directory depth limit
    # imposed by RMS.  We get around this with a rooted logical, but we
    # can't create logical names with attributes in Perl, so we do it
    # in a DCL subprocess and put it in the job table so the parent sees it.

    open TSBRL, '> tsbuildrl.com' or die "Error creating DCL-file; $!";

    print TSBRL <<COMMAND;
\$ $logical = F\$PARSE("SYS\$DISK:[]",,,,"NO_CONCEAL")-".][000000"-"]["-"].;"+".]"
\$ DEFINE/JOB/NOLOG/TRANSLATION=CONCEALED $logical '$logical'
COMMAND
    close TSBRL;

    my $result = system '@tsbuildrl.com';
    1 while unlink 'tsbuildrl.com';
    chdir $cwd;
    return $result == 0;
}

sub get_cfg_filename {
    my( $cfg_name ) = @_;
    return $cfg_name if defined $cfg_name && -f $cfg_name;

    my( $base_dir ) = ( $0 =~ m|^(.*)/| ) || File::Spec->curdir;
    $cfg_name = File::Spec->catfile( $base_dir, 'smoke.cfg' );
    return $cfg_name  if -f $cfg_name && -s _;

    $base_dir = File::Spec->curdir;
    $cfg_name = File::Spec->catfile( $base_dir, 'smoke.cfg' );
    return $cfg_name if -f $cfg_name && -s _;

    return undef;
}

sub grepccmsg {
    my( $cc, $logfile, $verbose ) = @_;
    defined $logfile or return;
    $cc ||= 'gcc';
    my %OS2PAT = (
        'aix' => 
            # "foo.c", line n.c: pppp-qqq (W) ...error description...
            # "foo.c", line n.c: pppp-qqq (S) ...error description...
            '(^".+?", line \d+\.\d+: \d+-\d+ \([WS]\) .+?$)',

        'dec_osf' =>
            # DEC OSF/1, Digital UNIX, Tru64 (notice also VMS)
            # cc: Warning: foo.c, line nnn: ...error description...(error_tag)
            #     ...error line...
            # ------^
            # cc: Error: foo.c, line nnn: ...error description... (error_tag)
            #     ...error line...
            # ------^
            '(^cc: (?:Warning|Error): .+?^-*\^$)',

       'hpux' =>
            # cc: "foo.c"" line nnn: warning ppp: ...error description...
            # cc: "foo.c"" line nnn: error ppp: ...error description...
            '(^cc: ".+?", line \d+: (?:warning|error) \d+: .+?$)',

        'irix' =>
            # cc-pppp cc: WARNING File = foo.c, Line = nnnn
            # ...error description...
            # 
            # ...error line...
            #   ^
            # cc-pppp cc: ERROR File = foo.c, Line = nnnn
            # ...error description...
            # 
            # ...error line...
            #   ^
            '^(cc-\d+ cc: (?:WARNING|ERROR) File = .+?, ' .
            'Line = \d+.+?^\s*\^$)',

        'solaris' =>
            # "foo.c", line nnn: warning: ...error description...
            # "foo.c", line nnn: warning: ...:
            #         ...error description...
            # "foo.c", line nnn: syntax error ...
            '(^".+?", line \d+: ' .
            '(?:warning: (?:(?:.+?:$)?.+?$)|syntax error.+?$))',

        'vms' => # same compiler as Tru64, different message syntax
            #     ...error line...
            # ......^
            # %CC-W-MESSAGEID, ...error description...
            # at line number nnn in file foo.c
            '(^\n.+?\n^\.+?\^\n^\%CC-(?:I|W|E|F)-\w+, ' .
            '.+?\nat line number \d+ in file \S+?$)',

        'gcc' =>
            # foo.c: In function `foo':
            # foo.c:nnn: warning: ...
            # foo.c: In function `foo':
            # foo.c:nnn:ppp: warning: ...
                # Sometimes also the column is mentioned.
            # foo.c: In function `foo':
            # foo.c:nnn: error: ...
            # foo.c(:nn)?: undefined reference to ...
            '(^(?-s:.+?):(?: In function .+?:$|' .
               '(?: undefined reference to .+?$)|' .
               '\d+(?:\:\d+)?: ' . '(?:warning:|error:|invalid) .+?$))',

        'mswin32' => # MSVC(?:60)*
            # foo.c : error LNKnnn: error description
            # full\path\to\fooc.c : fatal error LNKnnn: error description
            # foo.c(nnn) : warning Cnnn: warning description
            '(^(?!NMAKE)(?-s:.+?) : (?-s:.+?)\d+: .+?$)',

        'bcc32' => # BORLAND 5.5 on MSWin32
            # Warning Wnnn filename line: warning description
            # Error Ennn:: error description
            '(^(?:(?:Warning W)|(?:Error E))\d+ .+? \d+: .+?$)',
    );
    exists $OS2PAT{ lc $cc } or $cc = 'gcc';
    my $pat = $OS2PAT{ lc $cc };

    my( $indx, %error ) = ( 1 );
    my $smokelog = '';
    local *LOGFH;
    if ( open LOGFH, "< $logfile" ) {
        $verbose and print "Reading logfile '$logfile'\n";
        local $/;
        $smokelog = <LOGFH>;
        close LOGFH;
        $verbose and print "Pattern($cc): /$pat/\n";
    } else {
        $verbose and print "Skipping '$logfile' '$!'\n";
        $error{ "Couldn't examine '$logfile' for compiler warnings." } = 1;
    }

    $error{ $1 } ||= $indx++ while $smokelog =~ /$pat/mg;

    # I need to think about this IRIX/$Config{cc} thing
#    if ($cc eq 'irix') {
#        if ($Config{cc} =~ /-n32|-64/) {
#    	     delete @error{ grep { /cc-(?:1009|1110|1047) / } keys %error };
#        }
#    }

    my @errors = map {
        chomp; $_;
    } sort { $error{ $a } <=> $error{ $b } } keys %error;

    return wantarray ? @errors : \@errors;
}

sub get_local_patches {
    my( $ddir, $verbose ) = @_;
    $ddir = shift || cwd();
    my $plevel = catfile( $ddir, 'patchlevel.h' );

    my @lpatches = ( );
    local *PLEVEL;
    $verbose and print "Locally applied patches from '$plevel':";
    unless ( open PLEVEL, "< $plevel" ) {
        $verbose and print " error: $!";
        return @lpatches;
    }
    $verbose and print " open ok\n";
    my( $seen, $patchnum );
    while ( <PLEVEL> ) {
        $patchnum = $1 if /#define PERL_PATCHNUM\s+(\d+)/;
        $seen && /^\s*,"(.+)"/ and push @lpatches, $1;
        /^\s*static.+?local_patches\[\]/ and $seen++;
    }
    close PLEVEL;
    if ( defined $patchnum ) {
        @lpatches = map {
            s/^(MAINT|DEVEL)$/$1$patchnum/;
            $_;
        } @lpatches;
    }
    $verbose and do { local $"=';'; print "Patches: '@lpatches'\n" };
    return @lpatches;
}

sub set_local_patch {
    my( $ddir, @descr ) = @_;

    my $plh = catfile( $ddir, 'patchlevel.h' );
    my $pln = catfile( $ddir, 'patchlevel.new' );
    my $plb = catfile( $ddir, 'patchlevel.bak' );
    local( *PLIN, *PLOUT );
    open PLIN,  "< $plh" or return 0;
    open PLOUT, "> $pln" or return 0;
    my $seen=0;
    while ( <PLIN> ) {
        if ( /\t,NULL/ and $seen ) {
            while ( my $c = shift @descr ) {
                print PLOUT qq{\t,"$c"\n};
           }
        }
        $seen++ if /local_patches\[\]/;
        print PLOUT;
    }
    close PLIN;
    close PLOUT or return 0;

    -e $plb and 1 while unlink $plb;
    my $errno = "$!";
    if ( -e $plb ) {
        require Carp;
        Carp::carp( "Could not unlink $plb : $errno" );
        return 0;
    }

    unless ( rename $plh, $plb ) {
        require Carp;
        Carp::carp( "Could not rename $plh to $plb : $!" );
        return 0;
    }
    unless ( rename $pln, $plh ) {
        require Carp;
        Carp::carp( "Could not rename '$pln' to '$plh' : $!" );
        return 0;
    }

    return 1;
}

sub get_config {
    my( $config_file ) = @_;

    return (
        [ "",
          "-Dusethreads -Duseithreads"
        ],
        [ "",
          "-Duse64bitint",
          "-Duse64bitall",
          "-Duselongdouble",
          "-Dusemorebits",
          "-Duse64bitall -Duselongdouble"
        ],
        { policy_target =>       "-DDEBUGGING",
          args          => [ "", "-DDEBUGGING" ]
        },
    ) unless defined $config_file;

    open CONF, "< $config_file" or do {
        warn "Can't open '$config_file': $!\nUsing standard configuration";
        return get_config( undef );
    };
    my( @conf, @cnf_stack, @target );

    # Cheat. Force a break marker as a line after the last line.
    foreach (<CONF>, "=") {
        m/^#/ and next;
        s/\s+$// if m/\s/;	# Blanks, new-lines and carriage returns. M$
        if (m:^/:) {
      	    m:^/(.*)/$:;
            defined $1 or die "Policy target line didn't end with '/': '$_'";
            push @target, $1;
            next;
        }

        if (!m/^=/) {
            # Not a break marker
            push @conf, $_;
            next;
        }

        # Break marker, so process the lines we have.
        if (@target > 1) {
            warn "Multiple policy target lines " .
       	         join (", ", map {"'$_'"} @target) . " - will use first";
        }
        my %conf = map { $_ => 1 } @conf;
        if (keys %conf == 1 and exists $conf{""} and !@target) {
            # There are only blank lines - treat it as if there were no lines
            # (Lets people have blank sections in configuration files without
            #  warnings.)
            # Unless there is a policy target.  (substituting ''  in place of
            # target is a valid thing to do.)
            @conf = ();
        }

        unless (@conf) {
            # They have no target lines
            @target and
                warn "Policy target '$target[0]' has no configuration lines, ".
                     "so it will not be used";
            @target = ();
            next;
        }

        while (my ($key, $val) = each %conf) {
            $val > 1 and 
                warn "Configuration line '$key' duplicated $val times";
        }
        my $args = [@conf];
        @conf = ();
        if (@target) {
            push @cnf_stack, { policy_target => $target[0], args => $args };
            @target = ();
            next;
        }

        push @cnf_stack, $args;
    }
    close CONF;
    return @cnf_stack;
}

sub get_patch {
    my( $ddir ) = @_;
    $ddir ||= File::Spec->curdir;

    my $dot_patch = File::Spec->catfile( $ddir, '.patch' );
    local *DOTPATCH;
    my $patch_level = '?????';
    if ( open DOTPATCH, "< $dot_patch" ) {
        chomp( $patch_level = <DOTPATCH> || '' );
        close DOTPATCH;

        if ( $patch_level ) {
            my @dot_patch = split ' ', $patch_level;
            my @return = ( $dot_patch[2] || $dot_patch[0] );
            if ( $dot_patch[3] ) {
                ( my $short_describe = $dot_patch[3] ) =~ s/^GitLive-//;
                push @return, $short_describe;
            }
            return \@return;
        }
        else {
            return [ '' ];
        }
    }

    # There does not seem to be a '.patch', try 'patchlevel.h'
    local *PATCHLEVEL_H;
    my $patchlevel_h = File::Spec->catfile( $ddir, 'patchlevel.h' );
    if ( open PATCHLEVEL_H, "< $patchlevel_h" ) {
        my( $declaration_seen, $patchnum ) = ( 0, 0 );
        while ( <PATCHLEVEL_H> ) {
            $patchnum = $1 if /#define PERL_PATCHNUM\s+(\d+)/;
            $declaration_seen ||= /local_patches\[\]/;
            $declaration_seen &&
                /^\s+,"(?:(?:DEVEL|MAINT)(\d+)?)|(RC\d+)"/ or next;
            $patch_level = $patchnum || $1 || $2 || '?????';
            if ( $patch_level =~ /^RC/ ) {
                $patch_level = version_from_patchlevel_h( $ddir ) .
                               "-$patch_level";
            } else {
                $patch_level .= $patchnum ? "" : '(+)';
            }
        }
    }
    return [ $patch_level ];
}

sub version_from_patchlevel_h {
    my( $ddir ) = @_;
    $ddir ||= File::Spec->curdir;
    my $file = File::Spec->catfile( $ddir, 'patchlevel.h' );

    my( $revision, $version, $subversion ) = qw( 5 ? ? );
    local *PATCHLEVEL;
    if ( open PATCHLEVEL, "< $file" ) {
        my $patchlevel = do { local $/; <PATCHLEVEL> };
        close PATCHLEVEL;

        if ( $patchlevel =~ /^#define PATCHLEVEL\s+(\d+)/m ) {
            # Also support perl < 5.6
            $version = sprintf "%03u", $1;
            $subversion = $patchlevel =~ /^#define SUBVERSION\s+(\d+)/m
                ? sprintf "%02u", $1 : '??';
            return "$revision.$version$subversion";
        }

        $revision   = $patchlevel =~ /^#define PERL_REVISION\s+(\d+)/m 
                    ? $1 : '?';
        $version    = $patchlevel =~ /^#define PERL_VERSION\s+(\d+)/m
                    ? $1 : '?';
        $subversion = $patchlevel =~ /^#define PERL_SUBVERSION\s+(\d+)/m 
                    ? $1 : '?';
    }
    return "$revision.$version.$subversion";
}
 

sub get_ncpu {
    # Only *nixy osses need this, so use ':'
    local $ENV{PATH} = "$ENV{PATH}:/usr/sbin:/sbin";

    my $cpus = "?";
    OS_CHECK: {
        local $_ = shift or return "";

        /aix/i && do {
            my @output = `lsdev -C -c processor -S Available`;
            $cpus = scalar @output;
            last OS_CHECK;
        };

        /(?:darwin|.*bsd)/i && do {
            chomp( my @output = `sysctl -n hw.ncpu` );
            $cpus = $output[0];
            last OS_CHECK;
        };

        /hp-?ux/i && do {
            my @output = grep /^processor/ => `ioscan -fnkC processor`;
            $cpus = scalar @output;
            last OS_CHECK;
	};

        /irix/i && do {
            my @output = grep /\s+processors?$/i => `hinv -c processor`;
            $cpus = (split " ", $output[0])[0];
            last OS_CHECK;
        };

        /linux/i && do {
            my @output; local *PROC;
            if ( open PROC, "< /proc/cpuinfo" ) {
                @output = grep /^processor/ => <PROC>;
                close PROC;
            }
            $cpus = @output ? scalar @output : '';
            last OS_CHECK;
	};

        /solaris|sunos|osf/i && do {
            my @output = grep /on-line/ => `psrinfo`;
            $cpus =  scalar @output;
            last OS_CHECK;
        };

        /mswin32|cygwin/i && do {
            $cpus = exists $ENV{NUMBER_OF_PROCESSORS} 
                ? $ENV{NUMBER_OF_PROCESSORS} : '';
            last OS_CHECK;
        };

        /vms/i && do {
            my @output = grep /CPU \d+ is in RUN state/ => `show cpu/active`;
            $cpus = @output ? scalar @output : '';
            last OS_CHECK;
        };

        $cpus = "";
        require Carp;
        Carp::carp( "get_ncpu: unknown operationg system" );
    }

    return $cpus ? sprintf( "%s cpu%s", $cpus, $cpus ne "1" ? 's' : '' ) : "";
}

sub get_smoked_Config {
    my( $dir, @fields ) = @_;
    my %Config = map { ( lc $_ => undef ) } @fields;

    my $perl_Config_heavy = catfile ($dir, "lib", "Config_heavy.pl");
    my $perl_Config_pm    = catfile ($dir, "lib", "Config.pm");
    my $perl_config_sh    = catfile( $dir, 'config.sh' );
    local *CONF;
    if ( open CONF, "< $perl_Config_heavy" ) {

        while (<CONF>) {
            if ( m/^(?:
                                              (?:our|my)\ \$[cC]onfig_[sS][hH].*
                                        |
                                              \$_
                                        )\ =\ <<'!END!';/x..m/^!END!/){
                m/!END!(?:';)?$/      and next;
                m/^([^=]+)='([^']*)'/ or next;
                exists $Config{lc $1} and $Config{lc $1} = $2;
            }
        }
        close CONF;
    }
    my %conf2 = map {
        ( $_ => undef )
    } grep !defined $Config{ $_ } => keys %Config;
    if ( open CONF, "< $perl_Config_pm" ) {

        while (<CONF>) {
            if ( m/^(?:
                                              (?:our|my)\ \$[cC]onfig_[sS][hH].*
                                        |
                                              \$_
                                        )\ =\ <<'!END!';/x..m/^!END!/){
                m/!END!(?:';)?$/      and next;
                m/^([^=]+)='([^']*)'/ or next;
                exists $conf2{lc $1} and $Config{lc $1} = $2;
            }
        }
        close CONF;
    }
    %conf2 = map {
        ( $_ => undef )
    } grep !defined $Config{ $_ } => keys %Config;
    if ( open CONF, "< $perl_config_sh" ) {
        while ( <CONF> ) {
            m/^([^=]+)='([^']*)'/ or next; # '
            exists $conf2{ $1} and $Config{ lc $1 } = $2;
        }
        close CONF;
    }
    %conf2 = map {
        ( $_ => undef )
    } grep !defined $Config{ $_ } => keys %Config;
    if ( keys %conf2 ) { 
        # Fall-back values from POSIX::uname() (not reliable)
        require POSIX;
        my( $osname, undef, $osvers, undef, $arch) = POSIX::uname();
        $Config{osname}   = lc $osname if exists $conf2{osname};
        $Config{osvers}   = lc $osvers if exists $conf2{osvers};
        $Config{archname} = lc $arch   if exists $conf2{archname};
        $Config{version}  = version_from_patchlevel_h( $dir )
            if exists $conf2{version};
    }

    # There should be no under-bars in perl versions!
    exists $Config{version} and $Config{version} =~ s/_/./g;
    return %Config;
}

sub parse_report_Config {
    my( $report ) = @_;

    my $version  = $report =~ /^Automated.*for (.+) patch/ ? $1 : '';
    my $plevel   = $report =~ /^Automated.+?(\S+)$/m
        ? $1 : '';
    if ( !$plevel ) {
        $plevel = $report =~ /^Auto.*patch\s+\S+\s+(\S+)/ ? $1 : '';
    }
    my $osname   = $report =~ /\bon\s+(.*) - / ? $1 : '';
    my $osvers   = $report =~ /\bon\s+.* - (.*)/? $1 : '';
    $osvers =~ s/\s+\(.*//;
    my $archname = $report =~ /:.* \((.*)\)/ ? $1 : '';
    my $summary  = $report =~ /^Summary: (.*)/m ? $1 : '';

    return ( $version, $plevel, $osname, $osvers, $archname, $summary );
}

sub get_regen_headers {
    my( $ddir ) = @_;

    $ddir ||= File::Spec->curdir; # Don't smoke in a dir "0"!

    my $regen_headers_pl = File::Spec->catfile( $ddir, "regen_headers.pl" );

    -f $regen_headers_pl and return qq[$^X "$regen_headers_pl"];

    $regen_headers_pl = File::Spec->catfile( $ddir, "regen.pl" );
    -f $regen_headers_pl and return qq[$^X "$regen_headers_pl"];

    return; # Should this be "make regen_headers"?
}

sub run_regen_headers {
    my( $ddir, $verbose ) = @_;

    my $regen_headers = get_regen_headers( $ddir );

    defined $regen_headers or do {
        warn "Cannot find a regen_headers script\n";
        return;
    };

    $verbose and print "Running [$regen_headers]\n";
    local *REGENH;
    if ( open REGENH, "$regen_headers |" ) {
        while ( <REGENH> ) { $verbose > 1 and print }
        close REGENH or do {
            warn "Error in pipe [$regen_headers]\n";
            return;
        }
    } else {
        warn "Cannot fork [$regen_headers]\n";
        return;
    }
    return 1;
}

sub whereis {
    my $prog = shift;
    return undef unless $prog; # you shouldn't call it '0'!
    $^O eq 'VMS' and return vms_whereis( $prog );

    my $p_sep = $Config::Config{path_sep};
    my @path = split /\Q$p_sep\E/, $ENV{PATH};
    my @pext = split /\Q$p_sep\E/, $ENV{PATHEXT} || '';
    unshift @pext, '';

    foreach my $dir ( @path ) {
        foreach my $ext ( @pext ) {
            my $fname = File::Spec->catfile( $dir, "$prog$ext" );
            if ( -x $fname ) {
                return $fname =~ /\s/ ? qq/"$fname"/ : $fname;
            }
        }
    }
    return '';
}

sub vms_whereis {
    my $prog = shift;

    # Check SYMBOLS
    eval { require VMS::DCLsym };
    if ( $@ ) {
        require Carp;
        Carp::carp( "Oops, cannot load VMS::DCLsym: $@" );
    } else {
        my $syms = VMS::DCLsym->new;
        return $prog if scalar $syms->getsym( $prog );
    }
    # Check Known File Entry table (INSTALL LIST)
    my $img_re = '^\s+([\w\$]+);\d+';
    my %kfe = map {
        my $img = /$img_re/ ? $1 : '';
        ( uc $img => undef )
    } grep /$img_re/ => qx/INSTALL LIST/;
    return $prog if exists $kfe{ uc $prog };

    require Config;
    my $dclp_env = 'DCL$PATH';
    my $p_sep = $Config::Config{path_sep} || '|';
    my @path = split /\Q$p_sep\E/, $ENV{ $dclp_env }||"";
    my @pext = ( $Config::Config{exe_ext} || $Config::Config{_exe}, '.COM' );

    foreach my $dir ( @path ) {
        foreach my $ext ( @pext ) {
            my $fname = File::Spec->catfile( $dir, "$prog$ext" );
            if ( -x $fname ) {
                return $ext eq '.COM' ? "\@$fname" : "MCR $fname";
            }
        }
    }
    return '';
}

sub clean_filename {
    my $fname = shift;

    if ( $^O eq 'VMS' ) {
        my @parts = split /[.@#]/, $fname;
        if ( @parts > 1 ) {
            my $ext = ( pop @parts ) || '';
            $fname = join( "_", @parts ) . ".$ext";
        }
    }
    return $NOCASE ? uc $fname : $fname;
}

sub calc_timeout {
    my( $killtime, $from ) = @_;
    my $timeout = 0;
    if ( $killtime =~ /^\+(\d+):([0-5]?[0-9])$/ ) {
        $timeout = 60 * (60 * $1 + $2 );
    } elsif ( $killtime =~ /^((?:[0-1]?[0-9])|(?:2[0-3])):([0-5]?[0-9])$/ ) {
        defined $from or $from = time;
        my $time_min = 60 * $1 + $2;
        my( $now_m, $now_h ) = (localtime $from)[1, 2];
        my $now_min = 60 * $now_h + $now_m;
        my $kill_min = $time_min - $now_min;
        $kill_min += 60 * 24 if $kill_min <= 0;
        $timeout = 60 * $kill_min;
    }
    return $timeout;
}

sub time_in_hhmm {
    my $diff = shift;

    # Only show decimal point for diffs < 5 minutes
    my $digits = $diff =~ /\./ ? $diff < 5*60 ? 3 : 0 : 0;
    my $days = int( $diff / (24*60*60) );
    $diff -= 24*60*60 * $days;
    my $hour = int( $diff / (60*60) );
    $diff -= 60*60 * $hour;
    my $mins = int( $diff / 60 );
    $diff -=  60 * $mins;
    $diff = sprintf "%.${digits}f", $diff;

    my @parts;
    $days and push @parts, sprintf "%d day%s",   $days, $days == 1 ? "" : 's';
    $hour and push @parts, sprintf "%d hour%s",  $hour, $hour == 1 ? "" : 's';
    $mins and push @parts, sprintf "%d minute%s",$mins, $mins == 1 ? "" : 's';
    $diff && !$days && !$hour and push @parts, "$diff seconds";

    return join " ", @parts;
}

sub do_pod2usage {
    my %p2u_opt = @_;
    eval { require Pod::Usage };
    if ( $@ ) {
        my $usage = $p2u_opt{myusage} || <<__EO_USAGE__;
Usage: $0 [options]
__EO_USAGE__
        print <<EO_MSG;
$usage

Use 'perldoc $0' for the documentation.
Please install 'Pod::Usage' for easy access to the docs.

EO_MSG
        exit( exists $p2u_opt{exitval} ? $p2u_opt{exitval} : 1 );
    } else {
        exists $p2u_opt{myusage} and delete $p2u_opt{myusage};
        Pod::Usage::pod2usage( @_ );
    }
}

sub skip_config {
    my( $config ) = @_;

    my $skip = $config->has_arg(qw( -Uuseperlio -Dusethreads )) ||
               $config->has_arg(qw( -Uuseperlio -Duseithreads )) ||
               ( $^O eq 'MSWin32' && 
               (( $config->has_arg(qw( -Duseithreads -Dusemymalloc )) &&
                !$config->has_arg( '-Uuseimpsys' ) ) ||
               ( $config->has_arg(qw( -Dusethreads -Dusemymalloc )) &&
                !$config->has_arg( '-Uuseimpsys' ) ))
               );
    return $skip;
}

sub skip_filter {
    local( $_ ) = @_;
    # Still to be extended
    return m,^ *$, ||
    m,^	AutoSplitting, ||
    m,^\./miniperl , ||
    m,^\s*autosplit_lib, ||
    m,^\s*PATH=\S+\s+./miniperl, ||
    m,^	Making , ||
    m,^make\[[12], ||
    m,make( TEST_ARGS=)? (_test|TESTFILE=|lib/\w+.pm), ||
    m,^make:.*Error\s+\d, ||
    m,^\s+make\s+lib/, ||
    m,^ *cd t &&, ||
    m,^if \(true, ||
    m,^else \\, ||
    m,^fi$, ||
    m,^lib/ftmp-security....File::Temp::_gettemp: Parent directory \((\.|/tmp/)\) is not safe, ||
    m,^File::Temp::_gettemp: Parent directory \((\.|/tmp/)\) is not safe, ||
    m,^ok$, ||
    m,^[-a-zA-Z0-9_/]+\.*(ok|skipping test on this platform)$, ||
    m,^(xlc|cc_r) -c , ||
#    m,^\s+$testdir/, ||
    m,^sh mv-if-diff\b, ||
    m,File \S+ not changed, ||
    m,^(not\s+)?ok\s+\d+\s+[-#]\s+(?i:skip\S*[: ]),i ||
    # cygwin
    m,^dllwrap: no export definition file provided, ||
    m,^dllwrap: creating one. but that may not be what you want, ||
    m,^(GNUm|M)akefile:\d+: warning: overriding commands for target `perlmain.o', ||
    m,^(GNUm|M)akefile:\d+: warning: ignoring old commands for target `perlmain.o', ||
    m,^\s+CCCMD\s+=\s+, ||
    # Don't know why BSD's make does this
    m,^Extracting .*with variable substitutions, ||
    # Or these
    m,cc\s+-o\s+perl.*perlmain.o\s+lib/auto/DynaLoader/DynaLoader\.a\s+libperl\.a, ||
    m,^\S+ is up to date, ||
    m,^(   )?### , ||
    # Clean up Win32's output
    m,^(?:\.\.[/\\])?[\w/\\-]+\.*ok$, ||
    m,^(?:\.\.[/\\])?[\w/\\-]+\.*ok\s+\d+(\.\d+)?\s*m?s$, ||
    m,^(?:\.\.[/\\])?[\w/\\-]+\.*ok\,\s+\d+/\d+\s+skipped:, ||
    m,^(?:\.\.[/\\])?[\w/\\-]+\.*skipped[: ], ||
    m,^\t?x?copy , ||
    m,\d+\s+[Ff]ile\(s\) copied, ||
    m,[/\\](?:mini)?perl\.exe ,||
    m,^\t?cd , ||
    m,^\b[nd]make\b, ||
    m,dmake\.exe:?\s+-S, ||
    m,^\s+\d+/\d+ skipped: , ||
    m,^\s+all skipped: , ||
    m,\.+skipped$, ||
    m,^\s*pl2bat\.bat [\w\\]+, ||
    m,^Making , ||
    m,^Skip , ||
    m,^Creating library file: libExtTest\.dll\.a, ||
    m,^cc: warning 983: ,
}

1;