source: main/tags/2.52/gsdl/perllib/util.pm@ 25422

Last change on this file since 25422 was 7929, checked in by davidb, 20 years ago

doc.pm modified so filename stored under gsdlsourcefilename is local
to collection.
  • Property svn:keywords set to Author Date Id Revision
File size: 15.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 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 $first_file = shift(@_);
494 my (@filenames) = @_;
495 #check for non-empty first filename
496 if ($first_file =~ /\w/) {
497 unshift(@filenames, $first_file);
498 }
499
500 my $filename = join("/", @filenames);
501
502 # remove duplicate slashes and remove the last slash
503 if ($ENV{'GSDLOS'} =~ /^windows$/i) {
504 $filename =~ s/[\\\/]+/\\/g;
505 } else {
506 $filename =~ s/[\/]+/\//g;
507 # DB: want a filename abc\de.html to remain like this
508 }
509 $filename =~ s/[\\\/]$//;
510
511 return $filename;
512}
513
514# returns 1 if filename1 and filename2 point to the same
515# file or directory
516sub filenames_equal {
517 my ($filename1, $filename2) = @_;
518
519 # use filename_cat to clean up trailing slashes and
520 # multiple slashes
521 $filename1 = filename_cat ($filename1);
522 $filename2 = filename_cat ($filename2);
523
524 # filenames not case sensitive on windows
525 if ($ENV{'GSDLOS'} =~ /^windows$/i) {
526 $filename1 =~ tr/[A-Z]/[a-z]/;
527 $filename2 =~ tr/[A-Z]/[a-z]/;
528 }
529 return 1 if $filename1 eq $filename2;
530 return 0;
531}
532
533sub get_dirsep {
534
535 if ($ENV{'GSDLOS'} =~ /^windows$/i) {
536 return "\\";
537 } else {
538 return "\/";
539 }
540}
541
542sub get_os_dirsep {
543
544 if ($ENV{'GSDLOS'} =~ /^windows$/i) {
545 return "\\\\";
546 } else {
547 return "\\\/";
548 }
549}
550
551sub get_re_dirsep {
552
553 return "\\\\|\\\/";
554}
555
556
557# if this is running on windows we want binaries to end in
558# .exe, otherwise they don't have to end in any extension
559sub get_os_exe {
560 return ".exe" if $ENV{'GSDLOS'} =~ /^windows$/i;
561 return "";
562}
563
564
565# test to see whether this is a big or little endian machine
566sub is_little_endian {
567 return (ord(substr(pack("s",1), 0, 1)) == 1);
568}
569
570
571# will return the collection name if successful, "" otherwise
572sub use_collection {
573 my ($collection, $collectdir) = @_;
574
575 if (!defined $collectdir || $collectdir eq "") {
576 $collectdir = &filename_cat ($ENV{'GSDLHOME'}, "collect");
577 }
578
579 # get and check the collection
580 if (!defined($collection) || $collection eq "") {
581 if (defined $ENV{'GSDLCOLLECTION'}) {
582 $collection = $ENV{'GSDLCOLLECTION'};
583 } else {
584 print STDOUT "No collection specified\n";
585 return "";
586 }
587 }
588
589 if ($collection eq "modelcol") {
590 print STDOUT "You can't use modelcol.\n";
591 return "";
592 }
593
594 # make sure the environment variables GSDLCOLLECTION and GSDLCOLLECTDIR
595 # are defined
596 $ENV{'GSDLCOLLECTION'} = $collection unless defined $ENV{'GSDLCOLLECTION'};
597 $ENV{'GSDLCOLLECTDIR'} = &filename_cat ($collectdir, $collection);
598
599 # make sure this collection exists
600 if (!-e $ENV{'GSDLCOLLECTDIR'}) {
601 print STDOUT "Invalid collection ($collection).\n";
602 return "";
603 }
604
605 # everything is ready to go
606 return $collection;
607}
608
6091;
Note: See TracBrowser for help on using the repository browser.