File Coverage

blib/lib/Stat/lsMode.pm

Criterion	Covered	Total	%
statement	30	53	56.6
branch	9	40	22.5
condition			n/a
subroutine	7	9	77.7
pod	2	4	50.0
total	48	106	45.2

use strict; use warnings;

package Stat::lsMode;
our $VERSION = '0.51';

use Carp;
BEGIN { require Exporter; *import = \&Exporter::import }
our @EXPORT = qw(format_mode file_mode format_perms);

our (@perms, @ftype);
@perms = qw(--- --x -w- -wx r-- r-x rw- rwx);
@ftype = qw(. p c ? d ? b ? - ? l ? s D ? ?);
$ftype[0] = '';

our $NOVICE_MODE = 1;  # Default on?
sub novice {
  my $pack = shift;
  croak "novice_mode requires one boolean argument" unless @_ == 1;
  my $old = $NOVICE_MODE;  # Should this be localized t $pack?
  $NOVICE_MODE = $_[0];
  $old;
}

sub format_mode {
  croak "format_mode requires a mode as an argument" unless @_ >= 1;
  my $mode = shift;
  my %opts = @_;

  unless (defined $mode) {
    return wantarray() ? () : undef;
  }

  _novice_warning($mode) if $NOVICE_MODE;

  my $setids = ($mode & 07000)>>9;
  my @permstrs = @perms[($mode&0700)>>6, ($mode&0070)>>3, $mode&0007];
  my $ftype = $ftype[($mode & 0170000)>>12];
  my @ftype = $opts{no_ftype} ? () : ($ftype);

  if ($setids) {
    if ($setids & 01) { # Sticky bit
      $permstrs[2] =~ s/([-x])$/$1 eq 'x' ? 't' : 'T'/e;
    }
    if ($setids & 04) { # Setuid bit
      $permstrs[0] =~ s/([-x])$/$1 eq 'x' ? 's' : 'S'/e;
    }
    if ($setids & 02) { # Setgid bit
      $permstrs[1] =~ s/([-x])$/$1 eq 'x' ? 's' : 'S'/e;
    }
  }

  if (wantarray) {
    (@ftype, @permstrs);
  } else {
    join '', @ftype, @permstrs;
  }
}

sub file_mode {
  croak "file_mode requires one filename as an argument" unless @_ == 1;
  my $file = shift;
  my $mode = (lstat $file)[2];

  unless (defined $mode) {
    if (wantarray) {
      return ();
    } else {
      carp "Couldn't get mode for file `$file': $!" if $NOVICE_MODE;
      return undef;
    }
  }

  format_mode($mode, @_);
}

sub format_perms {
  croak "format_perms requires a permission mode as an argument" unless @_ == 1;
  format_mode($_[0], no_ftype => 1);
}

# None of these are really plausible modes.
# They are all almost certain to have occurred
# when someone used decimal instead of octal to specify a mode.

my %badmode = map +($_ => 1), (
  777, 775, 755, 770, 700, 750,
  751,
  666, 664, 644, 660, 600, 640,
  444, 440,
  400, # 400 = rw--w---- which is just barely plausible.
  # 000  *is* OK.  It means just what you think.
  711, 771, 751, 551, 111,
);

# Novices like to ask for the bits for mode `666' instead of `0666'.
# Try to detect and diagnose that.
sub _novice_warning {
  my $mode = shift;
  if ($badmode{$mode}) {
    carp "mode $mode is very surprising.  Perhaps you meant 0$mode";
  }
}

1;

__END__