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
  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]/) ) {
  36   $null_log = "nul"
  37 }
  38 #print "nul log=$null_log \n";
  39
  40 $TMP =~ s/\\/\//g;  # fix the temp variable for ms-winders.
  41
  42 # defines an array of problematic entries we were told to deal with.
  43 @missing_log = ();
  44
  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",
  55     "*.vspscc", "waste");
  56 ###, "*.wav"
  57 #print "junk list=@junk_file_list\n";
  58 @excludes = ();
  59 for (local($i) = 0; $i < scalar(@junk_file_list); $i++) {
  60   push(@excludes, "--exclude=$junk_file_list[$i]");
  61 }
  62 #print "excludes list=@excludes\n";
  63
  64 # generic versions work on sane OSes.
  65 $find_tool = `which find`; chop $find_tool;
  66 $tar_tool = `which tar`; chop $tar_tool;
  67
  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";
  75 }
  76
  77 #print "find tool: $find_tool\n";
  78 #print "tar tool: $tar_tool\n";
  79
  80 if ( ! -f "$find_tool" || ! -f "$tar_tool" ) {
  81   print "Could not locate either tar or find tools for this platform.\n";
  82   exit 3;
  83 }
  84
  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;
  90 }
  91
  92 # returns the current hostname, but without any domain included.
  93 sub short_hostname {
  94   local($temphost) = &hostname();
  95   $temphost =~ s/([^.]*)\..*/\1/;
  96   return &lower($temphost);
  97 }
  98
  99 # takes the base name and creates the full snarf prefix name, which includes
 100 # a timestamp and hostname.
 101 sub snarf_prefix {
 102   local($base) = @_;
 103   local($extra_path) = "";
 104   if ($OS =~ /win/i) {
 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";
 112     } else {
 113       # just hope that this is running under msys in our build bin.
 114       $extra_path = "$HOME/hoople2/build/msys/bin/";
 115     }
 116   }
 117
 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;
 123   return $base;
 124 }
 125
 126 # returns the name of the file to create based on the prefix and the
 127 # current archive number.
 128 sub snarf_name {
 129   local($prefix, $number) = @_;
 130   local($path) = &canonicalize($original_path);
 131   local($target_file) = $path . '/' . $prefix . "_" . $number . ".tar";
 132   return $target_file;
 133 }
 134
 135 # finishes up on the archive file.
 136 sub finalize_snarf {
 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"); }
 141
 142   if (scalar(@missing_log)) {
 143     print "The following files or directories were missing:\n";
 144     print "@missing_log\n";
 145   }
 146 }
 147
 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.
 153 sub chdir_to_top {
 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";
 162     chdir($drive);
 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";
 168       $directory = ".";
 169     }
 170   }
 171   return $directory;
 172 }
 173
 174 # snarfer scoops up some files in a directory.
 175 sub snarfer {
 176   local($prefix, $number, $root, $subdir, @extra_flags) = @_;
 177 #print "prefix=$prefix, num=$number, root=$root, subdir=$subdir, extra=@extra_flags\n";
 178
 179   $root = &chdir_to_top($root);
 180
 181   local($target_file) = &snarf_name($prefix, $number);
 182
 183   $random_num = (rand() * 1000000) % 1000000;
 184   $temp_file = `mktemp "$TMP/zz_snarf_tmp.XXXXXX"`;
 185   chop($temp_file);
 186
 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);
 191     return 0;
 192   }
 193   local($currdir) = cwd();
 194   chdir($root);
 195
 196   local($outcome) = 0;
 197   my @lines = qx( $find_tool $subdir @extra_flags "-type" "f" );
 198 #  if ( ($! != 0) || ($? != 0) ) {
 199 #    die("failure to find files in $subdir");
 200 #  }
 201
 202   open TEMPY_OUT, ">>$temp_file" or die "cannot open $temp_file";
 203   foreach (@lines) { print TEMPY_OUT "$_"; }
 204   close TEMPY_OUT;
 205
 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);
 210   }
 211
 212   local($outcome) = 0xff & system $tar_tool,
 213       "-rf", &msys_canonicalize($target_file), @excludes,
 214       "--files-from=" . &msys_canonicalize($temp_file);
 215   if ($outcome) {
 216     unlink($temp_file);
 217     die("failure to archive");
 218   }
 219   # clean up temporaries.
 220   unlink($temp_file);
 221   # change back to previous directory.
 222   chdir($currdir);
 223 }
 224
 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) = @_;
 229
 230 #print "prefix=$prefix, num=$number, root=$root, file_pattern=$file_pattern, extra=@extra_flags\n";
 231
 232   $root = &chdir_to_top($root);
 233
 234   local($target_file) = &snarf_name($prefix, $number);
 235
 236   local($currdir) = cwd();
 237   chdir("$root");
 238
 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);
 245   }
 246
 247   foreach $i (@files) {
 248     if ($i =~ /^\.\//) {
 249       $i = substr $i, 2, length($i) - 2;
 250     }
 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"); }
 255   }
 256   chdir("$currdir");
 257 }
 258
 259 # backup some specific files.
 260 sub backup_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);
 267   }
 268 }
 269
 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";
 274   foreach $i (@dirs) {
 275     local($path_to_use) = $subdir . "/" . $i;
 276     if ($i eq ".") {
 277       $path_to_use = $subdir;
 278     }
 279     &snarfer($prefix, $number, $root, $path_to_use, ("-maxdepth", "1"));
 280   }
 281 }
 282
 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);
 288
 289   open(TARPROC, "$tar_tool --delete -f " . &msys_canonicalize($target_file)
 290       . " \"$pattern\" 2>$null_log |");
 291   <TARPROC>;
 292 }
 293
 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);
 305     return;
 306   }
 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);
 314   } else {
 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);
 328       }
 329       &snarfer($prefix, $number, $new_locus, $extra_portion, ());
 330     }
 331   }
 332 }
 333
 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";
 339   foreach $i (@dirs) {
 340     &backup_hierarchy($prefix, $number, $root, $i);
 341   }
 342 }
 343
 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";
 349
 350   @dir_contents = &glob_list("$dir/*$pattern*");
 351 #  print "dir contents: @dir_contents\n";
 352
 353   if (!scalar(@dir_contents)) {
 354     print "no $pattern directores were backed up in $dir.\n";
 355   }
 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, ".");
 360   }
 361 }
 362
 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
 365 # ".num".
 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);
 372   return $number;
 373 }
 374
 375 # takes a name to use as the basename for a number file, and stores the
 376 # file into the archive specified.
 377 sub backup_number {
 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";
 382
 383   local($currdir) = cwd();
 384   chdir($TMP);
 385
 386   local($outcome) = 0xff & system $tar_tool, "-cf",
 387       &msys_canonicalize($target_file), &msys_canonicalize($number_file);
 388   if ($outcome) { die("failure to archive"); }
 389
 390   local($prefix_file) = "prefix.bac";
 391   open(NUM_PREFIX, ">" . $prefix_file);
 392   print NUM_PREFIX $number_prefix;
 393   close(NUM_PREFIX);
 394
 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);
 399   chdir($currdir);
 400 }
 401
 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.
 405 sub restore_number {
 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);
 413   }
 414   unlink($number_file);
 415 }
 416
 417 # ensures that the special restoration program is used on the archives by
 418 # renaming their extension.
 419 sub rename_archive {
 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.");
 428 }
 429
 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";
 436     exit 1;
 437   }
 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;
 446
 447   local($currdir) = cwd();
 448
 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.");
 454     }
 455   }
 456
 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;
 462   }
 463
 464   local($outcome) = 0xff & system $tar_tool, "-xzf",
 465       &msys_canonicalize($filename);
 466   if ($outcome) { die("failure to undo archive"); }
 467
 468   local($outcome) =
 469       0xff & system "bash", "$SHELLDIR/files/normal_perm.sh", ".";
 470   if ($outcome) { die("failure to normalize permissions"); }
 471
 472   # remove any links that might have crept in; these can cause mischief.
 473   local($outcome) = 0xff & system("$find_tool . -type l -exec rm {} ';'");
 474
 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>;
 479   close(NUM_PREFIX);
 480
 481   &restore_number($number_prefix, $number_prefix . ".num");
 482   unlink($prefix_file);
 483
 484   chdir($currdir);
 485 }
 486
 487 1;
 488