Filename | /var/www/foswikidev/core/lib/Foswiki/Configure/FileUtil.pm |
Statements | Executed 13 statements in 4.51ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 1.34ms | 28.1ms | BEGIN@19 | Foswiki::Configure::FileUtil::
1 | 1 | 1 | 17µs | 35µs | BEGIN@13 | Foswiki::Configure::FileUtil::
1 | 1 | 1 | 12µs | 60µs | BEGIN@18 | Foswiki::Configure::FileUtil::
1 | 1 | 1 | 12µs | 17µs | BEGIN@14 | Foswiki::Configure::FileUtil::
1 | 1 | 1 | 11µs | 44µs | BEGIN@16 | Foswiki::Configure::FileUtil::
1 | 1 | 1 | 8µs | 8µs | BEGIN@20 | Foswiki::Configure::FileUtil::
0 | 0 | 0 | 0s | 0s | _buildRWXMessageString | Foswiki::Configure::FileUtil::
0 | 0 | 0 | 0s | 0s | _tar | Foswiki::Configure::FileUtil::
0 | 0 | 0 | 0s | 0s | _untar | Foswiki::Configure::FileUtil::
0 | 0 | 0 | 0s | 0s | _unzip | Foswiki::Configure::FileUtil::
0 | 0 | 0 | 0s | 0s | _zip | Foswiki::Configure::FileUtil::
0 | 0 | 0 | 0s | 0s | checkCanCreateFile | Foswiki::Configure::FileUtil::
0 | 0 | 0 | 0s | 0s | checkGNUProgram | Foswiki::Configure::FileUtil::
0 | 0 | 0 | 0s | 0s | checkTreePerms | Foswiki::Configure::FileUtil::
0 | 0 | 0 | 0s | 0s | copytree | Foswiki::Configure::FileUtil::
0 | 0 | 0 | 0s | 0s | createArchive | Foswiki::Configure::FileUtil::
0 | 0 | 0 | 0s | 0s | findFileOnPath | Foswiki::Configure::FileUtil::
0 | 0 | 0 | 0s | 0s | findFileOnTree | Foswiki::Configure::FileUtil::
0 | 0 | 0 | 0s | 0s | findPackages | Foswiki::Configure::FileUtil::
0 | 0 | 0 | 0s | 0s | getPerlLocation | Foswiki::Configure::FileUtil::
0 | 0 | 0 | 0s | 0s | listDir | Foswiki::Configure::FileUtil::
0 | 0 | 0 | 0s | 0s | lscFileName | Foswiki::Configure::FileUtil::
0 | 0 | 0 | 0s | 0s | rewriteShebang | Foswiki::Configure::FileUtil::
0 | 0 | 0 | 0s | 0s | unpackArchive | Foswiki::Configure::FileUtil::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | # See bottom of file for license and copyright information | ||||
2 | |||||
3 | package Foswiki::Configure::FileUtil; | ||||
4 | |||||
5 | =begin TML | ||||
6 | |||||
7 | ---+ package Foswiki::Configure::FileUtil | ||||
8 | |||||
9 | Basic file utilities used by Configure and admin scripts | ||||
10 | |||||
11 | =cut | ||||
12 | |||||
13 | 2 | 36µs | 2 | 52µ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 # spent 35µs making 1 call to Foswiki::Configure::FileUtil::BEGIN@13
# spent 17µs making 1 call to strict::import |
14 | 2 | 31µs | 2 | 23µ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 # spent 17µs making 1 call to Foswiki::Configure::FileUtil::BEGIN@14
# spent 6µs making 1 call to warnings::import |
15 | |||||
16 | 2 | 33µs | 2 | 76µ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 # spent 44µs making 1 call to Foswiki::Configure::FileUtil::BEGIN@16
# spent 32µs making 1 call to Exporter::import |
17 | |||||
18 | 2 | 33µs | 2 | 108µ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 # spent 60µs making 1 call to Foswiki::Configure::FileUtil::BEGIN@18
# spent 48µs making 1 call to Exporter::import |
19 | 2 | 111µs | 1 | 28.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 # spent 28.1ms making 1 call to Foswiki::Configure::FileUtil::BEGIN@19 |
20 | 2 | 4.26ms | 1 | 8µ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 # spent 8µs making 1 call to Foswiki::Configure::FileUtil::BEGIN@20 |
21 | |||||
22 | =begin TML | ||||
23 | |||||
24 | ---++ StaticMethod findFileOnTree($dir, $pattern, $reject) ->> $fullpath | ||||
25 | Recursive search for a file matching the specified pattern, searching $dir | ||||
26 | and all subdirectories of $dir, Anything matching $reject is not | ||||
27 | considered, to avoid searching the ,pfv subdirectories.. | ||||
28 | |||||
29 | This is used by checkers and bootstrap to see if there are any ",v" rcs | ||||
30 | files in the Store. | ||||
31 | |||||
32 | Example: | ||||
33 | |||||
34 | findFileOnTree( $Foswiki::cfg{DataDir}, qr/,v$/, qr/,pfv$/ ); | ||||
35 | |||||
36 | SMELL: We could use File::Find as a CPAN solution, however in this case | ||||
37 | really only need to find the first occurance, we have no need for the full | ||||
38 | list, just whether or not any exist. File::Find returns the complete list | ||||
39 | of matching files. | ||||
40 | |||||
41 | =cut | ||||
42 | |||||
43 | sub 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 | ||||
69 | Find a file on the @INC path, or undef if not found. | ||||
70 | |||||
71 | $filename may be a simple file name e.g. Example.pm | ||||
72 | or may be a /-separated path e.g. Net/Util | ||||
73 | or a class path e.g. Net::Util | ||||
74 | |||||
75 | Note that a terminating .pm is required to find a | ||||
76 | perl module. | ||||
77 | |||||
78 | =cut | ||||
79 | |||||
80 | sub 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 | |||||
105 | Determine the pathname of LocalSite.cfg. This file must be | ||||
106 | on the path, but may not exist yet; it it doesn't, then | ||||
107 | Foswiki.spec must be and LocalSite.cfg will be placed in the | ||||
108 | same directory. | ||||
109 | |||||
110 | =cut | ||||
111 | |||||
112 | sub 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 | |||||
132 | Finds 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 | |||||
137 | Return a list of package names. | ||||
138 | |||||
139 | =cut | ||||
140 | |||||
141 | sub 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 | |||||
200 | Check that the given path can be created (or, if it already exists, | ||||
201 | can be written). If the existing path is a directory, recursively | ||||
202 | check for rw permissions using =checkTreePerms=. | ||||
203 | |||||
204 | Returns a message if the check fails or undef if the check passed. | ||||
205 | |||||
206 | =cut | ||||
207 | |||||
208 | sub 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 | |||||
248 | Perform a recursive check of the specified path. | ||||
249 | No failures will return undef, otherwise a string report is generated. | ||||
250 | |||||
251 | $perms is a string of permissions to check: | ||||
252 | |||||
253 | Basic checks: | ||||
254 | * r - File or directory is readable | ||||
255 | * w - File or directory is writable | ||||
256 | * x - File is executable. | ||||
257 | |||||
258 | Enhanced 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 | |||||
277 | The 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 | |||||
285 | In addition to the basic and enhanced checks specified in the $perms string, | ||||
286 | directories are always checked to determine if they have the 'x' permission. | ||||
287 | |||||
288 | Note that the enhanced checks are important especially on hosted sites. In some | ||||
289 | environments, the Foswiki perl scripts run under a different user/group than | ||||
290 | the web server. Basic checks will pass, but the server may still be unable | ||||
291 | to access the file. The enhanced checks will detect this condition. | ||||
292 | |||||
293 | =cut | ||||
294 | |||||
295 | sub 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 | |||||
446 | sub _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 | |||||
469 | Check for the availability of a GNU program. | ||||
470 | |||||
471 | Since Windows (without Cygwin) makes it hard to capture stderr | ||||
472 | ('2>&1' works only on Win2000 or higher), and Windows will usually have | ||||
473 | GNU tools in any case (installed for Foswiki since there's no built-in | ||||
474 | diff, grep, patch, etc), we only check for these tools on Unix/Linux | ||||
475 | and Cygwin. | ||||
476 | |||||
477 | Errors are reproted by calling ERROR and/or WARN on $reporter | ||||
478 | =cut | ||||
479 | |||||
480 | sub 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 | |||||
517 | Copy a directory tree from one place to another. | ||||
518 | Errors are reported in @errors, empty if it succeeds. | ||||
519 | A partial copy may happen if the copy fails mid-way. | ||||
520 | |||||
521 | =cut | ||||
522 | |||||
523 | sub 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] ) | ||||
557 | Recursively list the files in directory $dir. Optional $dflag can be set to 1 | ||||
558 | to cause the list to exclude the directory names from the list. | ||||
559 | |||||
560 | If $path is used internally for the recursive directory list. It is | ||||
561 | appended to the Directory. The list of files in @names is relative to the | ||||
562 | $dir directory. Subroutine called recursively for each subdirectory | ||||
563 | encountered. | ||||
564 | |||||
565 | =cut | ||||
566 | |||||
567 | # Recursively list a directory | ||||
568 | sub 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 | |||||
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 ) | ||||
605 | Create 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 | |||||
612 | sub 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 | |||||
689 | sub _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 | |||||
713 | sub _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 ) | ||||
731 | Unpack an archive. The unpacking method is determined from the file | ||||
732 | extension e.g. .zip, .tgz. .tar, etc. If $dir is not given, unpack | ||||
733 | to a temporary directory, the name of which is returned. | ||||
734 | |||||
735 | Errors are reported by returnng a non-null $err | ||||
736 | |||||
737 | =cut | ||||
738 | |||||
739 | sub 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 | |||||
764 | sub _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 | |||||
809 | sub _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( ) | ||||
849 | This routine will read in the first line of the bin/configure | ||||
850 | script and recover the location of the perl interpreter. | ||||
851 | |||||
852 | Optional parameter is file used to retrieve the shebang. If not | ||||
853 | specified, defaults to the configure script | ||||
854 | |||||
855 | =cut | ||||
856 | |||||
857 | sub 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 | |||||
878 | Rewrite the #! (shebang) line of the target script | ||||
879 | with the specified script name. Clear any taint flag | ||||
880 | by default, or set it if $taint is true. | ||||
881 | |||||
882 | This is used in 2 places: | ||||
883 | - The Package installer - used when installing extensions | ||||
884 | - In tools/rewriteshebang.pl | ||||
885 | |||||
886 | =cut | ||||
887 | |||||
888 | sub 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 | |||||
960 | 1 | 3µs | 1; | ||
961 | __END__ |