1 # Copyright 1997 Calle Dybedahl. All rights reserved.

     2 # Copyright 1998 Stephen Zander. All rights reserved.

     3 #

     4 # It is currently developed by Stephen Zander <gibreel@pobox.com>

     5 #

     6 # This library is free software; you can redistribute it and/or modify

     7 # it under the same terms as Perl itself.

     8 

     9 package Archive::Tar;

    10 

    11 use strict;

    12 use Carp qw(carp);

    13 use Cwd;

    14 use Fcntl qw(O_RDONLY O_RDWR O_WRONLY O_CREAT O_TRUNC F_DUPFD F_GETFL);

    15 use File::Basename;

    16 use Symbol;

    17 require Time::Local if $^O eq "MacOS";

    18 

    19 use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS);

    20 $VERSION = do { my @a=q$Name: version_0_22 $ =~ /\d+/g; sprintf "%d." . ("%02d" x $#a ),@a };

    21 

    22 require Exporter;

    23 @ISA = qw(Exporter);

    24 

    25 @EXPORT_OK = qw(FILE HARDLINK SYMLINK 

    26 		CHARDEV BLOCKDEV DIR

    27 		FIFO SOCKET INVALID);

    28 %EXPORT_TAGS = (filetypes => \@EXPORT_OK);

    29 

    30 # Check if symbolic links are available

    31 my $symlinks = eval { readlink $0 or 1; };

    32 carp "Symbolic links not available"

    33     unless $symlinks || !$^W;

    34 

    35 # Check if Compress::Zlib is available

    36 my $compression = eval { 

    37     local $SIG{__DIE__};

    38     require Compress::Zlib; 

    39     sub Compress::Zlib::gzFile::gzseek {

    40 	my $tmp;

    41 

    42 	$_[0]->gzread ($tmp, 4096), $_[1] -= 4096

    43 	    while ($_[1] > 4096);

    44 

    45 	$_[0]->gzread ($tmp, $_[1])

    46 	  if $_[1];

    47     }

    48     1;

    49 };

    50 carp "Compression not available"

    51     unless $compression || !$^W;

    52 

    53 # Check for get* (they don't exist on WinNT)

    54 my $fake_getpwuid;

    55 $fake_getpwuid = "unknown"

    56     unless eval { $_ = getpwuid (0); }; # Pointless assigment to make -w shut up

    57 

    58 my $fake_getgrgid;

    59 $fake_getgrgid = "unknown"

    60     unless eval { $_ = getgrgid (0); }; # Pointless assigment to make -w shut up

    61 

    62 # Automagically detect gziped files if they start with this

    63 my $gzip_magic_number = "^(?:\037\213|\037\235)";

    64 

    65 my $tar_unpack_header 

    66     = 'A100 A8 A8 A8 A12 A12 A8 A1 A100 A6 A2 A32 A32 A8 A8 A155 x12';

    67 my $tar_pack_header

    68     = 'a100 a8 a8 a8 a12 a12 A8 a1 a100 a6 a2 a32 a32 a8 a8 a155 x12',

    69 my $tar_header_length = 512;

    70 

    71 my $time_offset = ($^O eq "MacOS") ? Time::Local::timelocal(0,0,0,1,0,70) : 0;

    72 

    73 ## Subroutines to return type constants 

    74 sub FILE() { return 0; }

    75 sub HARDLINK() { return 1; }

    76 sub SYMLINK() { return 2; }

    77 sub CHARDEV() { return 3; }

    78 sub BLOCKDEV() { return 4; }

    79 sub DIR() { return 5; }

    80 sub FIFO() { return 6; }

    81 sub SOCKET() { return 8; }

    82 sub UNKNOWN() { return 9; }

    83 

    84 ###

    85 ### Non-method functions

    86 ###

    87 

    88 my $error;

    89 sub _drat {

    90     $error = $! . '';

    91     return;

    92 }

    93 

    94 sub error {

    95     $error;

    96 }

    97 

    98 sub set_error {

    99     shift;

   100     $error = "@_";

   101 }

   102 

   103 ## filetype -- Determine the type value for a given file

   104 sub filetype {

   105     my $file = shift;

   106 

   107     return SYMLINK

   108 	if (-l $file);		# Symlink

   109 

   110     return FILE

   111 	if (-f _);		# Plain file

   112 

   113     return DIR

   114 	if (-d _);		# Directory

   115 

   116     return FIFO

   117 	if (-p _);		# Named pipe

   118 

   119     return SOCKET

   120 	if (-S _);		# Socket

   121 

   122     return BLOCKDEV

   123 	if (-b _);		# Block special

   124 

   125     return CHARDEV

   126 	if (-c _);		# Character special

   127 

   128     return UNKNOWN;		# Something else (like what?)

   129 }

   130 

   131 sub _make_special_file_UNIX {

   132     # $file is the last component of $entry->{name}

   133     my ($entry, $file) = @_;

   134 

   135     if ($entry->{type} == SYMLINK) {

   136 	symlink $entry->{linkname}, $file or

   137 	    $^W && carp ("Making symbolic link from ", $entry->{linkname}, 

   138 			 " to ", $entry->{name}, ", failed.\n");

   139     }

   140     elsif ($entry->{type} == HARDLINK) {

   141 	link $entry->{linkname}, $file or

   142 	    $^W && carp ("Hard linking ", $entry->{linkname}, 

   143 			 " to ", $entry->{name}, ", failed.\n");

   144     }

   145     elsif ($entry->{type} == FIFO) {

   146 	system("mknod","$file","p") or

   147 	    $^W && carp "Making fifo ", $entry->{name}, ", failed.\n";

   148     }

   149     elsif ($entry->{type} == BLOCKDEV) {

   150 	system("mknod","$file","b",$entry->{devmajor},$entry->{devminor}) or

   151 	    $^W && carp ("Making block device ", $entry->{name},

   152 			 " (maj=", $entry->{devmajor}, 

   153 			 ", min=", $entry->{devminor}, "), failed.\n");

   154     }

   155     elsif ($entry->{type} == CHARDEV) {

   156 	system("mknod", "$file", "c", $entry->{devmajor}, $entry->{devminor}) or

   157 	    $^W && carp ("Making block device ", $entry->{name}, 

   158 			 " (maj=", $entry->{devmajor}, 

   159 			 " ,min=", $entry->{devminor}, "), failed.\n");

   160     }

   161 }

   162 

   163 sub _make_special_file_Win32 {

   164     # $file is the last component of $entry->{name}

   165     my ($entry, $file) = @_;

   166 

   167     if ($entry->{type} == SYMLINK) {

   168 	$^W && carp ("Making symbolic link from ", $entry->{linkname}, 

   169 		     " to ", $entry->{name}, ", failed.\n");

   170     }

   171     elsif ($entry->{type} == HARDLINK) {

   172 	link $entry->{linkname}, $file or

   173 	    $^W && carp ("Making hard link from ", $entry->{linkname}, 

   174 			 " to ", $entry->{name}, ", failed.\n");

   175     }

   176     elsif ($entry->{type} == FIFO) {

   177 	$^W && carp "Making fifo ", $entry->{name}, ", failed.\n";

   178     }

   179     elsif ($entry->{type} == BLOCKDEV) {

   180 	$^W && carp ("Making block device ", $entry->{name},

   181 		     " (maj=", $entry->{devmajor}, 

   182 		     ", min=", $entry->{devminor}, "), failed.\n");

   183     }

   184     elsif ($entry->{type} == CHARDEV) {

   185 	$^W && carp ("Making block device ", $entry->{name},

   186 		     " (maj=", $entry->{devmajor}, 

   187 		     " ,min=", $entry->{devminor}, "), failed.\n");

   188     }

   189 }

   190 

   191 *_make_special_file = $^O eq "MSWin32" ? 

   192     \&_make_special_file_Win32 : \&_make_special_file_UNIX;

   193 

   194 sub _munge_file {

   195 #

   196 #  Mac path to the Unix like equivalent to be used in tar archives

   197 #

   198     my $inpath = $_[0];

   199 #

   200 #  If there are no :'s in the name at all, assume it's a single item in the

   201 #  current directory.  Return it, changing any / in the name into :

   202 #

   203     if ($inpath !~ m,:,) {

   204 	$inpath =~ s,/,:,g;

   205 	return $inpath;

   206     }

   207 #

   208 #  If we now split on :, there will be just as many nulls in the list as

   209 #  there should be up requests, except if it begins with a :, where there

   210 #  will be one extra.

   211 #

   212     my @names = split (/:/, $inpath);

   213     shift (@names)

   214 	if ($names[0] eq "");

   215     my @outname = ();

   216 #

   217 #  Work from the end.

   218 #

   219     my $i;

   220     for ($i = $#names; $i >= 0; --$i) {

   221 	if ($names[$i] eq "") {

   222 	    unshift (@outname, "..");

   223 	} 

   224 	else {

   225 	    $names[$i] =~ s,/,:,g;

   226 	    unshift (@outname, $names[$i]);

   227 	}

   228     }

   229     my $netpath = join ("/", @outname);

   230     $netpath = $netpath . "/" if ($inpath =~ /:$/);

   231     if ($inpath !~ m,^:,) {

   232 	return "/".$netpath;

   233     } 

   234     else {

   235 	return $netpath;

   236     }

   237 }

   238 

   239 sub _get_handle {

   240     my ($fh, $flags, $mode);

   241 

   242     sysseek ($_[0], 0, 0)

   243 	or goto &_drat;

   244 

   245     if ($^O eq "MSWin32") {

   246 	$fh = $_[0];

   247     }

   248     else {

   249 	$fh = fcntl ($_[0], F_DUPFD, 0)

   250 	    or goto &_drat;

   251     }

   252     if ($compression && (@_ < 2 || $_[1] != 0)) {

   253 	$mode = $#_ ? (int($_[1]) > 1 ?

   254 			  "wb".int($_[1]) : "wb") : "rb";

   255 

   256 	$fh = Compress::Zlib::gzdopen_ ($fh, $mode, 0)

   257 	    or &_drat;

   258     }

   259     else {

   260 	$flags = fcntl ($_[0], F_GETFL, 0) & (O_RDONLY | O_WRONLY | O_RDWR);

   261 	$mode = ($flags == O_WRONLY) ? ">&=$fh" : 

   262 	    ($flags == O_RDONLY) ? "<&=$fh" : "+>&=$fh";

   263 	$fh = gensym;

   264 	open ($fh, $mode)

   265 	  or goto &_drat;

   266 

   267 	$fh = bless *{$fh}{IO}, "Archive::Tar::_io";

   268 	binmode $fh

   269 	    or goto &_drat;

   270     }

   271 

   272     return $fh;

   273 }

   274 

   275 sub _read_tar {

   276     my ($file, $seekable, $extract) = @_;

   277     my $tarfile = [];

   278     my ($head, $offset, $size);

   279 

   280     $file->gzread ($head, $tar_header_length)

   281 	or goto &_drat;

   282 

   283     if (substr ($head, 0, 2) =~ /$gzip_magic_number/o) {

   284 	$error =

   285 	    "Compression not available\n";

   286 	return undef;

   287     }

   288 

   289     $offset = $tar_header_length

   290 	if $seekable;

   291 

   292  READLOOP:

   293     while (length ($head) == $tar_header_length) {

   294 	my ($name,		# string

   295 	    $mode,		# octal number

   296 	    $uid,		# octal number

   297 	    $gid,		# octal number

   298 	    $size,		# octal number

   299 	    $mtime,		# octal number

   300 	    $chksum,		# octal number

   301 	    $type,		# character

   302 	    $linkname,		# string

   303 	    $magic,		# string

   304 	    $version,		# two bytes

   305 	    $uname,		# string

   306 	    $gname,		# string

   307 	    $devmajor,		# octal number

   308 	    $devminor,		# octal number

   309 	    $prefix) = unpack ($tar_unpack_header, $head);

   310 	my ($data, $block, $entry);

   311 

   312 	$mode = oct $mode;

   313 	$uid = oct $uid;

   314 	$gid = oct $gid;

   315 	$size = oct $size;

   316 	$mtime = oct $mtime;

   317 	$chksum = oct $chksum;

   318 	$devmajor = oct $devmajor;

   319 	$devminor = oct $devminor;

   320 	$name = $prefix."/".$name if $prefix;

   321 	$prefix = "";

   322 	# some broken tar-s don't set the type for directories

   323 	# so we ass_u_me a directory if the name ends in slash

   324 	$type = DIR

   325 	    if $name =~ m|/$| and $type == FILE;

   326 

   327 	last READLOOP if $head eq "\0" x 512; # End of archive

   328 	# Apparently this should really be two blocks of 512 zeroes,

   329 	# but GNU tar sometimes gets it wrong. See comment in the

   330 	# source code (tar.c) to GNU cpio.

   331 

   332 	substr ($head, 148, 8) = "        ";

   333 	if (unpack ("%16C*", $head) != $chksum) {

   334 	   warn "$name: checksum error.\n";

   335 	}

   336 

   337 	unless ($extract || $type != FILE) {

   338 	    # Always read in full 512 byte blocks

   339 	    $block = $size & 0x01ff ? ($size & ~0x01ff) + 512 : $size;

   340 	    if ($seekable) {

   341 		while ($block > 4096) {

   342 		    $file->gzread ($data, 4096)

   343 			or goto &_drat;

   344 		    $block -= 4096;

   345 		}

   346 		$file->gzread ($data, $block)

   347 		    or goto &_drat

   348 			if ($block);

   349 

   350 		# Ignore everything we've just read.

   351 		undef $data;

   352 	    } else {

   353 		if ($file->gzread ($data, $block) < $block) {

   354 		    $error = "Read error on tarfile.";

   355 		    return undef;

   356 		}

   357 

   358 		# Throw away any trailing garbage

   359 		substr ($data, $size) = "";

   360 	    }

   361 	}

   362 

   363 	# Guard against tarfiles with garbage at the end

   364 	last READLOOP if $name eq ''; 

   365 

   366 	$entry = {name => $name,		    

   367 		  mode => $mode,

   368 		  uid => $uid,

   369 		  gid => $gid,

   370 		  size => $size,

   371 		  mtime => $mtime,

   372 		  chksum => $chksum,

   373 		  type => $type,

   374 		  linkname => $linkname,

   375 		  magic => $magic,

   376 		  version => $version,

   377 		  uname => $uname,

   378 		  gname => $gname,

   379 		  devmajor => $devmajor,

   380 		  devminor => $devminor,

   381 		  prefix => $prefix,

   382 		  offset => $offset,

   383 		  data => $data};

   384 

   385 	if ($extract) {

   386 	    _extract_file ($entry, $file);

   387 	    $file->gzread ($head, 512 - ($size & 0x1ff)) 

   388 		or goto &_drat

   389 		    if ($size & 0x1ff && $type == FILE);

   390 	}

   391 	else {

   392 	    push @$tarfile, $entry;

   393 	}

   394 

   395 	if ($seekable) {

   396 	    $offset += $tar_header_length;

   397 	    $offset += ($size & 0x01ff) ? ($size & ~0x01ff) + 512 : $size

   398 		if $type == FILE;

   399 	}

   400 	$file->gzread ($head, $tar_header_length) 

   401 	    or goto &_drat;

   402     }

   403 

   404     $file->gzclose ()

   405 	unless $seekable;

   406 

   407     return $tarfile

   408 	unless $extract;

   409 }

   410 

   411 sub _format_tar_entry {

   412     my ($ref) = shift;

   413     my ($tmp,$file,$prefix,$pos);

   414 

   415     $file = $ref->{name};

   416     if (length ($file) > 99) {

   417 	$pos = index $file, "/", (length ($file) - 100);

   418 	next

   419 	    if $pos == -1;	# Filename longer than 100 chars!

   420 

   421 	$prefix = substr $file,0,$pos;

   422 	$file = substr $file,$pos+1;

   423 	substr ($prefix, 0, -155) = ""

   424 	    if length($prefix)>154;

   425     }

   426     else {

   427 	$prefix="";

   428     }

   429 

   430     $tmp = pack ($tar_pack_header,

   431 		 $file,

   432 		 sprintf("%06o ",$ref->{mode}),

   433 		 sprintf("%06o ",$ref->{uid}),

   434 		 sprintf("%06o ",$ref->{gid}),

   435 		 sprintf("%11o ",$ref->{size}),

   436 		 sprintf("%11o ",$ref->{mtime}),

   437 		 "",		#checksum field - space padded by pack("A8")

   438 		 $ref->{type},

   439 		 $ref->{linkname},

   440 		 $ref->{magic},

   441 		 $ref->{version} || '00',

   442 		 $ref->{uname},

   443 		 $ref->{gname},

   444 		 sprintf("%6o ",$ref->{devmajor}),

   445 		 sprintf("%6o ",$ref->{devminor}),

   446 		 $prefix);

   447     substr($tmp,148,7) = sprintf("%6o\0", unpack("%16C*",$tmp));

   448 

   449     return $tmp;

   450 }

   451 

   452 sub _format_tar_file {

   453     my @tarfile = @_;

   454     my $file = "";

   455 

   456     foreach (@tarfile) {

   457 	$file .= _format_tar_entry $_;

   458 	$file .= $_->{data};

   459 	$file .= "\0" x (512 - ($_->{size} & 0x1ff))

   460 	    if ($_->{size} & 0x1ff);

   461     }

   462     $file .= "\0" x 1024;

   463 

   464     return $file;

   465 }

   466 

   467 sub _write_tar {

   468     my $file = shift;

   469     my $entry;

   470 

   471     foreach $entry ((ref ($_[0]) eq 'ARRAY') ? @{$_[0]} : @_) {

   472 	next

   473 	    unless (ref ($entry) eq 'HASH');

   474 

   475 	my $src;

   476         if ($^O eq "MacOS") {  #convert back from Unix to Mac path

   477             my @parts = split(/\//, $entry->{name});

   478 

   479             $src = $parts[0] ? ":" : "";

   480             foreach (@parts) {

   481 		next if !$_ || $_ eq ".";  

   482                 s,:,/,g;

   483 

   484 		$_ = ":"

   485 		    if ($_ eq "..");

   486 

   487 		$src .= ($src =~ /:$/) ? $_ : ":$_";

   488 	    }

   489         }

   490 	else {

   491             $src = $entry->{name};

   492         }

   493 	sysopen (FH, $src, O_RDONLY)

   494 	    && binmode (FH)

   495 		or next

   496 		    unless $entry->{type} != FILE || $entry->{data};

   497 

   498 	$file->gzwrite (_format_tar_entry ($entry))

   499 	    or goto &_drat;

   500 

   501 	if ($entry->{type} == FILE) {

   502 	    if ($entry->{data}) {

   503 		$file->gzwrite ($entry->{data})

   504 		    or goto &_drat;

   505 	    }

   506 	    else {

   507 		my $size = $entry->{size};

   508 		my $data;

   509 		while ($size >= 4096) {

   510 		    sysread (FH, $data, 4096)

   511 			&& $file->gzwrite ($data)

   512 			    or goto &_drat;

   513 		    $size -= 4096;

   514 		}

   515 		sysread (FH, $data, $size)

   516 		    && $file->gzwrite ($data)

   517 			or goto &_drat

   518 			    if $size;

   519 		close FH;

   520 	    }

   521 	    $file->gzwrite ("\0" x (512 - ($entry->{size} & 511)))

   522 		or goto &_drat

   523 		    if ($entry->{size} & 511);

   524 	}

   525     }

   526 

   527     $file->gzwrite ("\0" x 1024)

   528 	and !$file->gzclose ()

   529 	    or goto &_drat;

   530 }

   531 

   532 sub _add_file {

   533     my $file = shift;

   534     my ($mode,$nlnk,$uid,$gid,$rdev,$size,$mtime,$type,$linkname);

   535 

   536     if (($mode,$nlnk,$uid,$gid,$rdev,$size,$mtime) = (lstat $file)[2..7,9]) {

   537 	$linkname = "";

   538 	$type = filetype ($file);

   539 

   540 	$linkname = readlink $file

   541 	    if ($type == SYMLINK) && $symlinks;

   542 

   543 	$file = _munge_file ($file)

   544 	    if ($^O eq "MacOS");

   545 

   546 	return +{name => $file,		    

   547 		 mode => $mode,

   548 		 uid => $uid,

   549 		 gid => $gid,

   550 		 size => $size,

   551 		 mtime => (($mtime - $time_offset) | 0),

   552 		 chksum => "      ",

   553 		 type => $type, 

   554 		 linkname => $linkname,

   555 		 magic => "ustar",

   556 		 version => "00",

   557 		 # WinNT protection

   558 		 uname => ($fake_getpwuid || scalar getpwuid($uid)),

   559 		 gname => ($fake_getgrgid || scalar getgrgid ($gid)),

   560 		 devmajor => 0, # We don't handle this yet

   561 		 devminor => 0, # We don't handle this yet

   562 		 prefix => "",

   563 		 data => undef,

   564 		};

   565     }

   566 }

   567 

   568 sub _extract_file {

   569     my ($entry, $handle) = @_;

   570     my ($file, $cwd, @path);

   571 

   572     # For the moment, we assume that all paths in tarfiles

   573     # are given according to Unix standards.

   574     # Which they *are*, according to the tar format spec!

   575     @path = split(/\//,$entry->{name});

   576     $path[0] = '/' unless defined $path[0]; # catch absolute paths

   577     $file = pop @path;

   578     $file =~ s,:,/,g

   579 	if $^O eq "MacOS";

   580     $cwd = cwd

   581 	if @path;

   582     foreach (@path) {

   583 	if ($^O eq "MacOS") {

   584 	    s,:,/,g;

   585 	    $_ = "::" if $_ eq "..";

   586 	    $_ = ":" if $_ eq ".";

   587 	}

   588 	if (-e $_ && ! -d _) {

   589 	    $^W && carp "$_ exists but is not a directory!\n";

   590 	    next;

   591 	}

   592 	mkdir $_, 0777 unless -d _;

   593 	chdir $_;

   594     }

   595 

   596     if ($entry->{type} == FILE) {	# Ordinary file

   597 	sysopen (FH, $file, O_WRONLY|O_CREAT|O_TRUNC)

   598 	    and binmode FH

   599 		or goto &_drat;

   600 

   601 	if ($handle) {

   602 	    my $size = $entry->{size};

   603 	    my $data;

   604 	    while ($size > 4096) {

   605 		$handle->gzread ($data, 4096)

   606 		    and syswrite (FH, $data, length $data)

   607 			or goto &_drat;

   608 		$size -= 4096;

   609 	    }

   610 	    $handle->gzread ($data, $size)

   611 		and syswrite (FH, $data, length $data)

   612 		    or goto &_drat

   613 			if ($size);

   614 	}

   615 	else {

   616 	    syswrite FH, $entry->{data}, $entry->{size}

   617 		or goto &_drat

   618 	}

   619 	close FH

   620 	    or goto &_drat

   621     }

   622     elsif ($entry->{type} == DIR) { # Directory

   623 	goto &_drat

   624 	    if (-e $file && ! -d $file);

   625 

   626 	mkdir $file,0777

   627 	    unless -d $file;

   628     }

   629     elsif ($entry->{type} == UNKNOWN) {

   630 	$error = "unknown file type: $_->{type}";

   631 	return undef;

   632     }

   633     else {

   634 	_make_special_file ($entry, $file);

   635     }

   636     utime time, $entry->{mtime} + $time_offset, $file;

   637 

   638     # We are root, and chown exists

   639     chown $entry->{uid}, $entry->{gid}, $file

   640 	if ($> == 0 and $^O ne "MacOS" and $^O ne "MSWin32");

   641 

   642     # chmod is done last, in case it makes file readonly

   643     # (this accomodates DOSish OSes)

   644     chmod $entry->{mode}, $file;

   645     chdir $cwd

   646 	if @path;

   647 }

   648 

   649 ###

   650 ### Methods

   651 ###

   652 

   653 ##

   654 ## Class methods

   655 ##

   656 

   657 # Perfom the equivalent of ->new()->add_files(), ->write() without the

   658 # overhead of maintaining an Archive::Tar object.

   659 sub create_archive {

   660     my ($handle, $file, $compress) = splice (@_, 0, 3);

   661 

   662     if ($compress && !$compression) {

   663 	$error = "Compression not available.\n";

   664 	return undef;

   665     }

   666 

   667     $handle = gensym;

   668     open $handle, ref ($file) ? ">&". fileno ($file) : ">" . $file

   669 	and binmode ($handle)

   670 	    or goto &_drat;

   671 

   672     _write_tar (_get_handle ($handle, int ($compress)),

   673 		map {_add_file ($_)} @_);

   674 }

   675 

   676 # Perfom the equivalent of ->new()->list_files() without the overhead

   677 # of maintaining an Archive::Tar object.

   678 sub list_archive {

   679     my ($handle, $file, $fields) = @_;

   680 

   681     $handle = gensym;

   682     open $handle, ref ($file) ? "<&". fileno ($file) : "<" . $file

   683 	and binmode ($handle)

   684 	    or goto &_drat;

   685 

   686     my $data = _read_tar (_get_handle ($handle), 1);

   687 

   688     return map {my %h; @h{@$fields} = @$_{@$fields}; \%h} @$data

   689         if (ref $fields eq 'ARRAY'

   690 	    && (@$fields > 1 || $fields->[0] ne 'name'));

   691 

   692     return map {$_->{name}} @$data;

   693 }

   694 

   695 # Perform the equivalen of ->new()->extract() without the overhead of

   696 # maintaining an Archive::Tar object.

   697 sub extract_archive {

   698     my ($handle, $file) = @_;

   699 

   700     $handle = gensym;

   701     open $handle, ref ($file) ? "<&". fileno ($file) : "<" . $file

   702 	and binmode ($handle)

   703 	    or goto &_drat;

   704 

   705     _read_tar (_get_handle ($handle), 0, 1);

   706 }

   707 

   708 # Constructor. Reads tarfile if given an argument that's the name of a

   709 # readable file.

   710 sub new {

   711     my ($class, $file) = @_;

   712 

   713     my $self = bless {}, $class;

   714 

   715     $self->read ($file)

   716       if defined $file;

   717 

   718     return $self;

   719 }

   720 

   721 

   722 # Read a tarfile. Returns number of component files.

   723 sub read {

   724     my ($self, $file) = @_;

   725 

   726     $self->{_data} = [];

   727 

   728     $self->{_handle} = gensym;

   729     open $self->{_handle}, ref ($file) ? "<&". fileno ($file) : "<" . $file

   730 	and binmode ($self->{_handle})

   731 	    or goto &_drat;

   732 

   733     $self->{_data} = _read_tar (_get_handle ($self->{_handle}), 

   734 				  sysseek $self->{_handle}, 0, 1);

   735     return scalar @{$self->{_data}};

   736 }

   737 

   738 # Write a tar archive to file

   739 sub write {

   740     my ($self, $file, $compress) = @_;

   741 

   742     return _format_tar_file (@{$self->{_data}})

   743 	unless (@_ > 1);

   744 

   745     my $handle = gensym;

   746     open $handle, ref ($file) ? ">&". fileno ($file) : ">" . $file

   747 	and binmode ($handle)

   748 	    or goto &_drat;

   749 

   750     if ($compress && !$compression) {

   751 	$error = "Compression not available.\n";

   752 	return undef;

   753     }

   754 

   755     _write_tar (_get_handle ($handle, $compress || 0), $self->{_data});

   756 }

   757 

   758 # Add files to the archive. Returns number of successfully added files.

   759 sub add_files {

   760     my $self = shift;

   761     my ($counter, $file, $entry);

   762 

   763     foreach $file (@_) {

   764 	if ($entry = _add_file ($file)) {

   765 	    push (@{$self->{'_data'}}, $entry);

   766 	    ++$counter;

   767 	}

   768     }

   769 

   770     return $counter;

   771 }

   772 

   773 # Add data as a file

   774 sub add_data {

   775     my ($self, $file, $data, $opt) = @_;

   776     my $ref = {};

   777     my ($key);

   778 

   779     if($^O eq "MacOS") {

   780 	$file = _munge_file($file);

   781     }

   782     $ref->{'data'} = $data;

   783     $ref->{name} = $file;

   784     $ref->{mode} = 0666 & (0777 - umask);

   785     $ref->{uid} = $>;

   786     $ref->{gid} = (split(/ /,$)))[0]; # Yuck

   787     $ref->{size} = length $data;

   788     $ref->{mtime} = ((time - $time_offset) | 0),

   789     $ref->{chksum} = "      ";	# Utterly pointless

   790     $ref->{type} = FILE;		# Ordinary file

   791     $ref->{linkname} = "";

   792     $ref->{magic} = "ustar";

   793     $ref->{version} = "00";

   794     # WinNT protection

   795     $ref->{uname} = $fake_getpwuid || getpwuid ($>);

   796     $ref->{gname} = $fake_getgrgid || getgrgid ($ref->{gid});

   797     $ref->{devmajor} = 0;

   798     $ref->{devminor} = 0;

   799     $ref->{prefix} = "";

   800 

   801     if ($opt) {

   802 	foreach $key (keys %$opt) {

   803 	    $ref->{$key} = $opt->{$key}

   804 	}

   805     }

   806 

   807     push (@{$self->{'_data'}}, $ref);

   808     return 1;

   809 }

   810 

   811 sub rename {

   812     my ($self) = shift;

   813     my $entry;

   814 

   815     foreach $entry (@{$self->{_data}}) {

   816 	@{$self->{_data}} = grep {$_->{name} ne $entry} @{$self->{'_data'}};

   817     }

   818     return $self;

   819 }

   820 

   821 sub remove {

   822     my ($self) = shift;

   823     my $entry;

   824 

   825     foreach $entry (@_) {

   826 	@{$self->{_data}} = grep {$_->{name} ne $entry} @{$self->{'_data'}};

   827     }

   828     return $self;

   829 }

   830 

   831 # Get the content of a file

   832 sub get_content {

   833     my ($self, $file) = @_;

   834     my ($entry, $data);

   835 

   836     foreach $entry (@{$self->{_data}}) {

   837 	next

   838 	    unless $entry->{name} eq $file;

   839 

   840 	return $entry->{data}

   841 	    unless $entry->{offset};

   842 

   843 	my $handle = _get_handle ($self->{_handle});

   844 	$handle->gzseek ($entry->{offset}, 0)

   845 	    or goto &_drat;

   846 

   847 	$handle->gzread ($data, $entry->{size}) != -1

   848 	    or goto &_drat;

   849 

   850 	return $data;

   851     }

   852 

   853     return;

   854 }

   855 

   856 # Replace the content of a file

   857 sub replace_content {

   858     my ($self, $file, $content) = @_;

   859     my $entry;

   860 

   861     foreach $entry (@{$self->{_data}}) {

   862 	next

   863 	    unless $entry->{name} eq $file;

   864 

   865 	$entry->{data} = $content;

   866 	$entry->{size} = length $content;

   867 	$entry->{offset} = undef;

   868 	return 1;

   869     }

   870 }

   871 

   872 # Write a single (probably) file from the in-memory archive to disk

   873 sub extract {

   874     my $self = shift;

   875     my @files = @_;

   876     my ($file, $entry);

   877 

   878     @files = list_files ($self) unless @files;

   879     foreach $entry (@{$self->{_data}}) {

   880 	my $cnt = 0;

   881 	foreach $file (@files) {

   882 	    ++$cnt, next

   883 		unless $entry->{name} eq $file;

   884 	    my $handle = $entry->{offset} && _get_handle ($self->{_handle});

   885 	    $handle->gzseek ($entry->{offset}, 0)

   886 		or goto &_drat

   887 		    if $handle;

   888 	    _extract_file ($entry, $handle);

   889 	    splice (@_, $cnt, 1);

   890 	    last;

   891 	}

   892 	last

   893 	    unless @_;

   894     }

   895     $self;

   896 }

   897 

   898 

   899 # Return a list names or attribute hashes for all files in the

   900 # in-memory archive.

   901 sub list_files {

   902  my ($self, $fields) = @_;

   903 

   904     return map {my %h; @h{@$fields} = @$_{@$fields}; \%h} @{$self->{'_data'}}

   905     if (ref $fields eq 'ARRAY' && (@$fields > 1 || $fields->[0] ne 'name'));

   906 

   907     return map {$_->{name}} @{$self->{'_data'}}

   908 }

   909 

   910 

   911 ### Standard end of module :-)

   912 1;

   913 

   914 # 

   915 # Sub-package to hide I/O differences between compressed &

   916 # uncompressed archives.

   917 #

   918 # Yes, I could have used the IO::* class hierarchy here, but I'm

   919 # trying to minimise the necessity for non-core modules on perl5

   920 # environments < 5.004

   921 

   922 package Archive::Tar::_io;

   923 

   924 sub gzseek {

   925     sysseek $_[0], $_[1], $_[2];

   926 }

   927 

   928 sub gzread {

   929     sysread $_[0], $_[1], $_[2];

   930 }

   931 

   932 sub gzwrite {

   933     syswrite $_[0], $_[1], length $_[1];

   934 }

   935 

   936 sub gzclose {

   937     !close $_[0];

   938 }

   939 

   940 1;

   941 

   942 __END__

   943 

   944 =head1 NAME

   945 

   946 Tar - module for manipulation of tar archives.

   947 

   948 =head1 SYNOPSIS

   949 

   950   use Archive::Tar;

   951 

   952   Archive::Tar->create_archive ("my.tar.gz", 9, "/this/file", "/that/file");

   953   print join "\n", Archive::Tar->list_archive ("my.tar.gz"), "";

   954 

   955   $tar = Archive::Tar->new();

   956   $tar->read("origin.tar.gz",1);

   957   $tar->add_files("file/foo.c", "file/bar.c");

   958   $tar->add_data("file/baz.c","This is the file contents");

   959   $tar->write("files.tar");

   960 

   961 =head1 DESCRIPTION

   962 

   963 This is a module for the handling of tar archives. 

   964 

   965 Archive::Tar provides an object oriented mechanism for handling tar

   966 files.  It provides class methods for quick and easy files handling

   967 while also allowing for the creation of tar file objects for custom

   968 manipulation.  If you have the Compress::Zlib module installed,

   969 Archive::Tar will also support compressed or gzipped tar files.

   970 

   971 =head2 Class Methods

   972 

   973 The class methods should be sufficient for most tar file interaction.

   974 

   975 =over 4

   976 

   977 =item create_archive ($file, $compression, @filelist)

   978 

   979 Creates a tar file from the list of files provided.  The first

   980 argument can either be the name of the tar file to create or a

   981 reference to an open file handle (e.g. a GLOB reference).

   982 

   983 The second argument specifies the level of compression to be used, if

   984 any.  Compression of tar files requires the installation of the

   985 Compress::Zlib module.  Specific levels or compression may be

   986 requested by passing a value between 2 and 9 as the second argument.

   987 Any other value evaluating as true will result in the default

   988 compression level being used.

   989 

   990 The remaining arguments list the files to be included in the tar file.

   991 These files must all exist.  Any files which don\'t exist or can\'t be

   992 read are silently ignored.

   993 

   994 If the archive creation fails for any reason, C<create_archive> will

   995 return undef.  Please use the C<error> method to find the cause of the

   996 failure.

   997 

   998 =item list_archive ($file, ['property', 'property',...])

   999 

  1000 =item list_archive ($file)

  1001 

  1002 Returns a list of the names of all the files in the archive.  The

  1003 first argument can either be the name of the tar file to create or a

  1004 reference to an open file handle (e.g. a GLOB reference).

  1005 

  1006 If C<list_archive()> is passed an array reference as its second

  1007 argument it returns a list of hash references containing the requested

  1008 properties of each file.  The following list of properties is

  1009 supported: name, size, mtime (last modified date), mode, uid, gid,

  1010 linkname, uname, gname, devmajor, devminor, prefix.

  1011 

  1012 Passing an array reference containing only one element, 'name', is

  1013 special cased to return a list of names rather than a list of hash

  1014 references.

  1015 

  1016 =item extract_archive ($file)

  1017 

  1018 Extracts the contents of the tar file.  The first argument can either

  1019 be the name of the tar file to create or a reference to an open file

  1020 handle (e.g. a GLOB reference).  All relative paths in the tar file will

  1021 be created underneath the current working directory.

  1022 

  1023 If the archive extraction fails for any reason, C<extract_archive>

  1024 will return undef.  Please use the C<error> method to find the cause

  1025 of the failure.

  1026 

  1027 =item new ($file)

  1028 

  1029 =item new ()

  1030 

  1031 Returns a new Tar object. If given any arguments, C<new()> calls the

  1032 C<read()> method automatically, parsing on the arguments provided L<read()>.

  1033 

  1034 If C<new()> is invoked with arguments and the read method fails for

  1035 any reason, C<new()> returns undef.

  1036 

  1037 =back

  1038 

  1039 =head2 Instance Methods

  1040 

  1041 =over 4

  1042 

  1043 =item read ($ref, $compressed)

  1044 

  1045 Read the given tar file into memory. The first argument can either be

  1046 the name of a file or a reference to an already open file handle (e.g. a

  1047 GLOB reference).  The second argument indicates whether the file

  1048 referenced by the first argument is compressed.

  1049 

  1050 The second argument is now optional as Archive::Tar will automatically

  1051 detect compressed archives.

  1052 

  1053 The C<read> will I<replace> any previous content in C<$tar>!

  1054 

  1055 =item add_files(@filenamelist)

  1056 

  1057 Takes a list of filenames and adds them to the in-memory archive.  On

  1058 MacOS, the path to the file is automatically converted to a Unix like

  1059 equivalent for use in the archive, and the file\'s modification time

  1060 is converted from the MacOS epoch to the Unix epoch.  So tar archives

  1061 created on MacOS with B<Archive::Tar> can be read both with I<tar> on

  1062 Unix and applications like I<suntar> or I<Stuffit Expander> on MacOS.

  1063 Be aware that the file\'s type/creator and resource fork will be lost,

  1064 which is usually what you want in cross-platform archives.

  1065 

  1066 =item add_data ($filename, $data, $opthashref)

  1067 

  1068 Takes a filename, a scalar full of data and optionally a reference to

  1069 a hash with specific options. Will add a file to the in-memory

  1070 archive, with name C<$filename> and content C<$data>. Specific

  1071 properties can be set using C<$opthashref>, The following list of

  1072 properties is supported: name, size, mtime (last modified date), mode,

  1073 uid, gid, linkname, uname, gname, devmajor, devminor, prefix.  (On

  1074 MacOS, the file\'s path and modification times are converted to Unix

  1075 equivalents.)

  1076 

  1077 =item remove (@filenamelist)

  1078 

  1079 Removes any entries with names matching any of the given filenames

  1080 from the in-memory archive. String comparisons are done with C<eq>.

  1081 

  1082 =item write ($file, $compressed)

  1083 

  1084 Write the in-memory archive to disk.  The first argument can either be

  1085 the name of a file or a reference to an already open file handle (be a

  1086 GLOB reference).  If the second argument is true, the module will use

  1087 Compress::Zlib to write the file in a compressed format.  If

  1088 Compress:Zlib is not available, the C<write> method will fail.

  1089 Specific levels of compression can be chosen by passing the values 2

  1090 through 9 as the second parameter.

  1091 

  1092 If no arguments are given, C<write> returns the entire formatted

  1093 archive as a string, which could be useful if you\'d like to stuff the

  1094 archive into a socket or a pipe to gzip or something.  This

  1095 functionality may be deprecated later, however, as you can also do

  1096 this using a GLOB reference for the first argument.

  1097 

  1098 =item extract(@filenames)

  1099 

  1100 Write files whose names are equivalent to any of the names in

  1101 C<@filenames> to disk, creating subdirectories as necessary. This

  1102 might not work too well under VMS.  Under MacPerl, the file\'s

  1103 modification time will be converted to the MacOS zero of time, and

  1104 appropriate conversions will be done to the path.  However, the length

  1105 of each element of the path is not inspected to see whether it\'s

  1106 longer than MacOS currently allows (32 characters).

  1107 

  1108 If C<extract> is called without a list of file names, the entire

  1109 contents of the archive are extracted.

  1110 

  1111 =item list_files(['property', 'property',...])

  1112 

  1113 =item list_files()

  1114 

  1115 Returns a list of the names of all the files in the archive.

  1116 

  1117 If C<list_files()> is passed an array reference as its first argument

  1118 it returns a list of hash references containing the requested

  1119 properties of each file.  The following list of properties is

  1120 supported: name, size, mtime (last modified date), mode, uid, gid,

  1121 linkname, uname, gname, devmajor, devminor, prefix.

  1122 

  1123 Passing an array reference containing only one element, 'name', is

  1124 special cased to return a list of names rather than a list of hash

  1125 references.

  1126 

  1127 =item get_content($file)

  1128 

  1129 Return the content of the named file.

  1130 

  1131 =item replace_content($file,$content)

  1132 

  1133 Make the string $content be the content for the file named $file.

  1134 

  1135 =back