File Coverage

blib/lib/File/chmod.pm

Criterion	Covered	Total	%
statement	92	164	56.1
branch	80	232	34.4
condition	13	23	56.5
subroutine	18	33	54.5
pod	7	28	25.0
total	210	480	43.7

package File::chmod;
use strict;
use warnings;
use Carp;
use vars qw( $VAL $W $MODE );

use base 'Exporter';

our $VERSION = '0.40'; # VERSION

our @EXPORT    = (qw( chmod getchmod )); ## no critic ( ProhibitAutomaticExportation )
our @EXPORT_OK = (qw( symchmod lschmod getsymchmod getlschmod getmod ));

our $DEBUG     = 1;
our $UMASK     = 2;
our $MASK      = umask;


my ($SYM,$LS) = (1,2);
my %ERROR = (
  EDETMOD => "use of determine_mode is deprecated",
  ENEXLOC => "cannot set group execute on locked file",
  ENLOCEX => "cannot set file locking on group executable file",
  ENSGLOC => "cannot set-gid on locked file",
  ENLOCSG => "cannot set file locking on set-gid file",
  ENEXUID => "execute bit must be on for set-uid",
  ENEXGID => "execute bit must be on for set-gid",
  ENULSID => "set-id has no effect for 'others'",
  ENULSBG => "sticky bit has no effect for 'group'",
  ENULSBU => "sticky bit has no effect for 'user'",
);

sub getmod {
  my @return = map { (stat)[2] & 07777 } @_;
  return wantarray ? @return : $return[0];
}


sub chmod (@) { ## no critic ( Subroutines::ProhibitBuiltinHomonyms Subroutines::ProhibitSubroutinePrototypes )
  my $mode = shift;
  my $how = mode($mode);

  return symchmod($mode,@_) if $how == $SYM;
  return lschmod($mode,@_) if $how == $LS;
  return CORE::chmod($mode,@_);
}


sub getchmod {
  my $mode = shift;
  my $how = mode($mode);

  return getsymchmod($mode,@_) if $how == $SYM;
  return getlschmod($mode,@_) if $how == $LS;
  return wantarray ? (($mode) x @_) : $mode;
}


sub symchmod {
  my $mode = shift;

  my @return = getsymchmod($mode,@_);
  my $ret = 0;
  for (@_){ $ret++ if CORE::chmod(shift(@return),$_) }
  return $ret;
}


sub getsymchmod {
  my $mode = shift;
  my @return;

  croak "symchmod received non-symbolic mode: $mode" if mode($mode) != $SYM;

  for (@_){
    local $VAL = getmod($_);

    for my $this (split /,/, $mode){
      local $W = 0;
      my $or;

      for (split //, $this){
        if (not defined $or and /[augo]/){
          /a/ and $W |= 7, next;
          /u/ and $W |= 1, next;
          /g/ and $W |= 2, next;
          /o/ and $W |= 4, next;
        }

        if (/[-+=]/){
          $W ||= 7;
          $or = (/[=+]/ ? 1 : 0);
          clear() if /=/;
          next;
        }

        croak "Bad mode $this" if not defined $or;
        croak "Unknown mode: $mode" if !/[ugorwxslt]/;

        /u/ and $or ? u_or() : u_not();
        /g/ and $or ? g_or() : g_not();
        /o/ and $or ? o_or() : o_not();
        /r/ and $or ? r_or() : r_not();
        /w/ and $or ? w_or() : w_not();
        /x/ and $or ? x_or() : x_not();
        /s/ and $or ? s_or() : s_not();
        /l/ and $or ? l_or() : l_not();
        /t/ and $or ? t_or() : t_not();
      }
    }
    $VAL &= ~$MASK if $UMASK;
    push @return, $VAL;
  }
  return wantarray ? @return : $return[0];
}


sub lschmod {
  my $mode = shift;

  return CORE::chmod(getlschmod($mode,@_),@_);
}


sub getlschmod {
  my $mode = shift;
  my $VAL = 0;

  croak "lschmod received non-ls mode: $mode" if mode($mode) != $LS;

  my ($u,$g,$o) = ($mode =~ /^.(...)(...)(...)$/);

  for ($u){
    $VAL |= 0400 if /r/;
    $VAL |= 0200 if /w/;
    $VAL |= 0100 if /[xs]/;
    $VAL |= 04000 if /[sS]/;
  }

  for ($g){
    $VAL |= 0040 if /r/;
    $VAL |= 0020 if /w/;
    $VAL |= 0010 if /[xs]/;
    $VAL |= 02000 if /[sS]/;
  }

  for ($o){
    $VAL |= 0004 if /r/;
    $VAL |= 0002 if /w/;
    $VAL |= 0001 if /[xt]/;
    $VAL |= 01000 if /[Tt]/;
  }

  return wantarray ? (($VAL) x @_) : $VAL;
}


