BATsh
view release on metacpan or search on metacpan
for my $file (@file) {
if (-e $file) {
mkpath(dirname("$tardir/$file"), 0, 0777);
print STDERR "copy $file $tardir/$file\n";
copy($file, "$tardir/$file");
if ($file =~ m/ (?: Build\.PL | Makefile\.PL ) \z/oxmsi) {
chmod(0664, "$tardir/$file");
}
elsif ($file =~ m/\. (?: pl | bat | exe | com ) \z/oxmsi) {
chmod(0775, "$tardir/$file");
}
elsif ($file =~ m{^bin/}oxmsi) {
chmod(0775, "$tardir/$file");
}
else {
chmod(0664, "$tardir/$file");
}
}
}
system(qq{tar -cvf $tardir.tar $tardir});
system(qq{gzip $tardir.tar});
}
else {
#-----------------------------------------------------------------------------
# https://metacpan.org/search?q=Archive%3A%3ATar%3A%3AConstant
# https://metacpan.org/release/Archive-Tar-Streamed
#-----------------------------------------------------------------------------
eval q{
use Compress::Zlib;
use Archive::Tar;
};
my $BLOCK_SIZE = 512;
my $ZERO_BLOCK = "\0" x $BLOCK_SIZE;
# make *.tar file
open(FH_TAR, ">$tardir.tar") || die "Can't open file: $tardir.tar\n"; #'
binmode FH_TAR;
for my $file (@file) {
if (-e $file) {
mkpath(dirname("$tardir/$file"), 0, 0777);
print STDERR "copy $file $tardir/$file\n";
copy($file, "$tardir/$file");
#-----------------------------------------------------------------------------
# Sunday December 21, 2008 07:38 PM
# Fixing world writable files in tarball before upload to CPAN [ #38127 ]
# http://use.perl.org/~bart/journal/38127 (dead link)
# Fix CPAN uploads for world writable files
# http://perlmonks.org/index.pl?node_id=731935
#-----------------------------------------------------------------------------
# $tar->add_files("$tardir/$file");
#-----------------------------------------------------------------------------
open(FH, $file) || die "Can't open file: $file\n"; #'
binmode FH;
local $/ = undef; # slurp mode
my $data = <FH>;
close FH;
#-----------------------------------------------------------------------------
# Kwalitee Indicator: buildtool_not_executable core
# The build tool (Build.PL/Makefile.PL) is executable. This is bad because
# you should specify which perl you want to use while installing.
#
# How to fix
# Change the permissions of Build.PL/Makefile.PL to not-executable.
#-----------------------------------------------------------------------------
my $tar = Archive::Tar->new;
if ($file =~ m/ (?: Build\.PL | Makefile\.PL ) \z/oxmsi) {
$tar->add_data("$tardir/$file", $data, {'mode' => 0664});
}
elsif ($file =~ m/\. (?: pl | bat | exe | com ) \z/oxmsi) {
$tar->add_data("$tardir/$file", $data, {'mode' => 0775});
}
else {
$tar->add_data("$tardir/$file", $data, {'mode' => 0664});
}
my $format_tar_file = $tar->write;
syswrite FH_TAR, $format_tar_file, length($format_tar_file) - length($ZERO_BLOCK . $ZERO_BLOCK);
undef $tar;
#-----------------------------------------------------------------------------
}
else {
die "file: $file is not exists.\n";
}
}
# syswrite FH_TAR, $ZERO_BLOCK; makes "tar: A lone zero block at %s"
syswrite FH_TAR, ($ZERO_BLOCK . $ZERO_BLOCK);
close FH_TAR;
rmtree($tardir, 0, 0);
# make *.tar.gz file
my $gz = gzopen("$tardir.tar.gz", 'wb');
open(FH_TAR, "$tardir.tar") || die "Can't open file: $tardir.tar\n";
binmode FH_TAR;
while (sysread(FH_TAR, $_, 1024*1024)) {
$gz->gzwrite($_);
}
close FH_TAR;
$gz->gzclose;
unlink "$tardir.tar";
}
# P.565 Cleaning Up Your Environment
# in Chapter 23: Security
# of ISBN 0-596-00027-8 Programming Perl Third Edition.
# local $ENV{'PATH'} = '.';
local @ENV{qw(IFS CDPATH ENV BASH_ENV)};
# untar test
if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
system(qq{pmake.bat ptar.bat});
system(qq{ptar.bat xzvf $tardir.tar.gz});
}
else {
system(qq{./pmake.bat ptar});
goto endofperl
@rem ';
#!perl
#line 14
undef @rem;
END
print FH_WGETBAT $pwget;
print FH_WGETBAT ":endofperl\n";
close FH_WGETBAT;
}
# make pwget
else {
open(FH_WGETBAT, '>pwget') || die "Can't open file: pwget\n";
print FH_WGETBAT '#!', &which($^X), "\n";
print FH_WGETBAT $pwget;
close FH_WGETBAT;
chmod 0755, 'pwget';
}
}
# pmake selfcheck [--check1] [--check2]
elsif ($target eq 'selfcheck') {
my $do_check1 = 0;
my $do_check2 = 0;
for my $arg (@ARGV) {
$do_check1 = 1 if $arg eq '--check1';
$do_check2 = 1 if $arg eq '--check2';
}
# Default: both checks enabled when no flag is given
if (!$do_check1 && !$do_check2) {
$do_check1 = 1;
$do_check2 = 1;
}
_selfcheck($do_check1, $do_check2);
last;
}
else {
warn "unknown target: $target.\n";
}
}
sub which {
if ($_[0] =~ m#\A / #oxms) {
return $_[0];
}
else {
for my $path (split(/:/,$ENV{'PATH'})) {
if (-e qq{$path/$_[0]}) {
return qq{$path/$_[0]};
}
}
return $_[0];
}
}
# Test::Harness::runtests cannot work heavy load.
sub _runtests {
my @script = @_;
my @fail_testno = ();
my $ok_script = 0;
my $not_ok_script = 0;
my $total_ok = 0;
my $total_not_ok = 0;
my $total_skip = 0;
# cygwin warning:
# MS-DOS style path detected: C:/cpan/Char-X.XX
# Preferred POSIX equivalent is: /cygdrive/c/cpan/Char-X.XX
# CYGWIN environment variable option "nodosfilewarning" turns off this warning.
# Consult the user's guide for more details about POSIX paths: #'
# http://cygwin.com/cygwin-ug-net/using.html#using-pathnames
if (exists $ENV{'CYGWIN'}) {
if ($ENV{'CYGWIN'} !~ /\b nodosfilewarning \b/x) {
$ENV{'CYGWIN'} = join(' ', $ENV{'CYGWIN'}, 'nodosfilewarning');
}
}
my $start_time = time();
my $scriptno = 0;
for my $script (@script) {
next if not -e $script;
my $ok = 0;
my $not_ok = 0;
my $skip = 0;
if (my @result = qx{$^X $script}) {
if (my($tests) = shift(@result) =~ /^1..([0-9]+)/) {
for my $result (@result) {
# Read TAP test number directly to avoid offset from comment lines
if ($result =~ /^ok (\d+)/) {
my $tapno = $1;
if ($result =~ /\bSKIP\b/i) {
$skip++;
}
else {
$ok++;
}
}
elsif ($result =~ /^not ok (\d+)/) {
my $tapno = $1;
push @{$fail_testno[$scriptno]}, $tapno;
$not_ok++;
}
# TAP comment lines (^#) and other lines are silently ignored
}
if ($not_ok == 0) {
if ($skip > 0) {
printf("$script ok (skipped: %d)\n", $skip);
}
else {
printf("$script ok\n");
}
$ok_script++;
}
else {
printf("$script Failed %d/%d subtests\n", $not_ok, $ok+$not_ok+$skip);
$not_ok_script++;
}
}
}
$total_ok += $ok;
$total_not_ok += $not_ok;
$total_skip += $skip;
$scriptno++;
}
my $elapsed = time() - $start_time;
if (scalar(@script) == $ok_script) {
my $skip_msg = $total_skip > 0 ? " (skipped: $total_skip)" : '';
printf("All tests successful.\n");
printf("Files=%d, Tests=%d%s, %d wallclock secs\n",
scalar(@script), $total_ok + $total_not_ok + $total_skip,
$skip_msg, $elapsed);
printf("Result: PASS\n");
}
else {
print "\nTest Summary Report\n-------------------\n";
my $scriptno = 0;
for my $fail_testno (@fail_testno) {
if (defined $fail_testno) {
print $script[$scriptno], "\n";
print ' Failed test: ', join(', ', @{$fail_testno[$scriptno]}), "\n";
}
$scriptno++;
}
printf("Files=%d, Tests=%d, %d wallclock secs\n",
scalar(@script), $total_ok + $total_not_ok + $total_skip, $elapsed);
printf("Result: FAIL\n");
printf("Failed %d/%d test programs. %d/%d subtests failed.\n",
$not_ok_script, scalar(@script),
$total_not_ok, $total_ok + $total_not_ok + $total_skip);
}
}
######################################################################
# selfcheck: Perl 5.5.3 compat (--check1) and coding style (--check2)
#
# These routines check pmake.bat itself.
# All TAP harness, slurp, and scanner logic is embedded here
# so that no external modules beyond core are required.
######################################################################
# --- Embedded TAP harness (no Test::Simple / Test::More) ---
my ($SC_PLAN, $SC_RUN, $SC_FAIL) = (0, 0, 0);
sub _sc_plan {
($SC_PLAN, $SC_RUN, $SC_FAIL) = ($_[0], 0, 0);
print "1..$SC_PLAN\n" if 0;
}
sub _sc_ok {
my ($ok, $name) = @_;
$SC_RUN++;
$SC_FAIL++ unless $ok;
if (not $ok) {
print +($ok ? '' : 'not ') . "ok $SC_RUN"
. (defined $name && length $name ? " - $name" : '') . "\n";
}
return $ok;
}
sub _sc_diag {
for my $line (@_) {
print "# $line\n";
}
}
# --- File utilities ---
sub _sc_slurp {
my ($path) = @_;
local *SC_FH;
open SC_FH, "< $path" or return '';
local $/;
my $c = <SC_FH>;
close SC_FH;
return defined $c ? $c : '';
}
sub _sc_slurp_lines {
my ($path) = @_;
local *SC_FH;
open SC_FH, "< $path" or return ();
my @lines = <SC_FH>;
close SC_FH;
return @lines;
}
sub _sc_has_non_usascii {
my ($path) = @_;
( run in 1.974 second using v1.01-cache-2.11-cpan-9581c071862 )