home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / misc / volume30 / mserv-3.0 / part02 / unpack.pl < prev   
Encoding:
Perl Script  |  1992-06-19  |  4.1 KB  |  195 lines
  1. #!/usr/local/bin/perl
  2. # unpack.pl -- unpack files
  3. # SCCS Status     : @(#)@ unpack    2.4
  4. # Author          : Johan Vromans
  5. # Created On      : Oct  2 21:33:00 1989
  6. # Last Modified By: Johan Vromans
  7. # Last Modified On: Sun May  3 17:37:22 1992
  8. # Update Count    : 5
  9. # Status          : Going steady
  10.  
  11. # Unpack a set of files sent by the mail server with a tiny bit
  12. # of error detection.
  13. #
  14. # Usage: save all the parts in one big file (in the correct order), 
  15. # say "foo", and then execute:
  16. #
  17. #   perl unpack.pl foo
  18. #
  19. # Note: if the filename contains a path, all subdirectories should 
  20. # exist!
  21. # Multiple files in one input stream are allowed: e.g:
  22. #
  23. #------ begin of INDEX -- ascii -- complete ------
  24. #------ end of INDEX -- ascii -- complete ------
  25. #------ begin of zoo.TZ -- btoa encoded -- part 1 of 2 ------
  26. #------ end of zoo.TZ -- btoa encoded -- part 1 of 2 ------
  27. #------ begin of zoo.TZ -- btoa encoded -- part 2 of 2 ------
  28. #------ end of zoo.TZ -- btoa encoded -- part 2 of 2 ------
  29. #
  30. #
  31. ################ configuration section ################
  32. #
  33. # Where to find these...
  34. #
  35. $atob = "atob";            # Ascii -> Binary
  36. $uudecode = "uudecode";        # UU
  37. $xxdecode = "xxdecode";        # XX
  38. $uud = "uud";            # Dumas' uue/uud programs.
  39. #
  40. ################ end of configuration section ################
  41.  
  42. &init;
  43.  
  44. while ( $line = <> ) {
  45.  
  46.     if ( $line =~ /^------ begin of (.+) -- (.+) -- (.+) ------/ ) {
  47.     print STDERR $line;
  48.  
  49.     # If a filename is known, it must be the same.
  50.     if ( $file ) {
  51.         if ( $file != $1 ) {
  52.         &errmsg ("Filename mismatch");
  53.         }
  54.     }
  55.     else {
  56.         $file = $1;
  57.     }
  58.  
  59.     # If an encoding is known, it must be the same.
  60.     if ( $encoding ) {
  61.         if ( $encoding != $2 ) {
  62.         &errmsg ("Encoding mismatch");
  63.         }
  64.     }
  65.     else {
  66.         # Determine encoding and build command.
  67.         $encoding = $2;
  68.         if ( $encoding eq "uuencoded" ) {
  69.         $cmd = "|$uudecode";
  70.         }
  71.         elsif ( $encoding eq "xxencoded" ) {
  72.         $cmd = "|$xxdecode";
  73.         }
  74.         elsif ( $encoding eq "btoa encoded" ) {
  75.         $cmd = "|$atob > $file";
  76.         }
  77.         elsif ( $encoding eq "uue-encoded" ) {
  78.         $cmd = "|$uud - ";
  79.         }
  80.         else {
  81.         $cmd = ">$file";
  82.         }
  83.     }
  84.  
  85.     # If a 'parts' section is known, it must match.
  86.     # A bit more complex ...
  87.     $tparts = $3;
  88.     if ( $parts ) {
  89.         if ( $tparts =~ /part (\d+) of (\d+)/ ) {
  90.  
  91.         $thispart++;    # Increment part number and check.
  92.         if ( $thispart != $1 ) {
  93.             &errmsg ("Sequence mismatch");
  94.         }
  95.  
  96.         # Total number must match also.
  97.         if ( $numparts ) {
  98.             if ( $numparts != $2 ) {
  99.             &errmsg ("Numparts mismatch");
  100.             }
  101.         }
  102.         else {
  103.             $numparts = $2;
  104.         }
  105.         }
  106.         elsif ( $parts ne $tparts ) {
  107.         &errmsg ("Parts mismatch");
  108.         }
  109.     }
  110.     else {
  111.  
  112.         # No 'parts' known yet.
  113.         $parts = $tparts;
  114.         if ( $tparts =~ /part (\d+) of (\d+)/ ) {
  115.         $thispart = $1;
  116.         # Should be first part.
  117.         if ( $thispart != 1 ) {
  118.             &errmsg ("Sequence mismatch");
  119.         }
  120.         $numparts = $2;
  121.         }
  122.         else {
  123.         $numparts = $thispart = 1;
  124.         }
  125.     }
  126.  
  127.     # If we have a file open, enable copying.
  128.     if ( $fileok ) {
  129.         $copy = 1;
  130.     }
  131.     elsif ( open (OUTFILE, $cmd) ) {
  132.         $fileok = 1;
  133.         $copy = 1;
  134.     }
  135.     else {
  136.         &errmsg ("Cannot create $cmd");
  137.     }
  138.  
  139.     # Matching end header to look for.
  140.     $trailer = "------ end " . substr ($line, 13, length($line)-13);
  141.  
  142.     }
  143.     elsif ( $line =~ /^------ end of (.+) -- (.+) -- (.+) ------/ ) {
  144.  
  145.     print STDERR $line;
  146.  
  147.     # Check that the header matches.
  148.     if ( $line ne $trailer ) {
  149.         &errmsg ("Header/trailer mismatch");
  150.     }
  151.  
  152.     # Wrap up if this was the last part.
  153.     &wrapup if $thispart == $numparts;
  154.  
  155.     # Stop copying.
  156.     $copy = 0;
  157.     }
  158.     else {
  159.     if ( $copy ) {
  160.         print OUTFILE $line;
  161.     }
  162.     }
  163. }
  164.  
  165. if ( $numparts && ( $thispart != $numparts )) {
  166.     &errmsg ("Only $thispart of $numparts parts found");
  167. }
  168.  
  169. if ( $fileok) {
  170.     &errmsg ("Unterminated section") if $?;
  171. }
  172.  
  173. ################ Subroutines ################
  174.  
  175. sub init {
  176.     $encoding = "";
  177.     $parts = "";
  178.     $numparts = "";
  179.     $file = "";
  180.     $copy = 0;
  181.     $thispart = 0;
  182.     $fileok = "";
  183. }
  184.  
  185. sub wrapup {
  186.     close (OUTFILE);
  187.     &errmsg ("Output close error [$?]") if $?;
  188.     &init;
  189. }
  190.  
  191. sub errmsg {
  192.     print STDERR ($my_name, ": ", pop(@_), " at input line $..\n");
  193.     exit 1;
  194. }
  195.