tar.pm

--黑客防线-精华奉献本(攻册)

	    }
	    elsif (-S $file) {	# Socket
		$typeflag = 8;	# Bogus value, POSIX doesn't believe in sockets
	    }
	    elsif (-b $file) {	# Block special
		$typeflag = 4;
	    }
	    elsif (-c $file) {	# Character special
		$typeflag = 3;
	    }
	    else {		# Something else (like what?)
		$typeflag = 9;	# Also bogus value.
	    }
	    push(@{$self->{'_data'}},{
				      name => $file,		    
				      mode => $mode,
				      uid => $uid,
				      gid => $gid,
				      size => length $data,
				      mtime => $mtime,
				      chksum => "      ",
				      typeflag => $typeflag, 
				      linkname => $linkname,
				      magic => "ustar\0",
				      version => "00",
				      # WinNT protection
				      uname => 
			      $has_getpwuid?(getpwuid($uid))[0]:"unknown",
				      gname => 
			      $has_getgrgid?(getgrgid($gid))[0]:"unknown",
				      devmajor => 0, # We don't handle this yet
				      devminor => 0, # We don't handle this yet
				      prefix => "",
				      'data' => $data,
				     });
	    $counter++;		# Successfully added file
	}
	else {
	    next;		# stat failed
	}
    }
    return $counter;
}

sub remove {
    my ($self) = shift;
    my (@files) = @_;
    my $file;
    
    foreach $file (@files) {
	@{$self->{'_data'}} = grep {$_->{name} ne $file} @{$self->{'_data'}};
    }
    return $self;
}

# Get the content of a file
sub get_content {
    my ($self) = shift;
    my ($file) = @_;
    my $entry;
    
    ($entry) = grep {$_->{name} eq $file} @{$self->{'_data'}};
    return $entry->{'data'};
}

# Replace the content of a file
sub replace_content {
    my ($self) = shift;
    my ($file,$content) = @_;
    my $entry;

    ($entry) = grep {$_->{name} eq $file} @{$self->{'_data'}};
    if ($entry) {
	$entry->{'data'} = $content;
	return 1;
    }
    else {
	return undef;
    }
}

# Add data as a file
sub add_data {
    my ($self, $file, $data, $opt) = @_;
    my $ref = {};
    my ($key);
    
    $ref->{'data'}=$data;
    $ref->{name}=$file;
    $ref->{mode}=0666&(0777-umask);
    $ref->{uid}=$>;
    $ref->{gid}=(split(/ /,$)))[0]; # Yuck
    $ref->{size}=length $data;
    $ref->{mtime}=time;
    $ref->{chksum}="      ";	# Utterly pointless
    $ref->{typeflag}=0;		# Ordinary file
    $ref->{linkname}="";
    $ref->{magic}="ustar\0";
    $ref->{version}="00";
    # WinNT protection
    $ref->{uname}=$has_getpwuid?(getpwuid($>))[0]:"unknown";
    $ref->{gname}=$has_getgrgid?(getgrgid($ref->{gid}))[0]:"unknown";
    $ref->{devmajor}=0;
    $ref->{devminor}=0;
    $ref->{prefix}="";

    if ($opt) {
	foreach $key (keys %$opt) {
	    $ref->{$key} = $opt->{$key}
	}
    }

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

