source: trunk/gsdl/perllib/util.pm@ 1454

Last change on this file since 1454 was 1454, checked in by stefan, 24 years ago

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