File Coverage

blib/lib/File/Strmode.pm

Criterion	Covered	Total	%
statement	35	35	100.0
branch	29	32	90.6
condition	4	7	57.1
subroutine	5	5	100.0
pod	0	1	0.0
total	73	80	91.2

package File::Strmode;

our $VERSION = '0.03';

use strict;
use warnings;

require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(strmode);

use Carp;

BEGIN {
    require Fcntl;
    require constant;
    eval { Fcntl->import($_); 1 } || constant->import($_, 0)
	for qw(S_IFDIR S_IFCHR S_IFBLK S_IFREG S_IFLNK S_IFMT S_IRUSR
	       S_IWUSR S_IXUSR S_ISUID S_IRGRP S_IWGRP S_IXGRP S_ISGID
	       S_IROTH S_IWOTH S_IXOTH S_ISVTX S_IFSOCK S_IFIFO);
}

my %type = (  S_IFDIR, 'd',
	      S_IFCHR, 'c',
	      S_IFBLK, 'b',
	      S_IFREG, '-',
	      S_IFLNK, 'l',
	      S_IFSOCK, 's',
	      S_IFIFO, 'p' );

delete $type{0}; # if some type constant is not defined for the
                 # running OS, it will end at this slot.

my %cache;

sub strmode {
    my $mode = shift;
    return undef unless defined $mode;
    $cache{$mode} ||= do {
	my $str = $type{$mode & S_IFMT} || '?';
	$str .= (($mode & S_IRUSR) ? 'r' : '-');
	$str .= (($mode & S_IWUSR) ? 'w' : '-');
	if ($mode & S_IXUSR) {
	    $str .= (($mode & S_ISUID) ? 's' : 'x');
	}
	else {
	    $str .= (($mode & S_ISUID) ? 'S' : '-');
	}
	$str .= (($mode & S_IRGRP) ? 'r' : '-');
	$str .= (($mode & S_IWGRP) ? 'w' : '-');
	if (($mode & S_IXGRP)) {
	    $str .= (($mode & S_ISGID) ? 's' : 'x');
	}
	else {
	    $str .= (($mode & S_ISGID) ? 'S' : '-');
	}
	$str .= (($mode & S_IROTH) ? 'r' : '-');
	$str .= (($mode & S_IWOTH) ? 'w' : '-');
	if ($mode & S_IXOTH) {
	    $str .= (($mode & S_ISVTX) ? 't' : 'x');
	}
	else {
	    $str .= (($mode & S_ISVTX) ? 'T' : '-');
	}
	$str .= ' '; # will be a '+' if ACL's implemented
	$str
    };
}

1;
__END__