# Write a single (probably) file from the in-memory archive to disk
sub extract {
    my $self = shift;
    my (@files) = @_;
    my ($file, $current, @path);

    foreach $file (@files) {
	foreach (@{$self->{'_data'}}) {
	    if ($_->{name} eq $file) {
		# For the moment, we assume that all paths in tarfiles
		# are given according to Unix standards.
		# Which they *are*, according to the tar format spec!
		(@path) = split(/\//,$file);
		$file = pop @path;
		$current = cwd;
		foreach (@path) {
		    if (-e $_ && ! -d $_) {
			warn "$_ exists but is not a directory!\n";
			next;
		    }
		    mkdir $_,0777 unless -d $_;
		    chdir $_;
		}
		if (not $_->{typeflag}) { # Ordinary file
		    open(FILE,">".$file);
		    binmode FILE;
		    print FILE $_->{'data'};
		    close FILE;
		}
		elsif ($_->{typeflag}==5) { # Directory
		    if (-e $file && ! -d $file) {
			drat;
		    }
		    mkdir $file,0777 unless -d $file;
		}
		elsif ($_->{typeflag}==1) {
		    symlink $_->{linkname},$file if $symlinks;
		}
		elsif ($_->{typeflag}==6) {
		    warn "Doesn't handle named pipes (yet).\n";
		    return 1;
		}
		elsif ($_->{typeflag}==4) {
		    warn "Doesn't handle device files (yet).\n";
		    return 1;
		}
		elsif ($_->{typeflag}==3) {
		    warn "Doesn't handle device files (yet).\n";
		    return 1;
		}
		else {
		    $error = "unknown file type: $_->{typeflag}";
		    return undef;
		}
		utime time, $_->{mtime}, $file;
		# We are root, and chown exists
		if ($>==0 and $^O ne "MacOS" and $^O ne "MSWin32") {
		    chown $_->{uid},$_->{gid},$file;
		}
		# chmod is done last, in case it makes file readonly
		# (this accomodates DOSish OSes)
		chmod $_->{mode},$file;
		chdir $current;
	    }
	}
    }
}

# Return a list of all filenames in in-memory archive.
sub list_files {
    my ($self) = shift;

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


### Standard end of module :-)
1;

=head1 NAME

Tar - module for manipulation of tar archives.

=head1 SYNOPSIS

  use Archive::Tar;

  $tar = Archive::Tar->new();
  $tar->read("origin.tar.gz",1);
  $tar->add_files("file/foo.c", "file/bar.c");
  $tar->add_data("file/baz.c","This is the file contents");
  $tar->write("files.tar");

=head1 DESCRIPTION

This is a module for the handling of tar archives. 

At the moment these methods are implemented:

=over 4

=item C<new()>

Returns a new Tar object. If given a filename as an argument, it will
try to load that as a tar file. If given a true value as a second
argument, will assume that the tar file is compressed, and will
attempt to read it using L<Compress::Zlib>.

=item C<add_files(@filenamelist)>

Takes a list of filenames and adds them to the in-memory archive. 
I suspect that this function will produce bogus tar archives when 
used under MacOS, but I'm not sure and I have no Mac to test it on.

=item C<add_data($filename,$data,$opthashref)>

Takes a filename, a scalar full of data and optionally a reference to
a hash with specific options. Will add a file to the in-memory
archive, with name C<$filename> and content C<$data>. Specific options
can be set using C<$opthashref>, which will be documented later.

=item C<remove(@filenamelist)>

Removes any entries with names matching any of the given filenames
from the in-memory archive. String comparisons are done with C<eq>.

=item C<read('F<file.tar>',$compressed)>

Try to read the given tarfile into memory. If the second argument is a
true value, the tarfile is assumed to be compressed. Will I<replace>
any previous content in C<$tar>!

=item C<write('F<file.tar>',$compressed)>

Will write the in-memory archive to disk. If no filename is given,
returns the entire formatted archive as a string, which should be
useful if you'd like to stuff the archive into a socket or a pipe to
gzip or something. If the second argument is true, the module will try
to write the file compressed.

=item C<data()>

Returns the in-memory archive. This is a list of references to hashes,
the internals of which is not currently documented.

=item C<extract(@filenames)>

Write files whose names are equivalent to any of the names in
C<@filenames> to disk, creating subdirectories as neccesary. This
might not work too well under VMS and MacOS.

=item C<list_files()>

Returns a list with the names of all files in the in-memory archive.

=item C<get_content($file)>

Return the content of the named file.

=item C<replace_content($file,$content)>

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

=back

=head1 CHANGES

=over 4

=item Version 0.071

Minor release.

Arrange to chmod() at the very end in case it makes the file readonly.
Win32 is actually picky about that.

SunOS 4.x tar makes tarfiles that contain directory entries
that don't have typeflag set properly.  We use the trailing
slash to recognize directories in such tarfiles.

=item Version 0.07

Fixed (hopefully) broken portability to MacOS, reported by Paul J.
Schinder at Goddard Space Flight Center.

Fixed two bugs with symlink handling, reported in excellent detail by
an admin at teleport.com called Chris.

Primive tar program (called ptar) included with distribution. Useage
should be pretty obvious if you've used a normal tar program.

Added methods get_content and replace_content.

Added support for paths longer than 100 characters, according to
POSIX. This is compatible with just about everything except GNU tar.
Way to go, GNU tar (use a better tar, or GNU cpio). 

NOTE: When adding files to an archive, files with basenames longer
      than 100 characters will be silently ignored. If the prefix part
      of a path is longer than 155 characters, only the last 155
      characters will be stored.

=item Version 0.06

Added list_files() method, as requested by Michael Wiedman.

Fixed a couple of dysfunctions when run under Windows NT. Michael
Wiedmann reported the bugs.

Changed the documentation to reflect reality a bit better.

Fixed bug in format_tar_entry. Bug reported by Michael Schilli.

=item Version 0.05

Quoted lots of barewords to make C<use strict;> stop complaining under
perl version 5.003.

Ties to L<Compress::Zlib> put in. Will warn if it isn't available.

$tar->write() with no argument now returns the formatted archive.

=item Version 0.04

Made changes to write_tar so that Solaris tar likes the resulting
archives better.

Protected the calls to readlink() and symlink(). AFAIK this module
should now run just fine on Windows NT.

Add method to write a single entry to disk (extract)

Added method to add entries entirely from scratch (add_data)

Changed name of add() to add_file()

All calls to croak() removed and replaced with returning undef and
setting Tar::error.

Better handling of tarfiles with garbage at the end.

=cut