view release on metacpan or  search on metacpan

lib/File/Replace.pm  view on Meta::CPAN

#!perl
package File::Replace;
use warnings;
use strict;
use Carp;
use warnings::register;
use IO::Handle; # allow method calls on filehandles on older Perls
use File::Temp qw/tempfile/;
use File::Basename qw/fileparse/;
use File::Spec::Functions qw/devnull/;
use File::Copy ();
use Fcntl qw/S_IMODE/;
use Exporter ();
BEGIN {
	require Hash::Util;
	# apparently this wasn't available until 0.06 / Perl 5.8.9
	# since this is just for internal typo prevention,
	# we can fake it when it's not available
	# uncoverable branch false
	# uncoverable condition right
	# uncoverable condition false
	if ($] ge '5.010' || defined &Hash::Util::lock_ref_keys)
		{ Hash::Util->import('lock_ref_keys') }
	else { *lock_ref_keys = sub {} }  # uncoverable statement
}

# For AUTHOR, COPYRIGHT, AND LICENSE see Replace.pod

## no critic (RequireArgUnpacking)

our $VERSION = '0.18';

our @EXPORT_OK = qw/ replace replace2 replace3 inplace /;
our @CARP_NOT = qw/ File::Replace::SingleHandle File::Replace::DualHandle File::Replace::Inplace /;

sub import {
	my @mine;
	for my $i (reverse 1..$#_)
		{ unshift @mine, splice @_, $i, 1 if $_[$i]=~/^-i|^-D$/ }
	if ( @mine and my @i = grep {/^-i/} @mine ) {
		croak "$_[0]: can't specify more than one -i switch" if @i>1;
		# the following double-check is currently just paranoia, so ignore it in code coverage:
		# uncoverable branch true
		my ($ext) = $i[0]=~/^-i(.*)$/ or croak "failed to parse '$i[0]'";
		my $debug = grep {/^-D$/} @mine;
		require File::Replace::Inplace;
		$File::Replace::Inplace::GlobalInplace = File::Replace::Inplace->new(backup=>$ext, debug=>$debug);  ## no critic (ProhibitPackageVars)
	}
	goto &Exporter::import;
}

sub inplace {
	require File::Replace::Inplace;
	return File::Replace::Inplace->new(@_);
}

our $DISABLE_CHMOD;

my %NEW_KNOWN_OPTS = map {$_=>1} qw/ debug layers create chmod
	perms autocancel autofinish in_fh backup /;
sub new {  ## no critic (ProhibitExcessComplexity)
	my $class = shift;
	@_ or croak "$class->new: not enough arguments";
	# set up the object
	my $filename = shift;
	my $_layers = @_%2 ? shift : undef;
	my %opts = @_;
	for (keys %opts) { croak "$class->new: unknown option '$_'"
		unless $NEW_KNOWN_OPTS{$_} }
	croak "$class->new: can't use autocancel and autofinish at once"
		if $opts{autocancel} && $opts{autofinish};
	unless (defined wantarray) { warnings::warnif("Useless use of $class->new in void context"); return }
	if (defined $opts{create}) { # normalize 'create' values
		   if ( $opts{create} eq 'off' || $opts{create} eq 'no' )
			 { $opts{create} = 'off' }
		elsif ( $opts{create} eq 'now' || $opts{create} eq 'later' )
			 { } # nothing needed
		else { croak "bad value for 'create' option, must be one of off/no/later/now" }
	}
	else { $opts{create} = 'later' } # default
	# create the object
	my $self = bless { chmod=>!$DISABLE_CHMOD, %opts, is_open=>0 }, $class;