File Coverage

blib/lib/clobber.pm

Criterion	Covered	Total	%
statement	62	73	84.9
branch	27	40	67.5
condition	19	31	61.2
subroutine	13	13	100.0
pod	0	3	0.0
total	121	160	75.6

package clobber;
use Carp;
use Fcntl;
use strict; no strict 'refs';
use vars '$VERSION'; $VERSION = 0.10_1;
eval "require Term::ReadKey";

BEGIN{ $^I||="~" }

sub unimport { #no strict 'refs';
  my $opt = $_[1] || '';
  $^H{'clobber-lax'} = $opt eq ':lax' ? 1 : 0;

  unless( exists($^H{clobber}) ){
      *{"CORE::GLOBAL::\L$_"} = \&{$_} foreach qw/OPEN RENAME SYSOPEN/;
  }
  $^H{'clobber'} = $ENV{'clobber.pm'} || 0;
}

sub import {
  my $opt = $_[1] || '';
  if( $opt eq ':lax' ){
    $^H{'clobber-lax'} = 1;
    &unimport();
  }
  else{
    $^H{'clobber'} = 1;
  }
}


sub OPEN(*;$@){
  my($handle, $mode, $file) = @_;
  my($testmode, $pipein) = $mode;
  my $scope = (caller 0)[10];

  my $stricture = $scope->{'clobber-lax'} ?
    qr/^\+>(?!>)|^>(?!&|>)/ : qr/^\+[<>](?!>)|^>(?!&|>)/;

  if( scalar(@_) == 1 ){ #no strict 'refs';
    unshift(@_, $mode = ${caller(1).'::'.$handle});
  }

  if( scalar(@_) == 2 ){
    #Since we can't simply pass @_ through due to open's prototype,
    #we might as well convert to 3-arg

    if( $mode =~ /^\s*
		  (
		   \|       |         #pipe-out
	           (?:\>{1,2}|<)&=?|  #dup & fdopen
		   \+?>{1,2}|         #write, append, write-read, append-read
                   \+?<               #read, read-write
		  )?
		  \s*
		  (.+?)               #the beef
		  \s*
		  (\|)?               #pipe-in
		  \s*
		  $/x ){
      ($testmode, $file, $pipein) = ($1||'', $2||'', $3||'');
      #if it's a 2-arg dup and we're a stale perl, just do it & return;
      return CORE::open($handle, $mode) if $[ < 5.008 &&
                                     $mode =~ /^\s*(?:\>{1,2}|<)&=?/;
    }
    else{
      croak "Failed to parse EXPR of 2-arg open: $_[1]";
    }

    $testmode = $testmode eq '|' ? '|-' : $testmode;
    unless( length $testmode ){
      $testmode = $pipein ? '-|' :
                  $file eq '-' ? '<' : '>';
    }
  }
  elsif( scalar(@_) > 2 ){
    ($testmode, $file) = @_[1,2];
  }

  prompt($file, $scope) if -e $file && $testmode =~ /$stricture/;

  splice(@_, 0, 3);

  #no strict 'refs';
  CORE::open(*{caller(0) . '::' . $handle}, $testmode, $file, @_);
}

sub SYSOPEN(*$$;$){
  my($handle, $file, $mode, $perms) = @_;
  my $scope = (caller 0)[10];

  my $stricture = $scope->{'clobber-lax'} ? O_TRUNC : (O_WRONLY|O_RDWR|O_TRUNC);

  #We don't use O_EXCL because sysopen's failure is not trappable
  prompt($file, $scope) if -e $file && $mode&$stricture;

  #no strict 'refs';
  CORE::sysopen(*{caller(0) . '::' . $handle}, $file, $mode, $perms||0666);
}

sub RENAME($$){
  my $scope = (caller 0)[10];

  prompt($_[1], $scope, "$_[0]: overwrite `$_[1]'?") if -e $_[1];

  CORE::rename($_[0], $_[1]);
}

sub prompt{
  my $clobber = 0;

  return if $_[1]->{'clobber'};

  if( -t STDIN && exists($INC{'Term/ReadKey.pm'}) ){

    select(STDERR); local $|=1;
    print STDERR  ($_[2] || "Allow modification of '$_[0]'?") . ' [yN] ';

    Term::ReadKey::ReadMode('cbreak'); $clobber = Term::ReadKey::ReadKey(0);

    Term::ReadKey::ReadMode('restore'); print STDERR "\n";

    $clobber =~ y/yY/1/; $clobber =~ y/1/0/c;
  }

  croak "$_[0]: File exists" unless $clobber;
}


1;
__END__