File-Replace-Inplace
view release on metacpan or search on metacpan
t/50_inplace.t view on Meta::CPAN
#!/usr/bin/env perl
use warnings;
use strict;
=head1 Synopsis
Tests for the Perl module File::Replace::Inplace.
These tests are based heavily on F<t/25_tie_handle_argv.t>.
=head1 Author, Copyright, and License
Copyright (c) 2018-2023 Hauke Daempfling (haukex@zero-g.net)
at the Leibniz Institute of Freshwater Ecology and Inland Fisheries (IGB),
Berlin, Germany, L<http://www.igb-berlin.de/>
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
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. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program. If not, see L<http://www.gnu.org/licenses/>.
=cut
use FindBin ();
use lib $FindBin::Bin;
use File_Replace_Testlib;
use Test::More tests=>33;
use Cwd qw/getcwd/;
use File::Temp qw/tempdir/;
use File::Spec::Functions qw/catdir catfile/;
use IPC::Run3::Shell 0.56 ':FATAL', [ perl => { fail_on_stderr=>1,
show_cmd=>Test::More->builder->output },
$^X, '-wMstrict', '-I'.catdir($FindBin::Bin,'..','lib') ];
use warnings FATAL => qw/ io inplace /;
our $DEBUG = 0;
our $FE = $] ge '5.012' && $] lt '5.029007' ? !!0 : !!1; # FE="first eof", see https://github.com/Perl/perl5/issues/16786
our $CE; # CE="can't eof()", Perl <5.12 doesn't support eof() on tied filehandles (gets set below)
our $FL = undef; # FL="First Line"
# Apparently there are some versions of Perl on Win32 where the following two appear to work slightly differently.
# I've seen differing results on different systems and I'm not sure why, so I set it dynamically... not pretty, but this test isn't critical.
if ( $^O eq 'MSWin32' && $] ge '5.014' && $] lt '5.018' )
{ $FL = $.; $FE = defined($.) }
diag "WARNING: Perl 5.16 or better is strongly recommended for File::Replace::Inplace\n\t"
."(see documentation of Tie::Handle::Argv for details)" if $] lt '5.016';
BEGIN {
use_ok 'File::Replace::Inplace';
use_ok 'File::Replace', 'inplace';
}
use warnings FATAL => 'File::Replace';
## no critic (RequireCarping)
our $TESTMODE;
sub testboth { ## no critic (RequireArgUnpacking)
# test that both regular $^I and our tied class act the same
die "bad nr of args" unless @_==2 || @_==3;
my ($name, $sub, $args) = @_;
my $stdin = delete $$args{stdin};
{
local $TESTMODE = 'Perl';
local (*ARGV, *ARGVOUT, $., $^I); ## no critic (RequireInitializationForLocalVars)
$^I = $$args{backup}||''; ## no critic (RequireLocalizedPunctuationVars)
my $osi = defined($stdin) ? OverrideStdin->new($stdin) : undef;
subtest "$name - Perl" =>
$^O eq 'MSWin32' && $] lt '5.028' && !length($^I)
? sub { plan skip_all=>'This test would fail on Win32 with Perls older then 5.28' }
# see https://perldoc.pl/perldiag#Can't-do-inplace-edit-without-backup
# and https://perldoc.pl/perl5280delta#In-place-editing-with-perl-i-is-now-safer
: $sub;
$osi and $osi->restore;
}
{
local $TESTMODE = 'Inplace';
local (*ARGV, *ARGVOUT, $., $^I); ## no critic (RequireInitializationForLocalVars)
local $CE = $] lt '5.012';
my $inpl = File::Replace::Inplace->new(debug=>$DEBUG, %$args);
my $osi = defined($stdin) ? OverrideStdin->new($stdin) : undef;
subtest "$name - ::Inplace" => $sub;
$osi and $osi->restore;
}
return;
}
testboth 'basic test' => sub { plan tests=>9;
my @tf = (newtempfn("Foo\nBar\n"), newtempfn("Quz\nBaz"));
@ARGV = @tf; ## no critic (RequireLocalizedPunctuationVars)
my @states;
is select(), 'main::STDOUT', 'STDOUT is selected initially';
push @states, [[@ARGV], $ARGV, defined(fileno ARGV), defined(fileno ARGVOUT), $., eof];
while (<>) {
print "$ARGV:$.: ".uc;
isnt select(), 'main::STDOUT', 'STDOUT isn\'t selected in loop';
push @states, [[@ARGV], $ARGV, defined(fileno ARGV), defined(fileno ARGVOUT), $., eof, $_];
}
push @states, [[@ARGV], $ARGV, defined(fileno ARGV), defined(fileno ARGVOUT), $., eof];
is select(), 'main::STDOUT', 'STDOUT is selected again';
is slurp($tf[0]), "$tf[0]:1: FOO\n$tf[0]:2: BAR\n", 'file 1 contents';
is slurp($tf[1]), "$tf[1]:3: QUZ\n$tf[1]:4: BAZ", 'file 2 contents';
is_deeply \@states, [
[[@tf], undef, !!0, !!0, $FL, $FE ],
[[$tf[1]], $tf[0], !!1, !!1, 1, !!0, "Foo\n"],
[[$tf[1]], $tf[0], !!1, !!1, 2, !!1, "Bar\n"],
[[], $tf[1], !!1, !!1, 3, !!0, "Quz\n"],
[[], $tf[1], !!1, !!1, 4, !!1, "Baz" ],
[[], $tf[1], !!0, !!0, 4, !!1 ],
], 'states' or diag explain \@states;
};
testboth 'basic test with eof()' => sub {
if ($CE) { plan skip_all=>"eof() not supported on tied handles on Perl<5.12" }
elsif ($^O eq 'MSWin32') { plan skip_all=>"eof() acts differently on Win32" }
elsif ($^O eq 'cygwin') { plan skip_all=>"this test doesn't work on cygwin" }
else { plan tests=>9 }
my @tf = (newtempfn("Foo\nBar"), newtempfn("Quz\nBaz\n"));
local @ARGV = @tf; # this also tests "local"ization after constructing the object
my @states;
is select(), 'main::STDOUT', 'STDOUT is selected initially';
push @states, [[@ARGV], $ARGV, defined(fileno ARGV), defined(fileno ARGVOUT), $., eof], eof();
# eof() will open the first file, so record the current state again:
push @states, [[@ARGV], $ARGV, defined(fileno ARGV), defined(fileno ARGVOUT), $., eof], eof();
while (<>) {
print "$ARGV:$.: ".uc;
isnt select(), 'main::STDOUT', 'STDOUT isn\'t selected in loop';
push @states, [[@ARGV], $ARGV, defined(fileno ARGV), defined(fileno ARGVOUT), $., eof, $_], eof();
}
push @states, [[@ARGV], $ARGV, defined(fileno ARGV), defined(fileno ARGVOUT), $., eof];
is select(), 'main::STDOUT', 'STDOUT is selected again';
is slurp($tf[0]), "$tf[0]:1: FOO\n$tf[0]:2: BAR", 'file 1 contents';
is slurp($tf[1]), "$tf[1]:3: QUZ\n$tf[1]:4: BAZ\n", 'file 2 contents';
is_deeply \@states, [
[[@tf], undef, !!0, !!0, $FL, $FE ], !!0,
[[$tf[1]], $tf[0], !!1, !!1, 0, !!0 ], !!0,
[[$tf[1]], $tf[0], !!1, !!1, 1, !!0, "Foo\n"], !!0,
[[$tf[1]], $tf[0], !!1, !!1, 2, !!1, "Bar" ], !!0,
[[], $tf[1], !!1, !!1, 3, !!0, "Quz\n"], !!0,
t/50_inplace.t view on Meta::CPAN
{ $warncount++ }
else { die @_ } };
is select(), 'main::STDOUT', 'STDOUT is selected initially';
push @states, [[@ARGV], $ARGV, defined(fileno ARGV), defined(fileno ARGVOUT), $., eof];
while (<>) {
print "$ARGV'$.'$_";
isnt select(), 'main::STDOUT', 'STDOUT isn\'t selected in loop';
push @states, [[@ARGV], $ARGV, defined(fileno ARGV), defined(fileno ARGVOUT), $., eof, $_];
}
push @states, [[@ARGV], $ARGV, defined(fileno ARGV), defined(fileno ARGVOUT), $., eof];
is select(), 'main::STDOUT', 'STDOUT is selected again';
@ARGV = @tf; ## no critic (RequireLocalizedPunctuationVars)
push @states, [[@ARGV], $ARGV, defined(fileno ARGV), defined(fileno ARGVOUT), $., eof];
is_deeply [<>], ["$tf[1]'1'Hullo","$tf[5]'2'World!\n","$tf[5]'3'Foo!"], '<> in list ctx';
push @states, [[@ARGV], $ARGV, defined(fileno ARGV), defined(fileno ARGVOUT), $., eof];
is slurp($tf[$_]), "", 'file '.($_+1).' correct' for 0,1,3,5,6;
# NOTE: difference to Perl's -i - File::Replace will create the files
if ($TESTMODE eq 'Perl')
{ ok !-e $tf[$_], "file ".($_+1)." doesn't exist" for 2,4 }
else
{ is slurp($tf[$_]), "", 'file '.($_+1).' correct' for 2,4 }
is_deeply \@states, [
[[@tf], undef, !!0, !!0, $FL, $FE ],
[[@tf[2..6]], $tf[1], !!1, !!1, 1, !!1, "Hullo" ],
[[$tf[6]], $tf[5], !!1, !!1, 2, !!0, "World!\n"],
[[$tf[6]], $tf[5], !!1, !!1, 3, !!1, "Foo!" ],
[[], $tf[6], !!0, !!0, 3, !!1 ],
[[@tf], $tf[6], !!0, !!0, 3, !!1 ],
[[], $tf[6], !!0, !!0, 3, !!1 ],
], 'states' or diag explain \@states;
is $warncount, $TESTMODE eq 'Perl' ? 4 : 0, 'warning count';
};
subtest 'create option' => sub { plan tests=>9;
local (*ARGV, *ARGVOUT, $., $^I); ## no critic (RequireInitializationForLocalVars)
{
my @tf = (newtempfn("Hi"), newtempfn, newtempfn("There"));
ok !-e $tf[1], 'file doesn\'t exist yet';
@ARGV = @tf; ## no critic (RequireLocalizedPunctuationVars)
my $inpl = File::Replace::Inplace->new( debug=>$DEBUG, create=>'now' );
is <>, "Hi", 'file 1 read ok';
print "Bingo1";
is <>, "There", 'file 3 read ok';
is slurp($tf[0]), "Bingo1", 'file 1 contents ok';
print "Bingo2";
is slurp($tf[1]), "", 'file created ok';
is <>, undef, 'finished reading ok';
is slurp($tf[2]), "Bingo2", 'file 3 contents ok';
}
{
my $tfn = newtempfn;
ok !-e $tfn, 'file doesn\'t exist';
@ARGV = ($tfn); ## no critic (RequireLocalizedPunctuationVars)
my $inpl = File::Replace::Inplace->new( debug=>$DEBUG, create=>'off' );
like exception { <>; 1 }, qr/\bfailed to open '\Q$tfn\E'/, 'read dies ok';
}
};
subtest 'premature destroy' => sub { plan tests=>7;
local (*ARGV, *ARGVOUT, $., $^I); ## no critic (RequireInitializationForLocalVars)
local $CE = $] lt '5.012';
is grep( {/\bunclosed file\b.+\bnot replaced\b/i} warns {
my $tfn = newtempfn("IJK\nMNO");
@ARGV = ($tfn); ## no critic (RequireLocalizedPunctuationVars)
my @states;
my $inpl = inplace(debug=>$DEBUG);
is select(), 'main::STDOUT', 'STDOUT is selected initially';
push @states, [[@ARGV], $ARGV, defined(fileno ARGV), defined(fileno ARGVOUT), $., eof];
is <>, "IJK\n", 'read ok';
isnt select(), 'main::STDOUT', 'STDOUT isn\'t selected after read';
push @states, [[@ARGV], $ARGV, defined(fileno ARGV), defined(fileno ARGVOUT), $., eof];
$inpl = undef;
push @states, [[@ARGV], $ARGV, defined(fileno ARGV), defined(fileno ARGVOUT), $., eof];
is select(), 'main::STDOUT', 'STDOUT is selected again';
is slurp($tfn), "IJK\nMNO", 'file contents';
is_deeply \@states, [
[[$tfn], undef, !!0, !!0, $FL, $FE ],
[[], $tfn, !!1, !!1, 1, !!0 ],
[[], $tfn, !!0, !!0, 1, $CE?!!1:$FE],
], 'states' or diag explain \@states;
} ), 1, 'warning about unclosed file';
};
testboth 'premature close' => sub { plan tests=>9;
my @tf = (newtempfn("foo\nBAR\n"), newtempfn("quZ\nBaz"));
my @states;
@ARGV = @tf; ## no critic (RequireLocalizedPunctuationVars)
is select(), 'main::STDOUT', 'STDOUT is selected initially';
push @states, [[@ARGV], $ARGV, defined(fileno ARGV), defined(fileno ARGVOUT), $., eof];
my $l=<>;
print "$ARGV<$.>".ucfirst($l);
isnt select(), 'main::STDOUT', 'STDOUT isn\'t selected';
push @states, [[@ARGV], $ARGV, defined(fileno ARGV), defined(fileno ARGVOUT), $., eof, $l];
close ARGV; close select if $TESTMODE eq 'Perl'; ## no critic (ProhibitOneArgSelect)
isnt select(), 'main::STDOUT', 'STDOUT still isn\'t selected';
push @states, [[@ARGV], $ARGV, defined(fileno ARGV), defined(fileno ARGVOUT), $., eof];
while (<>) {
print "$ARGV<$.>".ucfirst;
isnt select(), 'main::STDOUT', 'STDOUT isn\'t selected in loop';
push @states, [[@ARGV], $ARGV, defined(fileno ARGV), defined(fileno ARGVOUT), $., eof, $_];
}
push @states, [[@ARGV], $ARGV, defined(fileno ARGV), defined(fileno ARGVOUT), $., eof];
is select(), 'main::STDOUT', 'STDOUT is selected again';
is slurp($tf[0]), "$tf[0]<1>Foo\n", 'file 1 contents';
is slurp($tf[1]), "$tf[1]<1>QuZ\n$tf[1]<2>Baz", 'file 2 contents';
is_deeply \@states, [
[[@tf], undef, !!0, !!0, $FL, $FE ],
[[$tf[1]], $tf[0], !!1, !!1, 1, !!0, "foo\n"],
[[$tf[1]], $tf[0], !!0, !!0, 0, !!1 ],
[[], $tf[1], !!1, !!1, 1, !!0, "quZ\n"],
[[], $tf[1], !!1, !!1, 2, !!1, "Baz" ],
[[], $tf[1], !!0, !!0, 2, !!1 ],
], 'states' or diag explain \@states;
};
my $prevdir = getcwd;
my $tmpdir = tempdir(DIR=>$TEMPDIR,CLEANUP=>1);
chdir($tmpdir) or die "chdir $tmpdir: $!";
testboth 'diamond' => sub {
plan $^O eq 'MSWin32' ? (skip_all => 'special filenames won\'t work on Windows') : (tests=>1);
spew("foo","I am foo\nbar");
spew("<foo","I am <foo!\nquz");
my @states;
@ARGV = ("<foo"); ## no critic (RequireLocalizedPunctuationVars)
push @states, [[@ARGV], $ARGV, defined(fileno ARGV), $., eof];
push @states, [[@ARGV], $ARGV, defined(fileno ARGV), $., eof, $_] while <>;
push @states, [[@ARGV], $ARGV, defined(fileno ARGV), $., eof];
is_deeply \@states, [
[["<foo"], undef, !!0, undef, $FE ],
[[], "<foo", !!1, 1, !!0, "I am <foo!\n"],
[[], "<foo", !!1, 2, !!1, "quz" ],
[[], "<foo", !!0, 2, !!1 ],
], 'states for double-diamond';
};
testboth 'double-diamond' => sub {
if ($] lt '5.022') { plan skip_all => 'need Perl >=5.22 for double-diamond' }
elsif ($^O eq 'MSWin32') { plan skip_all => 'special filenames won\'t work on Windows' }
else { plan tests=>1 }
spew("foo","I am foo\nbar");
spew("<foo","I am <foo!\nquz");
my @states;
@ARGV = ("<foo"); ## no critic (RequireLocalizedPunctuationVars)
push @states, [[@ARGV], $ARGV, defined(fileno ARGV), $., eof];
my $code = <<' ENDCODE'; # need to eval this because otherwise <<>> is a syntax error on older Perls
push @states, [[@ARGV], $ARGV, defined(fileno ARGV), $., eof, $_] while <<>>;
; 1
ENDCODE
eval $code or die $@||"unknown error"; ## no critic (ProhibitStringyEval, ProhibitMixedBooleanOperators)
push @states, [[@ARGV], $ARGV, defined(fileno ARGV), $., eof];
is_deeply \@states, [
[["<foo"], undef, !!0, undef, $FE ],
[[], "<foo", !!1, 1, !!0, "I am <foo!\n"],
[[], "<foo", !!1, 2, !!1, "quz" ],
[[], "<foo", !!0, 2, !!1 ],
], 'states for double-diamond';
};
chdir($prevdir) or warn "chdir $prevdir: $!";
subtest 'perl -MFile::Replace=-i' => sub { plan tests=>10;
my @tf = (newtempfn("One\nTwo\n"), newtempfn("Three\nFour"));
is perl('-MFile::Replace=-i','-pe','s/[aeiou]/_/gi', @tf), '', 'no output';
is slurp($tf[0]), "_n_\nTw_\n", 'file 1 correct';
is slurp($tf[1]), "Thr__\nF__r", 'file 2 correct';
my @bf = map { "$_.bak" } @tf;
ok !-e $bf[0], 'backup 1 doesn\'t exist';
ok !-e $bf[1], 'backup 2 doesn\'t exist';
is perl('-MFile::Replace=-i.bak','-nle','print "$ARGV:$.: $_"', @tf), '', 'no output (2)';
is slurp($tf[0]), "$tf[0]:1: _n_\n$tf[0]:2: Tw_\n", 'file 1 correct (2)';
is slurp($tf[1]), "$tf[1]:3: Thr__\n$tf[1]:4: F__r\n", 'file 2 correct (2)';
is slurp($bf[0]), "_n_\nTw_\n", 'backup file 1 correct';
is slurp($bf[1]), "Thr__\nF__r", 'backup file 2 correct';
};
subtest '-i in import list' => sub { plan tests=>7;
local (*ARGV, *ARGVOUT, $., $^I); ## no critic (RequireInitializationForLocalVars)
my @tf = (newtempfn("XX\nYY\n"), newtempfn("ABC\nDEF\nGHI"));
@ARGV = @tf; ## no critic (RequireLocalizedPunctuationVars)
ok !defined $File::Replace::Inplace::GlobalInplace, 'GlobalInplace not set yet'; ## no critic (ProhibitPackageVars)
File::Replace->import('-i');
ok defined $File::Replace::Inplace::GlobalInplace, 'GlobalInplace is now set'; ## no critic (ProhibitPackageVars)
while (<>) {
print "$ARGV:$.:".lc;
}
is slurp($tf[0]), "$tf[0]:1:xx\n$tf[0]:2:yy\n", 'file 1 correct';
is slurp($tf[1]), "$tf[1]:3:abc\n$tf[1]:4:def\n$tf[1]:5:ghi", 'file 2 correct';
$File::Replace::Inplace::GlobalInplace = undef; ## no critic (ProhibitPackageVars)
is @ARGV, 0, '@ARGV empty';
# a couple more checks for code coverage
File::Replace->import('-D');
is undef, $File::Replace::Inplace::GlobalInplace, 'lone debug flag has no effect'; ## no critic (ProhibitPackageVars)
like exception {File::Replace->import('-i','-D','-i.bak')},
qr/\bmore than one -i\b/, 'multiple -i\'s fails';
$File::Replace::Inplace::GlobalInplace = undef; ## no critic (ProhibitPackageVars)
};
subtest 'cleanup' => sub { plan tests=>1; # mostly just to make code coverage happy
( run in 3.350 seconds using v1.01-cache-2.11-cpan-5e09290becf )