File Coverage

blib/lib/File/chmod.pm
Criterion Covered Total %
statement 93 165 56.3
branch 83 234 35.4
condition 13 23 56.5
subroutine 18 33 54.5
pod 7 28 25.0
total 214 483 44.3


line stmt bran cond sub pod time code
1             package File::chmod;
2 6     6   315089 use strict;
  6         13  
  6         243  
3 6     6   31 use warnings;
  6         9  
  6         198  
4 6     6   28 use Carp;
  6         8  
  6         437  
5 6     6   31 use vars qw( $VAL $W $MODE );
  6         17  
  6         484  
6              
7 6     6   30 use base 'Exporter';
  6         21  
  6         17272  
8              
9             our $VERSION = '0.41'; # VERSION
10              
11             our @EXPORT = (qw( chmod getchmod )); ## no critic ( ProhibitAutomaticExportation )
12             our @EXPORT_OK = (qw( symchmod lschmod getsymchmod getlschmod getmod ));
13              
14             our $DEBUG = 1;
15             our $UMASK = 2;
16             our $MASK = umask;
17              
18              
19             my ($SYM,$LS) = (1,2);
20             my %ERROR = (
21             EDETMOD => "use of determine_mode is deprecated",
22             ENEXLOC => "cannot set group execute on locked file",
23             ENLOCEX => "cannot set file locking on group executable file",
24             ENSGLOC => "cannot set-gid on locked file",
25             ENLOCSG => "cannot set file locking on set-gid file",
26             ENEXUID => "execute bit must be on for set-uid",
27             ENEXGID => "execute bit must be on for set-gid",
28             ENULSID => "set-id has no effect for 'others'",
29             ENULSBG => "sticky bit has no effect for 'group'",
30             ENULSBU => "sticky bit has no effect for 'user'",
31             );
32              
33             sub getmod {
34 34     34 1 1738 my @return = map { (stat)[2] & 07777 } @_;
  34         778  
35 34 100       252 return wantarray ? @return : $return[0];
36             }
37              
38              
39             sub chmod (@) { ## no critic ( Subroutines::ProhibitBuiltinHomonyms Subroutines::ProhibitSubroutinePrototypes )
40 21     21 1 2726 my $mode = shift;
41 21         58 my $how = mode($mode);
42              
43 21 100       95 return symchmod($mode,@_) if $how == $SYM;
44 3 50       22 return lschmod($mode,@_) if $how == $LS;
45 3         89 return CORE::chmod($mode,@_);
46             }
47              
48              
49             sub getchmod {
50 0     0 1 0 my $mode = shift;
51 0         0 my $how = mode($mode);
52              
53 0 0       0 return getsymchmod($mode,@_) if $how == $SYM;
54 0 0       0 return getlschmod($mode,@_) if $how == $LS;
55 0 0       0 return wantarray ? (($mode) x @_) : $mode;
56             }
57              
58              
59             sub symchmod {
60 18     18 1 24 my $mode = shift;
61              
62 18 50       44 warnings::warnif 'deprecated', '$UMASK being true is deprecated'
63             . ' it will be false by default in the future. This change'
64             . ' is being made because this not the behavior of the unix command'
65             . ' `chmod`. This warning can be disabled by putting explicitly'
66             . ' setting $File::chmod::UMASK to false or any non 2 true value'
67             . ' see Github issue #5 '
68             if $UMASK == 2;
69              
70 18         47 my @return = getsymchmod($mode,@_);
71 18         22 my $ret = 0;
72 18 50       34 for (@_){ $ret++ if CORE::chmod(shift(@return),$_) }
  18         508  
73 18         148 return $ret;
74             }
75              
76              
77             sub getsymchmod {
78 18     18 1 27 my $mode = shift;
79 18         18 my @return;
80              
81 18 50       33 croak "symchmod received non-symbolic mode: $mode" if mode($mode) != $SYM;
82              
83 18         45 for (@_){
84 18         33 local $VAL = getmod($_);
85              
86 18         78 for my $this (split /,/, $mode){
87 18         25 local $W = 0;
88 18         16 my $or;
89              
90 18         46 for (split //, $this){
91 52 100 100     213 if (not defined $or and /[augo]/){
92 16 50       37 /a/ and $W |= 7, next;
93 16 100       42 /u/ and $W |= 1, next;
94 9 100       38 /g/ and $W |= 2, next;
95 5 50       24 /o/ and $W |= 4, next;
96             }
97              
98 36 100       90 if (/[-+=]/){
99 18   100     65 $W ||= 7;
100 18 100       50 $or = (/[=+]/ ? 1 : 0);
101 18 50       48 clear() if /=/;
102 18         27 next;
103             }
104              
105 18 50       58 croak "Bad mode $this" if not defined $or;
106 18 50       55 croak "Unknown mode: $mode" if !/[ugorwxslt]/;
107              
108 18 0       42 /u/ and $or ? u_or() : u_not();
    50          
109 18 0       44 /g/ and $or ? g_or() : g_not();
    50          
110 18 0       92 /o/ and $or ? o_or() : o_not();
    50          
111 18 100       66 /r/ and $or ? r_or() : r_not();
    100          
112 18 100       92 /w/ and $or ? w_or() : w_not();
    100          
113 18 100       51 /x/ and $or ? x_or() : x_not();
    100          
114 18 0       43 /s/ and $or ? s_or() : s_not();
    50          
115 18 0       41 /l/ and $or ? l_or() : l_not();
    50          
116 18 100       83 /t/ and $or ? t_or() : t_not();
    100          
117             }
118             }
119 18 50       44 $VAL &= ~$MASK if $UMASK;
120 18         38 push @return, $VAL;
121             }
122 18 50       60 return wantarray ? @return : $return[0];
123             }
124              
125              
126             sub lschmod {
127 0     0 1 0 my $mode = shift;
128              
129 0         0 return CORE::chmod(getlschmod($mode,@_),@_);
130             }
131              
132              
133             sub getlschmod {
134 0     0 1 0 my $mode = shift;
135 0         0 my $VAL = 0;
136              
137 0 0       0 croak "lschmod received non-ls mode: $mode" if mode($mode) != $LS;
138              
139 0         0 my ($u,$g,$o) = ($mode =~ /^.(...)(...)(...)$/);
140              
141 0         0 for ($u){
142 0 0       0 $VAL |= 0400 if /r/;
143 0 0       0 $VAL |= 0200 if /w/;
144 0 0       0 $VAL |= 0100 if /[xs]/;
145 0 0       0 $VAL |= 04000 if /[sS]/;
146             }
147              
148 0         0 for ($g){
149 0 0       0 $VAL |= 0040 if /r/;
150 0 0       0 $VAL |= 0020 if /w/;
151 0 0       0 $VAL |= 0010 if /[xs]/;
152 0 0       0 $VAL |= 02000 if /[sS]/;
153             }
154              
155 0         0 for ($o){
156 0 0       0 $VAL |= 0004 if /r/;
157 0 0       0 $VAL |= 0002 if /w/;
158 0 0       0 $VAL |= 0001 if /[xt]/;
159 0 0       0 $VAL |= 01000 if /[Tt]/;
160             }
161              
162 0 0       0 return wantarray ? (($VAL) x @_) : $VAL;
163             }
164              
165              
166             sub mode {
167 39     39 0 38 my $mode = shift;
168 39 100       170 return 0 if $mode !~ /\D/;
169 36 100       131 return $SYM if $mode =~ /[augo=+,]/;
170 8 50       25 return $LS if $mode =~ /^.([r-][w-][xSs-]){2}[r-][w-][xTt-]$/;
171 8         17 return $SYM;
172             }
173              
174              
175             sub determine_mode {
176 0     0 0 0 carp $ERROR{EDECMOD};
177 0         0 mode(@_);
178             }
179              
180              
181             sub clear {
182 0 0   0 0 0 $W & 1 and $VAL &= 02077;
183 0 0       0 $W & 2 and $VAL &= 05707;
184 0 0       0 $W & 4 and $VAL &= 07770;
185             }
186              
187              
188             sub u_or {
189 0     0 0 0 my $val = $VAL;
190 0 0       0 $W & 2 and ($VAL |= (($val & 0700)>>3 | ($val & 04000)>>1));
191 0 0       0 $W & 4 and ($VAL |= (($val & 0700)>>6));
192             }
193              
194              
195             sub u_not {
196 0     0 0 0 my $val = $VAL;
197 0 0       0 $W & 1 and $VAL &= ~(($val & 0700) | ($val & 05000));
198 0 0       0 $W & 2 and $VAL &= ~(($val & 0700)>>3 | ($val & 04000)>>1);
199 0 0       0 $W & 4 and $VAL &= ~(($val & 0700)>>6);
200             }
201              
202              
203             sub g_or {
204 0     0 0 0 my $val = $VAL;
205 0 0       0 $W & 1 and $VAL |= (($val & 070)<<3 | ($val & 02000)<<1);
206 0 0       0 $W & 4 and $VAL |= ($val & 070)>>3;
207             }
208              
209              
210             sub g_not {
211 0     0 0 0 my $val = $VAL;
212 0 0       0 $W & 1 and $VAL &= ~(($val & 070)<<3 | ($val & 02000)<<1);
213 0 0       0 $W & 2 and $VAL &= ~(($val & 070) | ($val & 02000));
214 0 0       0 $W & 4 and $VAL &= ~(($val & 070)>>3);
215             }
216              
217              
218             sub o_or {
219 0     0 0 0 my $val = $VAL;
220 0 0       0 $W & 1 and $VAL |= (($val & 07)<<6);
221 0 0       0 $W & 2 and $VAL |= (($val & 07)<<3);
222             }
223              
224              
225             sub o_not {
226 0     0 0 0 my $val = $VAL;
227 0 0       0 $W & 1 and $VAL &= ~(($val & 07)<<6);
228 0 0       0 $W & 2 and $VAL &= ~(($val & 07)<<3);
229 0 0       0 $W & 4 and $VAL &= ~($val & 07);
230             }
231              
232              
233             sub r_or {
234 4 50   4 0 13 $W & 1 and $VAL |= 0400;
235 4 100       12 $W & 2 and $VAL |= 0040;
236 4 100       20 $W & 4 and $VAL |= 0004;
237             }
238              
239              
240             sub r_not {
241 4 50   4 0 8 $W & 1 and $VAL &= ~0400;
242 4 100       8 $W & 2 and $VAL &= ~0040;
243 4 100       7 $W & 4 and $VAL &= ~0004;
244             }
245              
246              
247             sub w_or {
248 1 50   1 0 7 $W & 1 and $VAL |= 0200;
249 1 50       3 $W & 2 and $VAL |= 0020;
250 1 50       6 $W & 4 and $VAL |= 0002;
251             }
252              
253              
254             sub w_not {
255 2 100   2 0 5 $W & 1 and $VAL &= ~0200;
256 2 100       6 $W & 2 and $VAL &= ~0020;
257 2 50       5 $W & 4 and $VAL &= ~0002;
258             }
259              
260              
261             sub x_or {
262 1 0   1 0 6 if ($VAL & 02000){ $DEBUG and carp($ERROR{ENEXLOC}), return }
  0 50       0  
263 1 50       4 $W & 1 and $VAL |= 0100;
264 1 50       4 $W & 2 and $VAL |= 0010;
265 1 50       5 $W & 4 and $VAL |= 0001;
266             }
267              
268              
269             sub x_not {
270 1 50   1 0 6 $W & 1 and $VAL &= ~0100;
271 1 50       4 $W & 2 and $VAL &= ~0010;
272 1 50       4 $W & 4 and $VAL &= ~0001;
273             }
274              
275              
276             sub s_or {
277 0 0   0 0 0 if ($VAL & 02000){ $DEBUG and carp($ERROR{ENSGLOC}), return }
  0 0       0  
278 0 0       0 if (not $VAL & 00100){ $DEBUG and carp($ERROR{ENEXUID}), return }
  0 0       0  
279 0 0       0 if (not $VAL & 00010){ $DEBUG and carp($ERROR{ENEXGID}), return }
  0 0       0  
280 0 0       0 $W & 1 and $VAL |= 04000;
281 0 0       0 $W & 2 and $VAL |= 02000;
282 0 0 0     0 $W & 4 and $DEBUG and carp $ERROR{ENULSID};
283             }
284              
285              
286             sub s_not {
287 0 0   0 0 0 $W & 1 and $VAL &= ~04000;
288 0 0       0 $W & 2 and $VAL &= ~02000;
289 0 0 0     0 $W & 4 and $DEBUG and carp $ERROR{ENULSID};
290             }
291              
292              
293             sub l_or {
294 0 0   0 0 0 if ($VAL & 02010){ $DEBUG and carp ($ERROR{ENLOCSG}), return }
  0 0       0  
295 0 0       0 if ($VAL & 00010){ $DEBUG and carp ($ERROR{ENLOCEX}), return }
  0 0       0  
296 0         0 $VAL |= 02000;
297             }
298              
299              
300             sub l_not {
301 0 0   0 0 0 $VAL &= ~02000 if not $VAL & 00010;
302             }
303              
304              
305             sub t_or {
306 3 50 66 3 0 470 $W & 1 and $DEBUG and carp $ERROR{ENULSBU};
307 3 50 66     160 $W & 2 and $DEBUG and carp $ERROR{ENULSBG};
308 3 100       45 $W & 4 and $VAL |= 01000;
309             }
310              
311              
312             sub t_not {
313 2 50 66 2 0 157 $W & 1 and $DEBUG and carp $ERROR{ENULSBU};
314 2 50 66     159 $W & 2 and $DEBUG and carp $ERROR{ENULSBG};
315 2 50       13 $W & 4 and $VAL &= ~01000;
316             }
317              
318              
319             1;
320             # ABSTRACT: Implements symbolic and ls chmod modes
321              
322             __END__