turned off debugging noise.
[feisty_meow.git] / scripts / archival / shared_snarfer.pl
1 #!/usr/bin/perl
2
3 ###############################################################################
4 #                                                                             #
5 #  Name   : shared_snarfer                                                    #
6 #  Author : Chris Koeritz                                                     #
7 #  Rights : Copyright (C) 1996-$now by Author                                 #
8 #                                                                             #
9 #  Purpose:                                                                   #
10 #                                                                             #
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.                               #
14 #                                                                             #
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 ###############################################################################
22
23 require "filename_helper.pl";
24 require "hostname.pl";
25 require "importenv.pl";
26 require "inc_num.pl";
27
28 use Cwd;
29 use File::Which;
30
31 $null_log = "/dev/null";
32
33 $TMP =~ s/\\/\//g;  # fix the temp variable for ms-winders.
34
35 # defines an array of problematic entries we were told to deal with.
36 @missing_log = ();
37
38 # these files are considered unimportant and won't be included in the archive.
39 @junk_file_list = ("*~", "*.$$$", "3rdparty", "*.aps", "*.bak", "binaries",
40     "*.bsc", "*.cgl", "*.csm", "CVS", "Debug", "*.dll", "*.err", "*.exe",
41     "generated_*", "*.git", "*.glb", "inprogress", "ipch", "*.llm",
42     "*.log", "*.lnk",
43     "makefile.fw*", "*.mbt", "*.mrt", "*.ncb", "*.o", "obj", "*.obj",
44     "octalforty.Wizardby", "*.obr", "*.opt", "packages", 
45     "*.pch", "*.pdb", "*.plg", "*.r$p", "*.rcs", "Release",
46     "*.res", "*.RES", "*.rws", "*.sbr", "*.scc", "*.spx", "*.stackdump",
47     "*.sdf", "*.suo", ".svn", "*.sym", "*.td", "*.tds", "*.tdw", "*.tlb",
48     "*.trw", "*.tmp", "*.tr", "*.user", "*_version.h", "*_version.rc",
49     "*.vspscc", "waste");
50 #print "junk list=@junk_file_list\n";
51 @excludes = ();
52 for (local($i) = 0; $i < scalar(@junk_file_list); $i++) {
53   push(@excludes, "--exclude=$junk_file_list[$i]");
54 }
55 #print "excludes list=@excludes\n";
56
57 # generic versions work on sane OSes.
58 $find_tool = which('find');
59 $tar_tool = which('tar');
60 #print "find tool: $find_tool\n";
61 #print "tar tool: $tar_tool\n";
62
63 if ( ! -f "$find_tool" || ! -f "$tar_tool" ) {
64   print "Could not locate either tar or find tools for this platform.\n";
65   exit 3;
66 }
67
68 # this is somewhat ugly, but it sets up a global variable called
69 # "original_path" so we remember where we started.
70 sub initialize_snarfer {
71   $original_path = cwd();
72   $original_path =~ s/\\/\//g;
73 }
74
75 # returns the current hostname, but without any domain included.
76 sub short_hostname {
77   local($temphost) = &hostname();
78   $temphost =~ s/([^.]*)\..*/\1/;
79   return &lower($temphost);
80 }
81
82 # takes the base name and creates the full snarf prefix name, which includes
83 # a timestamp and hostname.
84 sub snarf_prefix {
85   local($base) = @_;
86   $date_tool = "date";
87
88 #  if ($OS =~ /win/i) {
89 #    # just hope that this is running under msys in our build bin.
90 #    $date_tool = "$PRODUCTION_DIR/msys/bin/date";
91 #  }
92
93   local($date_part) = `$date_tool +%Y-%m-%d-%H%M`;
94   while ($date_part =~ /[\r\n]$/) { chop $date_part; }
95   local($host) = &short_hostname();
96   while ($host =~ /[\r\n]$/) { chop $host; }
97   $base = $base . "_" . $host . "_" . $date_part;
98   return $base;
99 }
100
101 # returns the name of the file to create based on the prefix and the
102 # current archive number.
103 sub snarf_name {
104   local($prefix, $number) = @_;
105   local($path) = &canonicalize($original_path);
106   local($target_file) = $path . '/' . $prefix . "_" . $number . ".tar";
107   return $target_file;
108 }
109
110 # finishes up on the archive file.
111 sub finalize_snarf {
112   local($filename) = @_;
113 #print "finalizing now on filename $filename\n";
114   local($outcome) = 0xff & system "gzip", $filename;
115   if ($outcome) { die("failure to finalize"); }
116
117   if (scalar(@missing_log)) {
118     print "The following files or directories were missing:\n";
119     print "@missing_log\n";
120   }
121 }
122
123 # fixes the directory passed in, if required.  this is only needed for
124 # dos-like operating systems, where there are drives to worry about and where
125 # cygwin refuses to store the full path for an absolute pathname in the
126 # archive.  instead of letting it store partial paths, we change to the top
127 # of the drive and scoop up the files using a relative path.
128 sub chdir_to_top {
129   local($directory) = @_;
130   if ( (substr($directory, 0, 2) eq "//")
131       && (substr($directory, 3, 1) eq "/") ) {
132 #print "into special case\n";
133     # it was originally a dos path, so now we must do some directory changing
134     # magic to get the paths to work right.
135     local($drive) = substr($directory, 0, 4);  # get just drive letter biz.
136 #print "going to change to $drive\n";
137     chdir($drive);
138 #print "cwd now=" . cwd() . "\n";
139     $directory = substr($directory, 4);  # rip off absolutist path.
140 #print "using dir now as $directory\n";
141     if (length($directory) == 0) {
142 #print "caught zero length dir, patching to dot now.\n";
143       $directory = ".";
144     }
145   }
146   return $directory;
147 }
148
149 # snarfer scoops up some files in a directory.
150 sub snarfer {
151   local($prefix, $number, $root, $subdir, @extra_flags) = @_;
152 #print "prefix=$prefix, num=$number, root=$root, subdir=$subdir, extra=@extra_flags\n";
153
154   $root = &chdir_to_top($root);
155
156   local($target_file) = &snarf_name($prefix, $number);
157
158   $random_num = (rand() * 1000000) % 1000000;
159   $temp_file = `mktemp "$TMP/zz_snarf_tmp.XXXXXX"`;
160   chop($temp_file);
161
162   if (! -d $root . "/" . $subdir) {
163     local($base) = &basename($root . "/" . $subdir);
164 #print "adding to missing in snarfer A: $base\n";
165     push(@missing_log, $base);
166     return 0;
167   }
168   local($currdir) = cwd();
169   chdir($root);
170
171   local($outcome) = 0;
172   my @lines = qx( $find_tool "$subdir" @extra_flags "-type" "f" );
173 #  if ( ($! != 0) || ($? != 0) ) {
174 #    die("failure to find files in $subdir"); 
175 #  }
176
177   open TEMPY_OUT, ">>$temp_file" or die "cannot open $temp_file";
178   foreach (@lines) { print TEMPY_OUT "$_"; }
179   close TEMPY_OUT;
180
181   if (-s $temp_file == 0) {
182     local($base) = &basename($root . "/" . $subdir);
183 #print "adding to missing in snarfer B: $base\n";
184     push(@missing_log, $base);
185   }
186
187 print "snarfer function assumes msys canonicalization is appropriate--not cygwin compat.\n";
188   local($outcome) = 0xff & system $tar_tool, 
189       "-rf", &msys_canonicalize($target_file), @excludes,
190       "--files-from=" . &msys_canonicalize($temp_file);
191   if ($outcome) {
192     unlink($temp_file);
193     die("failure to archive");
194   }
195   # clean up temporaries.
196   unlink($temp_file);
197   # change back to previous directory.
198   chdir($currdir);
199 }
200
201 # snarf_file_list is like snarfer but expects a file pattern at the end rather
202 # than a directory name.
203 sub snarf_file_list {
204   local($prefix, $number, $root, $file_pattern, @extra_flags) = @_;
205
206 #print "prefix=$prefix, num=$number, root=$root, file_pattern=$file_pattern, extra=@extra_flags\n";
207
208   $root = &chdir_to_top($root);
209
210   local($target_file) = &snarf_name($prefix, $number);
211
212   local($currdir) = cwd();
213   chdir("$root");
214
215   local(@files) = &glob_list($file_pattern);
216   if (!scalar(@files)) {
217     local($base) = $root . "/" . $file_pattern;
218     $base =~ s/\/\//\//g;
219 #print "adding to missing in snarf_file_list: $base\n";
220     push(@missing_log, $base);
221   }
222
223   foreach $i (@files) {
224     if ($i =~ /^\.\//) {
225       $i = substr $i, 2, length($i) - 2;
226     }
227 print "snarf_file_list function assumes msys canonicalization is appropriate--not cygwin compat.\n";
228     local($outcome) = 0xff & system $tar_tool,
229 #"--directory=" . "$root",
230         @extra_flags, "-rf", &msys_canonicalize($target_file), @excludes, $i;
231     if ($outcome) { die("failure to archive"); }
232   }
233   chdir("$currdir");
234 }
235
236 # backup some specific files.
237 sub backup_files {
238   local($prefix, $number, $root, $subdir, @files) = @_;
239 #print "backup_files: ref=$prefix, num=$number, subdir=$subdir, list of files=@files\n";
240   foreach $i (@files) {
241     local($new_path) = $subdir . "/" . $i;
242     if ($subdir eq ".") { $new_path = "$i"; }
243     &snarf_file_list($prefix, $number, $root, $new_path);
244   }
245 }
246
247 # backup some specific directories.
248 sub backup_directories {
249   local($prefix, $number, $root, $subdir, @dirs) = @_;
250 #print "backup_directories: ref=$prefix, num=$number, root=$root, subdir=$subdir, list of dirs=@dirs.\n";
251   foreach $i (@dirs) {
252     local($path_to_use) = $subdir . "/" . $i;
253     if ($i eq ".") {
254       $path_to_use = $subdir;
255     }
256     &snarfer($prefix, $number, $root, $path_to_use, ("-maxdepth", "1"));
257   }
258 }
259
260 # removes items from the file that match a pattern.
261 sub remove_from_backup {
262   local($prefix, $number, $pattern) = @_;
263 #print "remove_from_backup: pref=$prefix, num=$number, patt=$pattern,\n";
264   local($target_file) = &snarf_name($prefix, $number);
265
266 print "remove_from_backup function assumes msys canonicalization is appropriate--not cygwin compat.\n";
267   open(TARPROC, "$tar_tool --delete -f " . &msys_canonicalize($target_file)
268       . " \"$pattern\" 2>$null_log |");
269   <TARPROC>;
270 }
271
272 # recursively scoops up a directory hierarchy.
273 sub backup_hierarchy {
274   local($prefix, $number, $root, $filepart) = @_;
275 #print "backup_hierarchy: pref=$prefix, num=$number, root=$root, filepart=$filepart\n";
276   local(@locus_temp) = &glob_list($root);
277   local($save_root) = $root;
278   local($root) = $locus_temp[0];
279   if (!length($root)) {
280     local($base) = $save_root . "/" . $filepart;
281 #print "adding to missing in backup_hierarchy A: $base\n";
282     push(@missing_log, $base);
283     return;
284   }
285   local($new_pattern) = "$root/$filepart";
286   if ($root =~ /\/$/) { $new_pattern = "$root$filepart"; }
287   local(@mod_locus) = &glob_list($new_pattern);
288   if (!scalar(@mod_locus)) {
289     local($base) = &basename($root . "/" . $filepart);
290 #print "adding to missing in backup_hierarchy B: $base\n";
291     push(@missing_log, $base);
292   } else {
293     foreach $i (@mod_locus) {
294       local($new_locus) = $root;
295       local $offset_len = length($root) + 1;
296       local $char_len = length($i) - length($root) - 1;
297       # make sure we don't double slashes up if one's already there.
298       if ($root =~ /\/$/) { $offset_len--; $char_len++; }
299       local($extra_portion) = substr $i, $offset_len, $char_len;
300       if (!length($extra_portion)) {
301         # well, in this case, there's nothing left of the extra part after
302         # the root.  we'll push the last component of the root down into
303         # the extra part so there's actually something to traverse.
304         $new_locus = &dirname($root);
305         $extra_portion = &basename($root);
306       }
307       &snarfer($prefix, $number, $new_locus, $extra_portion, ());
308     }
309   }
310 }
311
312 # recursively scoop up a list of directory hierarchies.
313 sub backup_hierarchies {
314   local($prefix, $number, $root, @dirs) = @_;
315 #  print "backup_hierarchy: pref=$prefix, num=$number, root=$root,\n";
316 #  print "list of dirs=@dirs.\n";
317   foreach $i (@dirs) {
318     &backup_hierarchy($prefix, $number, $root, $i);
319   }
320 }
321
322 # grab up all the files in a directory (second parm) that are named matching
323 # a simple text pattern (third parm).  if there is a fourth parameter, it is
324 # used as an extra directory component after the main directory.
325 sub snarf_by_pattern {
326   local($prefix, $dir, $pattern, $extra_component) = @_;
327   local($had_extra) = length($extra_component) != 0;
328 #print "snarf by pattern, dir = $dir, patt = $pattern, extra = $extra_component\n";
329   if ($had_extra) {
330     $dir = "$dir/$extra_component";
331   }
332   @dir_contents = &glob_list("$dir/*$pattern*"); 
333 #print "dir contents: @dir_contents\n";
334
335   if (!scalar(@dir_contents)) {
336     print "no '$pattern' directores were backed up in $dir.\n";
337   }
338   
339   foreach $item (@dir_contents) {
340     if ( ($item =~ /$pattern.*snarf/) || ($item =~ /$pattern.*tar/) ) { next; }
341     if ( ! -d "$item" ) { next; }
342 #print "now really planning to backup hier of $item\n";
343     # normal backup had no extra component.
344     local $upper_dir = &dirname($item);
345     local $dir_plus_base = &basename($item);
346     # if we did have an extra component, we do this a bit differently.
347     if ($had_extra) {
348       $upper_dir = &dirname( &dirname($item) );
349       $dir_plus_base = &basename( &dirname($item) ) . "/" . &basename($item);
350     }
351 #print "using upper=$upper_dir and dir+base=$dir_plus_base\n";
352     &backup_hierarchy($prefix, $number, $upper_dir, $dir_plus_base);
353   }
354 }
355
356 # gets the number out of the file specified by a basename.  the number file
357 # is assumed to be stored in the TMP directory and to have an extension of
358 # ".num".
359 sub retrieve_number {
360   local($number_prefix) = @_;
361   # get number from the file specified and increment it for the next use.
362   local($NUMBER_FILE) = $TMP."/$number_prefix.num";
363   local($number) = &get_number($NUMBER_FILE);
364   &next_number($NUMBER_FILE);
365   return $number;
366 }
367
368 # takes a name to use as the basename for a number file, and stores the
369 # file into the archive specified.
370 sub backup_number {
371   local($number_prefix, $snarf_prefix, $number) = @_;
372 #print "backup_number: parms are: numpref=$number_prefix, archpref=$snarf_prefix, num=$number.\n";
373   local($target_file) = $original_path ."/". $snarf_prefix . "_" . $number . ".tar";
374   local($number_file) = $number_prefix . ".num";
375
376   local($currdir) = cwd();
377   chdir($TMP);
378
379 print "backup_number function assumes msys canonicalization is appropriate--not cygwin compat.\n";
380   local($outcome) = 0xff & system $tar_tool, "-cf",
381       &msys_canonicalize($target_file), &msys_canonicalize($number_file);
382   if ($outcome) { die("failure to archive"); }
383
384   local($prefix_file) = "prefix.bac";
385   open(NUM_PREFIX, ">" . $prefix_file);
386   print NUM_PREFIX $number_prefix;
387   close(NUM_PREFIX);
388
389   $outcome = 0xff & system $tar_tool, "-rf",
390       &msys_canonicalize($target_file), &msys_canonicalize($prefix_file);
391   if ($outcome) { die("failure to archive"); }
392   unlink($prefix_file);
393   chdir($currdir);
394 }
395
396 # takes a prefix for the number file and a filename where it can be found.
397 # the current number in the temporary directory is compared against the file,
398 # and the new number's used if it's greater.
399 sub restore_number {
400   local($number_prefix, $number_file) = @_;
401 #print "restore num has numpref $number_prefix and numfile $number_file\n";
402   local($comparison_file) = "$TMP" . "/" . $number_prefix . ".num";
403   local($number) = &get_number($number_file);
404   local($old_number) = &get_number($comparison_file);
405   if ($number > $old_number) {
406     &store_number($number, $comparison_file);
407   }
408   unlink($number_file);
409 }
410
411 # ensures that the special restoration program is used on the archives by
412 # renaming their extension.
413 sub rename_archive {
414   local($filename) = @_;
415 #print "rename_archive: file=$filename\n";
416   &finalize_snarf($filename);
417   local(@pieces) = split(/\.[^.]*$/, $filename, 3);
418   local($just_dir_and_base) = $pieces[0];
419   local($new_name) = $just_dir_and_base . '.snarf'; 
420   rename($filename . ".gz", $new_name)
421       || die("could not rename $filename to $new_name.");
422 }
423
424 # undoes a snarfed up archive and pulls out the number.
425 sub restore_archive {
426   local($filename) = &canonicalize(&remove_trailing_slashes(@_));
427   local(@split_name) = &split_filename($filename);
428   if ($#split_name < 1) {
429     print "The name \"$filename\" could not be parsed for restoration.\n";
430     exit 1;
431   }
432   # get the basename of the file.
433   local(@pieces) = split(/\.[^.]*$/, @split_name[1], 2);
434   # we don't want the extension.
435   local($just_dir_and_base) = $split_name[0] . $pieces[0];
436   # now just get the basename without a directory.
437   local(@name_components) = split(/\//, $just_dir_and_base);
438   local($basename) = $name_components[$#name_components];
439   local($new_dir_name) = 'snarf_' . $basename;
440
441   local($currdir) = cwd();
442
443   if (!chdir($new_dir_name)) {
444     mkdir($new_dir_name, 0777)
445         || die("could not create directory $new_dir_name.");
446     if (!chdir($new_dir_name)) {
447       die("could not change to directory $new_dir_name.");
448     }
449   }
450
451   # patch a relative path name to reflect the fact that we're now underneath
452   # the directory where we were.
453   if (! ($filename =~ /^\//) 
454       && ! ($filename =~ /^.:/) ) {
455     $filename = "../" . $filename;
456   }
457
458 print "restore_archive function assumes msys canonicalization is appropriate--not cygwin compat.\n";
459   local($outcome) = 0xff & system $tar_tool, "-xzf",
460       &msys_canonicalize($filename);
461   if ($outcome) { die("failure to undo archive"); }
462
463   local($outcome) =
464       0xff & system "bash", "$FEISTY_MEOW_SCRIPTS/files/normal_perm.sh", ".";
465   if ($outcome) { die("failure to normalize permissions"); }
466
467   # remove any links that might have crept in; these can cause mischief.
468   local($outcome) = 0xff & system("$find_tool . -type l -exec rm {} ';'");
469
470   # read the name of the prefix file.
471   local($prefix_file) = "prefix.bac";
472   open(NUM_PREFIX, "<" . $prefix_file);
473   local($number_prefix) = <NUM_PREFIX>;
474   close(NUM_PREFIX);
475
476   &restore_number($number_prefix, $number_prefix . ".num");
477   unlink($prefix_file);
478
479   chdir($currdir);
480 }
481
482 1;
483