source: main/tags/2.13/gsdl/perllib/util.pm@ 24526

Last change on this file since 24526 was 983, checked in by sjboddie, 24 years ago

link() function isn't supported on windows - use copy
  • Property svn:keywords set to Author Date Id Revision
File size: 13.9 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
242sub mk_all_dir {
243 my ($dir) = @_;
244
245 # use / for the directory separator, remove duplicate and
246 # trailing slashes
247 $dir=~s/[\\\/]+/\//g;
248 $dir=~s/[\\\/]+$//;
249
250 # make sure the cache directory exists
251 my $dirsofar = "";
252 my $first = 1;
253 foreach $dirname (split ("/", $dir)) {
254 $dirsofar .= "/" unless $first;
255 $first = 0;
256
257 $dirsofar .= $dirname;
258
259 next if $dirname =~ /^(|[a-z]:)$/i;
260 if (!-e $dirsofar)
261 {
262 my $store_umask = umask(0002);
263 my $mkdir_ok = mkdir ($dirsofar, 0777);
264 umask($store_umask);
265 if (!$mkdir_ok)
266 {
267 print STDERR "util::mk_all_dir could not create directory $dirsofar\n";
268 return;
269 }
270 }
271 }
272}
273
274# make hard link to file if supported by OS, otherwise copy the file
275sub hard_link {
276 my ($src, $dest) = @_;
277
278 # remove trailing slashes from source and destination files
279 $src =~ s/[\\\/]+$//;
280 $dest =~ s/[\\\/]+$//;
281
282 # a few sanity checks
283 if (-e $dest) {
284 # destination file already exists
285 return;
286 }
287 elsif (!-e $src) {
288 print STDERR "util::hard_link source file $src does not exist\n";
289 return;
290 }
291 elsif (-d $src) {
292 print STDERR "util::hard_link source $src is a directory\n";
293 return;
294 }
295
296 my $dest_dir = &File::Basename::dirname($dest);
297 mk_all_dir($dest_dir) if (!-e $dest_dir);
298
299 # link not supported on wondows
300 if ($ENV{'GSDLOS'} =~ /^windows$/i) {
301 &File::Copy::copy ($src, $dest);
302
303 } elsif (!link($src, $dest)) {
304 print STDERR "util::hard_link: unable to create hard link. ";
305 print STDERR " Attempting to copy file: $src -> $dest\n";
306 &File::Copy::copy ($src, $dest);
307 }
308}
309
310# make soft link to file if supported by OS, otherwise return error
311sub soft_link {
312 my ($src, $dest) = @_;
313
314 # remove trailing slashes from source and destination files
315 $src =~ s/[\\\/]+$//;
316 $dest =~ s/[\\\/]+$//;
317
318 # a few sanity checks
319 if (!-e $src) {
320 print STDERR "util::soft_link source file $src does not exist\n";
321 return 0;
322 }
323
324 my $dest_dir = &File::Basename::dirname($dest);
325 mk_all_dir($dest_dir) if (!-e $dest_dir);
326
327 if (!symlink($src, $dest))
328 {
329 print STDERR "util::soft_link: unable to create soft link.";
330 return 0;
331 }
332
333 return 1;
334}
335
336
337
338
339# updates a copy of a directory in some other part of the filesystem
340# verbosity settings are: 0=low, 1=normal, 2=high
341# both $fromdir and $todir should be absolute paths
342sub cachedir {
343 my ($fromdir, $todir, $verbosity) = @_;
344 $verbosity = 1 unless defined $verbosity;
345
346 # use / for the directory separator, remove duplicate and
347 # trailing slashes
348 $fromdir=~s/[\\\/]+/\//g;
349 $fromdir=~s/[\\\/]+$//;
350 $todir=~s/[\\\/]+/\//g;
351 $todir=~s/[\\\/]+$//;
352
353 &mk_all_dir ($todir);
354
355 # get the directories in ascending order
356 if (!opendir (FROMDIR, $fromdir)) {
357 print STDERR "util::cachedir could not read directory $fromdir\n";
358 return;
359 }
360 my @fromdir = grep (!/^\.\.?$/, sort(readdir (FROMDIR)));
361 closedir (FROMDIR);
362
363 if (!opendir (TODIR, $todir)) {
364 print STDERR "util::cacedir could not read directory $todir\n";
365 return;
366 }
367 my @todir = grep (!/^\.\.?$/, sort(readdir (TODIR)));
368 closedir (TODIR);
369
370 my $fromi = 0;
371 my $toi = 0;
372
373 while ($fromi < scalar(@fromdir) || $toi < scalar(@todir)) {
374# print "fromi: $fromi toi: $toi\n";
375
376 # see if we should delete a file/directory
377 # this should happen if the file/directory
378 # is not in the from list or if its a different
379 # size, or has an older timestamp
380 if ($toi < scalar(@todir)) {
381 if (($fromi >= scalar(@fromdir)) ||
382 ($todir[$toi] lt $fromdir[$fromi] ||
383 ($todir[$toi] eq $fromdir[$fromi] &&
384 &differentfiles("$fromdir/$fromdir[$fromi]","$todir/$todir[$toi]",
385 $verbosity)))) {
386
387 # the files are different
388 &rm_r("$todir/$todir[$toi]");
389 splice(@todir, $toi, 1); # $toi stays the same
390
391 } elsif ($todir[$toi] eq $fromdir[$fromi]) {
392 # the files are the same
393 # if it is a directory, check its contents
394 if (-d "$todir/$todir[$toi]") {
395 &cachedir ("$fromdir/$fromdir[$fromi]",
396 "$todir/$todir[$toi]", $verbosity);
397 }
398
399 $toi++;
400 $fromi++;
401 next;
402 }
403 }
404
405 # see if we should insert a file/directory
406 # we should insert a file/directory if there
407 # is no tofiles left or if the tofile does not exist
408 if ($fromi < scalar(@fromdir) && ($toi >= scalar(@todir) ||
409 $todir[$toi] gt $fromdir[$fromi])) {
410 &cp_r ("$fromdir/$fromdir[$fromi]", "$todir/$fromdir[$fromi]");
411 splice (@todir, $toi, 0, $fromdir[$fromi]);
412
413 $toi++;
414 $fromi++;
415 }
416 }
417}
418
419# this function returns -1 if either file is not found
420# assumes that $file1 and $file2 are absolute file names or
421# in the current directory
422# $file2 is allowed to be newer than $file1
423sub differentfiles {
424 my ($file1, $file2, $verbosity) = @_;
425 $verbosity = 1 unless defined $verbosity;
426
427 $file1 =~ s/\/+$//;
428 $file2 =~ s/\/+$//;
429
430 my ($file1name) = $file1 =~ /\/([^\/]*)$/;
431 my ($file2name) = $file2 =~ /\/([^\/]*)$/;
432
433 return -1 unless (-e $file1 && -e $file2);
434 if ($file1name ne $file2name) {
435 print STDERR "filenames are not the same\n" if ($verbosity >= 2);
436 return 1;
437 }
438
439 @file1stat = stat ($file1);
440 @file2stat = stat ($file2);
441
442 if (-d $file1) {
443 if (! -d $file2) {
444 print STDERR "one file is a directory\n" if ($verbosity >= 2);
445 return 1;
446 }
447 return 0;
448 }
449
450 # both must be regular files
451 unless (-f $file1 && -f $file2) {
452 print STDERR "one file is not a regular file\n" if ($verbosity >= 2);
453 return 1;
454 }
455
456 # the size of the files must be the same
457 if ($file1stat[7] != $file2stat[7]) {
458 print STDERR "different sized files\n" if ($verbosity >= 2);
459 return 1;
460 }
461
462 # the second file cannot be older than the first
463 if ($file1stat[9] > $file2stat[9]) {
464 print STDERR "file is older\n" if ($verbosity >= 2);
465 return 1;
466 }
467
468 return 0;
469}
470
471
472sub get_tmp_filename {
473 my $tmpdir = "$ENV{'GSDLHOME'}/tmp";
474 &mk_all_dir ($tmpdir) unless -e $tmpdir;
475
476 my $count = 1000;
477 my $rand = int(rand $count);
478 while (-e "$tmpdir/F$rand") {
479 $rand = int(rand $count);
480 $count++;
481 }
482
483 return "$tmpdir/F$rand";
484}
485
486
487sub filename_cat {
488 my (@filenames) = @_;
489 my $filename = join("/", @filenames);
490
491 # remove duplicate slashes and remove the last slash
492 if ($ENV{'GSDLOS'} =~ /^windows$/i) {
493 $filename =~ s/[\\\/]+/\\/g;
494 } else {
495 $filename =~ s/[\/]+/\//g;
496 # DB: want a filename abc\de.html to remain like this
497 }
498 $filename =~ s/[\\\/]$//;
499
500 return $filename;
501}
502
503sub get_os_dirsep {
504
505 if ($ENV{'GSDLOS'} =~ /^windows$/i) {
506 return "\\\\";
507 } else {
508 return "\\\/";
509 }
510}
511
512sub get_re_dirsep {
513
514 return "\\\\|\\\/";
515}
516
517
518# if this is running on windows we want binaries to end in
519# .exe, otherwise they don't have to end in any extension
520sub get_os_exe {
521 return ".exe" if $ENV{'GSDLOS'} =~ /^windows$/i;
522 return "";
523}
524
525
526# test to see whether this is a big or little endian machine
527sub is_little_endian {
528 return (ord(substr(pack("s",1), 0, 1)) == 1);
529}
530
531
532# will return the collection name if successful, "" otherwise
533sub use_collection {
534 my ($collection) = @_;
535
536 # get and check the collection
537 if (!defined($collection) || $collection eq "") {
538 if (defined $ENV{'GSDLCOLLECTION'}) {
539 $collection = $ENV{'GSDLCOLLECTION'};
540 } else {
541 print STDERR "No collection specified\n";
542 return "";
543 }
544 }
545
546 if ($collection eq "modelcol") {
547 print STDERR "You can't use modelcol.\n";
548 return "";
549 }
550
551 # make sure the environment variables GSDLCOLLECTION and GSDLCOLLECTDIR
552 # are defined
553 $ENV{'GSDLCOLLECTION'} = $collection unless defined $ENV{'GSDLCOLLECTION'};
554 $ENV{'GSDLCOLLECTDIR'} = "$ENV{'GSDLHOME'}/collect/$collection";
555
556 # make sure this collection exists
557 if (!-e $ENV{'GSDLCOLLECTDIR'}) {
558 print STDERR "Invalid collection ($collection).\n";
559 return "";
560 }
561
562 # everything is ready to go
563 return $collection;
564}
565
5661;
Note: See TracBrowser for help on using the repository browser.