File Coverage

blib/lib/Paranoid/Filesystem.pm
Criterion Covered Total %
statement 354 440 80.4
branch 142 228 62.2
condition 31 60 51.6
subroutine 29 31 93.5
pod 16 16 100.0
total 572 775 73.8


line stmt bran cond sub pod time code
1             # Paranoid::Filesystem -- Filesystem support for paranoid programs
2             #
3             # $Id: lib/Paranoid/Filesystem.pm, 2.09 2021/12/28 15:46:49 acorliss Exp $
4             #
5             # This software is free software. Similar to Perl, you can redistribute it
6             # and/or modify it under the terms of either:
7             #
8             # a) the GNU General Public License
9             # as published by the
10             # Free Software Foundation ; either version 1
11             # , or any later version
12             # , or
13             # b) the "Artistic License 2.0
14             # ",
15             #
16             # subject to the following additional term: No trademark rights to
17             # "Paranoid" have been or are conveyed under any of the above licenses.
18             # However, "Paranoid" may be used fairly to describe this unmodified
19             # software, in good faith, but not as a trademark.
20             #
21             # (c) 2005 - 2020, Arthur Corliss (corliss@digitalmages.com)
22             # (tm) 2008 - 2020, Paranoid Inc. (www.paranoid.com)
23             #
24             #####################################################################
25              
26             #####################################################################
27             #
28             # Environment definitions
29             #
30             #####################################################################
31              
32             package Paranoid::Filesystem;
33              
34 20     20   6347 use 5.008;
  20         80  
35              
36 20     20   104 use strict;
  20         39  
  20         397  
37 20     20   97 use warnings;
  20         38  
  20         573  
38 20     20   102 use vars qw($VERSION @EXPORT @EXPORT_OK %EXPORT_TAGS);
  20         39  
  20         1474  
39 20     20   225 use base qw(Exporter);
  20         47  
  20         1795  
40 20     20   135 use Cwd qw(realpath);
  20         42  
  20         1350  
41 20     20   3591 use Errno qw(:POSIX);
  20         10157  
  20         7647  
42 20     20   160 use Fcntl qw(:DEFAULT :seek :flock :mode);
  20         48  
  20         10877  
43 20     20   147 use Paranoid;
  20         42  
  20         1143  
44 20     20   135 use Paranoid::Debug qw(:all);
  20         54  
  20         3609  
45 20     20   4717 use Paranoid::Process qw(ptranslateUser ptranslateGroup);
  20         49  
  20         1560  
46 20     20   4917 use Paranoid::Input;
  20         42  
  20         1235  
47 20     20   5936 use Paranoid::IO;
  20         91  
  20         2173  
48 20     20   10880 use Paranoid::Glob;
  20         59  
  20         2019  
49              
50             ($VERSION) = ( q$Revision: 2.09 $ =~ /(\d+(?:\.\d+)+)/sm );
51              
52             @EXPORT = qw(
53             preadDir psubdirs pfiles
54             pmkdir prm prmR ptouch
55             ptouchR pchmod pchmodR pchown
56             pchownR pwhich
57             );
58             @EXPORT_OK = (
59             @EXPORT, qw(
60             ptranslateLink
61             pcleanPath
62             ptranslatePerms
63             ) );
64             %EXPORT_TAGS = ( all => [@EXPORT_OK], );
65              
66 20     20   172 use constant PERMMASK => 0777;
  20         48  
  20         94125  
