source: main/tags/2.50-cdrom/gsdl/perllib/util.pm@ 26494

Last change on this file since 26494 was 5494, checked in by sjboddie, 21 years ago

It turns out that the perl link() function is supported on NTFS. Instead
of resorting to a copy() instead of a link() for all windows platforms
in hard_link() we now only do it for non-ntfs windows's.
  • Property svn:keywords set to Author Date Id Revision
File size: 14.8 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 directory)
169# destination must be a directory - to copy one file to
170# another use cp instead
171sub cp_r {
172 my $dest = pop (@_);
173 my (@srcfiles) = @_;
174
175 # a few sanity checks
176 if (scalar (@srcfiles) == 0) {
177 print STDERR "util::cp_r no destination directory given\n";
178 return;
179 } elsif (-f $dest) {
180 print STDERR "util::cp_r destination must be a directory\n";
181 return;
182 }
183
184 # create destination directory if it doesn't exist already
185 if (! -d $dest) {
186 my $store_umask = umask(0002);
187 mkdir ($dest, 0777);
188 umask($store_umask);
189 }
190
191 # copy the files
192 foreach $file (@srcfiles) {
193
194 if (!-e $file) {
195 print STDERR "util::cp_r $file does not exist\n";
196
197 } elsif (-d $file) {
198 # make the new directory
199 my ($filename) = $file =~ /([^\\\/]*)$/;
200 $dest = &util::filename_cat ($dest, $filename);
201 my $store_umask = umask(0002);
202 mkdir ($dest, 0777);
203 umask($store_umask);
204
205 # get the contents of this directory
206 if (!opendir (INDIR, $file)) {
207 print STDERR "util::cp_r could not open directory $file\n";
208 } else {
209 my @filedir = readdir (INDIR);
210 closedir (INDIR);
211 foreach $f (@filedir) {
212 next if $f =~ /^\.\.?$/;
213 # copy all the files in this directory
214 my $ff = &util::filename_cat ($file, $f);
215 &cp_r ($ff, $dest);
216 }
217 }
218
219 } else {
220 &cp($file, $dest);
221 }
222 }
223}
224
225
226sub mk_dir {
227 my ($dir) = @_;
228
229 my $store_umask = umask(0002);
230 my $mkdir_ok = mkdir ($dir, 0777);
231 umask($store_umask);
232
233 if (!$mkdir_ok)
234 {
235 print STDERR "util::mk_dir could not create directory $dir\n";
236 return;
237 }
238}
239
240# in case anyone cares - I did some testing (using perls Benchmark module)
241# on this subroutine against File::Path::mkpath (). mk_all_dir() is apparently
242# slightly faster (surprisingly) - Stefan.
243sub mk_all_dir {
244 my ($dir) = @_;
245
246 # use / for the directory separator, remove duplicate and
247 # trailing slashes
248 $dir=~s/[\\\/]+/\//g;
249 $dir=~s/[\\\/]+$//;
250
251 # make sure the cache directory exists
252 my $dirsofar = "";
253 my $first = 1;
254 foreach $dirname (split ("/", $dir)) {
255 $dirsofar .= "/" unless $first;
256 $first = 0;
257
258 $dirsofar .= $dirname;
259
260 next if $dirname =~ /^(|[a-z]:)$/i;
261 if (!-e $dirsofar)
262 {
263 my $store_umask = umask(0002);
264 my $mkdir_ok = mkdir ($dirsofar, 0777);
265 umask($store_umask);
266 if (!$mkdir_ok)
267 {
268 print STDERR "util::mk_all_dir could not create directory $dirsofar\n";
269 return;
270 }
271 }
272 }
273}
274
275# make hard link to file if supported by OS, otherwise copy the file
276sub hard_link {
277 my ($src, $dest) = @_;
278
279 # remove trailing slashes from source and destination files
280 $src =~ s/[\\\/]+$//;
281 $dest =~ s/[\\\/]+$//;
282
283 # a few sanity checks
284 if (-e $dest) {
285 # destination file already exists
286 return;
287 }
288 elsif (!-e $src) {
289 print STDERR "util::hard_link source file $src does not exist\n";
290 return 1;
291 }
292 elsif (-d $src) {
293 print STDERR "util::hard_link source $src is a directory\n";
294 return 1;
295 }
296
297 my $dest_dir = &File::Basename::dirname($dest);
298 mk_all_dir($dest_dir) if (!-e $dest_dir);
299
300 # link not supported on windows 9x
301 if (($ENV{'GSDLOS'} =~ /^windows$/i) && (Win32::FsType() !~ /^ntfs$/i)) {
302 &File::Copy::copy ($src, $dest);
303
304 } elsif (!link($src, $dest)) {
305 print STDERR "util::hard_link: unable to create hard link. ";
306 print STDERR " Attempting to copy file: $src -> $dest\n";
307 &File::Copy::copy ($src, $dest);
308 }
309 return 0;
310}
311
312# make soft link to file if supported by OS, otherwise copy file
313sub soft_link {
314 my ($src, $dest) = @_;
315
316 # remove trailing slashes from source and destination files
317 $src =~ s/[\\\/]+$//;
318 $dest =~ s/[\\\/]+$//;
319
320 # a few sanity checks
321 if (!-e $src) {
322 print STDERR "util::soft_link source file $src does not exist\n";
323 return 0;
324 }
325
326 my $dest_dir = &File::Basename::dirname($dest);
327 mk_all_dir($dest_dir) if (!-e $dest_dir);
328
329 if ($ENV{'GSDLOS'} =~ /^windows$/i) {
330 # symlink not supported on windows
331 &File::Copy::copy ($src, $dest);
332
333 } elsif (!eval {symlink($src, $dest)}) {
334 print STDERR "util::soft_link: unable to create soft link.\n";
335 return 0;
336 }
337
338 return 1;
339}
340
341
342
343
344# updates a copy of a directory in some other part of the filesystem
345# verbosity settings are: 0=low, 1=normal, 2=high
346# both $fromdir and $todir should be absolute paths
347sub cachedir {
348 my ($fromdir, $todir, $verbosity) = @_;
349 $verbosity = 1 unless defined $verbosity;
350
351 # use / for the directory separator, remove duplicate and
352 # trailing slashes
353 $fromdir=~s/[\\\/]+/\//g;
354 $fromdir=~s/[\\\/]+$//;
355 $todir=~s/[\\\/]+/\//g;
356 $todir=~s/[\\\/]+$//;
357
358 &mk_all_dir ($todir);
359
360 # get the directories in ascending order
361 if (!opendir (FROMDIR, $fromdir)) {
362 print STDERR "util::cachedir could not read directory $fromdir\n";
363 return;
364 }
365 my @fromdir = grep (!/^\.\.?$/, sort(readdir (FROMDIR)));
366 closedir (FROMDIR);
367
368 if (!opendir (TODIR, $todir)) {
369 print STDERR "util::cacedir could not read directory $todir\n";
370 return;
371 }
372 my @todir = grep (!/^\.\.?$/, sort(readdir (TODIR)));
373 closedir (TODIR);
374
375 my $fromi = 0;
376 my $toi = 0;
377
378 while ($fromi < scalar(@fromdir) || $toi < scalar(@todir)) {
379# print "fromi: $fromi toi: $toi\n";
380
381 # see if we should delete a file/directory
382 # this should happen if the file/directory
383 # is not in the from list or if its a different
384 # size, or has an older timestamp
385 if ($toi < scalar(@todir)) {
386 if (($fromi >= scalar(@fromdir)) ||
387 ($todir[$toi] lt $fromdir[$fromi] ||
388 ($todir[$toi] eq $fromdir[$fromi] &&
389 &differentfiles("$fromdir/$fromdir[$fromi]","$todir/$todir[$toi]",
390 $verbosity)))) {
391
392 # the files are different
393 &rm_r("$todir/$todir[$toi]");
394 splice(@todir, $toi, 1); # $toi stays the same
395
396 } elsif ($todir[$toi] eq $fromdir[$fromi]) {
397 # the files are the same
398 # if it is a directory, check its contents
399 if (-d "$todir/$todir[$toi]") {
400 &cachedir ("$fromdir/$fromdir[$fromi]",
401 "$todir/$todir[$toi]", $verbosity);
402 }
403
404 $toi++;
405 $fromi++;
406 next;
407 }
408 }
409
410 # see if we should insert a file/directory
411 # we should insert a file/directory if there
412 # is no tofiles left or if the tofile does not exist
413 if ($fromi < scalar(@fromdir) && ($toi >= scalar(@todir) ||
414 $todir[$toi] gt $fromdir[$fromi])) {
415 &cp_r ("$fromdir/$fromdir[$fromi]", "$todir/$fromdir[$fromi]");
416 splice (@todir, $toi, 0, $fromdir[$fromi]);
417
418 $toi++;
419 $fromi++;
420 }
421 }
422}
423
424# this function returns -1 if either file is not found
425# assumes that $file1 and $file2 are absolute file names or
426# in the current directory
427# $file2 is allowed to be newer than $file1
428sub differentfiles {
429 my ($file1, $file2, $verbosity) = @_;
430 $verbosity = 1 unless defined $verbosity;
431
432 $file1 =~ s/\/+$//;
433 $file2 =~ s/\/+$//;
434
435 my ($file1name) = $file1 =~ /\/([^\/]*)$/;
436 my ($file2name) = $file2 =~ /\/([^\/]*)$/;
437
438 return -1 unless (-e $file1 && -e $file2);
439 if ($file1name ne $file2name) {
440 print STDERR "filenames are not the same\n" if ($verbosity >= 2);
441 return 1;
442 }
443
444 @file1stat = stat ($file1);
445 @file2stat = stat ($file2);
446
447 if (-d $file1) {
448 if (! -d $file2) {
449 print STDERR "one file is a directory\n" if ($verbosity >= 2);
450 return 1;
451 }
452 return 0;
453 }
454
455 # both must be regular files
456 unless (-f $file1 && -f $file2) {
457 print STDERR "one file is not a regular file\n" if ($verbosity >= 2);
458 return 1;
459 }
460
461 # the size of the files must be the same
462 if ($file1stat[7] != $file2stat[7]) {
463 print STDERR "different sized files\n" if ($verbosity >= 2);
464 return 1;
465 }
466
467 # the second file cannot be older than the first
468 if ($file1stat[9] > $file2stat[9]) {
469 print STDERR "file is older\n" if ($verbosity >= 2);
470 return 1;
471 }
472
473 return 0;
474}
475
476
477sub get_tmp_filename {
478 my $tmpdir = filename_cat($ENV{'GSDLHOME'}, "tmp");
479 &mk_all_dir ($tmpdir) unless -e $tmpdir;
480
481 my $count = 1000;
482 my $rand = int(rand $count);
483 while (-e &filename_cat($tmpdir, "F$rand")) {
484 $rand = int(rand $count);
485 $count++;
486 }
487
488 return filename_cat($tmpdir, "F$rand");
489}
490
491
492sub filename_cat {
493 my (@filenames) = @_;
494 my $filename = join("/", @filenames);
495
496 # remove duplicate slashes and remove the last slash
497 if ($ENV{'GSDLOS'} =~ /^windows$/i) {
498 $filename =~ s/[\\\/]+/\\/g;
499 } else {
500 $filename =~ s/[\/]+/\//g;
501 # DB: want a filename abc\de.html to remain like this
502 }
503 $filename =~ s/[\\\/]$//;
504
505 return $filename;
506}
507
508# returns 1 if filename1 and filename2 point to the same
509# file or directory
510sub filenames_equal {
511 my ($filename1, $filename2) = @_;
512
513 # use filename_cat to clean up trailing slashes and
514 # multiple slashes
515 $filename1 = filename_cat ($filename1);
516 $filename2 = filename_cat ($filename2);
517
518 # filenames not case sensitive on windows
519 if ($ENV{'GSDLOS'} =~ /^windows$/i) {
520 $filename1 =~ tr/[A-Z]/[a-z]/;
521 $filename2 =~ tr/[A-Z]/[a-z]/;
522 }
523 return 1 if $filename1 eq $filename2;
524 return 0;
525}
526
527sub get_os_dirsep {
528
529 if ($ENV{'GSDLOS'} =~ /^windows$/i) {
530 return "\\\\";
531 } else {
532 return "\\\/";
533 }
534}
535
536sub get_re_dirsep {
537
538 return "\\\\|\\\/";
539}
540
541
542# if this is running on windows we want binaries to end in
543# .exe, otherwise they don't have to end in any extension
544sub get_os_exe {
545 return ".exe" if $ENV{'GSDLOS'} =~ /^windows$/i;
546 return "";
547}
548
549
550# test to see whether this is a big or little endian machine
551sub is_little_endian {
552 return (ord(substr(pack("s",1), 0, 1)) == 1);
553}
554
555
556# will return the collection name if successful, "" otherwise
557sub use_collection {
558 my ($collection, $collectdir) = @_;
559
560 if (!defined $collectdir || $collectdir eq "") {
561 $collectdir = &filename_cat ($ENV{'GSDLHOME'}, "collect");
562 }
563
564 # get and check the collection
565 if (!defined($collection) || $collection eq "") {
566 if (defined $ENV{'GSDLCOLLECTION'}) {
567 $collection = $ENV{'GSDLCOLLECTION'};
568 } else {
569 print STDOUT "No collection specified\n";
570 return "";
571 }
572 }
573
574 if ($collection eq "modelcol") {
575 print STDOUT "You can't use modelcol.\n";
576 return "";
577 }
578
579 # make sure the environment variables GSDLCOLLECTION and GSDLCOLLECTDIR
580 # are defined
581 $ENV{'GSDLCOLLECTION'} = $collection unless defined $ENV{'GSDLCOLLECTION'};
582 $ENV{'GSDLCOLLECTDIR'} = &filename_cat ($collectdir, $collection);
583
584 # make sure this collection exists
585 if (!-e $ENV{'GSDLCOLLECTDIR'}) {
586 print STDOUT "Invalid collection ($collection).\n";
587 return "";
588 }
589
590 # everything is ready to go
591 return $collection;
592}
593
5941;
Note: See TracBrowser for help on using the repository browser.