← Index
NYTProf Performance Profile   « line view »
For ./view
  Run on Fri Jul 31 18:42:36 2015
Reported on Fri Jul 31 18:48:13 2015

Filename/var/www/foswikidev/core/lib/Foswiki/Configure/FileUtil.pm
StatementsExecuted 13 statements in 4.51ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
1111.34ms28.1msFoswiki::Configure::FileUtil::::BEGIN@19Foswiki::Configure::FileUtil::BEGIN@19
11117µs35µsFoswiki::Configure::FileUtil::::BEGIN@13Foswiki::Configure::FileUtil::BEGIN@13
11112µs60µsFoswiki::Configure::FileUtil::::BEGIN@18Foswiki::Configure::FileUtil::BEGIN@18
11112µs17µsFoswiki::Configure::FileUtil::::BEGIN@14Foswiki::Configure::FileUtil::BEGIN@14
11111µs44µsFoswiki::Configure::FileUtil::::BEGIN@16Foswiki::Configure::FileUtil::BEGIN@16
1118µs8µsFoswiki::Configure::FileUtil::::BEGIN@20Foswiki::Configure::FileUtil::BEGIN@20
0000s0sFoswiki::Configure::FileUtil::::_buildRWXMessageStringFoswiki::Configure::FileUtil::_buildRWXMessageString
0000s0sFoswiki::Configure::FileUtil::::_tarFoswiki::Configure::FileUtil::_tar
0000s0sFoswiki::Configure::FileUtil::::_untarFoswiki::Configure::FileUtil::_untar
0000s0sFoswiki::Configure::FileUtil::::_unzipFoswiki::Configure::FileUtil::_unzip
0000s0sFoswiki::Configure::FileUtil::::_zipFoswiki::Configure::FileUtil::_zip
0000s0sFoswiki::Configure::FileUtil::::checkCanCreateFileFoswiki::Configure::FileUtil::checkCanCreateFile
0000s0sFoswiki::Configure::FileUtil::::checkGNUProgramFoswiki::Configure::FileUtil::checkGNUProgram
0000s0sFoswiki::Configure::FileUtil::::checkTreePermsFoswiki::Configure::FileUtil::checkTreePerms
0000s0sFoswiki::Configure::FileUtil::::copytreeFoswiki::Configure::FileUtil::copytree
0000s0sFoswiki::Configure::FileUtil::::createArchiveFoswiki::Configure::FileUtil::createArchive
0000s0sFoswiki::Configure::FileUtil::::findFileOnPathFoswiki::Configure::FileUtil::findFileOnPath
0000s0sFoswiki::Configure::FileUtil::::findFileOnTreeFoswiki::Configure::FileUtil::findFileOnTree
0000s0sFoswiki::Configure::FileUtil::::findPackagesFoswiki::Configure::FileUtil::findPackages
0000s0sFoswiki::Configure::FileUtil::::getPerlLocationFoswiki::Configure::FileUtil::getPerlLocation
0000s0sFoswiki::Configure::FileUtil::::listDirFoswiki::Configure::FileUtil::listDir
0000s0sFoswiki::Configure::FileUtil::::lscFileNameFoswiki::Configure::FileUtil::lscFileName
0000s0sFoswiki::Configure::FileUtil::::rewriteShebangFoswiki::Configure::FileUtil::rewriteShebang
0000s0sFoswiki::Configure::FileUtil::::unpackArchiveFoswiki::Configure::FileUtil::unpackArchive
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1# See bottom of file for license and copyright information
2
3package Foswiki::Configure::FileUtil;
4
5=begin TML
6
7---+ package Foswiki::Configure::FileUtil
8
9Basic file utilities used by Configure and admin scripts
10
11=cut
12
13236µs252µs
# spent 35µs (17+17) within Foswiki::Configure::FileUtil::BEGIN@13 which was called: # once (17µs+17µs) by Foswiki::Configure::Load::BEGIN@26 at line 13
use strict;
# spent 35µs making 1 call to Foswiki::Configure::FileUtil::BEGIN@13 # spent 17µs making 1 call to strict::import
14231µs223µs
# spent 17µs (12+6) within Foswiki::Configure::FileUtil::BEGIN@14 which was called: # once (12µs+6µs) by Foswiki::Configure::Load::BEGIN@26 at line 14
use warnings;
# spent 17µs making 1 call to Foswiki::Configure::FileUtil::BEGIN@14 # spent 6µs making 1 call to warnings::import
15
16233µs276µs
# spent 44µs (11+32) within Foswiki::Configure::FileUtil::BEGIN@16 which was called: # once (11µs+32µs) by Foswiki::Configure::Load::BEGIN@26 at line 16
use Assert;
# spent 44µs making 1 call to Foswiki::Configure::FileUtil::BEGIN@16 # spent 32µs making 1 call to Exporter::import
17
18233µs2108µs
# spent 60µs (12+48) within Foswiki::Configure::FileUtil::BEGIN@18 which was called: # once (12µs+48µs) by Foswiki::Configure::Load::BEGIN@26 at line 18
use Encode;
# spent 60µs making 1 call to Foswiki::Configure::FileUtil::BEGIN@18 # spent 48µs making 1 call to Exporter::import
192111µs128.1ms
# spent 28.1ms (1.34+26.8) within Foswiki::Configure::FileUtil::BEGIN@19 which was called: # once (1.34ms+26.8ms) by Foswiki::Configure::Load::BEGIN@26 at line 19
use Foswiki::Configure::Reporter ();
# spent 28.1ms making 1 call to Foswiki::Configure::FileUtil::BEGIN@19
2024.26ms18µs
# spent 8µs within Foswiki::Configure::FileUtil::BEGIN@20 which was called: # once (8µs+0s) by Foswiki::Configure::Load::BEGIN@26 at line 20
use File::Spec;
# spent 8µs making 1 call to Foswiki::Configure::FileUtil::BEGIN@20
21
22=begin TML
23
24---++ StaticMethod findFileOnTree($dir, $pattern, $reject) ->> $fullpath
25Recursive search for a file matching the specified pattern, searching $dir
26and all subdirectories of $dir, Anything matching $reject is not
27considered, to avoid searching the ,pfv subdirectories..
28
29This is used by checkers and bootstrap to see if there are any ",v" rcs
30files in the Store.
31
32Example:
33
34 findFileOnTree( $Foswiki::cfg{DataDir}, qr/,v$/, qr/,pfv$/ );
35
36SMELL: We could use File::Find as a CPAN solution, however in this case
37really only need to find the first occurance, we have no need for the full
38list, just whether or not any exist. File::Find returns the complete list
39of matching files.
40
41=cut
42
43sub findFileOnTree {
44
45 #my ( $dir, $match, $reject ) = @_;
46
47 if ( opendir( my $dh, $_[0] ) ) {
48 foreach ( grep !/^\./, readdir($dh) ) {
49 next if $_ =~ $_[2];
50 my $dentry = File::Spec->catdir( $_[0], $_ );
51 return $dentry if $dentry =~ $_[1];
52 if ( -d $dentry ) {
53 my $hit = findFileOnTree( $dentry, $_[1], $_[2] );
54 return $hit if ($hit);
55 }
56 }
57 closedir $dh;
58 }
59 else {
60 return
61 "Search failed: Directory open of $_[0] failed. Check permissions.\n";
62 }
63 return 0;
64}
65
66=begin TML
67
68---++ StaticMethod findFileOnPath($filename) ->> $fullpath
69Find a file on the @INC path, or undef if not found.
70
71$filename may be a simple file name e.g. Example.pm
72or may be a /-separated path e.g. Net/Util
73or a class path e.g. Net::Util
74
75Note that a terminating .pm is required to find a
76perl module.
77
78=cut
79
80sub findFileOnPath {
81 my $file = shift;
82
83 $file =~ s(::)(/)g;
84
85 foreach my $incdir (@INC) {
86
87 my ( $volume, $directories, $filename ) =
88 File::Spec->splitpath("$incdir/$file");
89 next unless ( -d $volume . $directories );
90 opendir( my $df, $volume . $directories ) || next;
91 my @files = grep { $_ eq $filename } readdir($df);
92 closedir($df);
93
94 if ( scalar @files ) {
95 return "$incdir/$file";
96 }
97 }
98 return undef;
99}
100
101=begin TML
102
103---++ StaticMethod lscFileName() -> $localsite_cfg_path
104
105Determine the pathname of LocalSite.cfg. This file must be
106on the path, but may not exist yet; it it doesn't, then
107Foswiki.spec must be and LocalSite.cfg will be placed in the
108same directory.
109
110=cut
111
112sub lscFileName {
113 my $lsc = findFileOnPath('LocalSite.cfg');
114
115 return $lsc if ($lsc);
116
117 # If not found on the path, park it beside Foswiki.spec
118 $lsc = findFileOnPath('Foswiki.spec');
119 if ($lsc) {
120 $lsc =~ s/Foswiki\.spec/LocalSite.cfg/;
121 return $lsc;
122 }
123
124 # No existing file we can use
125 return undef;
126}
127
128=begin TML
129
130---++ StaticMethod findPackages( $pattern ) -> @list
131
132Finds all packages that match the pattern in @INC
133
134 * =$pattern= is a wildcard expression that matches classes e.g.
135 Foswiki::Plugins::*Plugin. * is the only wildcard supported.
136
137Return a list of package names.
138
139=cut
140
141sub findPackages {
142 my ($pattern) = @_;
143
144 $pattern =~ s/\*/.*/g;
145 my @path = split( /::/, $pattern );
146
147 my $places = \@INC;
148 my $dir;
149
150 while ( scalar(@path) > 1 && @$places ) {
151 my $pathel = shift(@path);
152 eval("\$pathel = qr/^($pathel)\$/"); # () to untaint
153 my @newplaces;
154
155 foreach my $place (@$places) {
156 if ( opendir( $dir, $place ) ) {
157
158 #next if ($place =~ m/^\..*/);
159 foreach my $subplace ( readdir $dir ) {
160 next unless $subplace =~ $pathel;
161
162 #next if ($subplace =~ m/^\..*/);
163 push( @newplaces, $place . '/' . $1 );
164 }
165 closedir $dir;
166 }
167 }
168 $places = \@newplaces;
169 }
170
171 my @list;
172 my $leaf = pop(@path);
173 eval("\$leaf = qr/$leaf\\.pm\$/");
174 ASSERT( !$@, $@ ) if DEBUG;
175
176 my %known;
177 foreach my $place (@$places) {
178 if ( opendir( $dir, $place ) ) {
179 foreach my $file ( readdir $dir ) {
180 next unless $file =~ $leaf;
181 next if ( $file =~ m/^\..*/ );
182 next unless $file =~ m/^(.*)\.pm$/;
183 my $module = "$place/$1";
184 $module =~ s./.::.g;
185 if ( $module =~ m/($pattern)$/ ) {
186 push( @list, $1 ) unless $known{$1};
187 $known{$1} = 1;
188 }
189 }
190 closedir $dir;
191 }
192 }
193 return @list;
194}
195
196=begin TML
197
198---++ StaticMethod checkCanCreateFile($path) -> $report
199
200Check that the given path can be created (or, if it already exists,
201can be written). If the existing path is a directory, recursively
202check for rw permissions using =checkTreePerms=.
203
204Returns a message if the check fails or undef if the check passed.
205
206=cut
207
208sub checkCanCreateFile {
209 my ($name) = @_;
210
211 if ( -e $name ) {
212
213 # if the file exists just check perms and return
214 my $report = checkTreePerms( $name, 'rw' );
215 if ( @{ $report->{messages} } ) {
216 return join( "\n", @{ $report->{messages} } );
217 }
218 return undef;
219 }
220
221 # check the containing dir
222 my @path = File::Spec->splitdir($name);
223 pop(@path);
224 unless ( -w File::Spec->catfile( @path, '' ) ) {
225 return File::Spec->catfile( @path, '' ) . ' is not writable';
226 }
227 my $txt1 = "test 1 2 3";
228 open( my $fh, '>', $name )
229 or return 'Could not create test file ' . $name . ':' . $!;
230 print $fh $txt1;
231 close($fh);
232 open( my $in_file, '<', $name )
233 or return 'Could not read test file ' . $name . ':' . $!;
234 my $txt2 = <$in_file>;
235 close($in_file);
236 unlink $name if ( -e $name );
237
238 unless ( defined $txt2 && $txt2 eq $txt1 ) {
239 return 'Could not write and then read ' . $name;
240 }
241 return '';
242}
243
244=begin TML
245
246---++ StaticMethod checkTreePerms($path, $perms, %options) -> \%report
247
248Perform a recursive check of the specified path.
249No failures will return undef, otherwise a string report is generated.
250
251$perms is a string of permissions to check:
252
253Basic checks:
254 * r - File or directory is readable
255 * w - File or directory is writable
256 * x - File is executable.
257
258Enhanced checks:
259 * d - Directory permission matches the permissions
260 in {Store}{dirPermission}
261 * f - File permission matches the permission in
262 {Store}{filePermission} (FUTURE)
263 * p - Verify that a WebPreferences exists for each web
264
265%options may include the following:
266 * =filter= is a regular expression. Files matching the regex
267 if present will not be checked. This is used to skip hidden files
268 and those with different permission requirements.
269 * =maxFileCount= - limit on number of files checked
270 * =maxFileErrors= - limit on number of fileError messages generated
271 Default is 10
272 * =maxExcessPerms= - limit on number of excessPerms messages generated
273 Default is 10
274 * =maxMissingFile= - limit on number of missing file messages generated
275 Default is 10
276
277The returned \%report contains the following fields:
278 * fileCount - number of files checked
279 * fileErrors - number of file errors errors encountered
280 * excessPerms - number of excess permissions encountered
281 * missingFile - number of missing files encountered
282 * messages - ref of an array containing individual file messages,
283 limited as per the options.
284
285In addition to the basic and enhanced checks specified in the $perms string,
286directories are always checked to determine if they have the 'x' permission.
287
288Note that the enhanced checks are important especially on hosted sites. In some
289environments, the Foswiki perl scripts run under a different user/group than
290the web server. Basic checks will pass, but the server may still be unable
291to access the file. The enhanced checks will detect this condition.
292
293=cut
294
295sub checkTreePerms {
296 my ( $path, $perms, %options ) = @_;
297
298 my %report = (
299 fileCount => 0,
300 fileErrors => 0,
301 missingFile => 0,
302 excessPerms => 0,
303 messages => []
304 );
305
306 return \%report
307 if ( defined( $options{filter} )
308 && $path =~ m/$options{filter}/
309 && !-d $path );
310
311 # Let's ignore Subversion and git directories
312 return \%report if ( $path eq '_svn' );
313 return \%report if ( $path eq '.svn' );
314 return \%report if ( $path eq '.git' );
315
316 $options{maxFileErrors} = 10 unless defined $options{maxFileErrors};
317 $options{maxExcessPerms} = 10 unless defined $options{maxExcessPerms};
318 $options{maxMissingFile} = 10 unless defined $options{maxMissingFile};
319
320 # Okay to increment count once filtered files are ignored.
321 $report{fileCount}++;
322
323 my $errs = '';
324 my $permErrs = '';
325 my $rwxString = _buildRWXMessageString( $perms, $path );
326
327 unless ( -e $path || -l $path ) {
328 push( @{ $report{messages} }, $path . ' cannot be found' );
329 return \%report;
330 }
331
332 if ( $perms =~ m/d/ && -d $path ) {
333 my $mode = ( stat($path) )[2] & oct(7777);
334 if ( $mode != $Foswiki::cfg{Store}{dirPermission} ) {
335 my $omode = sprintf( '%04o', $mode );
336 my $operm = sprintf( '%04o', $Foswiki::cfg{Store}{dirPermission} );
337 if (
338 (
339 ( $mode | $Foswiki::cfg{Store}{dirPermission} )
340 ^ $Foswiki::cfg{Store}{dirPermission}
341 )
342 )
343 {
344 if ( $report{excessPerms}++ < $options{maxExcessPerms} ) {
345 push(
346 @{ $report{messages} },
347" * $path - directory permission $omode differs from requested $operm - check directory for possible excess permissions"
348 );
349 }
350 }
351 if ( ( $mode & $Foswiki::cfg{Store}{dirPermission} ) !=
352 $Foswiki::cfg{Store}{dirPermission} )
353 {
354 if ( $report{fileErrors}++ < $options{maxFileErrors} ) {
355 push(
356 @{ $report{messages} },
357" * $path - directory permission $omode differs from requested $operm - check directory for possible insufficient permissions"
358 );
359 }
360 }
361 }
362 }
363
364 if ( $perms =~ m/f/ && -f $path ) {
365 my $mode = ( stat($path) )[2] & oct(7777);
366 if ( $mode != $Foswiki::cfg{Store}{filePermission} ) {
367 my $omode = sprintf( '%04o', $mode );
368 my $operm = sprintf( '%04o', $Foswiki::cfg{Store}{filePermission} );
369 if (
370 (
371 ( $mode | $Foswiki::cfg{Store}{filePermission} )
372 ^ $Foswiki::cfg{Store}{filePermission}
373 )
374 )
375 {
376 if ( $report{excessPerms}++ < $options{maxExcessPerms} ) {
377 push(
378 @{ $report{messages} },
379" * $path - file permission $omode differs from requested $operm - check file for possible excess permissions."
380 );
381 }
382 }
383 if ( ( $mode & $Foswiki::cfg{Store}{filePermission} ) !=
384 $Foswiki::cfg{Store}{filePermission} )
385 {
386 if ( $report{fileErrors}++ < $options{maxFileErrors} ) {
387 push(
388 @{ $report{messages} },
389" * $path - file permission $omode differs from requested $operm - check file for possible insufficient permissions."
390 );
391 }
392 }
393 }
394 }
395
396 if ( $perms =~ m/p/
397 && $path =~ m/\Q$Foswiki::cfg{DataDir}\E\/(.+)$/
398 && -d $path )
399 {
400 unless ( -e "$path/$Foswiki::cfg{WebPrefsTopicName}.txt" ) {
401 unless ( $report{missingFile}++ > $options{maxMissingFile} ) {
402 push(
403 @{ $report{messages} },
404 " * $path missing $Foswiki::cfg{WebPrefsTopicName} topic."
405 );
406 }
407 }
408 }
409
410 if ( $rwxString && $report{fileErrors}++ < $options{maxFileErrors} ) {
411 push( @{ $report{messages} }, "=$path= $rwxString" );
412 }
413
414 return \%report if scalar( @{ $report{messages} } );
415
416 return \%report unless -d $path;
417
418 if ( -d $path && !-x $path ) {
419 unshift( @{ $report{messages} }, " * $path missing -x permission" );
420 return \%report;
421 }
422
423 opendir( my $Dfh, $path )
424 or return "Directory $path is not readable.";
425
426 foreach my $e ( grep { !/^\./ } readdir($Dfh) ) {
427 my $p = $path . '/' . Encode::decode_utf8($e);
428 my $subreport = checkTreePerms( $p, $perms, %options );
429 while ( my ( $k, $v ) = each %report ) {
430 if ( ref($v) eq 'ARRAY' ) {
431 push( @$v, @{ $subreport->{$k} } );
432 }
433 else {
434 $report{$k} += $subreport->{$k};
435 }
436 }
437 last
438 if ( defined $options{maxFileCount}
439 && $report{fileCount} >= $options{maxFileCount} );
440 }
441 closedir($Dfh);
442
443 return \%report;
444}
445
446sub _buildRWXMessageString {
447 my ( $perms, $path ) = @_;
448 my $message = '';
449
450 if ( $perms =~ m/r/ && !-r $path ) {
451 $message .= ' not readable';
452 }
453
454 if ( $perms =~ m/w/ && !-d $path && !-w $path ) {
455 $message .= ' not writable';
456 }
457
458 if ( $perms =~ m/x/ && !-x $path ) {
459 $message .= ' not executable';
460 }
461
462 return $message;
463}
464
465=begin TML
466
467---++ StaticMethod checkGNUProgram($prog, $reporter)
468
469Check for the availability of a GNU program.
470
471Since Windows (without Cygwin) makes it hard to capture stderr
472('2>&1' works only on Win2000 or higher), and Windows will usually have
473GNU tools in any case (installed for Foswiki since there's no built-in
474diff, grep, patch, etc), we only check for these tools on Unix/Linux
475and Cygwin.
476
477Errors are reproted by calling ERROR and/or WARN on $reporter
478=cut
479
480sub checkGNUProgram {
481 my ( $prog, $reporter ) = @_;
482
483 if ( $Foswiki::cfg{OS} eq 'UNIX'
484 || $Foswiki::cfg{OS} eq 'WINDOWS'
485 && $Foswiki::cfg{DetailedOS} eq 'cygwin' )
486 {
487
488 # SMELL: assumes no spaces in program pathnames
489 $prog =~ m/^\s*(\S+)/;
490 $prog = $1;
491 my $diffOut = ( `$prog --version 2>&1` || "" );
492 my $notFound = ( $? != 0 );
493 if ($notFound) {
494 $reporter->ERROR("'$prog' was not found on the current PATH");
495 }
496 elsif ( $diffOut !~ /\bGNU\b/ ) {
497
498 # Program found on path, complain if no GNU in version output
499 $reporter->WARN(
500 "'$prog' program was found on the PATH ",
501 "but is not GNU $prog - this may cause ",
502 "problems. $diffOut"
503 );
504 }
505 }
506 elsif ( $Foswiki::cfg{OS} eq 'WINDOWS' ) {
507
508 #real windows - using GnuWin32 tools
509 }
510
511}
512
513=begin TML
514
515---++ StaticMethod copytree($from, $to) => @errors
516
517Copy a directory tree from one place to another.
518Errors are reported in @errors, empty if it succeeds.
519A partial copy may happen if the copy fails mid-way.
520
521=cut
522
523sub copytree {
524 my ( $from, $to ) = @_;
525
526 if ( -d $from ) {
527 if ( !-e $to ) {
528 mkdir($to) || return ("Failed to mkdir $to: $!");
529 }
530 elsif ( !-d $to ) {
531 return ("Existing $to is in the way");
532 }
533
534 my $d;
535 return ("Failed to copy $from: $!") unless opendir( $d, $from );
536 my @e;
537 foreach my $f ( grep { !/^\./ } readdir $d ) {
538 $f =~ m/(.*)/;
539 $f = $1; # untaint
540 push( @e, copytree( "$from/$f", "$to/$f" ) );
541 }
542 closedir($d);
543 return @e if scalar(@e);
544 }
545
546 unless ( -e $to ) {
547 require File::Copy;
548 if ( !File::Copy::copy( $from, $to ) ) {
549 return ("Failed to copy $from to $to: $!");
550 }
551 }
552}
553
554=begin TML
555
556---++ StaticMethod listDir($dir, [$dflag], [$path] )
557Recursively list the files in directory $dir. Optional $dflag can be set to 1
558to cause the list to exclude the directory names from the list.
559
560If $path is used internally for the recursive directory list. It is
561appended to the Directory. The list of files in @names is relative to the
562$dir directory. Subroutine called recursively for each subdirectory
563encountered.
564
565=cut
566
567# Recursively list a directory
568sub listDir {
569 my ( $dir, $dflag, $path ) = @_;
570 $path ||= '';
571 $dflag ||= '';
572 $dir .= '/' unless $dir =~ m/\/$/;
573 my $d;
574 my @names = ();
575 if ( opendir( $d, "$dir$path" ) ) {
576 foreach my $f ( grep { !/^\.*$/ } readdir $d ) {
577
578 # Someone might upload a package that contains
579 # a filename which, when passed to File::Copy, does something
580 # evil. Check and untaint the filenames here.
581 # SMELL: potential problem with unicode chars in file names? (yes)
582 if ( $f =~ m/^([-\w.,]+)$/ ) {
583 $f = $1;
584 if ( -d "$dir$path/$f" ) {
585 push( @names, "$path$f/" ) unless ($dflag);
586 push( @names, listDir( $dir, $dflag, "$path$f/" ) );
587 }
588 else {
589 push( @names, "$path$f" );
590 }
591 }
592 else {
593 print
594"WARNING: skipping possibly unsafe file (not able to show it for the same reason :( )<br />\n";
595 }
596 }
597 closedir($d);
598 }
599 return @names;
600}
601
602=begin TML
603
604---++ StaticMethod createArchive($name, $dir, $delete )
605Create an archive of the passed directory.
606 * $name is the directory to be backed up _and_ the filename of the archive to be created. $name will be given a suffix of the backup type - depends on what type of backup tools are installed.
607 * $dir is the root directory of the backups - typically the working/configure/backup directory
608 * $delete - set if the directory being backed up should be deleted after archive is created.
609
610=cut
611
612sub createArchive {
613 my ( $name, $dir, $delete, $test ) = @_;
614 eval('use File::Path qw(rmtree)');
615 ASSERT( !$@, $@ );
616
617 my $file = undef;
618 my $results = '';
619 my $warn = '';
620
621 my $here = Cwd::getcwd();
622 $here =~ m/(.*)/;
623 $here = $1; # untaint current dir name
624
625 return ( undef, "Directory $dir/$name does not exist \n" )
626 unless ( -e "$dir/$name" && -d "$dir/$name" );
627
628 chdir("$dir/$name");
629
630 if ( !defined $test || ( defined $test && $test eq 'tar' ) ) {
631 $results .= `tar -czvf "../$name.tgz" .`;
632
633 if ( $results && !$@ ) {
634 $file = "$dir/$name.tgz";
635 }
636 }
637
638 unless ($results) {
639 $warn .= "tar command failed $!, trying zip \n";
640
641 if ( !defined $test || ( defined $test && $test eq 'zip' ) ) {
642 $results .= `zip -r "../$name.zip" .`;
643
644 if ( $results && !$@ ) {
645 $file = "$dir/$name.zip";
646 }
647 }
648
649 unless ($results) {
650 $warn .= "zip failed $!, trying perl routines \n";
651
652 if ( !defined $test || ( defined $test && $test eq 'Ptar' ) ) {
653 my @flist = listDir( '.', 1 );
654 $results = _tar( "../$name.tgz", \@flist );
655
656 if ($results) {
657 $file = "$dir/$name.tgz";
658 }
659 }
660
661 unless ($results) {
662 $warn .= "Perl Archive::Tar failed - trying zip \n";
663
664 if ( !defined $test || ( defined $test && $test eq 'Pzip' ) ) {
665 my @flist = listDir( '.', 1 );
666 $results = _zip( "../$name.zip", \@flist );
667
668 if ($results) {
669 $file = "$dir/$name.zip";
670 }
671 else {
672 $warn .=
673"Perl Archive::Zip failed - Backup directory remains \n";
674 }
675 }
676 }
677 }
678 }
679
680 chdir($here);
681
682 return ( undef, $warn ) unless ($results);
683
684 rmtree("$dir/$name") if ($delete);
685 return ( $file, $results );
686
687}
688
689sub _zip {
690 my $archive = shift;
691 my $files = shift;
692 my $err;
693
694 eval('use Archive::Zip ( )');
695 unless ($@) {
696 my $zip = Archive::Zip->new();
697 unless ($zip) {
698 return 0;
699 }
700
701 # Note: Archive::Zip addTree fails with taint errors.
702 # Workaround was to add each file individually
703 foreach my $f (@$files) {
704 $zip->addFile($f);
705 }
706 $err = $zip->writeToFileNamed("$archive");
707 return join( "\n", $zip->memberNames() ) unless ($err);
708 }
709
710 return 0;
711}
712
713sub _tar {
714 my $archive = shift;
715 my $files = shift;
716
717 eval('use Archive::Tar ()');
718 unless ($@) {
719 my $tgz = Archive::Tar->new();
720 return 0 unless ($tgz);
721 $tgz->add_files(@$files);
722 $tgz->write( "$archive", 7 );
723 return join( "\n", $tgz->list_files() );
724 }
725 return 0;
726}
727
728=begin TML
729
730---++ StaticMethod unpackArchive($archive [,$dir] ) -> ( $dir, $err )
731Unpack an archive. The unpacking method is determined from the file
732extension e.g. .zip, .tgz. .tar, etc. If $dir is not given, unpack
733to a temporary directory, the name of which is returned.
734
735Errors are reported by returnng a non-null $err
736
737=cut
738
739sub unpackArchive {
740 my ( $name, $dir ) = @_;
741
742 $dir ||= File::Temp::tempdir( CLEANUP => 1 );
743 my $here = Cwd::getcwd();
744 $here =~ m/(.*)/;
745 $here = $1; # untaint current dir name
746 chdir($dir);
747
748 my $error;
749 if ( $name =~ m/\.zip$/i ) {
750 $error = _unzip($name);
751 $error = "Failed to unpack archive $name: $error" if $error;
752 }
753 else {
754 if ( $name =~ m/(\.tar\.gz|\.tgz|\.tar)$/i ) {
755 $error = _untar($name);
756 $error = "Failed to unpack archive $name: $error" if $error;
757 }
758 }
759 chdir($here);
760
761 return ( $dir, $error );
762}
763
764sub _unzip {
765 my $archive = shift;
766
767 my $testzip = ( `unzip -hh 2>&1` || "" );
768 my $noUnzip = ( $? != 0 );
769
770 if ($noUnzip) {
771 eval('require Archive::Zip');
772 unless ($@) {
773 my $zip;
774 eval { $zip = Archive::Zip->new($archive); };
775 return Foswiki::Configure::Reporter::stripStacktrace($@) if $@;
776 return "Failed to open zip file $archive" unless $zip;
777
778 my @members = $zip->members();
779 foreach my $member (@members) {
780 my $file = $member->fileName();
781 $file =~ m/^(.*)$/;
782 $file = $1; #yes, we must untaint
783 my $target = $file;
784 my $dest = Cwd::getcwd();
785 ($dest) = $dest =~ m/^(.*)$/;
786
787 #SMELL: Archive::Zip->extractMember( $file) would be better to use
788 # but it has taint issues on Perl 5.12.
789 my $contents = $zip->contents($file);
790 if ($contents) {
791 my ( $vol, $dir, $fn ) = File::Spec->splitpath($file);
792 File::Path::mkpath("$dest/$dir");
793 open( my $fh, '>', "$dest/$file" )
794 || die "Unable to open $dest/$file \n $! \n\n ";
795 binmode $fh;
796 print $fh $contents;
797 close($fh);
798 }
799 }
800 }
801 }
802 else {
803 `unzip -n $archive`;
804 return "$? - $!" if ($?);
805 }
806 return undef;
807}
808
809sub _untar {
810 my $archive = shift;
811
812 my $compressed = ( $archive =~ m/z$/i ) ? 'z' : '';
813
814 my $testtar = ( `tar --version 2>&1` || "" );
815 my $noTar = ( $? != 0 );
816
817 if ($noTar) {
818
819 eval('require Archive::Tar');
820 unless ($@) {
821 my $tar;
822 eval { $tar = Archive::Tar->new( $archive, $compressed ); };
823 return Foswiki::Configure::Reporter::stripStacktrace($@) if $@;
824 return "Could not open tar file $archive" unless $tar;
825
826 my @members = $tar->list_files();
827 foreach my $file (@members) {
828
829 #SMELL: Some tarfiles return a trigger for long filenames
830 next if ( $file eq '././@LongLink' );
831 my $err = $tar->extract($file);
832 unless ($err) {
833 return 'Failed to extract ', $file, ' from tar file ',
834 $tar, ". Archive may be corrupt.\n";
835 }
836 }
837 }
838 }
839 else {
840 `tar xvf$compressed $archive`;
841 return "$? - $!" if ($?);
842 }
843 return undef;
844}
845
846=begin TML
847
848---++ StaticMethod getPerlLocation( )
849This routine will read in the first line of the bin/configure
850script and recover the location of the perl interpreter.
851
852Optional parameter is file used to retrieve the shebang. If not
853specified, defaults to the configure script
854
855=cut
856
857sub getPerlLocation {
858
859 my $file = shift
860 || "$Foswiki::cfg{ScriptDir}/configure$Foswiki::cfg{ScriptSuffix}";
861
862 local $/ = "\n";
863 open( my $fh, '<', "$file" )
864 || return "";
865 my $Shebang = <$fh>;
866 chomp $Shebang;
867 ($Shebang) = $Shebang =~ m/^#\!\s*(.*?perl.*?)\s?(?:\s-.*?)?$/;
868 $Shebang =~ s/\s+$//;
869 close($fh);
870 return $Shebang;
871
872}
873
874=begin TML
875
876---++ StaticMethod rewriteShebang($file, $newShebang, $taint )
877
878Rewrite the #! (shebang) line of the target script
879with the specified script name. Clear any taint flag
880by default, or set it if $taint is true.
881
882This is used in 2 places:
883 - The Package installer - used when installing extensions
884 - In tools/rewriteshebang.pl
885
886=cut
887
888sub rewriteShebang {
889 my $file = shift;
890 my $newShebang = shift;
891 my $taint = shift;
892
893 return 'Not a file' unless ( -f $file );
894 return 'Missing Shebang' unless $newShebang;
895
896 local $/ = undef;
897 open( my $fh, '<', $file ) || return "Rewrite shebang failed: $!";
898 my $contents = <$fh>;
899 close $fh;
900
901 # Pull out the first line, parse it into the script (match) and arguments
902 my $firstline = substr( $contents, 0, index( $contents, "\n" ) );
903 my ( $match, $args ) =
904 $firstline =~ m/^#\!\s*(.*?perl[^\s]*)(\s?-w?T?w?)?.*?$/ms;
905 $match ||= '';
906 $args ||= '';
907 my $newargs = $args;
908
909 return "Not a perl script" unless ($match);
910
911 if ( $newShebang =~ m/env perl/ ) {
912 $newargs = ''; # No arguments possible when using env perl
913 }
914 elsif ( defined $taint ) {
915 if ($args) {
916 if ($taint) {
917 $newargs .= 'T' unless ( $args =~ m/T/ );
918 }
919 else {
920 $newargs =~ s/T//;
921 $newargs = '' if ( $newargs eq ' -' );
922 }
923 }
924 }
925
926 # Find position of existing args, and replace with new arguments
927 my $argsIdx = index( $contents, $args );
928 if ($argsIdx) {
929 substr( $contents, $argsIdx, length($args) ) = "$newargs";
930 }
931 elsif ( defined $taint ) {
932 $newShebang .= ' -T' if ($taint);
933 }
934
935 # Note: space inserted after #! - needed on some flavors of Unix
936 my $perlIdx = index( $contents, $match );
937 substr( $contents, $perlIdx, length($match) ) =
938 ( substr( $contents, $perlIdx - 1, 1 ) eq ' ' ? '' : ' ' )
939 . "$newShebang";
940
941 return "No change required"
942 if ( $match eq $newShebang
943 && $args eq $newargs
944 && substr( $contents, $perlIdx - 1, 1 ) eq ' ' );
945
946 my $mode = ( stat($file) )[2];
947 $file =~ m/(.*)/;
948 $file = $1;
949 chmod( oct(600), "$file" );
950 open( $fh, '>', $file ) || return "Rewrite shebang failed: $!";
951 print $fh $contents;
952 close $fh;
953 $mode =~ m/(.*)/;
954 $mode = $1;
955 chmod( $mode, "$file" );
956
957 return '';
958}
959
96013µs1;
961__END__