home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / Std.pm < prev    next >
Encoding:
Perl POD Document  |  2003-09-16  |  22.4 KB  |  949 lines
  1. package Archive::Tar::Std;
  2.  
  3. use strict;
  4. use Carp qw(carp);
  5. use Cwd;
  6. use Fcntl qw(O_RDONLY O_RDWR O_WRONLY O_CREAT O_TRUNC F_DUPFD F_GETFL);
  7. use File::Basename;
  8. use Symbol;
  9. require Time::Local if $^O eq "MacOS";
  10.  
  11. use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS);
  12. $VERSION = do { my @a=q$Name:  $ =~ /\d+/g; sprintf "%d." . ("%02d" x $#a ),@a };
  13.  
  14. require Exporter;
  15. @ISA = qw(Exporter);
  16.  
  17. @EXPORT_OK = qw(FILE HARDLINK SYMLINK 
  18.         CHARDEV BLOCKDEV DIR
  19.         FIFO SOCKET INVALID);
  20. %EXPORT_TAGS = (filetypes => \@EXPORT_OK);
  21.  
  22. # Check if symbolic links are available
  23. my $symlinks = eval { readlink $0 or 1; };
  24. carp "Symbolic links not available"
  25.     unless $symlinks || !$^W;
  26.  
  27. # Check if Compress::Zlib is available
  28. my $compression = eval { 
  29.     local $SIG{__DIE__};
  30.     require Compress::Zlib; 
  31.     sub Compress::Zlib::gzFile::gzseek {
  32.     my $tmp;
  33.  
  34.     $_[0]->gzread ($tmp, 4096), $_[1] -= 4096
  35.         while ($_[1] > 4096);
  36.  
  37.     $_[0]->gzread ($tmp, $_[1])
  38.       if $_[1];
  39.     }
  40.     1;
  41. };
  42. carp "Compression not available"
  43.     unless $compression || !$^W;
  44.  
  45. # Check for get* (they don't exist on WinNT)
  46. my $fake_getpwuid;
  47. $fake_getpwuid = "unknown"
  48.     unless eval { $_ = getpwuid (0); }; # Pointless assigment to make -w shut up
  49.  
  50. my $fake_getgrgid;
  51. $fake_getgrgid = "unknown"
  52.     unless eval { $_ = getgrgid (0); }; # Pointless assigment to make -w shut up
  53.  
  54. # Automagically detect gziped files if they start with this
  55. my $gzip_magic_number = "^(?:\037\213|\037\235)";
  56.  
  57. my $tar_unpack_header 
  58.     = 'A100 A8 A8 A8 A12 A12 A8 A1 A100 A6 A2 A32 A32 A8 A8 A155 x12';
  59. my $tar_pack_header
  60.     = 'a100 a8 a8 a8 a12 a12 A8 a1 a100 a6 a2 a32 a32 a8 a8 a155 x12',
  61. my $tar_header_length = 512;
  62.  
  63. my $time_offset = ($^O eq "MacOS") ? Time::Local::timelocal(0,0,0,1,0,70) : 0;
  64.  
  65. ## Subroutines to return type constants 
  66. sub FILE() { return 0; }
  67. sub HARDLINK() { return 1; }
  68. sub SYMLINK() { return 2; }
  69. sub CHARDEV() { return 3; }
  70. sub BLOCKDEV() { return 4; }
  71. sub DIR() { return 5; }
  72. sub FIFO() { return 6; }
  73. sub SOCKET() { return 8; }
  74. sub UNKNOWN() { return 9; }
  75.  
  76. ###
  77. ### Non-method functions
  78. ###
  79.  
  80. my $error;
  81. sub _drat {
  82.     $error = $! . '';
  83.     return;
  84. }
  85.  
  86. sub error {
  87.     $error;
  88. }
  89.  
  90. sub set_error {
  91.     shift;
  92.     $error = "@_";
  93. }
  94.  
  95. ## filetype -- Determine the type value for a given file
  96. sub filetype {
  97.     my $file = shift;
  98.  
  99.     return SYMLINK
  100.     if (-l $file);        # Symlink
  101.  
  102.     return FILE
  103.     if (-f _);        # Plain file
  104.  
  105.     return DIR
  106.     if (-d _);        # Directory
  107.  
  108.     return FIFO
  109.     if (-p _);        # Named pipe
  110.  
  111.     return SOCKET
  112.     if (-S _);        # Socket
  113.  
  114.     return BLOCKDEV
  115.     if (-b _);        # Block special
  116.  
  117.     return CHARDEV
  118.     if (-c _);        # Character special
  119.  
  120.     return UNKNOWN;        # Something else (like what?)
  121. }
  122.  
  123. sub _make_special_file_UNIX {
  124.     # $file is the last component of $entry->{name}
  125.     my ($entry, $file) = @_;
  126.  
  127.     if ($entry->{type} == SYMLINK) {
  128.     symlink $entry->{linkname}, $file or
  129.         $^W && carp ("Making symbolic link from ", $entry->{linkname}, 
  130.              " to ", $entry->{name}, ", failed.\n");
  131.     }
  132.     elsif ($entry->{type} == HARDLINK) {
  133.     link $entry->{linkname}, $file or
  134.         $^W && carp ("Hard linking ", $entry->{linkname}, 
  135.              " to ", $entry->{name}, ", failed.\n");
  136.     }
  137.     elsif ($entry->{type} == FIFO) {
  138.     system("mknod","$file","p") or
  139.         $^W && carp "Making fifo ", $entry->{name}, ", failed.\n";
  140.     }
  141.     elsif ($entry->{type} == BLOCKDEV) {
  142.     system("mknod","$file","b",$entry->{devmajor},$entry->{devminor}) or
  143.         $^W && carp ("Making block device ", $entry->{name},
  144.              " (maj=", $entry->{devmajor}, 
  145.              ", min=", $entry->{devminor}, "), failed.\n");
  146.     }
  147.     elsif ($entry->{type} == CHARDEV) {
  148.     system("mknod", "$file", "c", $entry->{devmajor}, $entry->{devminor}) or
  149.         $^W && carp ("Making block device ", $entry->{name}, 
  150.              " (maj=", $entry->{devmajor}, 
  151.              " ,min=", $entry->{devminor}, "), failed.\n");
  152.     }
  153. }
  154.  
  155. sub _make_special_file_Win32 {
  156.     # $file is the last component of $entry->{name}
  157.     my ($entry, $file) = @_;
  158.  
  159.     if ($entry->{type} == SYMLINK) {
  160.     $^W && carp ("Making symbolic link from ", $entry->{linkname}, 
  161.              " to ", $entry->{name}, ", failed.\n");
  162.     }
  163.     elsif ($entry->{type} == HARDLINK) {
  164.     link $entry->{linkname}, $file or
  165.         $^W && carp ("Making hard link from ", $entry->{linkname}, 
  166.              " to ", $entry->{name}, ", failed.\n");
  167.     }
  168.     elsif ($entry->{type} == FIFO) {
  169.     $^W && carp "Making fifo ", $entry->{name}, ", failed.\n";
  170.     }
  171.     elsif ($entry->{type} == BLOCKDEV) {
  172.     $^W && carp ("Making block device ", $entry->{name},
  173.              " (maj=", $entry->{devmajor}, 
  174.              ", min=", $entry->{devminor}, "), failed.\n");
  175.     }
  176.     elsif ($entry->{type} == CHARDEV) {
  177.     $^W && carp ("Making block device ", $entry->{name},
  178.              " (maj=", $entry->{devmajor}, 
  179.              " ,min=", $entry->{devminor}, "), failed.\n");
  180.     }
  181. }
  182.  
  183. *_make_special_file = $^O eq "MSWin32" ? 
  184.     \&_make_special_file_Win32 : \&_make_special_file_UNIX;
  185.  
  186. sub _munge_file {
  187. #
  188. #  Mac path to the Unix like equivalent to be used in tar archives
  189. #
  190.     my $inpath = $_[0];
  191. #
  192. #  If there are no :'s in the name at all, assume it's a single item in the
  193. #  current directory.  Return it, changing any / in the name into :
  194. #
  195.     if ($inpath !~ m,:,) {
  196.     $inpath =~ s,/,:,g;
  197.     return $inpath;
  198.     }
  199. #
  200. #  If we now split on :, there will be just as many nulls in the list as
  201. #  there should be up requests, except if it begins with a :, where there
  202. #  will be one extra.
  203. #
  204.     my @names = split (/:/, $inpath);
  205.     shift (@names)
  206.     if ($names[0] eq "");
  207.     my @outname = ();
  208. #
  209. #  Work from the end.
  210. #
  211.     my $i;
  212.     for ($i = $#names; $i >= 0; --$i) {
  213.     if ($names[$i] eq "") {
  214.         unshift (@outname, "..");
  215.     } 
  216.     else {
  217.         $names[$i] =~ s,/,:,g;
  218.         unshift (@outname, $names[$i]);
  219.     }
  220.     }
  221.     my $netpath = join ("/", @outname);
  222.     $netpath = $netpath . "/" if ($inpath =~ /:$/);
  223.     if ($inpath !~ m,^:,) {
  224.     return "/".$netpath;
  225.     } 
  226.     else {
  227.     return $netpath;
  228.     }
  229. }
  230.  
  231. sub _get_handle {
  232.     my ($fh, $flags, $mode);
  233.  
  234.     sysseek ($_[0], 0, 0)
  235.     or goto &_drat;
  236.  
  237.     if ($^O eq "MSWin32") {
  238.     $fh = $_[0];
  239.     }
  240.     else {
  241.     $fh = fcntl ($_[0], F_DUPFD, 0)
  242.         or goto &_drat;
  243.     }
  244.     if ($compression && (@_ < 2 || $_[1] != 0)) {
  245.     $mode = $#_ ? (int($_[1]) > 1 ?
  246.               "wb".int($_[1]) : "wb") : "rb";
  247.  
  248. #    $fh = Compress::Zlib::gzopen ($_[0], $mode)
  249. #        or &_drat;
  250.     $fh = Compress::Zlib::gzdopen_ ($fh, $mode, 0)
  251.         or &_drat;
  252.     }
  253.     else {
  254.     $flags = fcntl ($_[0], F_GETFL, 0) & (O_RDONLY | O_WRONLY | O_RDWR);
  255.     $mode = ($flags == O_WRONLY) ? ">&=$fh" : 
  256.         ($flags == O_RDONLY) ? "<&=$fh" : "+>&=$fh";
  257.     $fh = gensym;
  258.     open ($fh, $mode)
  259.       or goto &_drat;
  260.  
  261.     $fh = bless *{$fh}{IO}, "Archive::Tar::Std::_io";
  262.     binmode $fh
  263.         or goto &_drat;
  264.     }
  265.  
  266.     return $fh;
  267. }
  268.  
  269. sub _read_tar {
  270.     my ($file, $seekable, $extract) = @_;
  271.     my $tarfile = [];
  272.     my ($head, $offset, $size);
  273.  
  274.     $file->gzread ($head, $tar_header_length)
  275.     or goto &_drat;
  276.  
  277.     if (substr ($head, 0, 2) =~ /$gzip_magic_number/o) {
  278.     $error =
  279.         "Compression not available\n";
  280.     return undef;
  281.     }
  282.  
  283.     $offset = $tar_header_length
  284.     if $seekable;
  285.  
  286.  READLOOP:
  287.     while (length ($head) == $tar_header_length) {
  288.     my ($name,        # string
  289.         $mode,        # octal number
  290.         $uid,        # octal number
  291.         $gid,        # octal number
  292.         $size,        # octal number
  293.         $mtime,        # octal number
  294.         $chksum,        # octal number
  295.         $type,        # character
  296.         $linkname,        # string
  297.         $magic,        # string
  298.         $version,        # two bytes
  299.         $uname,        # string
  300.         $gname,        # string
  301.         $devmajor,        # octal number
  302.         $devminor,        # octal number
  303.         $prefix) = unpack ($tar_unpack_header, $head);
  304.     my ($data, $block, $entry);
  305.  
  306.     $mode = oct $mode;
  307.     $uid = oct $uid;
  308.     $gid = oct $gid;
  309.     $size = oct $size;
  310.     $mtime = oct $mtime;
  311.     $chksum = oct $chksum;
  312.     $devmajor = oct $devmajor;
  313.     $devminor = oct $devminor;
  314.     $name = $prefix."/".$name if $prefix;
  315.     $prefix = "";
  316.     # some broken tar-s don't set the type for directories
  317.     # so we ass_u_me a directory if the name ends in slash
  318.     $type = DIR
  319.         if $name =~ m|/$| and $type == FILE;
  320.  
  321.     last READLOOP if $head eq "\0" x 512; # End of archive
  322.     # Apparently this should really be two blocks of 512 zeroes,
  323.     # but GNU tar sometimes gets it wrong. See comment in the
  324.     # source code (tar.c) to GNU cpio.
  325.  
  326.     substr ($head, 148, 8) = "        ";
  327.     if (unpack ("%16C*", $head) != $chksum) {
  328.        warn "$name: checksum error.\n";
  329.     }
  330.  
  331.     unless ($extract || $type != FILE) {
  332.         # Always read in full 512 byte blocks
  333.         $block = $size & 0x01ff ? ($size & ~0x01ff) + 512 : $size;
  334.         if ($seekable) {
  335.         while ($block > 4096) {
  336.             $file->gzread ($data, 4096)
  337.             or goto &_drat;
  338.             $block -= 4096;
  339.         }
  340.         $file->gzread ($data, $block)
  341.             or goto &_drat
  342.             if ($block);
  343.  
  344.         # Ignore everything we've just read.
  345.         undef $data;
  346.         } else {
  347.         if ($file->gzread ($data, $block) < $block) {
  348.             $error = "Read error on tarfile.";
  349.             return undef;
  350.         }
  351.  
  352.         # Throw away any trailing garbage
  353.         substr ($data, $size) = "";
  354.         }
  355.     }
  356.  
  357.     # Guard against tarfiles with garbage at the end
  358.     last READLOOP if $name eq ''; 
  359.  
  360.     $entry = {name => $name,            
  361.           mode => $mode,
  362.           uid => $uid,
  363.           gid => $gid,
  364.           size => $size,
  365.           mtime => $mtime,
  366.           chksum => $chksum,
  367.           type => $type,
  368.           linkname => $linkname,
  369.           magic => $magic,
  370.           version => $version,
  371.           uname => $uname,
  372.           gname => $gname,
  373.           devmajor => $devmajor,
  374.           devminor => $devminor,
  375.           prefix => $prefix,
  376.           offset => $offset,
  377.           data => $data};
  378.  
  379.     if ($extract) {
  380.         _extract_file ($entry, $file);
  381.         $file->gzread ($head, 512 - ($size & 0x1ff)) 
  382.         or goto &_drat
  383.             if ($size & 0x1ff && $type == FILE);
  384.     }
  385.     else {
  386.         push @$tarfile, $entry;
  387.     }
  388.  
  389.     if ($seekable) {
  390.         $offset += $tar_header_length;
  391.         $offset += ($size & 0x01ff) ? ($size & ~0x01ff) + 512 : $size
  392.         if $type == FILE;
  393.     }
  394.     $file->gzread ($head, $tar_header_length) 
  395.         or goto &_drat;
  396.     }
  397.  
  398.     $file->gzclose ()
  399.     unless $seekable;
  400.  
  401.     return $tarfile
  402.     unless $extract;
  403. }
  404.  
  405. sub _format_tar_entry {
  406.     my ($ref) = shift;
  407.     my ($tmp,$file,$prefix,$pos);
  408.  
  409.     $file = $ref->{name};
  410.     if (length ($file) > 99) {
  411.     $pos = index $file, "/", (length ($file) - 100);
  412.     next
  413.         if $pos == -1;    # Filename longer than 100 chars!
  414.  
  415.     $prefix = substr $file,0,$pos;
  416.     $file = substr $file,$pos+1;
  417.     substr ($prefix, 0, -155) = ""
  418.         if length($prefix)>154;
  419.     }
  420.     else {
  421.     $prefix="";
  422.     }
  423.  
  424.     $tmp = pack ($tar_pack_header,
  425.          $file,
  426.          sprintf("%06o ",$ref->{mode}),
  427.          sprintf("%06o ",$ref->{uid}),
  428.          sprintf("%06o ",$ref->{gid}),
  429.          sprintf("%11o ",$ref->{size}),
  430.          sprintf("%11o ",$ref->{mtime}),
  431.          "",        #checksum field - space padded by pack("A8")
  432.          $ref->{type},
  433.          $ref->{linkname},
  434.          $ref->{magic},
  435.          $ref->{version} || '00',
  436.          $ref->{uname},
  437.          $ref->{gname},
  438.          sprintf("%6o ",$ref->{devmajor}),
  439.          sprintf("%6o ",$ref->{devminor}),
  440.          $prefix);
  441.     substr($tmp,148,7) = sprintf("%6o\0", unpack("%16C*",$tmp));
  442.  
  443.     return $tmp;
  444. }
  445.  
  446. sub _format_tar_file {
  447.     my @tarfile = @_;
  448.     my $file = "";
  449.  
  450.     foreach (@tarfile) {
  451.     $file .= _format_tar_entry $_;
  452.     $file .= $_->{data};
  453.     $file .= "\0" x (512 - ($_->{size} & 0x1ff))
  454.         if ($_->{size} & 0x1ff);
  455.     }
  456.     $file .= "\0" x 1024;
  457.  
  458.     return $file;
  459. }
  460.  
  461. sub _write_tar {
  462.     my $file = shift;
  463.     my $entry;
  464.  
  465.     foreach $entry ((ref ($_[0]) eq 'ARRAY') ? @{$_[0]} : @_) {
  466.     next
  467.         unless (ref ($entry) eq 'HASH');
  468.  
  469.     my $src;
  470.         if ($^O eq "MacOS") {  #convert back from Unix to Mac path
  471.             my @parts = split(/\//, $entry->{name});
  472.  
  473.             $src = $parts[0] ? ":" : "";
  474.             foreach (@parts) {
  475.         next if !$_ || $_ eq ".";  
  476.                 s,:,/,g;
  477.  
  478.         $_ = ":"
  479.             if ($_ eq "..");
  480.  
  481.         $src .= ($src =~ /:$/) ? $_ : ":$_";
  482.         }
  483.         }
  484.     else {
  485.             $src = $entry->{name};
  486.         }
  487.     sysopen (FH, $src, O_RDONLY)
  488.         && binmode (FH)
  489.         or next
  490.             unless $entry->{type} != FILE || $entry->{data};
  491.  
  492.     $file->gzwrite (_format_tar_entry ($entry))
  493.         or goto &_drat;
  494.  
  495.     if ($entry->{type} == FILE) {
  496.         if ($entry->{data}) {
  497.         $file->gzwrite ($entry->{data})
  498.             or goto &_drat;
  499.         }
  500.         else {
  501.         my $size = $entry->{size};
  502.         my $data;
  503.         while ($size >= 4096) {
  504.             sysread (FH, $data, 4096)
  505.             && $file->gzwrite ($data)
  506.                 or goto &_drat;
  507.             $size -= 4096;
  508.         }
  509.         sysread (FH, $data, $size)
  510.             && $file->gzwrite ($data)
  511.             or goto &_drat
  512.                 if $size;
  513.         close FH;
  514.         }
  515.         $file->gzwrite ("\0" x (512 - ($entry->{size} & 511)))
  516.         or goto &_drat
  517.             if ($entry->{size} & 511);
  518.     }
  519.     }
  520.  
  521.     $file->gzwrite ("\0" x 1024)
  522.     and !$file->gzclose ()
  523.         or goto &_drat;
  524. }
  525.  
  526. sub _add_file {
  527.     my $file = shift;
  528.     my ($mode,$nlnk,$uid,$gid,$rdev,$size,$mtime,$type,$linkname);
  529.  
  530.     if (($mode,$nlnk,$uid,$gid,$rdev,$size,$mtime) = (lstat $file)[2..7,9]) {
  531.     $linkname = "";
  532.     $type = filetype ($file);
  533.  
  534.     $linkname = readlink $file
  535.         if ($type == SYMLINK) && $symlinks;
  536.  
  537.     $file = _munge_file ($file)
  538.         if ($^O eq "MacOS");
  539.  
  540.     return +{name => $file,            
  541.          mode => $mode,
  542.          uid => $uid,
  543.          gid => $gid,
  544.          size => $size,
  545.          mtime => (($mtime - $time_offset) | 0),
  546.          chksum => "      ",
  547.          type => $type, 
  548.          linkname => $linkname,
  549.          magic => "ustar",
  550.          version => "00",
  551.          # WinNT protection
  552.          uname => ($fake_getpwuid || scalar getpwuid($uid)),
  553.          gname => ($fake_getgrgid || scalar getgrgid ($gid)),
  554.          devmajor => 0, # We don't handle this yet
  555.          devminor => 0, # We don't handle this yet
  556.          prefix => "",
  557.          data => undef,
  558.         };
  559.     }
  560. }
  561.  
  562. sub _extract_file {
  563.     my ($entry, $handle) = @_;
  564.     my ($file, $cwd, @path);
  565.  
  566.     # For the moment, we assume that all paths in tarfiles
  567.     # are given according to Unix standards.
  568.     # Which they *are*, according to the tar format spec!
  569.     @path = split(/\//,$entry->{name});
  570.     $path[0] = '/' unless defined $path[0]; # catch absolute paths
  571.     $file = pop @path;
  572.     $file =~ s,:,/,g
  573.     if $^O eq "MacOS";
  574.     $cwd = cwd
  575.     if @path;
  576.     foreach (@path) {
  577.     if ($^O eq "MacOS") {
  578.         s,:,/,g;
  579.         $_ = "::" if $_ eq "..";
  580.         $_ = ":" if $_ eq ".";
  581.     }
  582.     if (-e $_ && ! -d _) {
  583.         $^W && carp "$_ exists but is not a directory!\n";
  584.         next;
  585.     }
  586.     mkdir $_, 0777 unless -d _;
  587.     chdir $_;
  588.     }
  589.  
  590.     if ($entry->{type} == FILE) {    # Ordinary file
  591.     sysopen (FH, $file, O_WRONLY|O_CREAT|O_TRUNC)
  592.         and binmode FH
  593.         or goto &_drat;
  594.  
  595.     if ($handle) {
  596.         my $size = $entry->{size};
  597.         my $data;
  598.         while ($size > 4096) {
  599.         $handle->gzread ($data, 4096)
  600.             and syswrite (FH, $data, length $data)
  601.             or goto &_drat;
  602.         $size -= 4096;
  603.         }
  604.         $handle->gzread ($data, $size)
  605.         and syswrite (FH, $data, length $data)
  606.             or goto &_drat
  607.             if ($size);
  608.     }
  609.     else {
  610.         syswrite FH, $entry->{data}, $entry->{size}
  611.         or goto &_drat
  612.     }
  613.     close FH
  614.         or goto &_drat
  615.     }
  616.     elsif ($entry->{type} == DIR) { # Directory
  617.     goto &_drat
  618.         if (-e $file && ! -d $file);
  619.  
  620.     mkdir $file,0777
  621.         unless -d $file;
  622.     }
  623.     elsif ($entry->{type} == UNKNOWN) {
  624.     $error = "unknown file type: $_->{type}";
  625.     return undef;
  626.     }
  627.     else {
  628.     _make_special_file ($entry, $file);
  629.     }
  630.     utime time, $entry->{mtime} + $time_offset, $file;
  631.  
  632.     # We are root, and chown exists
  633.     chown $entry->{uid}, $entry->{gid}, $file
  634.     if ($> == 0 and $^O ne "MacOS" and $^O ne "MSWin32");
  635.  
  636.     # chmod is done last, in case it makes file readonly
  637.     # (this accomodates DOSish OSes)
  638.     chmod $entry->{mode}, $file;
  639.     chdir $cwd
  640.     if @path;
  641. }
  642.  
  643. ###
  644. ### Methods
  645. ###
  646.  
  647. ##
  648. ## Class methods
  649. ##
  650.  
  651. # Perfom the equivalent of ->new()->add_files(), ->write() without the
  652. # overhead of maintaining an Archive::Tar object.
  653. sub create_archive {
  654.     my ($handle, $file, $compress) = splice (@_, 0, 3);
  655.  
  656.     if ($compress && !$compression) {
  657.     $error = "Compression not available.\n";
  658.     return undef;
  659.     }
  660.  
  661.     $handle = gensym;
  662.     open $handle, ref ($file) ? ">&". fileno ($file) : ">" . $file
  663.     and binmode ($handle)
  664.         or goto &_drat;
  665.  
  666.     _write_tar (_get_handle ($handle, int ($compress)),
  667.         map {_add_file ($_)} @_);
  668. }
  669.  
  670. # Perfom the equivalent of ->new()->list_files() without the overhead
  671. # of maintaining an Archive::Tar object.
  672. sub list_archive {
  673.     my ($handle, $file, $fields) = @_;
  674.  
  675.     $handle = gensym;
  676.     open $handle, ref ($file) ? "<&". fileno ($file) : "<" . $file
  677.     and binmode ($handle)
  678.         or goto &_drat;
  679.  
  680.     my $data = _read_tar (_get_handle ($handle), 1);
  681.  
  682.     return map {my %h; @h{@$fields} = @$_{@$fields}; \%h} @$data
  683.         if (ref $fields eq 'ARRAY'
  684.         && (@$fields > 1 || $fields->[0] ne 'name'));
  685.  
  686.     return map {$_->{name}} @$data;
  687. }
  688.  
  689. # Perform the equivalen of ->new()->extract() without the overhead of
  690. # maintaining an Archive::Tar object.
  691. sub extract_archive {
  692.     my ($handle, $file) = @_;
  693.  
  694.     $handle = gensym;
  695.     open $handle, ref ($file) ? "<&". fileno ($file) : "<" . $file
  696.     and binmode ($handle)
  697.         or goto &_drat;
  698.  
  699.     _read_tar (_get_handle ($handle), 0, 1);
  700. }
  701.  
  702. # Constructor. Reads tarfile if given an argument that's the name of a
  703. # readable file.
  704. sub new {
  705.     my ($class, $file) = @_;
  706.  
  707.     my $self = bless {}, $class;
  708.  
  709.     $self->read ($file)
  710.       if defined $file;
  711.  
  712.     return $self;
  713. }
  714.  
  715. ## Return list with references to hashes representing the tar archive's
  716. ## component files.
  717. #sub data {
  718. #    my $self = shift;
  719.  
  720. #    return @{$self->{'_data'}};
  721. #}
  722.  
  723. # Read a tarfile. Returns number of component files.
  724. sub read {
  725.     my ($self, $file) = @_;
  726.  
  727.     $self->{_data} = [];
  728.  
  729.     $self->{_handle} = gensym;
  730.     open $self->{_handle}, ref ($file) ? "<&". fileno ($file) : "<" . $file
  731.     and binmode ($self->{_handle})
  732.         or goto &_drat;
  733.  
  734.     $self->{_data} = _read_tar (_get_handle ($self->{_handle}), 
  735.                   sysseek $self->{_handle}, 0, 1);
  736.     return scalar @{$self->{_data}};
  737. }
  738.  
  739. # Write a tar archive to file
  740. sub write {
  741.     my ($self, $file, $compress) = @_;
  742.  
  743.     return _format_tar_file (@{$self->{_data}})
  744.     unless (@_ > 1);
  745.  
  746.     my $handle = gensym;
  747.     open $handle, ref ($file) ? ">&". fileno ($file) : ">" . $file
  748.     and binmode ($handle)
  749.         or goto &_drat;
  750.  
  751.     if ($compress && !$compression) {
  752.     $error = "Compression not available.\n";
  753.     return undef;
  754.     }
  755.  
  756.     _write_tar (_get_handle ($handle, $compress || 0), $self->{_data});
  757. }
  758.  
  759. # Add files to the archive. Returns number of successfully added files.
  760. sub add_files {
  761.     my $self = shift;
  762.     my ($counter, $file, $entry);
  763.  
  764.     foreach $file (@_) {
  765.     if ($entry = _add_file ($file)) {
  766.         push (@{$self->{'_data'}}, $entry);
  767.         ++$counter;
  768.     }
  769.     }
  770.  
  771.     return $counter;
  772. }
  773.  
  774. # Add data as a file
  775. sub add_data {
  776.     my ($self, $file, $data, $opt) = @_;
  777.     my $ref = {};
  778.     my ($key);
  779.  
  780.     if($^O eq "MacOS") {
  781.     $file = _munge_file($file);
  782.     }
  783.     $ref->{'data'} = $data;
  784.     $ref->{name} = $file;
  785.     $ref->{mode} = 0666 & (0777 - umask);
  786.     $ref->{uid} = $>;
  787.     $ref->{gid} = (split(/ /,$)))[0]; # Yuck
  788.     $ref->{size} = length $data;
  789.     $ref->{mtime} = ((time - $time_offset) | 0),
  790.     $ref->{chksum} = "      ";    # Utterly pointless
  791.     $ref->{type} = FILE;        # Ordinary file
  792.     $ref->{linkname} = "";
  793.     $ref->{magic} = "ustar";
  794.     $ref->{version} = "00";
  795.     # WinNT protection
  796.     $ref->{uname} = $fake_getpwuid || getpwuid ($>);
  797.     $ref->{gname} = $fake_getgrgid || getgrgid ($ref->{gid});
  798.     $ref->{devmajor} = 0;
  799.     $ref->{devminor} = 0;
  800.     $ref->{prefix} = "";
  801.  
  802.     if ($opt) {
  803.     foreach $key (keys %$opt) {
  804.         $ref->{$key} = $opt->{$key}
  805.     }
  806.     }
  807.  
  808.     push (@{$self->{'_data'}}, $ref);
  809.     return 1;
  810. }
  811.  
  812. sub rename {
  813.     my ($self) = shift;
  814.     my $entry;
  815.  
  816.     foreach $entry (@{$self->{_data}}) {
  817.     @{$self->{_data}} = grep {$_->{name} ne $entry} @{$self->{'_data'}};
  818.     }
  819.     return $self;
  820. }
  821.  
  822. sub remove {
  823.     my ($self) = shift;
  824.     my $entry;
  825.  
  826.     foreach $entry (@_) {
  827.     @{$self->{_data}} = grep {$_->{name} ne $entry} @{$self->{'_data'}};
  828.     }
  829.     return $self;
  830. }
  831.  
  832. # Get the content of a file
  833. sub get_content {
  834.     my ($self, $file) = @_;
  835.     my ($entry, $data);
  836.  
  837.     foreach $entry (@{$self->{_data}}) {
  838.     next
  839.         unless $entry->{name} eq $file;
  840.  
  841.     return $entry->{data}
  842.         unless $entry->{offset};
  843.  
  844.     my $handle = _get_handle ($self->{_handle});
  845.     $handle->gzseek ($entry->{offset}, 0)
  846.         or goto &_drat;
  847.  
  848.     $handle->gzread ($data, $entry->{size}) != -1
  849.         or goto &_drat;
  850.  
  851.     return $data;
  852.     }
  853.  
  854.     return;
  855. }
  856.  
  857. # Replace the content of a file
  858. sub replace_content {
  859.     my ($self, $file, $content) = @_;
  860.     my $entry;
  861.  
  862.     foreach $entry (@{$self->{_data}}) {
  863.     next
  864.         unless $entry->{name} eq $file;
  865.  
  866.     $entry->{data} = $content;
  867.     $entry->{size} = length $content;
  868.     $entry->{offset} = undef;
  869.     return 1;
  870.     }
  871. }
  872.  
  873. # Write a single (probably) file from the in-memory archive to disk
  874. sub extract {
  875.     my $self = shift;
  876.     my @files = @_;
  877.     my ($file, $entry);
  878.  
  879.     @files = list_files ($self) unless @files;
  880.     foreach $entry (@{$self->{_data}}) {
  881.     my $cnt = 0;
  882.     foreach $file (@files) {
  883.         ++$cnt, next
  884.         unless $entry->{name} eq $file;
  885.         my $handle = $entry->{offset} && _get_handle ($self->{_handle});
  886.         $handle->gzseek ($entry->{offset}, 0)
  887.         or goto &_drat
  888.             if $handle;
  889.         _extract_file ($entry, $handle);
  890.         splice (@_, $cnt, 1);
  891.         last;
  892.     }
  893.     last
  894.         unless @_;
  895.     }
  896.     $self;
  897. }
  898.  
  899.  
  900. # Return a list names or attribute hashes for all files in the
  901. # in-memory archive.
  902. sub list_files {
  903.  my ($self, $fields) = @_;
  904.  
  905.     return map {my %h; @h{@$fields} = @$_{@$fields}; \%h} @{$self->{'_data'}}
  906.     if (ref $fields eq 'ARRAY' && (@$fields > 1 || $fields->[0] ne 'name'));
  907.  
  908.     return map {$_->{name}} @{$self->{'_data'}}
  909. }
  910.  
  911.  
  912. ### Standard end of module :-)
  913. 1;
  914.  
  915. # 
  916. # Sub-package to hide I/O differences between compressed &
  917. # uncompressed archives.
  918. #
  919. # Yes, I could have used the IO::* class hierarchy here, but I'm
  920. # trying to minimise the necessity for non-core modules on perl5
  921. # environments < 5.004
  922.  
  923. package Archive::Tar::Std::_io;
  924.  
  925. sub gzseek {
  926.     sysseek $_[0], $_[1], $_[2];
  927. }
  928.  
  929. sub gzread {
  930.     sysread $_[0], $_[1], $_[2];
  931. }
  932.  
  933. sub gzwrite {
  934.     syswrite $_[0], $_[1], length $_[1];
  935. }
  936.  
  937. sub gzclose {
  938.     !close $_[0];
  939. }
  940.  
  941. 1;
  942.  
  943. __END__
  944.  
  945. =pod
  946.  
  947. See L<Archive::Tar> for the documentation on this module!
  948.  
  949. =cut