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


line stmt bran cond sub pod time code
1             package File::Mode;
2 1     1   586 use strict;
  1         2  
  1         46  
3 1     1   4 use Exporter;
  1         1  
  1         28  
4 1     1   30 use Carp;
  1         4  
  1         77  
5            
6 1     1   3 use vars qw/$VERSION/;
  1         2  
  1         903  
7             $VERSION = 0.05;
8            
9             #-------------------------- File::Mode Ver 0.05 ---------------------#
10             #--------------------- 2000 Idan Robbins aka Aqutiv ----------------#
11            
12             #I was thinking... If they invented comments, why not use them?
13             #So there you go, here's a comment. And you know what? I actually like comments.
14             #Yeah, that's it. Much better, fills in some empty spaces like this.
15             #What could have been here without these comments. ah?
16             #
17             #Shit, I've nothing left to say... Ah, well. See ya in the next version. :)
18            
19             #--------------------- New Object ---------------------#
20             sub new {
21 1     1 0 87 my $which = shift;
22 1   33     8 my $class = ref($which) || $which;
23 1         5 return bless {},$class;
24             }
25            
26             #-------------- Unix file mode to Number Mode ---------#
27             sub UnixToOct {
28 0     0 0   my $self = shift;
29 0   0       my $mod = shift || "-" x 6;
30 0   0       my $NoType = shift || 0;
31 0           my $type = undef;
32 0           my $skipchar = 0;
33 0           my $OctMod = 0;
34            
35             #The common format that is used for file modes. (i.e the mode that 'ls -l' unix commands gives)
36 0 0         if ($mod =~ /^([d\-]?)([r\-][w\-][x\-]){3}$/) {
37            
38             #Determine whether it is a file or a directory. (stays undefined if none)
39 0 0         if (!$1) { $skipchar = 1;}
  0 0          
  0            
40 0           elsif (substr($mod, 0, 1) eq "d") {$type = "DIR";}
41             else {$type = "FILE";}
42            
43 0 0         $mod =~ s/^.// unless $skipchar; #get rid of the first character for easy handling.
44            
45 0           my($ownermod) = substr($mod, 0, 3);
46 0           my($groupmod) = substr($mod, 3, 3);
47 0           my($publicmod) = substr($mod, 6, 3);
48            
49 0           my($dig1) = $self->GetNum($ownermod);
50 0           my($dig2) = $self->GetNum($groupmod);
51 0           my($dig3) = $self->GetNum($publicmod);
52            
53 0           $OctMod = 0 . $dig1 . $dig2 . $dig3;
54            
55            
56             }
57            
58             else {
59             #Uncomment if you want the module to be strict, otherwise will return an empty list.
60             #croak "Wrong format for Unix file mode";
61 0           return ();
62             }
63            
64 0 0 0       if(!$type || $NoType) { return $OctMod}
  0            
  0            
65             else {return $OctMod, $type}
66            
67            
68             }
69            
70             #-------------- Numeric Mode to Unix Standart ---------#
71             sub OctToUnix {
72 0     0 0   my $self = shift;
73 0   0       my $mod = shift || "000";
74 0           my($UnixMod) = 0;
75            
76             #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.
77             #For example, 755 and 0755 will both match.
78 0 0 0       if (($mod =~ /^0?\d{3}$/) && ($mod !~ /[89]/)) {
79            
80             #A tricky method to get each one of the digits, don't you think?
81             #It also takes care of the optional 4 digits. ;)
82 0           my($ownermod) = int($mod / 100); #first
83 0           my($groupmod) = int($mod % 100 / 10); #middle
84 0           my($publicmod) = int($mod % 10); #last
85            
86 0           my($str1) = $self->GetString($ownermod);
87 0           my($str2) = $self->GetString($groupmod);
88 0           my($str3) = $self->GetString($publicmod);
89            
90 0           $UnixMod = $str1 . $str2 . $str3;
91            
92             }
93             #Uncomment if you want the module to be strict. Otherwise, returns 0.
94             #else {
95             # croak "Illegal octal file mode";
96             #}
97            
98 0           return $UnixMod;
99            
100             }
101             #--------------------- String to Digit Conversion ---------------------#
102             sub GetNum {
103            
104 0     0 0   my $self = shift;
105 0   0       my $ModValue = shift || "-" x 3;
106            
107 0           $ModValue =~ tr/\-a-z/01/; #Converts the string to a binary value.
108            
109             #Convert from binary into an octal digit.
110 0           $ModValue = oct( unpack("N", pack("B32", substr("0" x 32 . $ModValue, -32))) );
111             #Took me awhile to figure this out... Ok, I admit, Grabbed it out of the perldocs...
112             #But it still took me some time to find it. ;)
113            
114 0           return $ModValue;
115            
116             }
117            
118             #--------------------- Digit to (short) String Conversion ---------------------#
119             sub GetString {
120            
121 0     0 0   my $self = shift;
122 0   0       my $ModDig = shift || 0;
123            
124             #Convert to a binary value:
125 0           my($ModValue) = unpack('B*', $ModDig);
126 0           $ModValue =~ s/^.*(\d{3})$/$1/; #Remove useless digits.
127            
128             #Binary to unix file mode convertion.
129 0           $ModValue =~ tr/0/\-/;
130 0           $ModValue =~ s/^1/r/;
131 0           $ModValue =~ s/^(.)1(.)$/$1w$2/;
132 0           $ModValue =~ s/1$/x/;
133            
134 0           return $ModValue;
135            
136             }
137            
138             #----------------------- File plus Mode Directory Listing ---------------------#
139             sub FileList {
140            
141 0     0 0   my $self = shift;
142 0   0       my $HashRef = shift || croak "No hash refeference specified for method FileList";
143 0   0       my $Directory = shift || "./";
144 0   0       my $NoDir = shift || 0;
145 0           my $mode = 000;
146 0           my $error = 0;
147 0           my $file = '';
148            
149 0 0         croak qq{Not a hash reference for method FileList} unless ref($HashRef) eq "HASH";
150            
151 0 0         opendir(DIR, $Directory) or $error = 1;
152 0           my @files = readdir(DIR);
153 0           closedir(DIR);
154            
155 0           foreach $file (@files) {
156            
157 0           $mode = (stat("$Directory/$file"))[2];
158 0           $mode = sprintf "%04o", $mode & 07777;
159            
160 0           $mode = $self->OctToUnix($mode);
161            
162             #Determine Directories
163 0 0 0       if ((-d $file) && !$NoDir) {$mode = "d" . $mode}
  0 0          
  0            
164             elsif (!$NoDir) {$mode = "-" . $mode}
165            
166 0           $HashRef->{$file} = "$mode";
167            
168             }
169            
170 0 0         if ($error) {return 0}
  0            
  0            
171             else {return 1}
172            
173             }
174            
175             1;
176             __END__