view release on metacpan or  search on metacpan

perlbench-run  view on Meta::CPAN

            change_mode($mode, $name);
        }
    }
    else {
        open(my $f, "<", $name) || return undef;
        binmode($f);
        local $/;
        return scalar <$f>;
    }
}

sub link_or_copy {
    my $f = shift;
    link($f, "$dir/$f") || do {
	require File::Copy;
	File::Copy::copy($f, $f);
    }
}
sub htmlesc {
    my $str = shift || '';
    $str =~ s/&/&amp;/g;
    $str =~ s/</&lt;/g;
    $str;
}

sub time2iso
{
    my $time = shift;
    $time = time unless defined $time;
    my($sec,$min,$hour,$mday,$mon,$year) = localtime($time);
    return sprintf("%04d-%02d-%02d %02d:%02d:%02d",
            $year+1900, $mon+1, $mday, $hour, $min, $sec);
}

BEGIN {
package Perl;
use constant OS => $^O;

my $NEXT_LABEL = "A";

sub new
{
    my($class, $path) = @_;
    my $label;
    if ($path =~ s/^(\S+)=//) {
	$label = $1;
    }
    else {
	$label = $NEXT_LABEL++;
    }
    unless (-x $path) {
	die "$path is not executable";
	next;
    }
    if (-d $path and -x "$path/perl") {
	$path = "$path/perl";
	print "updating given dir path to $path\n" if $::opt_v;
    }

    my $self = bless { path => $path, label => $label }, $class;
    $self->run_cmd(*V, '-e', 'print qq(This is perl ), $]+0, qq(\n)');
    my $version = <V>;
    close V or die "closing pipe from perl: exit code $?";
    chomp $version;
    unless ($version =~ /^This is perl (\d+.\d+)/) {
	die "$path does not appear to be a working perl";
    }
    $self->{version} = $1;
    $self->run_cmd(*V, '-v');
    while (<V>) {
	if (/^This is perl, v(\S+)/) {	# old format
	    $self->{name} = "perl-$1";
	}
	if (/^This is perl (\d), version (\d+), subversion (\d+) \((\S+) (?:\((\S+)\){2})?/) {
	    print "new format: $4 $5\n" if $::opt_v;
	    $self->{name} = "perl-$1";
	    $self->{git_version} = $5
	}
	if (/^Binary build (\d+.*) provided by ActiveState/) {
	    $self->{name} .= " build $1";
	    $self->{name} =~ s/^perl/ActivePerl/;
	}
    }
    close(V);

    if ($self->{version} >= 5) {
	# The perl should have Configure support.  Try to extract
	# some key settings
	my $prog = 'use Config; Config::config_vars(qw(cc ccversion gccversion optimize ccflags usethreads use64bitint use64bitall usemymalloc))';
	$self->run_cmd(*CONFIG, '-e', $prog);
	while (<CONFIG>) {
	   next unless /^(\w+)='([^']+)'/;  #' #
           $self->{config}{$1} = $2;
        }
	close(CONFIG);
    }
    return $self;
}

my $ld_path = Cwd::extLibpath()	 if $^O eq 'os2';
$ld_path .= ';'			 if $ld_path and $^O eq 'os2';

sub cmd
{
    my $self = shift;
    my $path = $self->{path};
    (my $pdir = $path) =~ s,[/\\][^/\\]+$,/,;
    if (-d "$pdir/lib") {
        # uninstalled perl
        Cwd::extLibpath_set("$ld_path$pdir") if $^O eq 'os2'; # Find DLL
	($path, '-I', "$pdir/lib");
    } else {
	$path;
    }
}

sub run_cmd
{
    my $self = shift;
    my @cmd = $self->cmd;
    my $fh = shift;
    my @args = map {/\s/ ? OS ne 'MSWin32' ? "'$_'" : "\"$_\"" : $_} @_;
    open($fh, "@cmd @args |") or die "Cannot pipe from '@cmd @args': $!";
}

}