sub mode {
  my $mode = shift;
  return 0 if $mode !~ /\D/;
  return $SYM if $mode =~ /[augo=+,]/;
  return $LS if $mode =~ /^.([r-][w-][xSs-]){2}[r-][w-][xTt-]$/;
  return $SYM;
}


sub determine_mode {
  carp $ERROR{EDECMOD};
  mode(@_);
}


sub clear {
  $W & 1 and $VAL &= 02077;
  $W & 2 and $VAL &= 05707;
  $W & 4 and $VAL &= 07770;
}


sub u_or {
  my $val = $VAL;
  $W & 2 and ($VAL |= (($val & 0700)>>3 | ($val & 04000)>>1));
  $W & 4 and ($VAL |= (($val & 0700)>>6));
}


sub u_not {
  my $val = $VAL;
  $W & 1 and $VAL &= ~(($val & 0700) | ($val & 05000));
  $W & 2 and $VAL &= ~(($val & 0700)>>3 | ($val & 04000)>>1);
  $W & 4 and $VAL &= ~(($val & 0700)>>6);
}


sub g_or {
  my $val = $VAL;
  $W & 1 and $VAL |= (($val & 070)<<3 | ($val & 02000)<<1);
  $W & 4 and $VAL |= ($val & 070)>>3;
}


sub g_not {
  my $val = $VAL;
  $W & 1 and $VAL &= ~(($val & 070)<<3 | ($val & 02000)<<1);
  $W & 2 and $VAL &= ~(($val & 070) | ($val & 02000));
  $W & 4 and $VAL &= ~(($val & 070)>>3);
}


sub o_or {
  my $val = $VAL;
  $W & 1 and $VAL |= (($val & 07)<<6);
  $W & 2 and $VAL |= (($val & 07)<<3);
}


sub o_not {
  my $val = $VAL;
  $W & 1 and $VAL &= ~(($val & 07)<<6);
  $W & 2 and $VAL &= ~(($val & 07)<<3);
  $W & 4 and $VAL &= ~($val & 07);
}


sub r_or {
  $W & 1 and $VAL |= 0400;
  $W & 2 and $VAL |= 0040;
  $W & 4 and $VAL |= 0004;
}


sub r_not {
  $W & 1 and $VAL &= ~0400;
  $W & 2 and $VAL &= ~0040;
  $W & 4 and $VAL &= ~0004;
}


sub w_or {
  $W & 1 and $VAL |= 0200;
  $W & 2 and $VAL |= 0020;
  $W & 4 and $VAL |= 0002;
}


sub w_not {
  $W & 1 and $VAL &= ~0200;
  $W & 2 and $VAL &= ~0020;
  $W & 4 and $VAL &= ~0002;
}


sub x_or {
  if ($VAL & 02000){ $DEBUG and carp($ERROR{ENEXLOC}), return }
  $W & 1 and $VAL |= 0100;
  $W & 2 and $VAL |= 0010;
  $W & 4 and $VAL |= 0001;
}


sub x_not {
  $W & 1 and $VAL &= ~0100;
  $W & 2 and $VAL &= ~0010;
  $W & 4 and $VAL &= ~0001;
}


sub s_or {
  if ($VAL & 02000){ $DEBUG and carp($ERROR{ENSGLOC}), return }
  if (not $VAL & 00100){ $DEBUG and carp($ERROR{ENEXUID}), return }
  if (not $VAL & 00010){ $DEBUG and carp($ERROR{ENEXGID}), return }
  $W & 1 and $VAL |= 04000;
  $W & 2 and $VAL |= 02000;
  $W & 4 and $DEBUG and carp $ERROR{ENULSID};
}


sub s_not {
  $W & 1 and $VAL &= ~04000;
  $W & 2 and $VAL &= ~02000;
  $W & 4 and $DEBUG and carp $ERROR{ENULSID};
}


sub l_or {
  if ($VAL & 02010){ $DEBUG and carp ($ERROR{ENLOCSG}), return }
  if ($VAL & 00010){ $DEBUG and carp ($ERROR{ENLOCEX}), return }
  $VAL |= 02000;
}


sub l_not {
  $VAL &= ~02000 if not $VAL & 00010;
}


sub t_or {
  $W & 1 and $DEBUG and carp $ERROR{ENULSBU};
  $W & 2 and $DEBUG and carp $ERROR{ENULSBG};
  $W & 4 and $VAL |= 01000;
}


sub t_not {
  $W & 1 and $DEBUG and carp $ERROR{ENULSBU};
  $W & 2 and $DEBUG and carp $ERROR{ENULSBG};
  $W & 4 and $VAL &= ~01000;
}


1;
# ABSTRACT: Implements symbolic and ls chmod modes

__END__