67              
68             #####################################################################
69             #
70             # Module code follows
71             #
72             #####################################################################
73              
74             sub pmkdir ($;$\%) {
75              
76             # Purpose: Simulates a 'mkdir -p' command in pure Perl
77             # Returns: True (1) if all targets were successfully created,
78             # False (0) if there are any errors
79             # Usage: $rv = pmkdir("/foo/{a1,b2}");
80             # Usage: $rv = pmkdir("/foo", 0750);
81             # Usage: $rv = pmkdir("/foo", 0750, %errors);
82              
83 7     7 1 51 my $path = shift;
84 7         12 my $mode = shift;
85 7   50     36 my $eref = shift || {};
86 7         20 my ( $dirs, $directory, $subdir, @parts, $i );
87 7         14 my $rv = 1;
88              
89 7         27 pdebug( 'entering w/(%s)(%s)', PDLEVEL1, $path, $mode );
90 7         23 pIn();
91              
92             # Create a glob object if we weren't handed one.
93 7 100       19 if ( defined $path ) {
94 6 100       44 $dirs =
95             ref $path eq 'Paranoid::Glob'
96             ? $path
97             : Paranoid::Glob->new( globs => [$path] );
98             }
99              
100             # Leave Paranoid::Glob's errors in place if there was a problem
101 7 100       22 $rv = 0 unless defined $dirs;
102              
103             # Set and detaint mode
104 7 100       27 if ($rv) {
105 6 100       56 $mode = ptranslatePerms( defined $mode ? $mode : umask ^ PERMMASK );
106 6 100       23 unless ( detaint( $mode, 'int' ) ) {
107 1         4 Paranoid::ERROR =
108             pdebug( 'invalid mode argument passed', PDLEVEL1 );
109 1         3 $rv = 0;
110             }
111             }
112              
113             # Start creating directories
114 7 100       16 if ($rv) {
115              
116             # Iterate over each directory in the glob
117 5         24 foreach $directory (@$dirs) {
118 11         45 pdebug( 'processing %s', PDLEVEL2, $directory );
119              
120             # Skip directories already present
121 11 50       202 next if -d $directory;
122              
123             # Otherwise, split so we can backtrack to the first available
124             # subdirectory and start creating subdirectories from there
125 11         99 @parts = split m#/+#s, $directory;
126 11 50       34 $i = $parts[0] eq '' ? 1 : 0;
127 11   100     396 $i++ while $i < $#parts and -d join '/', @parts[ 0 .. $i ];
128 11         47 while ( $i <= $#parts ) {
129 17         61 $subdir = join '/', @parts[ 0 .. $i ];
130 17 50       268 unless ( -d $subdir ) {
131 17 50       1179 if ( mkdir $subdir, $mode ) {
132              
133             # Make sure perms are applied
134 17         337 chmod $mode, $subdir;
135              
136             } else {
137              
138             # Error out and halt all work
139 0         0 Paranoid::ERROR = pdebug( 'failed to create %s: %s',
140             PDLEVEL1, $subdir, $! );
141 0         0 $rv = 0;
142 0         0 last;
143             }
144             }
145 17         97 $i++;
146             }
147             }
148             }
149              
150 7         29 pOut();
151 7         20 pdebug( 'leaving w/rv: %s', PDLEVEL1, $rv );
152              
153 7         66 return $rv;
154             }
155              
156             sub prm ($;\%) {
157              
158             # Purpose: Simulates a "rm -f" command in pure Perl
159             # Returns: True (1) if all targets were successfully removed,
160             # False (0) if there are any errors
161             # Usage: $rv = prm("/foo");
162             # Usage: $rv = prm("/foo", %errors);
163              
164 7     7 1 1219 my $target = shift;
165 7         14 my $errRef = shift;
166 7         15 my $rv = 1;
167 7         12 my ( $glob, $tglob, @fstat );
168              
169 7         26 pdebug( 'entering w/(%s)(%s)', PDLEVEL1, $target, $errRef );
170 7         23 pIn();
171              
172             # Prep error hash
173 7 50       18 $errRef = {} unless defined $errRef;
174 7         16 %$errRef = ();
175              
176             # Create a glob object if we weren't handed one.
177 7 50       33 if ( defined $target ) {
178 7 100       34 $glob =
179             ref $target eq 'Paranoid::Glob'
180             ? $target
181             : Paranoid::Glob->new( globs => [$target] );
182             }
183 7 50       17 $rv = 0 unless defined $glob;
184              
185             # Start removing files
186 7 50       17 if ($rv) {
187              
188             # Consolidate the entries
189 7         24 $glob->consolidate;
190              
191             # Iterate over entries
192 7         28 foreach ( reverse @$glob ) {
193 21         182 pdebug( 'processing %s', PDLEVEL2, $_ );
194              
195             # Stat the file
196 21         355 @fstat = lstat $_;
197              
198 21 100       82 unless (@fstat) {
199              
200             # If the file is missing, consider the removal successful and
201             # move on.
202 2 50       22 next if $! == ENOENT;
203              
204             # Report remaining errors (permission denied, etc.)
205 0         0 $rv = 0;
206 0         0 $$errRef{$_} = $!;
207 0         0 Paranoid::ERROR =
208             pdebug( 'failed to remove %s: %s', PDLEVEL1, $_, $! );
209 0         0 next;
210             }
211              
212 19 100       75 if ( S_ISDIR( $fstat[2] ) ) {
213              
214             # Remove directories
215 12 100       536 unless ( rmdir $_ ) {
216              
217             # Record errors
218 1         4 $rv = 0;
219 1         19 $$errRef{$_} = $!;
220 1         6 Paranoid::ERROR =
221             pdebug( 'failed to remove %s: %s', PDLEVEL1, $_, $! );
222             }
223              
224             } else {
225              
226             # Remove all non-directories
227 7 50       314 unless ( unlink $_ ) {
228              
229             # Record errors
230 0         0 $rv = 0;
231 0         0 $$errRef{$_} = $!;
232 0         0 Paranoid::ERROR =
233             pdebug( 'failed to remove %s: %s', PDLEVEL1, $_, $! );
234             }
235             }
236             }
237             }
238              
239 7         38 pOut();
240 7         24 pdebug( 'leaving w/rv: %s', PDLEVEL1, $rv );
241              
242 7         42 return $rv;
243             }
244              
245             sub prmR ($;$\%) {
246              
247             # Purpose: Recursively calls prm to simulate "rm -rf"
248             # Returns: True (1) if all targets were successfully removed,
249             # False (0) if there are any errors
250             # Usage: $rv = prmR("/foo");
251             # Usage: $rv = prmR("/foo", 1);
252             # Usage: $rv = prmR("/foo", 1, %errors);
253              
254 4     4 1 1080 my $target = shift;
255 4         8 my $follow = shift;
256 4         10 my $errRef = shift;
257 4         8 my $rv = 1;
258 4         8 my ( $glob, $tglob );
259              
260 4         18 pdebug( 'entering w/(%s)(%s)(%s)', PDLEVEL1, $target, $follow, $errRef );
261 4         15 pIn();
262              
263             # Prep error hash
264 4 50       15 $errRef = {} unless defined $errRef;
265 4         9 %$errRef = ();
266              
267             # Create a glob object if we weren't handed one.
268 4 50       12 if ( defined $target ) {
269 4 50       36 $glob =
270             ref $target eq 'Paranoid::Glob'
271             ? $target
272             : Paranoid::Glob->new( globs => [$target] );
273             }
274 4 50       16 $rv = 0 unless defined $glob;
275              
276 4 50       10 if ($rv) {
277              
278             # Load the directory tree and execute prm
279 4   33     19 $rv = $glob->recurse( $follow, 1 ) && prm( $glob, %$errRef );
280             }
281              
282 4         15 pOut();
283 4         11 pdebug( 'leaving w/rv: %s', PDLEVEL1, $rv );
284              
285 4         34 return $rv;
286             }
287              
288             sub preadDir ($\@;$) {
289              
290             # Purpose: Populates the passed array ref with a list of all the
291             # directory entries (minus the '.' & '..') in the passed
292             # directory
293             # Returns: True (1) if the read was successful,
294             # False (0) if there are any errors
295             # Usage: $rv = preadDir("/tmp", @entries);
296             # Usage: $rv = preadDir("/tmp", @entries, 1);
297              
298 9     9 1 523 my ( $dir, $aref, $noLinks ) = @_;
299 9         13 my $rv = 1;
300 9         15 my $fh;
301              
302 9         26 pdebug( 'entering w/(%s)(%s)(%s)', PDLEVEL1, $dir, $aref, $noLinks );
303 9         23 pIn();
304 9         19 @$aref = ();
305              
306             # Validate directory and exit early, if need be
307 9 100 66     244 unless ( defined $dir and -e $dir and -d _ and -r _ ) {
      100        
      66        
308 4         13 $rv = 0;
309 4 50       25 Paranoid::ERROR = pdebug( (
    100          
    50          
310             !defined $dir ? 'undefined value passed as directory name'
311             : !-e _ ? 'directory (%s) does not exist'
312             : !-d _ ? '%s is not a directory'
313             : 'directory (%s) is not readable by the effective user'
314             ),
315             PDLEVEL1, $dir
316             );
317             }
318              
319 9 100       28 if ($rv) {
320              
321             # Read the directory's contents
322 5         183 $rv = opendir $fh, $dir;
323              
324 5 50       19 if ($rv) {
325              
326             # Get the list, filtering out '.' & '..'
327 5         127 foreach ( readdir $fh ) {
328 23 100       115 push @$aref, "$dir/$_" unless m/^\.\.?$/s;
329             }
330 5         61 closedir $fh;
331              
332             # Filter out symlinks, if necessary
333 5 50       17 @$aref = grep { !-l $_ } @$aref if $noLinks;
  0         0  
334              
335             } else {
336 0         0 Paranoid::ERROR = pdebug( 'error opening directory (%s): %s',
337             PDLEVEL1, $dir, $! );
338             }
339             }
340              
341 9         33 pdebug( 'returning %d entries', PDLEVEL2, scalar @$aref );
342              
343 9         22 pOut();
344 9         22 pdebug( 'leaving w/rv: %s', PDLEVEL1, $rv );
345              
346 9         37 return $rv;
347             }
348              
349             sub psubdirs ($\@;$) {
350              
351             # Purpose: Performs a preadDir but filters out all non-directory entries
352             # so that only subdirectory entries are returned. Can
353             # optionally filter out symlinks to directories as well.
354             # Returns: True (1) if the directory read was successful,
355             # False (0) if there are any errors
356             # Usage: $rv = psubdirs($dir, @entries);
357             # Usage: $rv = psubdirs($dir, @entries, 1);
358              
359 3     3 1 10 my ( $dir, $aref, $noLinks ) = @_;
360 3         6 my $rv = 0;
361              
362             # Validate arguments
363 3 50       9 $noLinks = 0 unless defined $noLinks;
364              
365 3         10 pdebug( 'entering w/(%s)(%s)(%s)', PDLEVEL1, $dir, $aref, $noLinks );
366 3         10 pIn();
367              
368             # Empty target array and retrieve list
369 3         9 $rv = preadDir( $dir, @$aref, $noLinks );
370              
371             # Filter out all non-directories
372 3 100       11 @$aref = grep { -d $_ } @$aref if $rv;
  5         87  
373              
374 3         24 pdebug( 'returning %d entries', PDLEVEL2, scalar @$aref );
375              
376 3         8 pOut();
377 3         8 pdebug( 'leaving w/rv: %s', PDLEVEL1, $rv );
378              
379 3         13 return $rv;
380             }
381              
382             sub pfiles ($\@;$) {
383              
384             # Purpose: Performs a preadDir but filters out all directory entries
385             # so that only file entries are returned. Can
386             # optionally filter out symlinks to files as well.
387             # Returns: True (1) if the directory read was successful,
388             # False (0) if there are any errors
389             # Usage: $rv = pfiles($dir, @entries);
390             # Usage: $rv = pfiles($dir, @entries, 1);
391              
392 3     3 1 10 my ( $dir, $aref, $noLinks ) = @_;
393 3         6 my $rv = 0;
394              
395             # Validate arguments
396 3 50       24 $noLinks = 0 unless defined $noLinks;
397              
398 3         12 pdebug( 'entering w/(%s)(%s)', PDLEVEL1, $dir, $aref );
399 3         9 pIn();
400              
401             # Empty target array and retrieve list
402 3         6 @$aref = ();
403 3         10 $rv = preadDir( $dir, @$aref, $noLinks );
404              
405             # Filter out all non-files
406 3 100       15 @$aref = grep { -f $_ } @$aref if $rv;
  4         62  
407              
408 3         14 pdebug( 'returning %d entries', PDLEVEL2, scalar @$aref );
409              
410 3         7 pOut();
411 3         8 pdebug( 'leaving w/rv: %s', PDLEVEL1, $rv );
412              
413 3         14 return $rv;
414             }
415              
416             sub pcleanPath {
417              
418             # Purpose: Removes/resolves directory artifacts like '/../', etc.
419             # Returns: Filtered string
420             # Usage: $filename = pcleanPath($filename);
421              
422 9     9 1 3763 my $filename = shift;
423              
424 9         33 pdebug( 'entering w/(%s)', PDLEVEL1, $filename );
425 9         29 pIn();
426              
427 9 100       19 if ( defined $filename ) {
428              
429             # Strip all //+, /./, and /{parent}/../
430 8         44 while ( $filename =~ m#/\.?/+#s ) { $filename =~ s#/\.?/+#/#sg }
  1         10  
431 8         31 while ( $filename =~ m#/(?:(?!\.\.)[^/]{2,}|[^/])/\.\./#s ) {
432 6         39 $filename =~ s#/(?:(?!\.\.)[^/]{2,}|[^/])/\.\./#/#sg;
433             }
434              
435             # Strip trailing /. and leading /../
436 8         20 $filename =~ s#/\.$##s;
437 8         20 while ( $filename =~ m#^/\.\./#s ) { $filename =~ s#^/\.\./#/#s }
  3         11  
438              
439             # Strip any ^[^/]+/../
440 8         23 while ( $filename =~ m#^[^/]+/\.\./#s ) {
441 1         6 $filename =~ s#^[^/]+/\.\./##s;
442             }
443              
444             # Strip any trailing /^[^/]+/..$
445 8         22 while ( $filename =~ m#/[^/]+/\.\.$#s ) {
446 1         6 $filename =~ s#/[^/]+/\.\.$##s;
447             }
448             }
449              
450 9         27 pOut();
451 9         22 pdebug( 'leaving w/rv: %s', PDLEVEL1, $filename );
452              
453 9         36 return $filename;
454             }
455              
456             sub ptranslateLink {
457              
458             # Purpose: Performs either a full (realpath) or a partial one (last
459             # filename element only) on the passed filename
460             # Returns: Altered filename if successful, undef if there are any
461             # failures
462             # Usage: $filename = ptranslateLink($filename);
463             # Usage: $filename = ptranslateLink($filename, 1);
464              
465 2     2 1 679 my $link = shift;
466 2   50     11 my $fullyTranslate = shift || 0;
467 2         5 my $nLinks = 0;
468 2         6 my ( $i, $target );
469              
470 2         9 pdebug( 'entering w/(%s)(%s)', PDLEVEL1, $link, $fullyTranslate );
471 2         6 pIn();
472              
473             # Validate link and exit early, if need be
474 2 50 50     53 unless ( defined $link and scalar lstat $link ) {
475 0         0 Paranoid::ERROR = pdebug( 'link (%s) does not exist on filesystem',
476             PDLEVEL1, $link );
477 0         0 pOut();
478 0         0 pdebug( 'leaving w/rv: undef', PDLEVEL1 );
479 0         0 return undef;
480             }
481              
482             # Check every element in the path for symlinks and translate it if
483             # if a full translation was requested
484 2 50       9 if ($fullyTranslate) {
485              
486             # Resolve the link
487 0         0 $target = realpath($link);
488              
489             # Make sure we got an answer
490 0 0       0 if ( defined $target ) {
491              
492             # Save the answer
493 0         0 $link = $target;
494              
495             } else {
496              
497             # Report our inability to resolve the link
498 0         0 Paranoid::ERROR =
499             pdebug( 'link (%s) couldn\'t be resolved fully: %s',
500             PDLEVEL1, $link, $! );
501 0         0 $link = undef;
502             }
503              
504             } else {
505              
506             # Is the file passed a symlink?
507 2 50       25 if ( -l $link ) {
508              
509             # Yes it is, let's get the target
510 2         30 $target = readlink $link;
511 2         11 pdebug( 'last element is a link to %s', PDLEVEL1, $target );
512              
513             # Is the target a relative filename?
514 2 50       13 if ( $target =~ m#^(?:\.\.?/|[^/])#s ) {
515              
516             # Yupper, replace the filename with the target
517 2         16 $link =~ s#[^/]+$#$target#s;
518              
519             } else {
520              
521             # The target is fully qualified, so replace link entirely
522 0         0 $link = $target;
523             }
524             }
525             }
526              
527 2 50       14 $link = pcleanPath($link) if defined $link;
528              
529 2         10 pOut();
530 2         7 pdebug( 'leaving w/rv: %s', PDLEVEL1, $link );
531              
532 2         8 return $link;
533             }
534              
535             sub ptouch ($;$\%) {
536              
537             # Purpose: Simulates a "touch" command in pure Perl
538             # Returns: True (1) if all targets were successfully touched,
539             # False (0) if there are any errors
540             # Usage: $rv = ptouch("/foo/*");
541             # Usage: $rv = ptouch("/foo/*", $tstamp);
542             # Usage: $rv = ptouch("/foo/*", $tstamp, %errors);
543              
544 7     7 1 572 my $target = shift;
545 7         12 my $stamp = shift;
546 7         11 my $errRef = shift;
547 7         10 my $rv = 1;
548 7         12 my $irv = 1;
549 7         9 my ( $glob, $tglob, $fh );
550              
551 7         25 pdebug( 'entering w/(%s)(%s)(%s)', PDLEVEL1, $target, $stamp, $errRef );
552 7         23 pIn();
553              
554             # Prep error hash
555 7 100       16 $errRef = {} unless defined $errRef;
556 7         13 %$errRef = ();
557              
558             # Create a glob object if we weren't handed one.
559 7 50       15 if ( defined $target ) {
560 7 100       36 $glob =
561             ref $target eq 'Paranoid::Glob'
562             ? $target
563             : Paranoid::Glob->new( globs => [$target] );
564             }
565 7 50       19 $rv = 0 unless defined $glob;
566              
567 7 50       15 if ($rv) {
568              
569             # Apply the default timestamp if omitted
570 7 100       14 $stamp = time unless defined $stamp;
571              
572 7 50       26 unless ( detaint( $stamp, 'int' ) ) {
573 0         0 Paranoid::ERROR = pdebug( 'Invalid characters in timestamp: %s',
574             PDLEVEL2, $stamp );
575 0         0 $rv = 0;
576             }
577             }
578              
579             # Start touching stuff
580 7 50       16 if ($rv) {
581              
582             # Consolidate the entries
583 7         27 $glob->consolidate;
584              
585             # Iterate over entries
586 7         16 foreach $target (@$glob) {
587 16         63 pdebug( 'processing %s', PDLEVEL2, $target );
588 16         21 $irv = 1;
589              
590             # Create the target if it does not exist
591 16 100       260 unless ( -e $target ) {
592 4         17 pdebug( 'creating empty file (%s)', PDLEVEL2, $target );
593 4   66     16 $fh = popen( $target, O_CREAT | O_EXCL | O_RDWR )
594             || popen( $target, O_RDWR );
595 4 100       11 if ( defined $fh ) {
596 2         7 pclose($target);
597             } else {
598 2         9 $$errRef{$target} = $!;
599 2         5 $irv = $rv = 0;
600             }
601             }
602              
603             # Touch the file
604 16 100       48 if ($irv) {
605 14 50       261 unless ( utime $stamp, $stamp, $target ) {
606 0         0 $$errRef{$target} = $!;
607 0         0 $rv = 0;
608             }
609             }
610             }
611             }
612              
613 7         31 pOut();
614 7         18 pdebug( 'leaving w/rv: %s', PDLEVEL1, $rv );
615              
616 7         49 return $rv;
617             }
618              
619             sub ptouchR ($;$$\%) {
620              
621             # Purpose: Calls ptouch recursively
622             # Returns: True (1) if all targets were successfully touched,
623             # False (0) if there are any errors
624             # Usage: $rv = ptouchR("/foo");
625             # Usage: $rv = ptouchR("/foo", $tstamp);
626             # Usage: $rv = ptouchR("/foo", $tstamp, $follow);
627             # Usage: $rv = ptouchR("/foo", $tstamp, $follow, %errors);
628              
629 3     3 1 1140 my $target = shift;
630 3         5 my $stamp = shift;
631 3         5 my $follow = shift;
632 3         5 my $errRef = shift;
633 3         5 my $rv = 1;
634 3         6 my ( $glob, $tglob );
635              
636 3         11 pdebug( 'entering w/(%s)(%s)(%s)(%s)',
637             PDLEVEL1, $target, $stamp, $follow, $errRef );
638 3         10 pIn();
639              
640             # Prep error hash
641 3 100       7 $errRef = {} unless defined $errRef;
642 3         8 %$errRef = ();
643              
644             # Create a glob object if we weren't handed one.
645 3 50       8 if ( defined $target ) {
646 3 100       18 $glob =
647             ref $target eq 'Paranoid::Glob'
648             ? $target
649             : Paranoid::Glob->new( globs => [$target] );
650             }
651 3 50       8 $rv = 0 unless defined $glob;
652              
653 3 50       7 if ($rv) {
654              
655             # Load the directory tree and execute prm
656 3   66     12 $rv = $glob->recurse( $follow, 1 )
657             && ptouch( $glob, $stamp, %$errRef );
658             }
659              
660 3         9 pOut();
661 3         8 pdebug( 'leaving w/rv: %s', PDLEVEL1, $rv );
662              
663 3         20 return $rv;
664             }
665              
666             sub ptranslatePerms {
667              
668             # Purpose: Translates symbolic permissions (as supported by userland
669             # chmod, etc.) into the octal permissions.
670             # Returns: Numeric permissions if valid symbolic permissions were passed,
671             # undef otherwise
672             # Usage: $perm = ptranslatePerms('ug+srw');
673              
674 21     21 1 3151 my $perm = shift;
675 21         35 my $rv = undef;
676 21         40 my ( @tmp, $o, $p );
677              
678 21         69 pdebug( 'entering w/(%s)', PDLEVEL1, $perm );
679 21         60 pIn();
680              
681             # Validate permissions string
682 21 100 66     193 if ( defined $perm and $perm =~ /^\d+$/s ) {
    100 66        
683              
684 12 100       41 if ( $perm =~ /^0/s ) {
685 2 100       9 if ( $perm =~ /^0[0-8]{3,4}$/s ) {
686              
687             # String representation of octal number
688 1         67 eval "\$perm = $perm;";
689 1         8 detaint( $perm, 'int', $p );
690              
691             } else {
692 1         3 pdebug( 'invalid octal presentation: %s', PDLEVEL1, $perm );
693             }
694              
695             } else {
696              
697             # Probably a converted integer already, treat it as verbatim
698 10         58 detaint( $perm, 'int', $p );
699             }
700              
701             } elsif ( defined $perm and $perm =~ /^([ugo]+)([+\-])([rwxst]+)$/s ) {
702              
703             # Translate symbolic representation
704 6         14 $o = $p = 00;
705 6         31 @tmp = ( $1, $2, $3 );
706 6 100       26 $o = S_IRWXU if $tmp[0] =~ /u/s;
707 6 100       16 $o |= S_IRWXG if $tmp[0] =~ /g/s;
708 6 100       22 $o |= S_IRWXO if $tmp[0] =~ /o/s;
709 6 50       18 $p = ( S_IRUSR | S_IRGRP | S_IROTH ) if $tmp[2] =~ /r/s;
710 6 100       17 $p |= ( S_IWUSR | S_IWGRP | S_IWOTH ) if $tmp[2] =~ /w/s;
711 6 50       21 $p |= ( S_IXUSR | S_IXGRP | S_IXOTH ) if $tmp[2] =~ /x/s;
712 6         22 $p &= $o;
713 6 100       16 $p |= S_ISVTX if $tmp[2] =~ /t/s;
714 6 50 66     18 $p |= S_ISGID if $tmp[2] =~ /s/s && $tmp[0] =~ /g/s;
715 6 100 66     20 $p |= S_ISUID if $tmp[2] =~ /s/s && $tmp[0] =~ /u/s;
716              
717             } else {
718              
719             # Report invalid characters in permission string
720 3         11 Paranoid::ERROR =
721             pdebug( 'invalid permissions (%s)', PDLEVEL1, $perm );
722              
723             }
724 21         40 $rv = $p;
725              
726 21         57 pOut();
727 21 100       113 pdebug( (
728             defined $rv
729             ? sprintf( 'leaving w/rv: %04o', $rv )
730             : 'leaving w/rv: undef'
731             ),
732             PDLEVEL1
733             );
734              
735 21         64 return $rv;
736             }
737              
738             sub pchmod ($$;\%) {
739              
740             # Purpose: Simulates a "chmod" command in pure Perl
741             # Returns: True (1) if all targets were successfully chmod'd,
742             # False (0) if there are any errors
743             # Usage: $rv = pchmod("/foo", $perms);
744             # Usage: $rv = pchmod("/foo", $perms, %errors);
745              
746 8     8 1 24 my $target = shift;
747 8         18 my $perms = shift;
748 8         12 my $errRef = shift;
749 8         14 my $rv = 1;
750 8         23 my ( $glob, $tglob, @fstat );
751 8         0 my ( $ptrans, $cperms, $addPerms, @tmp );
752              
753 8         23 pdebug( 'entering w/(%s)(%s)(%s)', PDLEVEL1, $target, $perms, $errRef );
754 8         19 pIn();
755              
756             # Prep error hash
757 8 100       19 $errRef = {} unless defined $errRef;
758 8         13 %$errRef = ();
759              
760             # Create a glob object if we weren't handed one.
761 8 50       17 if ( defined $target ) {
762 8 100       28 $glob =
763             ref $target eq 'Paranoid::Glob'
764             ? $target
765             : Paranoid::Glob->new( globs => [$target] );
766             }
767 8 50       15 $rv = 0 unless defined $glob;
768              
769             # Convert perms if they're symbolic
770 8 50 33     34 if ( defined $perms and defined( $ptrans = ptranslatePerms($perms) ) ) {
771 8 100       33 if ( $perms =~ /[ugo]+[+-]/si ) {
772 3 50       9 $addPerms = $perms =~ /-/s ? 0 : 1;
773             } else {
774 5         9 $ptrans = undef;
775             }
776             } else {
777 0         0 pdebug( 'invalid permissions passed: %s', PDLEVEL1, $perms );
778 0         0 $rv = 0;
779             }
780              
781 8 50       16 if ($rv) {
782              
783             # Consolidate the entries
784 8         27 $glob->consolidate;
785              
786             # Iterate over entries
787 8         18 foreach (@$glob) {
788 20         75 pdebug( 'processing %s', PDLEVEL2, $_ );
789              
790 20 100       44 if ( defined $ptrans ) {
791              
792             # Get the current file mode
793 8         130 @fstat = stat $_;
794 8 100       31 unless (@fstat) {
795 1         3 $rv = 0;
796 1         14 $$errRef{$_} = $!;
797 1         4 Paranoid::ERROR =
798             pdebug( 'failed to adjust permissions of %s: %s',
799             PDLEVEL1, $_, $! );
800 1         5 next;
801             }
802              
803             # If ptrans is defined we're going to do relative
804             # application of permissions
805             pdebug(
806 7 50       55 $addPerms
807             ? sprintf( 'adding perms %04o', $ptrans )
808             : sprintf( 'removing perms %04o', $ptrans ),
809             PDLEVEL2
810             );
811              
812             # Get the current permissions
813 7         13 $cperms = $fstat[2] & PERMMASK;
814 7         28 pdebug(
815             sprintf( 'current permissions of %s: %04o', $_, $cperms ),
816             PDLEVEL2
817             );
818 7 50       16 $cperms =
819             $addPerms
820             ? ( $cperms | $ptrans )
821             : ( $cperms & ( PERMMASK ^ $ptrans ) );
822 7         27 pdebug( sprintf( 'new permissions of %s: %04o', $_, $cperms ),
823             PDLEVEL2 );
824 7 50       145 unless ( chmod $cperms, $_ ) {
825 0         0 $rv = 0;
826 0         0 $$errRef{$_} = $!;
827 0         0 Paranoid::ERROR =
828             pdebug( 'failed to adjust permissions of %s: %s',
829             PDLEVEL1, $_, $! );
830             }
831              
832             } else {
833              
834             # Otherwise, the permissions are explicit
835             #
836             # Detaint number mode
837 12 50       35 if ( detaint( $perms, 'int' ) ) {
838              
839             # Detainted, now apply
840 12         58 pdebug(
841             sprintf(
842             'assigning permissions of %04o to %s',
843             $perms, $_
844             ),
845             PDLEVEL2
846             );
847 12 100       263 unless ( chmod $perms, $_ ) {
848 2         7 $rv = 0;
849 2         18 $$errRef{$_} = $!;
850             }
851             } else {
852              
853             # Detainting failed -- report
854 0         0 $$errRef{$_} = $!;
855 0         0 Paranoid::ERROR =
856             pdebug( 'failed to detaint permissions mode',
857             PDLEVEL1 );
858 0         0 $rv = 0;
859             }
860             }
861             }
862             }
863              
864 8         33 pOut();
865 8         21 pdebug( 'leaving w/rv: %s', PDLEVEL1, $rv );
866              
867 8         48 return $rv;
868             }
869              
870             sub pchmodR ($$;$\%) {
871              
872             # Purpose: Recursively calls pchmod
873             # Returns: True (1) if all targets were successfully chmod'd,
874             # False (0) if there are any errors
875             # Usage: $rv = pchmodR("/foo", $perms);
876             # Usage: $rv = pchmodR("/foo", $perms, $follow);
877             # Usage: $rv = pchmodR("/foo", $perms, $follow, %errors);
878              
879 4     4 1 19 my $target = shift;
880 4         11 my $perms = shift;
881 4         7 my $follow = shift;
882 4         7 my $errRef = shift;
883 4         6 my $rv = 1;
884 4         7 my ( $glob, $tglob );
885              
886 4         15 pdebug( 'entering w/(%s)(%s)(%s)(%s)',
887             PDLEVEL1, $target, $perms, $follow, $errRef );
888 4         13 pIn();
889              
890             # Prep error hash
891 4 100       12 $errRef = {} unless defined $errRef;
892 4         7 %$errRef = ();
893              
894             # Create a glob object if we weren't handed one.
895 4 50       10 if ( defined $target ) {
896 4 50       27 $glob =
897             ref $target eq 'Paranoid::Glob'
898             ? $target
899             : Paranoid::Glob->new( globs => [$target] );
900             }
901 4 50       13 $rv = 0 unless defined $glob;
902              
903 4 50       10 if ($rv) {
904              
905             # Load the directory tree and execute pchmod
906 4   66     20 $rv = $glob->recurse( $follow, 1 )
907             && pchmod( $glob, $perms, %$errRef );
908             }
909              
910 4         11 pOut();
911 4         10 pdebug( 'leaving w/rv: %s', PDLEVEL1, $rv );
912              
913 4         23 return $rv;
914             }
915              
916             sub pchown ($$;$\%) {
917              
918             # Purpose: Simulates a "chown" command in pure Perl
919             # Returns: True (1) if all targets were successfully owned,
920             # False (0) if there are any errors
921             # Usage: $rv = pchown("/foo", $user);
922             # Usage: $rv = pchown("/foo", $user, $group);
923             # Usage: $rv = pchown("/foo", $user, $group, %errors);
924              
925 0     0 1 0 my $target = shift;
926 0         0 my $user = shift;
927 0         0 my $group = shift;
928 0         0 my $errRef = shift;
929 0         0 my $rv = 1;
930 0         0 my ( $glob, $tglob, @fstat );
931              
932 0         0 pdebug( 'entering w/(%s)(%s)(%s)(%s)',
933             PDLEVEL1, $target, $user, $group, $errRef );
934 0         0 pIn();
935              
936             # Translate to UID/GID
937 0 0       0 $user = -1 unless defined $user;
938 0 0       0 $group = -1 unless defined $group;
939 0 0       0 $user = ptranslateUser($user) unless $user =~ /^-?\d+$/s;
940 0 0       0 $group = ptranslateGroup($group) unless $group =~ /^-?\d+$/s;
941 0 0 0     0 unless ( defined $user and defined $group ) {
942 0         0 $rv = 0;
943 0         0 Paranoid::ERROR =
944             pdebug( 'unsuccessful at translating uid/gid', PDLEVEL1 );
945             }
946              
947             # Prep error hash
948 0 0       0 $errRef = {} unless defined $errRef;
949 0         0 %$errRef = ();
950              
951             # Create a glob object if we weren't handed one.
952 0 0       0 if ( defined $target ) {
953 0 0       0 $glob =
954             ref $target eq 'Paranoid::Glob'
955             ? $target
956             : Paranoid::Glob->new( globs => [$target] );
957             }
958 0 0       0 $rv = 0 unless defined $glob;
959              
960 0 0 0     0 if ( $rv and ( $user != -1 or $group != -1 ) ) {
      0        
961              
962             # Proceed
963 0         0 pdebug( 'UID: %s GID: %s', PDLEVEL2, $user, $group );
964              
965             # Consolidate the entries
966 0         0 $glob->consolidate;
967              
968             # Process the list
969 0         0 foreach (@$glob) {
970              
971 0         0 pdebug( 'processing %s', PDLEVEL2, $_ );
972              
973 0 0       0 unless ( chown $user, $group, $_ ) {
974 0         0 $rv = 0;
975 0         0 $$errRef{$_} = $!;
976 0         0 Paranoid::ERROR =
977             pdebug( 'failed to adjust ownership of %s: %s',
978             PDLEVEL1, $_, $! );
979             }
980             }
981             }
982              
983 0         0 pOut();
984 0         0 pdebug( 'leaving w/rv: %s', PDLEVEL1, $rv );
985              
986 0         0 return $rv;
987             }
988              
989             sub pchownR ($$;$$\%) {
990              
991             # Purpose: Calls pchown recursively
992             # Returns: True (1) if all targets were successfully owned,
993             # False (0) if there are any errors
994             # Usage: $rv = pchownR("/foo", $user);
995             # Usage: $rv = pchownR("/foo", $user, $group);
996             # Usage: $rv = pchownR("/foo", $user, $group, $follow);
997             # Usage: $rv = pchownR("/foo", $user, $group, $follow, %errors);
998              
999 0     0 1 0 my $target = shift;
1000 0         0 my $user = shift;
1001 0         0 my $group = shift;
1002 0         0 my $follow = shift;
1003 0         0 my $errRef = shift;
1004 0         0 my $rv = 1;
1005 0         0 my ( $glob, $tglob );
1006              
1007 0         0 pdebug( 'entering w/(%s)(%s)(%s)(%s)(%s)',
1008             PDLEVEL1, $target, $user, $group, $follow, $errRef );
1009 0         0 pIn();
1010              
1011             # Prep error hash
1012 0 0       0 $errRef = {} unless defined $errRef;
1013 0         0 %$errRef = ();
1014              
1015             # Create a glob object if we weren't handed one.
1016 0 0       0 if ( defined $target ) {
1017 0 0       0 $glob =
1018             ref $target eq 'Paranoid::Glob'
1019             ? $target
1020             : Paranoid::Glob->new( globs => [$target] );
1021             }
1022 0 0       0 $rv = 0 unless defined $glob;
1023              
1024 0 0       0 if ($rv) {
1025              
1026             # Load the directory tree and execute pchown
1027 0   0     0 $rv = $glob->recurse( $follow, 1 )
1028             && pchown( $glob, $user, $group, %$errRef );
1029             }
1030              
1031 0         0 pOut();
1032 0         0 pdebug( 'leaving w/rv: %s', PDLEVEL1, $rv );
1033              
1034 0         0 return $rv;
1035             }
1036              
1037             sub pwhich {
1038              
1039             # Purpose: Simulates a "which" command in pure Perl
1040             # Returns: The full path to the requested program if successful
1041             # undef if not found
1042             # Usage: $filename = pwhich('ls');
1043              
1044 2     2 1 1385 my $binary = shift;
1045 2         29 my @directories = grep /^.+$/s, split /:/s, $ENV{PATH};
1046 2         5 my $match = undef;
1047              
1048 2         9 pdebug( 'entering w/(%s)', PDLEVEL1, $binary );
1049 2         8 pIn();
1050              
1051             # Try to detaint filename
1052 2 50       10 if ( detaint( $binary, 'filename', $b ) ) {
1053              
1054             # Success -- start searching directories in PATH
1055 2         6 foreach (@directories) {
1056 3         19 pdebug( 'searching %s', PDLEVEL2, $_ );
1057 3 100 66     152 if ( -r "$_/$b" && -x _ ) {
1058 1         5 $match = "$_/$b";
1059 1         8 $match =~ s#/+#/#sg;
1060 1         5 last;
1061             }
1062             }
1063              
1064             } else {
1065              
1066             # Report detaint failure
1067 0         0 Paranoid::ERROR = pdebug( 'failed to detaint %s', PDLEVEL1, $binary );
1068             }
1069              
1070 2         10 pOut();
1071 2         5 pdebug( 'leaving w/rv: %s', PDLEVEL1, $match );
1072              
1073 2         7 return $match;
1074             }
1075              
1076             1;
1077              
1078             __END__