3 ###############################################################################
5 # Name : shared_snarfer #
6 # Author : Chris Koeritz #
7 # Rights : Copyright (C) 1996-$now by Author #
11 # A shared library collection for "snarfing up" archives. This uses the #
12 # compressed tar format for files ending in ".snarf" to store collections #
13 # of files, folders, hierarchies and so forth. #
15 ###############################################################################
16 # This program is free software; you can redistribute it and/or modify it #
17 # under the terms of the GNU General Public License as published by the Free #
18 # Software Foundation; either version 2 of the License or (at your option) #
19 # any later version. See: "http://www.gruntose.com/Info/GNU/GPL.html" for a #
20 # version of the License. Please send any updates to "fred@gruntose.com". #
21 ###############################################################################
23 require "filename_helper.pl";
24 require "hostname.pl";
25 require "importenv.pl";
30 #hmmm: maybe move this to a utility script file.
31 $null_log = "/dev/null";
32 #hmmm: move especially this check to a script file, and recast anything
33 # referring to Windows_NT to it.
34 if ( ("$OS" =~ /[wW][iI][nN]/) || ("$OS" =~ /[Oo][Ss]2/)
35 || ("$OS" =~ /[Dd][Oo][Ss]/) ) {
38 #print "nul log=$null_log \n";
40 $TMP =~ s/\\/\//g; # fix the temp variable for ms-winders.
42 # defines an array of problematic entries we were told to deal with.
45 # these files are considered unimportant and won't be included in the archive.
46 @junk_file_list = ("*~", "*.$$$", "3rdparty", "*.aps", "*.bak", "binaries",
47 "*.bsc", "*.cgl", "*.csm", "CVS", "Debug", "*.dll", "*.err", "*.exe",
48 "generated_*", "*.glb", "inprogress", "ipch", "*.llm", "*.log", "*.lnk",
49 "makefile.fw*", "*.mbt", "*.mrt", "*.ncb", "*.o", "obj", "*.obj",
50 "octalforty.Wizardby", "*.obr", "*.opt", "packages",
51 "*.pch", "*.pdb", "*.plg", "*.r$p", "*.rcs", "Release",
52 "*.res", "*.RES", "*.rws", "*.sbr", "*.scc", "*.spx", "*.stackdump",
53 "*.sdf", "*.suo", ".svn", "*.sym", "*.td", "*.tds", "*.tdw", "*.tlb",
54 "*.trw", "*.tmp", "*.tr", "*.user", "*_version.h", "*_version.rc",
57 #print "junk list=@junk_file_list\n";
59 for (local($i) = 0; $i < scalar(@junk_file_list); $i++) {
60 push(@excludes, "--exclude=$junk_file_list[$i]");
62 #print "excludes list=@excludes\n";
64 # generic versions work on sane OSes.
65 $find_tool = `which find`; chop $find_tool;
66 $tar_tool = `which tar`; chop $tar_tool;
68 # pick a more specific version for windows.
69 if ( ("$OS" =~ /[wW][iI][nN]/) || ("$OS" =~ /[Oo][Ss]2/)
70 || ("$OS" =~ /[Dd][Oo][Ss]/) ) {
71 $top_level = "$BUILD_TOP";
72 $msys_folder = "$top_level/build/msys/bin";
73 $find_tool = "$msys_folder/find.exe";
74 $tar_tool = "$msys_folder/tar.exe";
77 #print "find tool: $find_tool\n";
78 #print "tar tool: $tar_tool\n";
80 if ( ! -f "$find_tool" || ! -f "$tar_tool" ) {
81 print "Could not locate either tar or find tools for this platform.\n";
85 # this is somewhat ugly, but it sets up a global variable called
86 # "original_path" so we remember where we started.
87 sub initialize_snarfer {
88 $original_path = cwd();
89 $original_path =~ s/\\/\//g;
92 # returns the current hostname, but without any domain included.
94 local($temphost) = &hostname();
95 $temphost =~ s/([^.]*)\..*/\1/;
96 return &lower($temphost);
99 # takes the base name and creates the full snarf prefix name, which includes
100 # a timestamp and hostname.
103 local($extra_path) = "";
105 if (length($MINGBIN)) {
106 # we rely on the ming binary path on windows, since otherwise a strange
107 # interaction between perl and windowz causes 'date' to use the retarded
108 # windows date program, even with the ming binaries in the path before
109 # the windows directory.
110 $extra_path = "$MINGBIN/";
111 #print "ming path here is:\n$MINGBIN\n";
113 # just hope that this is running under msys in our build bin.
114 $extra_path = "$HOME/hoople2/build/msys/bin/";
118 local($date_part) = `${extra_path}date +%Y-%m-%d-%H%M`;
119 while ($date_part =~ /[\r\n]$/) { chop $date_part; }
120 local($host) = &short_hostname();
121 while ($host =~ /[\r\n]$/) { chop $host; }
122 $base = $base . "_" . $host . "_" . $date_part;
126 # returns the name of the file to create based on the prefix and the
127 # current archive number.
129 local($prefix, $number) = @_;
130 local($path) = &canonicalize($original_path);
131 local($target_file) = $path . '/' . $prefix . "_" . $number . ".tar";
135 # finishes up on the archive file.
137 local($filename) = @_;
138 #print "finalizing now on filename $filename\n";
139 local($outcome) = 0xff & system "gzip", $filename;
140 if ($outcome) { die("failure to finalize"); }
142 if (scalar(@missing_log)) {
143 print "The following files or directories were missing:\n";
144 print "@missing_log\n";
148 # fixes the directory passed in, if required. this is only needed for
149 # dos-like operating systems, where there are drives to worry about and where
150 # cygwin refuses to store the full path for an absolute pathname in the
151 # archive. instead of letting it store partial paths, we change to the top
152 # of the drive and scoop up the files using a relative path.
154 local($directory) = @_;
155 if ( (substr($directory, 0, 2) eq "//")
156 && (substr($directory, 3, 1) eq "/") ) {
157 #print "into special case\n";
158 # it was originally a dos path, so now we must do some directory changing
159 # magic to get the paths to work right.
160 local($drive) = substr($directory, 0, 4); # get just drive letter biz.
161 #print "going to change to $drive\n";
163 #print "cwd now=" . cwd() . "\n";
164 $directory = substr($directory, 4); # rip off absolutist path.
165 #print "using dir now as $directory\n";
166 if (length($directory) == 0) {
167 #print "caught zero length dir, patching to dot now.\n";
174 # snarfer scoops up some files in a directory.
176 local($prefix, $number, $root, $subdir, @extra_flags) = @_;
177 #print "prefix=$prefix, num=$number, root=$root, subdir=$subdir, extra=@extra_flags\n";
179 $root = &chdir_to_top($root);
181 local($target_file) = &snarf_name($prefix, $number);
183 $random_num = (rand() * 1000000) % 1000000;
184 $temp_file = `mktemp "$TMP/zz_snarf_tmp.XXXXXX"`;
187 if (! -d $root . "/" . $subdir) {
188 local($base) = &basename($root . "/" . $subdir);
189 #print "adding to missing in snarfer A: $base\n";
190 push(@missing_log, $base);
193 local($currdir) = cwd();
197 my @lines = qx( $find_tool $subdir @extra_flags "-type" "f" );
198 # if ( ($! != 0) || ($? != 0) ) {
199 # die("failure to find files in $subdir");
202 open TEMPY_OUT, ">>$temp_file" or die "cannot open $temp_file";
203 foreach (@lines) { print TEMPY_OUT "$_"; }
206 if (-s $temp_file == 0) {
207 local($base) = &basename($root . "/" . $subdir);
208 #print "adding to missing in snarfer B: $base\n";
209 push(@missing_log, $base);
212 local($outcome) = 0xff & system $tar_tool,
213 "-rf", &msys_canonicalize($target_file), @excludes,
214 "--files-from=" . &msys_canonicalize($temp_file);
217 die("failure to archive");
219 # clean up temporaries.
221 # change back to previous directory.
225 # snarf_file_list is like snarfer but expects a file pattern at the end rather
226 # than a directory name.
227 sub snarf_file_list {
228 local($prefix, $number, $root, $file_pattern, @extra_flags) = @_;
230 #print "prefix=$prefix, num=$number, root=$root, file_pattern=$file_pattern, extra=@extra_flags\n";
232 $root = &chdir_to_top($root);
234 local($target_file) = &snarf_name($prefix, $number);
236 local($currdir) = cwd();
239 local(@files) = &glob_list($file_pattern);
240 if (!scalar(@files)) {
241 local($base) = $root . "/" . $file_pattern;
242 $base =~ s/\/\//\//g;
243 #print "adding to missing in snarf_file_list: $base\n";
244 push(@missing_log, $base);
247 foreach $i (@files) {
249 $i = substr $i, 2, length($i) - 2;
251 local($outcome) = 0xff & system $tar_tool,
252 #"--directory=" . "$root",
253 @extra_flags, "-rf", &msys_canonicalize($target_file), @excludes, $i;
254 if ($outcome) { die("failure to archive"); }
259 # backup some specific files.
261 local($prefix, $number, $root, $subdir, @files) = @_;
262 #print "backup_files: ref=$prefix, num=$number, subdir=$subdir, list of files=@files\n";
263 foreach $i (@files) {
264 local($new_path) = $subdir . "/" . $i;
265 if ($subdir eq ".") { $new_path = "$i"; }
266 &snarf_file_list($prefix, $number, $root, $new_path);
270 # backup some specific directories.
271 sub backup_directories {
272 local($prefix, $number, $root, $subdir, @dirs) = @_;
273 #print "backup_directories: ref=$prefix, num=$number, root=$root, subdir=$subdir, list of dirs=@dirs.\n";
275 local($path_to_use) = $subdir . "/" . $i;
277 $path_to_use = $subdir;
279 &snarfer($prefix, $number, $root, $path_to_use, ("-maxdepth", "1"));
283 # removes items from the file that match a pattern.
284 sub remove_from_backup {
285 local($prefix, $number, $pattern) = @_;
286 #print "remove_from_backup: pref=$prefix, num=$number, patt=$pattern,\n";
287 local($target_file) = &snarf_name($prefix, $number);
289 open(TARPROC, "$tar_tool --delete -f " . &msys_canonicalize($target_file)
290 . " \"$pattern\" 2>$null_log |");
294 # recursively scoops up a directory hierarchy.
295 sub backup_hierarchy {
296 local($prefix, $number, $root, $filepart) = @_;
297 #print "backup_hierarchy: pref=$prefix, num=$number, root=$root, filepart=$filepart\n";
298 local(@locus_temp) = &glob_list($root);
299 local($save_root) = $root;
300 local($root) = $locus_temp[0];
301 if (!length($root)) {
302 local($base) = $save_root . "/" . $filepart;
303 #print "adding to missing in backup_hierarchy A: $base\n";
304 push(@missing_log, $base);
307 local($new_pattern) = "$root/$filepart";
308 if ($root =~ /\/$/) { $new_pattern = "$root$filepart"; }
309 local(@mod_locus) = &glob_list($new_pattern);
310 if (!scalar(@mod_locus)) {
311 local($base) = &basename($root . "/" . $filepart);
312 #print "adding to missing in backup_hierarchy B: $base\n";
313 push(@missing_log, $base);
315 foreach $i (@mod_locus) {
316 local($new_locus) = $root;
317 local $offset_len = length($root) + 1;
318 local $char_len = length($i) - length($root) - 1;
319 # make sure we don't double slashes up if one's already there.
320 if ($root =~ /\/$/) { $offset_len--; $char_len++; }
321 local($extra_portion) = substr $i, $offset_len, $char_len;
322 if (!length($extra_portion)) {
323 # well, in this case, there's nothing left of the extra part after
324 # the root. we'll push the last component of the root down into
325 # the extra part so there's actually something to traverse.
326 $new_locus = &dirname($root);
327 $extra_portion = &basename($root);
329 &snarfer($prefix, $number, $new_locus, $extra_portion, ());
334 # recursively scoop up a list of directory hierarchies.
335 sub backup_hierarchies {
336 local($prefix, $number, $root, @dirs) = @_;
337 # print "backup_hierarchy: pref=$prefix, num=$number, root=$root,\n";
338 # print "list of dirs=@dirs.\n";
340 &backup_hierarchy($prefix, $number, $root, $i);
344 # grab up all the files in a directory (first parm) that are named matching
345 # a simple text pattern (second parm).
346 sub snarf_by_pattern {
347 local($dir, $pattern) = @_;
348 # print "dir = $dir and patt = $pattern\n";
350 @dir_contents = &glob_list("$dir/*$pattern*");
351 # print "dir contents: @dir_contents\n";
353 if (!scalar(@dir_contents)) {
354 print "no $pattern directores were backed up in $dir.\n";
356 foreach $item (@dir_contents) {
357 if ( ($item =~ /$pattern.*snarf/) || ($item =~ /$pattern.*tar/) ) { next; }
358 if ( ! -d "$item" ) { next; }
359 &backup_hierarchy($base, $number, $item, ".");
363 # gets the number out of the file specified by a basename. the number file
364 # is assumed to be stored in the TMP directory and to have an extension of
366 sub retrieve_number {
367 local($number_prefix) = @_;
368 # get number from the file specified and increment it for the next use.
369 local($NUMBER_FILE) = $TMP."/$number_prefix.num";
370 local($number) = &get_number($NUMBER_FILE);
371 &next_number($NUMBER_FILE);
375 # takes a name to use as the basename for a number file, and stores the
376 # file into the archive specified.
378 local($number_prefix, $snarf_prefix, $number) = @_;
379 #print "backup_number: parms are: numpref=$number_prefix, archpref=$snarf_prefix, num=$number.\n";
380 local($target_file) = $original_path ."/". $snarf_prefix . "_" . $number . ".tar";
381 local($number_file) = $number_prefix . ".num";
383 local($currdir) = cwd();
386 local($outcome) = 0xff & system $tar_tool, "-cf",
387 &msys_canonicalize($target_file), &msys_canonicalize($number_file);
388 if ($outcome) { die("failure to archive"); }
390 local($prefix_file) = "prefix.bac";
391 open(NUM_PREFIX, ">" . $prefix_file);
392 print NUM_PREFIX $number_prefix;
395 $outcome = 0xff & system $tar_tool, "-rf",
396 &msys_canonicalize($target_file), &msys_canonicalize($prefix_file);
397 if ($outcome) { die("failure to archive"); }
398 unlink($prefix_file);
402 # takes a prefix for the number file and a filename where it can be found.
403 # the current number in the temporary directory is compared against the file,
404 # and the new number's used if it's greater.
406 local($number_prefix, $number_file) = @_;
407 #print "restore num has numpref $number_prefix and numfile $number_file\n";
408 local($comparison_file) = "$TMP" . "/" . $number_prefix . ".num";
409 local($number) = &get_number($number_file);
410 local($old_number) = &get_number($comparison_file);
411 if ($number > $old_number) {
412 &store_number($number, $comparison_file);
414 unlink($number_file);
417 # ensures that the special restoration program is used on the archives by
418 # renaming their extension.
420 local($filename) = @_;
421 #print "rename_archive: file=$filename\n";
422 &finalize_snarf($filename);
423 local(@pieces) = split(/\.[^.]*$/, $filename, 3);
424 local($just_dir_and_base) = $pieces[0];
425 local($new_name) = $just_dir_and_base . '.snarf';
426 rename($filename . ".gz", $new_name)
427 || die("could not rename $filename to $new_name.");
430 # undoes a snarfed up archive and pulls out the number.
431 sub restore_archive {
432 local($filename) = &canonicalize(&remove_trailing_slashes(@_));
433 local(@split_name) = &split_filename($filename);
434 if ($#split_name < 1) {
435 print "The name \"$filename\" could not be parsed for restoration.\n";
438 # get the basename of the file.
439 local(@pieces) = split(/\.[^.]*$/, @split_name[1], 2);
440 # we don't want the extension.
441 local($just_dir_and_base) = $split_name[0] . $pieces[0];
442 # now just get the basename without a directory.
443 local(@name_components) = split(/\//, $just_dir_and_base);
444 local($basename) = $name_components[$#name_components];
445 local($new_dir_name) = 'snarf_' . $basename;
447 local($currdir) = cwd();
449 if (!chdir($new_dir_name)) {
450 mkdir($new_dir_name, 0777)
451 || die("could not create directory $new_dir_name.");
452 if (!chdir($new_dir_name)) {
453 die("could not change to directory $new_dir_name.");
457 # patch a relative path name to reflect the fact that we're now underneath
458 # the directory where we were.
459 if (! ($filename =~ /^\//)
460 && ! ($filename =~ /^.:/) ) {
461 $filename = "../" . $filename;
464 local($outcome) = 0xff & system $tar_tool, "-xzf",
465 &msys_canonicalize($filename);
466 if ($outcome) { die("failure to undo archive"); }
469 0xff & system "bash", "$SHELLDIR/files/normal_perm.sh", ".";
470 if ($outcome) { die("failure to normalize permissions"); }
472 # remove any links that might have crept in; these can cause mischief.
473 local($outcome) = 0xff & system("$find_tool . -type l -exec rm {} ';'");
475 # read the name of the prefix file.
476 local($prefix_file) = "prefix.bac";
477 open(NUM_PREFIX, "<" . $prefix_file);
478 local($number_prefix) = <NUM_PREFIX>;
481 &restore_number($number_prefix, $number_prefix . ".num");
482 unlink($prefix_file);