File Coverage

blib/lib/File/Mode.pm

Criterion	Covered	Total	%
statement	15	86	17.4
branch	0	22	0.0
condition	1	29	3.4
subroutine	5	10	50.0
pod	0	6	0.0
total	21	153	13.7

package File::Mode;
use strict;
use Exporter;
use Carp;

use vars qw/$VERSION/;
$VERSION = 0.05;

#--------------------------  File::Mode Ver 0.05 ---------------------#
#---------------------  ©2000 Idan Robbins aka Aqutiv ----------------#

#I was thinking... If they invented comments, why not use them?
#So there you go, here's a comment. And you know what? I actually like comments.
#Yeah, that's it. Much better, fills in some empty spaces like this.
#What could have been here without these comments. ah?
#
#Shit, I've nothing left to say... Ah, well. See ya in the next version. :)

#--------------------- New Object ---------------------#
sub new {
    my $which = shift;
    my $class = ref($which) || $which;
    return bless {},$class;
}

#-------------- Unix file mode to Number Mode ---------#
sub UnixToOct {
    my $self = shift;
    my $mod  = shift || "-" x 6;
    my $NoType = shift || 0;
    my $type = undef;
    my $skipchar = 0;
    my $OctMod = 0;

    #The common format that is used for file modes. (i.e the mode that 'ls -l' unix commands gives)
    if ($mod =~ /^([d\-]?)([r\-][w\-][x\-]){3}$/) {

	#Determine whether it is a file or a directory. (stays undefined if none)
	if (!$1) { $skipchar = 1;}
	elsif (substr($mod, 0, 1) eq "d") {$type = "DIR";}
	else {$type = "FILE";}

	$mod =~ s/^.// unless $skipchar; #get rid of the first character for easy handling.

	my($ownermod)  = substr($mod, 0, 3);
       	my($groupmod)  = substr($mod, 3, 3);
	my($publicmod) = substr($mod, 6, 3);

	my($dig1) = $self->GetNum($ownermod);
	my($dig2) = $self->GetNum($groupmod);
	my($dig3) = $self->GetNum($publicmod);

	$OctMod = 0 . $dig1 . $dig2 . $dig3;


   }

   else {
        #Uncomment if you want the module to be strict, otherwise will return an empty list.
   	#croak "Wrong format for Unix file mode";
        return ();
   }

   if(!$type || $NoType) { return $OctMod}
   else {return $OctMod, $type}


}

#-------------- Numeric Mode to Unix Standart ---------#
sub OctToUnix {
    my $self = shift;
    my $mod  = shift || "000";
    my($UnixMod) = 0;

    #Makes sure that the number is made of 3 digits (or 4, with an option 0 at start) and each one of them is 7 or smaller.
    #For example, 755 and 0755 will both match.
    if (($mod =~ /^0?\d{3}$/) && ($mod !~ /[89]/)) {

	#A tricky method to get each one of the digits, don't you think?
	#It also takes care of the optional 4 digits. ;)
	my($ownermod)  = int($mod / 100); #first
       	my($groupmod)  = int($mod % 100 / 10); #middle
	my($publicmod) = int($mod % 10); #last

	my($str1) = $self->GetString($ownermod);
	my($str2) = $self->GetString($groupmod);
	my($str3) = $self->GetString($publicmod);

	$UnixMod = $str1 . $str2 . $str3;

   }
   #Uncomment if you want the module to be strict. Otherwise, returns 0.
   #else {
   #	croak "Illegal octal file mode";
   #}

   return $UnixMod;

}
#--------------------- String to Digit Conversion ---------------------#
sub GetNum {

my $self = shift;
my $ModValue = shift || "-" x 3;

$ModValue =~ tr/\-a-z/01/; #Converts the string to a binary value.

#Convert from binary into an octal digit.
$ModValue = oct( unpack("N", pack("B32", substr("0" x 32 . $ModValue, -32))) );
#Took me awhile to figure this out... Ok, I admit, Grabbed it out of the perldocs...
#But it still took me some time to find it. ;)

return $ModValue;

}

#--------------------- Digit to (short) String Conversion ---------------------#
sub GetString {

my $self = shift;
my $ModDig = shift || 0;

#Convert to a binary value:
my($ModValue) = unpack('B*', $ModDig);
$ModValue =~ s/^.*(\d{3})$/$1/; #Remove useless digits.

#Binary to unix file mode convertion.
$ModValue =~ tr/0/\-/;
$ModValue =~ s/^1/r/;
$ModValue =~ s/^(.)1(.)$/$1w$2/;
$ModValue =~ s/1$/x/;

return $ModValue;

}

#----------------------- File plus Mode Directory Listing ---------------------#
sub FileList {

my $self = shift;
my $HashRef = shift || croak "No hash refeference specified for method FileList";
my $Directory = shift || "./";
my $NoDir = shift || 0;
my $mode = 000;
my $error = 0;
my $file = '';

croak qq{Not a hash reference for method FileList} unless ref($HashRef) eq "HASH";

opendir(DIR, $Directory) or $error = 1;
my @files = readdir(DIR);
closedir(DIR);

foreach $file (@files) {

	$mode = (stat("$Directory/$file"))[2];
	$mode = sprintf "%04o", $mode & 07777;

	$mode = $self->OctToUnix($mode);

	#Determine Directories
	if ((-d $file) && !$NoDir) {$mode = "d" . $mode}
	elsif (!$NoDir) {$mode = "-" . $mode}

	$HashRef->{$file} = "$mode";

}

if ($error) {return 0}
else {return 1}

}

1;
__END__