source: main/tags/2.23/gsdl/perllib/util.pm@ 24581

Last change on this file since 24581 was 1046, checked in by sjboddie, 24 years ago

added comment to make me feel better for having spent an hour testing
the speed of mk_all_dir only to find it's faster than the alternative.
  • Property svn:keywords set to Author Date Id Revision
File size: 14.1 KB
Line 
1###########################################################################
2#
3# util.pm -- various useful utilities
4# A component of the Greenstone digital library software
5# from the New Zealand Digital Library Project at the
6# University of Waikato, New Zealand.
7#
8# Copyright (C) 1999 New Zealand Digital Library Project
9#
10# This program is free software; you can redistribute it and/or modify
11# it under the terms of the GNU General Public License as published by
12# the Free Software Foundation; either version 2 of the License, or
13# (at your option) any later version.
14#
15# This program is distributed in the hope that it will be useful,
16# but WITHOUT ANY WARRANTY; without even the implied warranty of
17# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18# GNU General Public License for more details.
19#
20# You should have received a copy of the GNU General Public License
21# along with this program; if not, write to the Free Software
22# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
23#
24###########################################################################
25
26package util;
27
28use File::Copy;
29use File::Basename;
30
31
32# removes files (but not directories)
33sub rm {
34 my (@files) = @_;
35 my @filefiles = ();
36
37 # make sure the files we want to delete exist
38 # and are regular files
39 foreach $file (@files) {
40 if (!-e $file) {
41 print STDERR "util::rm $file does not exist\n";
42 } elsif ((!-f $file) && (!-l $file)) {
43 print STDERR "util::rm $file is not a regular (or symbolic) file\n";
44 } else {
45 push (@filefiles, $file);
46 }
47 }
48
49 # remove the files
50 my $numremoved = unlink @filefiles;
51
52 # check to make sure all of them were removed
53 if ($numremoved != scalar(@filefiles)) {
54 print STDERR "util::rm Not all files were removed\n";
55 }
56}
57
58
59# recursive removal
60sub rm_r {
61 my (@files) = @_;
62
63 # recursively remove the files
64 foreach $file (@files) {
65 $file =~ s/[\/\\]+$//; # remove trailing slashes
66
67 if (!-e $file) {
68 print STDERR "util::rm_r $file does not exist\n";
69
70 } elsif ((-d $file) && (!-l $file)) { # don't recurse down symbolic link
71 # get the contents of this directory
72 if (!opendir (INDIR, $file)) {
73 print STDERR "util::rm_r could not open directory $file\n";
74 } else {
75 my @filedir = grep (!/^\.\.?$/, readdir (INDIR));
76 closedir (INDIR);
77
78 # remove all the files in this directory
79 &rm_r (map {$_="$file/$_";} @filedir);
80
81 # remove this directory
82 if (!rmdir $file) {
83 print STDERR "util::rm_r couldn't remove directory $file\n";
84 }
85 }
86
87 } else {
88 # remove this file
89 &rm ($file);
90 }
91 }
92}
93
94# moves a file or a group of files
95sub mv {
96 my $dest = pop (@_);
97 my (@srcfiles) = @_;
98
99 # remove trailing slashes from source and destination files
100 $dest =~ s/[\\\/]+$//;
101 map {$_ =~ s/[\\\/]+$//;} @srcfiles;
102
103 # a few sanity checks
104 if (scalar (@srcfiles) == 0) {
105 print STDERR "util::mv no destination directory given\n";
106 return;
107 } elsif ((scalar (@srcfiles) > 1) && (!-d $dest)) {
108 print STDERR "util::mv if multiple source files are given the ".
109 "destination must be a directory\n";
110 return;
111 }
112
113 # move the files
114 foreach $file (@srcfiles) {
115 my $tempdest = $dest;
116 if (-d $tempdest) {
117 my ($filename) = $file =~ /([^\\\/]+)$/;
118 $tempdest .= "/$filename";
119 }
120 if (!-e $file) {
121 print STDERR "util::mv $file does not exist\n";
122 } else {
123 rename ($file, $tempdest);
124 }
125 }
126}
127
128
129# copies a file or a group of files
130sub cp {
131 my $dest = pop (@_);
132 my (@srcfiles) = @_;
133
134 # remove trailing slashes from source and destination files
135 $dest =~ s/[\\\/]+$//;
136 map {$_ =~ s/[\\\/]+$//;} @srcfiles;
137
138 # a few sanity checks
139 if (scalar (@srcfiles) == 0) {
140 print STDERR "util::cp no destination directory given\n";
141 return;
142 } elsif ((scalar (@srcfiles) > 1) && (!-d $dest)) {
143 print STDERR "util::cp if multiple source files are given the ".
144 "destination must be a directory\n";
145 return;
146 }
147
148 # copy the files
149 foreach $file (@srcfiles) {
150 my $tempdest = $dest;
151 if (-d $tempdest) {
152 my ($filename) = $file =~ /([^\\\/]+)$/;
153 $tempdest .= "/$filename";
154 }
155 if (!-e $file) {
156 print STDERR "util::cp $file does not exist\n";
157 } elsif (!-f $file) {
158 print STDERR "util::cp $file is not a plain file\n";
159 } else {
160 &File::Copy::copy ($file, $tempdest);
161 }
162 }
163}
164
165
166
167# recursively copies a file or group of files
168# syntax: cp_r (sourcefiles, destination file or directory)
169sub cp_r {
170 my $dest = pop (@_);
171 my (@srcfiles) = @_;
172
173 # remove trailing slashes from source and destination files
174 $dest =~ s/[\\\/]+$//;
175 map {$_ =~ s/[\\\/]+$//;} @srcfiles;
176
177 # a few sanity checks
178 if (scalar (@srcfiles) == 0) {
179 print STDERR "util::cp no destination directory given\n";
180 return;
181 } elsif ((scalar (@srcfiles) > 1) && (!-d $dest)) {
182 print STDERR "util::cp if multiple source files are given the ".
183 "destination must be a directory\n";
184 return;
185 }
186
187 # copy the files
188 foreach $file (@srcfiles) {
189 # copy the file to within dest if dest is a directory
190 # exception: if there is only one source file and that
191 # source file is a directory
192 my $tempdest = $dest;
193 if (-d $tempdest && !(scalar(@srcfiles) == 1 && -d $file)) {
194 my ($filename) = $file =~ /([^\\\/]+)$/;
195 $tempdest .= "/$filename";
196 }
197
198 if (!-e $file) {
199 print STDERR "util::cp $file does not exist\n";
200
201 } elsif (-d $file) {
202 # make a new directory (if needed)
203 unless (-e $tempdest)
204 {
205 my $store_umask = umask(0002);
206 mkdir ($tempdest, 0777);
207 umask($store_umask);
208 }
209
210 # get the contents of this directory
211 if (!opendir (INDIR, $file)) {
212 print STDERR "util::cp_r could not open directory $file\n";
213 } else {
214 my @filedir = grep (!/^\.\.?$/, readdir (INDIR));
215 closedir (INDIR);
216
217 # copy all the files in this directory
218 &cp_r (map {$_="$file/$_";} @filedir, $tempdest);
219 }
220
221 } else {
222 &cp($file, $tempdest);
223 }
224 }
225}
226
227
228sub mk_dir {
229 my ($dir) = @_;
230
231 my $store_umask = umask(0002);
232 my $mkdir_ok = mkdir ($dir, 0777);
233 umask($store_umask);
234
235 if (!$mkdir_ok)
236 {
237 print STDERR "util::mk_dir could not create directory $dir\n";
238 return;
239 }
240}
241
242# in case anyone cares - I did some testing (using perls Benchmark module)
243# on this subroutine against File::Path::mkpath (). mk_all_dir() is apparently
244# slightly faster (surprisingly) - Stefan.
245sub mk_all_dir {
246 my ($dir) = @_;
247
248 # use / for the directory separator, remove duplicate and
249 # trailing slashes
250 $dir=~s/[\\\/]+/\//g;
251 $dir=~s/[\\\/]+$//;
252
253 # make sure the cache directory exists
254 my $dirsofar = "";
255 my $first = 1;
256 foreach $dirname (split ("/", $dir)) {
257 $dirsofar .= "/" unless $first;
258 $first = 0;
259
260 $dirsofar .= $dirname;
261
262 next if $dirname =~ /^(|[a-z]:)$/i;
263 if (!-e $dirsofar)
264 {
265 my $store_umask = umask(0002);
266 my $mkdir_ok = mkdir ($dirsofar, 0777);
267 umask($store_umask);
268 if (!$mkdir_ok)
269 {
270 print STDERR "util::mk_all_dir could not create directory $dirsofar\n";
271 return;
272 }
273 }
274 }
275}
276
277# make hard link to file if supported by OS, otherwise copy the file
278sub hard_link {
279 my ($src, $dest) = @_;
280
281 # remove trailing slashes from source and destination files
282 $src =~ s/[\\\/]+$//;
283 $dest =~ s/[\\\/]+$//;
284
285 # a few sanity checks
286 if (-e $dest) {
287 # destination file already exists
288 return;
289 }
290 elsif (!-e $src) {
291 print STDERR "util::hard_link source file $src does not exist\n";
292 return;
293 }
294 elsif (-d $src) {
295 print STDERR "util::hard_link source $src is a directory\n";
296 return;
297 }
298
299 my $dest_dir = &File::Basename::dirname($dest);
300 mk_all_dir($dest_dir) if (!-e $dest_dir);
301
302 # link not supported on wondows
303 if ($ENV{'GSDLOS'} =~ /^windows$/i) {
304 &File::Copy::copy ($src, $dest);
305
306 } elsif (!link($src, $dest)) {
307 print STDERR "util::hard_link: unable to create hard link. ";
308 print STDERR " Attempting to copy file: $src -> $dest\n";
309 &File::Copy::copy ($src, $dest);
310 }
311}
312
313# make soft link to file if supported by OS, otherwise return error
314sub soft_link {
315 my ($src, $dest) = @_;
316
317 # remove trailing slashes from source and destination files
318 $src =~ s/[\\\/]+$//;
319 $dest =~ s/[\\\/]+$//;
320
321 # a few sanity checks
322 if (!-e $src) {
323 print STDERR "util::soft_link source file $src does not exist\n";
324 return 0;
325 }
326
327 my $dest_dir = &File::Basename::dirname($dest);
328 mk_all_dir($dest_dir) if (!-e $dest_dir);
329
330 if (!symlink($src, $dest))
331 {
332 print STDERR "util::soft_link: unable to create soft link.";
333 return 0;
334 }
335
336 return 1;
337}
338
339
340
341
342# updates a copy of a directory in some other part of the filesystem
343# verbosity settings are: 0=low, 1=normal, 2=high
344# both $fromdir and $todir should be absolute paths
345sub cachedir {
346 my ($fromdir, $todir, $verbosity) = @_;
347 $verbosity = 1 unless defined $verbosity;
348
349 # use / for the directory separator, remove duplicate and
350 # trailing slashes
351 $fromdir=~s/[\\\/]+/\//g;
352 $fromdir=~s/[\\\/]+$//;
353 $todir=~s/[\\\/]+/\//g;
354 $todir=~s/[\\\/]+$//;
355
356 &mk_all_dir ($todir);
357
358 # get the directories in ascending order
359 if (!opendir (FROMDIR, $fromdir)) {
360 print STDERR "util::cachedir could not read directory $fromdir\n";
361 return;
362 }
363 my @fromdir = grep (!/^\.\.?$/, sort(readdir (FROMDIR)));
364 closedir (FROMDIR);
365
366 if (!opendir (TODIR, $todir)) {
367 print STDERR "util::cacedir could not read directory $todir\n";
368 return;
369 }
370 my @todir = grep (!/^\.\.?$/, sort(readdir (TODIR)));
371 closedir (TODIR);
372
373 my $fromi = 0;
374 my $toi = 0;
375
376 while ($fromi < scalar(@fromdir) || $toi < scalar(@todir)) {
377# print "fromi: $fromi toi: $toi\n";
378
379 # see if we should delete a file/directory
380 # this should happen if the file/directory
381 # is not in the from list or if its a different
382 # size, or has an older timestamp
383 if ($toi < scalar(@todir)) {
384 if (($fromi >= scalar(@fromdir)) ||
385 ($todir[$toi] lt $fromdir[$fromi] ||
386 ($todir[$toi] eq $fromdir[$fromi] &&
387 &differentfiles("$fromdir/$fromdir[$fromi]","$todir/$todir[$toi]",
388 $verbosity)))) {
389
390 # the files are different
391 &rm_r("$todir/$todir[$toi]");
392 splice(@todir, $toi, 1); # $toi stays the same
393
394 } elsif ($todir[$toi] eq $fromdir[$fromi]) {
395 # the files are the same
396 # if it is a directory, check its contents
397 if (-d "$todir/$todir[$toi]") {
398 &cachedir ("$fromdir/$fromdir[$fromi]",
399 "$todir/$todir[$toi]", $verbosity);
400 }
401
402 $toi++;
403 $fromi++;
404 next;
405 }
406 }
407
408 # see if we should insert a file/directory
409 # we should insert a file/directory if there
410 # is no tofiles left or if the tofile does not exist
411 if ($fromi < scalar(@fromdir) && ($toi >= scalar(@todir) ||
412 $todir[$toi] gt $fromdir[$fromi])) {
413 &cp_r ("$fromdir/$fromdir[$fromi]", "$todir/$fromdir[$fromi]");
414 splice (@todir, $toi, 0, $fromdir[$fromi]);
415
416 $toi++;
417 $fromi++;
418 }
419 }
420}
421
422# this function returns -1 if either file is not found
423# assumes that $file1 and $file2 are absolute file names or
424# in the current directory
425# $file2 is allowed to be newer than $file1
426sub differentfiles {
427 my ($file1, $file2, $verbosity) = @_;
428 $verbosity = 1 unless defined $verbosity;
429
430 $file1 =~ s/\/+$//;
431 $file2 =~ s/\/+$//;
432
433 my ($file1name) = $file1 =~ /\/([^\/]*)$/;
434 my ($file2name) = $file2 =~ /\/([^\/]*)$/;
435
436 return -1 unless (-e $file1 && -e $file2);
437 if ($file1name ne $file2name) {
438 print STDERR "filenames are not the same\n" if ($verbosity >= 2);
439 return 1;
440 }
441
442 @file1stat = stat ($file1);
443 @file2stat = stat ($file2);
444
445 if (-d $file1) {
446 if (! -d $file2) {
447 print STDERR "one file is a directory\n" if ($verbosity >= 2);
448 return 1;
449 }
450 return 0;
451 }
452
453 # both must be regular files
454 unless (-f $file1 && -f $file2) {
455 print STDERR "one file is not a regular file\n" if ($verbosity >= 2);
456 return 1;
457 }
458
459 # the size of the files must be the same
460 if ($file1stat[7] != $file2stat[7]) {
461 print STDERR "different sized files\n" if ($verbosity >= 2);
462 return 1;
463 }
464
465 # the second file cannot be older than the first
466 if ($file1stat[9] > $file2stat[9]) {
467 print STDERR "file is older\n" if ($verbosity >= 2);
468 return 1;
469 }
470
471 return 0;
472}
473
474
475sub get_tmp_filename {
476 my $tmpdir = "$ENV{'GSDLHOME'}/tmp";
477 &mk_all_dir ($tmpdir) unless -e $tmpdir;
478
479 my $count = 1000;
480 my $rand = int(rand $count);
481 while (-e "$tmpdir/F$rand") {
482 $rand = int(rand $count);
483 $count++;
484 }
485
486 return "$tmpdir/F$rand";
487}
488
489
490sub filename_cat {
491 my (@filenames) = @_;
492 my $filename = join("/", @filenames);
493
494 # remove duplicate slashes and remove the last slash
495 if ($ENV{'GSDLOS'} =~ /^windows$/i) {
496 $filename =~ s/[\\\/]+/\\/g;
497 } else {
498 $filename =~ s/[\/]+/\//g;
499 # DB: want a filename abc\de.html to remain like this
500 }
501 $filename =~ s/[\\\/]$//;
502
503 return $filename;
504}
505
506sub get_os_dirsep {
507
508 if ($ENV{'GSDLOS'} =~ /^windows$/i) {
509 return "\\\\";
510 } else {
511 return "\\\/";
512 }
513}
514
515sub get_re_dirsep {
516
517 return "\\\\|\\\/";
518}
519
520
521# if this is running on windows we want binaries to end in
522# .exe, otherwise they don't have to end in any extension
523sub get_os_exe {
524 return ".exe" if $ENV{'GSDLOS'} =~ /^windows$/i;
525 return "";
526}
527
528
529# test to see whether this is a big or little endian machine
530sub is_little_endian {
531 return (ord(substr(pack("s",1), 0, 1)) == 1);
532}
533
534
535# will return the collection name if successful, "" otherwise
536sub use_collection {
537 my ($collection) = @_;
538
539 # get and check the collection
540 if (!defined($collection) || $collection eq "") {
541 if (defined $ENV{'GSDLCOLLECTION'}) {
542 $collection = $ENV{'GSDLCOLLECTION'};
543 } else {
544 print STDERR "No collection specified\n";
545 return "";
546 }
547 }
548
549 if ($collection eq "modelcol") {
550 print STDERR "You can't use modelcol.\n";
551 return "";
552 }
553
554 # make sure the environment variables GSDLCOLLECTION and GSDLCOLLECTDIR
555 # are defined
556 $ENV{'GSDLCOLLECTION'} = $collection unless defined $ENV{'GSDLCOLLECTION'};
557 $ENV{'GSDLCOLLECTDIR'} = "$ENV{'GSDLHOME'}/collect/$collection";
558
559 # make sure this collection exists
560 if (!-e $ENV{'GSDLCOLLECTDIR'}) {
561 print STDERR "Invalid collection ($collection).\n";
562 return "";
563 }
564
565 # everything is ready to go
566 return $collection;
567}
568
5691;
Note: See TracBrowser for help on using the repository browser.