source: main/tags/2.10/gsdl/perllib/util.pm@ 32783

Last change on this file since 32783 was 619, checked in by sjboddie, 25 years ago

Added function to form hard link between two files
(used for handling images sensibly during building of

HTML pages)
  • Property svn:keywords set to Author Date Id Revision
File size: 11.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) {
43 print STDERR "util::rm $file is not a regular 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) {
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
95# copies a file or a group of files
96sub cp {
97 my $dest = pop (@_);
98 my (@srcfiles) = @_;
99
100 # remove trailing slashes from source and destination files
101 $dest =~ s/[\\\/]+$//;
102 map {$_ =~ s/[\\\/]+$//;} @srcfiles;
103
104 # a few sanity checks
105 if (scalar (@srcfiles) == 0) {
106 print STDERR "util::cp no destination directory given\n";
107 return;
108 } elsif ((scalar (@srcfiles) > 1) && (!-d $dest)) {
109 print STDERR "util::cp if multiple source files are given the ".
110 "destination must be a directory\n";
111 return;
112 }
113
114 # copy the files
115 foreach $file (@srcfiles) {
116 my $tempdest = $dest;
117 if (-d $tempdest) {
118 my ($filename) = $file =~ /([^\\\/]+)$/;
119 $tempdest .= "/$filename";
120 }
121 if (!-e $file) {
122 print STDERR "util::cp $file does not exist\n";
123 } elsif (!-f $file) {
124 print STDERR "util::cp $file is not a plain file\n";
125 } else {
126 &File::Copy::copy ($file, $tempdest);
127 }
128 }
129}
130
131
132# recursively copies a file or group of files
133# syntax: cp_r (sourcefiles, destination file or directory)
134sub cp_r {
135 my $dest = pop (@_);
136 my (@srcfiles) = @_;
137
138 # remove trailing slashes from source and destination files
139 $dest =~ s/[\\\/]+$//;
140 map {$_ =~ s/[\\\/]+$//;} @srcfiles;
141
142 # a few sanity checks
143 if (scalar (@srcfiles) == 0) {
144 print STDERR "util::cp no destination directory given\n";
145 return;
146 } elsif ((scalar (@srcfiles) > 1) && (!-d $dest)) {
147 print STDERR "util::cp if multiple source files are given the ".
148 "destination must be a directory\n";
149 return;
150 }
151
152 # copy the files
153 foreach $file (@srcfiles) {
154 # copy the file to within dest if dest is a directory
155 # exception: if there is only one source file and that
156 # source file is a directory
157 my $tempdest = $dest;
158 if (-d $tempdest && !(scalar(@srcfiles) == 1 && -d $file)) {
159 my ($filename) = $file =~ /([^\\\/]+)$/;
160 $tempdest .= "/$filename";
161 }
162
163 if (!-e $file) {
164 print STDERR "util::cp $file does not exist\n";
165
166 } elsif (-d $file) {
167 # make a new directory (if needed)
168 mkdir ($tempdest, 0775) unless -e $tempdest;
169
170 # get the contents of this directory
171 if (!opendir (INDIR, $file)) {
172 print STDERR "util::cp_r could not open directory $file\n";
173 } else {
174 my @filedir = grep (!/^\.\.?$/, readdir (INDIR));
175 closedir (INDIR);
176
177 # copy all the files in this directory
178 &cp_r (map {$_="$file/$_";} @filedir, $tempdest);
179 }
180
181 } else {
182 &cp($file, $tempdest);
183 }
184 }
185}
186
187
188sub mk_all_dir {
189 my ($dir) = @_;
190
191 # use / for the directory separator, remove duplicate and
192 # trailing slashes
193 $dir=~s/[\\\/]+/\//g;
194 $dir=~s/[\\\/]+$//;
195
196 # make sure the cache directory exists
197 my $dirsofar = "";
198 my $first = 1;
199 foreach $dirname (split ("/", $dir)) {
200 $dirsofar .= "/" unless $first;
201 $first = 0;
202
203 $dirsofar .= $dirname;
204
205 next if $dirname =~ /^(|[a-z]:)$/i;
206 if (!-e $dirsofar && !mkdir ($dirsofar, 0775)) {
207 print STDERR "util::mk_all_dir could not create directory $dirsofar\n";
208 return;
209 }
210 }
211}
212
213# make hard link to file if supported by OS, otherwise copy the file
214sub hard_link {
215 my ($src,$dest) = @_;
216
217 # remove trailing slashes from source and destination files
218 $src =~ s/[\\\/]+$//;
219 $dest =~ s/[\\\/]+$//;
220
221 # a few sanity checks
222 if (!-e $src) {
223 print STDERR "util::hard_link source file $src does not exist\n";
224 return;
225 }
226 elsif (-d $src) {
227 print STDERR "util::hard_link source $src is a directory\n";
228 return;
229 }
230
231 my $dest_dir = &File::Basename::dirname($dest);
232 mk_all_dir($dest_dir) if (!-e $dest_dir);
233
234 if (!link($src,$dest))
235 {
236 print STDERR "util::hard_link: unable to create hard link. ";
237 print STDERR " Attempting to copy file: $src -> $dest\n";
238 &File::Copy::copy ($src, $dest);
239 }
240
241}
242
243
244
245
246# updates a copy of a directory in some other part of the filesystem
247# verbosity settings are: 0=low, 1=normal, 2=high
248# both $fromdir and $todir should be absolute paths
249sub cachedir {
250 my ($fromdir, $todir, $verbosity) = @_;
251 $verbosity = 1 unless defined $verbosity;
252
253 # use / for the directory separator, remove duplicate and
254 # trailing slashes
255 $fromdir=~s/[\\\/]+/\//g;
256 $fromdir=~s/[\\\/]+$//;
257 $todir=~s/[\\\/]+/\//g;
258 $todir=~s/[\\\/]+$//;
259
260 &mk_all_dir ($todir);
261
262 # get the directories in ascending order
263 if (!opendir (FROMDIR, $fromdir)) {
264 print STDERR "util::cachedir could not read directory $fromdir\n";
265 return;
266 }
267 my @fromdir = grep (!/^\.\.?$/, sort(readdir (FROMDIR)));
268 closedir (FROMDIR);
269
270 if (!opendir (TODIR, $todir)) {
271 print STDERR "util::cacedir could not read directory $todir\n";
272 return;
273 }
274 my @todir = grep (!/^\.\.?$/, sort(readdir (TODIR)));
275 closedir (TODIR);
276
277 my $fromi = 0;
278 my $toi = 0;
279
280 while ($fromi < scalar(@fromdir) || $toi < scalar(@todir)) {
281# print "fromi: $fromi toi: $toi\n";
282
283 # see if we should delete a file/directory
284 # this should happen if the file/directory
285 # is not in the from list or if its a different
286 # size, or has an older timestamp
287 if ($toi < scalar(@todir)) {
288 if (($fromi >= scalar(@fromdir)) ||
289 ($todir[$toi] lt $fromdir[$fromi] ||
290 ($todir[$toi] eq $fromdir[$fromi] &&
291 &differentfiles("$fromdir/$fromdir[$fromi]","$todir/$todir[$toi]",
292 $verbosity)))) {
293
294 # the files are different
295 &rm_r("$todir/$todir[$toi]");
296 splice(@todir, $toi, 1); # $toi stays the same
297
298 } elsif ($todir[$toi] eq $fromdir[$fromi]) {
299 # the files are the same
300 # if it is a directory, check its contents
301 if (-d "$todir/$todir[$toi]") {
302 &cachedir ("$fromdir/$fromdir[$fromi]",
303 "$todir/$todir[$toi]", $verbosity);
304 }
305
306 $toi++;
307 $fromi++;
308 next;
309 }
310 }
311
312 # see if we should insert a file/directory
313 # we should insert a file/directory if there
314 # is no tofiles left or if the tofile does not exist
315 if ($fromi < scalar(@fromdir) && ($toi >= scalar(@todir) ||
316 $todir[$toi] gt $fromdir[$fromi])) {
317 &cp_r ("$fromdir/$fromdir[$fromi]", "$todir/$fromdir[$fromi]");
318 splice (@todir, $toi, 0, $fromdir[$fromi]);
319
320 $toi++;
321 $fromi++;
322 }
323 }
324}
325
326# this function returns -1 if either file is not found
327# assumes that $file1 and $file2 are absolute file names or
328# in the current directory
329# $file2 is allowed to be newer than $file1
330sub differentfiles {
331 my ($file1, $file2, $verbosity) = @_;
332 $verbosity = 1 unless defined $verbosity;
333
334 $file1 =~ s/\/+$//;
335 $file2 =~ s/\/+$//;
336
337 my ($file1name) = $file1 =~ /\/([^\/]*)$/;
338 my ($file2name) = $file2 =~ /\/([^\/]*)$/;
339
340 return -1 unless (-e $file1 && -e $file2);
341 if ($file1name ne $file2name) {
342 print STDERR "filenames are not the same\n" if ($verbosity >= 2);
343 return 1;
344 }
345
346 @file1stat = stat ($file1);
347 @file2stat = stat ($file2);
348
349 if (-d $file1) {
350 if (! -d $file2) {
351 print STDERR "one file is a directory\n" if ($verbosity >= 2);
352 return 1;
353 }
354 return 0;
355 }
356
357 # both must be regular files
358 unless (-f $file1 && -f $file2) {
359 print STDERR "one file is not a regular file\n" if ($verbosity >= 2);
360 return 1;
361 }
362
363 # the size of the files must be the same
364 if ($file1stat[7] != $file2stat[7]) {
365 print STDERR "different sized files\n" if ($verbosity >= 2);
366 return 1;
367 }
368
369 # the second file cannot be older than the first
370 if ($file1stat[9] > $file2stat[9]) {
371 print STDERR "file is older\n" if ($verbosity >= 2);
372 return 1;
373 }
374
375 return 0;
376}
377
378
379sub get_tmp_filename {
380 my $tmpdir = "$ENV{'GSDLHOME'}/tmp";
381 &mk_all_dir ($tmpdir) unless -e $tmpdir;
382
383 my $count = 1000;
384 my $rand = int(rand $count);
385 while (-e "$tmpdir/F$rand") {
386 $rand = int(rand $count);
387 $count++;
388 }
389
390 return "$tmpdir/F$rand";
391}
392
393
394sub filename_cat {
395 my (@filenames) = @_;
396 my $filename = join("/", @filenames);
397
398 # remove duplicate slashes and remove the last slash
399 if ($ENV{'GSDLOS'} =~ /^windows$/i) {
400 $filename =~ s/[\\\/]+/\\/g;
401 } else {
402 $filename =~ s/[\\\/]+/\//g;
403 }
404 $filename =~ s/[\\\/]$//;
405
406 return $filename;
407}
408
409sub get_os_dirsep {
410
411 if ($ENV{'GSDLOS'} =~ /^windows$/i) {
412 return "\\\\";
413 } else {
414 return "\\\/";
415 }
416}
417
418sub get_re_dirsep {
419
420 return "\\\\|\\\/";
421}
422
423
424# if this is running on windows we want binaries to end in
425# .exe, otherwise they don't have to end in any extension
426sub get_os_exe {
427 return ".exe" if $ENV{'GSDLOS'} =~ /^windows$/i;
428 return "";
429}
430
431
432# test to see whether this is a big or little endian machine
433sub is_little_endian {
434 return (ord(substr(pack("s",1), 0, 1)) == 1);
435}
436
437
438# will return the collection name if successful, "" otherwise
439sub use_collection {
440 my ($collection) = @_;
441
442 # get and check the collection
443 if (!defined($collection) || $collection eq "") {
444 if (defined $ENV{'GSDLCOLLECTION'}) {
445 $collection = $ENV{'GSDLCOLLECTION'};
446 } else {
447 print STDERR "No collection specified\n";
448 return "";
449 }
450 }
451
452 if ($collection eq "modelcol") {
453 print STDERR "You can't use modelcol.\n";
454 return "";
455 }
456
457 # make sure the environment variables GSDLCOLLECTION and GSDLCOLLECTDIR
458 # are defined
459 $ENV{'GSDLCOLLECTION'} = $collection unless defined $ENV{'GSDLCOLLECTION'};
460 $ENV{'GSDLCOLLECTDIR'} = "$ENV{'GSDLHOME'}/collect/$collection";
461
462 # make sure this collection exists
463 if (!-e $ENV{'GSDLCOLLECTDIR'}) {
464 print STDERR "Invalid collection ($collection).\n";
465 return "";
466 }
467
468 # everything is ready to go
469 return $collection;
470}
471
4721;
Note: See TracBrowser for help on using the repository browser.