aboutsummaryrefslogtreecommitdiffstats
path: root/Packdrakeng.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Packdrakeng.pm')
-rw-r--r--Packdrakeng.pm853
1 files changed, 853 insertions, 0 deletions
diff --git a/Packdrakeng.pm b/Packdrakeng.pm
new file mode 100644
index 0000000..cad49da
--- /dev/null
+++ b/Packdrakeng.pm
@@ -0,0 +1,853 @@
+##- Nanar <nanardon@mandrake.org>
+##-
+##- This program is free software; you can redistribute it and/or modify
+##- it under the terms of the GNU General Public License as published by
+##- the Free Software Foundation; either version 2, or (at your option)
+##- any later version.
+##-
+##- This program is distributed in the hope that it will be useful,
+##- but WITHOUT ANY WARRANTY; without even the implied warranty of
+##- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+##- GNU General Public License for more details.
+##-
+##- You should have received a copy of the GNU General Public License
+##- along with this program; if not, write to the Free Software
+##- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+##- $Id$
+
+package packdrakeng;
+
+use strict;
+use warnings;
+use POSIX;
+use File::Path;
+use File::Temp qw(tempfile);
+use Compress::Zlib;
+use vars qw($VERSION);
+
+my $debug = 1;
+$VERSION = 0.10;
+
+my ($toc_header, $toc_footer) =
+ ('cz[0', '0]cz');
+my $gzip_header = pack("C" . Compress::Zlib::MIN_HDR_SIZE,
+ Compress::Zlib::MAGIC1, Compress::Zlib::MAGIC2,
+ Compress::Zlib::Z_DEFLATED(), 0,0,0,0,0,0, Compress::Zlib::OSCODE);
+my $gzip_header_len = length($gzip_header);
+
+
+sub _new {
+ my ($class, %options) = @_;
+
+ my $pack = {
+ filename => $options{archive},
+
+ compress_method => $options{compress},
+ uncompress_method => $options{uncompress},
+ force_extern => $options{extern} || 0, # Don't use perl-zlib
+ use_extern => 1, # default behaviour, informative only
+
+ level => $options{comp_level} || 6, # compression level, aka -X gzip or bzip option
+
+ bloc_size => $options{bloc_size} || 400 * 1024, # A compressed bloc will contain 400k of compressed data
+ bufsize => $options{bufsize} || 65536, # Arbitrary buffer size to read files
+
+ # Internal data
+ handle => undef, # Archive handle
+
+ # Toc information
+ files => {}, # filename => { off, size, coff, csize }
+ dir => {}, # dir => no matter what value
+ 'symlink' => {}, # file => link
+
+ coff => 0, # end of current compressed data
+
+ # Compression sub
+ subcompress => \&extern_compress,
+ subuncompress => \&extern_uncompress,
+ direct_write => 0, # Define if wrapper write directly in archive and not into temp file
+
+ # Data we need keep in memory to achieve the storage
+ current_bloc_files => {}, # Files in pending compressed bloc
+ current_bloc_csize => 0, # Actual size in pending compressed bloc
+ current_bloc_coff => 0, # The bloc bloc location (offset)
+ current_bloc_off => 0, # Actual uncompressed file offset within the pending bloc
+
+ cstream_data => undef, # Wrapper data we need to keep in memory (compression)
+ ustream_data => undef, # Wrapper data we need to keep in memory (uncompression)
+
+ # log and verbose function:
+ log => $options{quiet} ? sub {} : sub { my @w = @_; $w[0] .= "\n"; printf STDERR @w },
+ debug => $options{debug} ? sub { my @w =@_; $w[0] = "Debug: $w[0]\n"; printf STDERR @w } : sub {},
+ };
+
+ bless($pack, $class)
+}
+
+sub new {
+ my ($class, %options) = @_;
+ my $pack = _new($class, %options);
+ sysopen($pack->{handle}, $pack->{filename}, O_WRONLY | O_TRUNC | O_CREAT) or return undef;
+ $pack->choose_compression_method();
+ $pack->{need_build_toc} = 1;
+ $pack->{log}->("Creating new archive with '%s' / '%s'%s.",
+ $pack->{compress_method}, $pack->{uncompress_method},
+ $pack->{use_extern} ? "" : " (internal compression)");
+ $pack
+}
+
+sub open {
+ my ($class, %options) = @_;
+ my $pack = _new($class, %options);
+ sysopen($pack->{handle}, $pack->{filename}, O_RDONLY) or return undef;
+ $pack->read_toc();
+ $pack->{log}->("Opening archive with '%s' / '%s'%s.",
+ $pack->{compress_method}, $pack->{uncompress_method},
+ $pack->{use_extern} ? "" : " (internal compression)");
+ $pack
+}
+
+# look $pack->{(un)compressed_method} and setup functions/commands to use
+# Have some facility about detecting we want gzip/bzip
+sub choose_compression_method {
+ my ($pack) = @_;
+
+ (!defined($pack->{compress_method}) && !defined($pack->{uncompress_method}))
+ and $pack->{compress_method} = "gzip";
+ my $test_method = $pack->{compress_method} || $pack->{uncompress_method};
+
+ $test_method =~ m/^bzip2|^bunzip2/ and do {
+ $pack->{compress_method} ||= "bzip2";
+ };
+ $test_method =~ m/^gzip|^gunzip/ and do {
+ $pack->{compress_method} ||= "gzip";
+ if (!$pack->{force_extern}) {
+ $pack->{subcompress} = \&gzip_compress;
+ $pack->{subuncompress} = \&gzip_uncompress;
+ $pack->{use_extern} = 0;
+ $pack->{direct_write} = 1;
+ }
+ };
+ $pack->{uncompress_method} ||= "$pack->{compress_method} -d";
+ $pack->{compress_method} = "$pack->{compress_method} -$pack->{level}";
+}
+
+sub DESTROY {
+ my ($pack) = @_;
+ $pack->build_toc();
+ close($pack->{handle}) if ($pack->{handle});
+}
+
+# Flush current compressed bloc
+# Write
+sub build_toc {
+ my ($pack) = @_;
+ $pack->{need_build_toc} or return 1;
+ $pack->end_bloc();
+ my ($toc_length, $cf, $cd, $cl) = (0, 0, 0, 0);
+
+ sysseek($pack->{handle}, $pack->{coff}, 0) == $pack->{coff} or return 0;
+
+ foreach my $entry (keys %{$pack->{'dir'}}) {
+ $cd++;
+ $toc_length += syswrite($pack->{handle}, $entry . "\n");
+ }
+ foreach my $entry (keys %{$pack->{'symlink'}}) {
+ $cl++;
+ $toc_length += syswrite($pack->{handle}, sprintf("%s\n%s\n", $entry, $pack->{'symlink'}{$entry}));
+ }
+ foreach my $entry (sort keys %{$pack->{files}}) {
+ $cf++;
+ $toc_length += syswrite($pack->{handle}, $entry ."\n");
+ }
+ foreach my $file (sort keys %{$pack->{files}}) {
+ my $entry = $pack->{files}{$file};
+ syswrite($pack->{handle}, pack('NNNN', $entry->{coff}, $entry->{csize}, $entry->{off}, $entry->{size})) or return 0;
+ }
+ syswrite($pack->{handle}, pack("a4NNNNa40a4",
+ $toc_header,
+ $cd, $cl, $cf,
+ $toc_length,
+ $pack->{uncompress_method},
+ $toc_footer)) or return 0;
+ 1
+}
+
+sub read_toc {
+ my ($pack) = @_;
+ sysseek($pack->{handle}, -64, 2) ; #or return 0;
+ sysread($pack->{handle}, my $buf, 64);# == 64 or return 0;
+ my ($header, $toc_d_count, $toc_l_count, $toc_f_count, $toc_str_size, $uncompress, $trailer) =
+ unpack("a4NNNNZ40a4", $buf);
+ $header eq $toc_header && $trailer eq $toc_footer or do {
+ warn "Error reading toc: wrong header/trailer";
+ return 0;
+ };
+
+ $pack->{uncompress_method} ||= $uncompress;
+ $pack->choose_compression_method();
+
+ #printf STDERR "Toc size: %d + 16 * %d\n", $toc_str_size, $toc_f_count;
+ sysseek($pack->{handle}, -64 - ($toc_str_size + 16 * $toc_f_count) ,2);
+ sysread($pack->{handle}, my $fileslist, $toc_str_size);
+ my @filenames = split("\n", $fileslist);
+ sysread($pack->{handle}, my $sizes_offsets, 16 * $toc_f_count);
+ my @size_offset = unpack("N" . 4*$toc_f_count, $sizes_offsets);
+
+ foreach (1 .. $toc_d_count) {
+ $pack->{dir}{shift(@filenames)} = 1;
+ }
+ foreach (1 .. $toc_l_count) {
+ my $n = shift(@filenames);
+ $pack->{'symlink'}{$n} = shift(@filenames);
+ }
+
+ foreach (1 .. $toc_f_count) {
+ my $f = shift(@filenames);
+ $pack->{files}{$f}{coff} = shift(@size_offset);
+ $pack->{files}{$f}{csize} = shift(@size_offset);
+ $pack->{files}{$f}{off} = shift(@size_offset);
+ $pack->{files}{$f}{size} = shift(@size_offset);
+ # looking for offset for this archive
+ $pack->{files}{$f}{coff} + $pack->{files}{$f}{csize} > $pack->{coff} and
+ $pack->{coff} = $pack->{files}{$f}{coff} + $pack->{files}{$f}{csize};
+ }
+ 1
+}
+
+# Goto to the end of written compressed data
+sub end_seek {
+ my ($pack) = @_;
+ my $seekvalue = $pack->{direct_write} ? $pack->{coff} + $pack->{current_bloc_csize} : $pack->{coff};
+ sysseek($pack->{handle}, $seekvalue, 0) == $seekvalue
+}
+
+#- To terminate a compressed bloc, flush the pending compressed data,
+#- fill toc data still unknown
+sub end_bloc {
+ my ($pack) = @_;
+ $pack->end_seek() or return 0;
+ my $m = $pack->{subcompress};
+ my (undef, $csize) = $pack->$m(undef);
+ $pack->{current_bloc_csize} += $csize;
+ foreach (keys %{$pack->{current_bloc_files}}) {
+ $pack->{files}{$_} = $pack->{current_bloc_files}{$_};
+ $pack->{files}{$_}{csize} = $pack->{current_bloc_csize};
+ }
+ $pack->{coff} += $pack->{current_bloc_csize};
+ $pack->{current_bloc_coff} += $pack->{current_bloc_csize};
+ $pack->{current_bloc_csize} = 0;
+ $pack->{current_bloc_files} = {};
+ $pack->{current_bloc_off} = 0;
+
+}
+
+#######################
+# Compression wrapper #
+#######################
+
+sub extern_compress {
+ my ($pack, $sourcefh) = @_;
+ my ($insize, $outsize, $filesize) = (0, 0, 0); # aka uncompressed / compressed data length
+ my ($hin, $hout); # handle for open2
+
+ if (defined($pack->{cstream_data})) {
+ ($hin, $hout) = ($pack->{cstream_data}{hin}, $pack->{cstream_data}{hout});
+ $filesize = (stat($pack->{cstream_data}{file_bloc}))[7];
+ }
+ if (defined($sourcefh)) {
+ if (!defined($pack->{cstream_data})) {
+ ($hin, $pack->{cstream_data}{file_bloc}) = tempfile();
+ CORE::open($hout, "|$pack->{compress_method} > $pack->{cstream_data}{file_bloc}") or do {
+ warn "Unable to start $pack->{compress_method}";
+ return 0, 0;
+ };
+ ($pack->{cstream_data}{hin}, $pack->{cstream_data}{hout}) = ($hin, $hout);
+ binmode $hin; binmode $hout;
+ $| =1;
+ }
+ # until we have data to push or data to read
+ while (my $length = sysread($sourcefh, my $data, $pack->{bufsize})) {
+ # pushing data to compressor
+ (my $l = syswrite($hout, $data)) == $length or do {
+ warn "can't push all data to compressor";
+ };
+ $insize += $l;
+ $outsize = (stat($pack->{cstream_data}{file_bloc}))[7];
+ }
+ } elsif (defined($pack->{cstream_data})) {
+ # If $sourcefh is not set, this mean we want a flush(), for end_bloc()
+ close($hout);
+ unlink($pack->{cstream_data}{file_bloc});
+ while (my $lenght = sysread($hin, my $data, $pack->{bufsize})) {
+ (my $l = syswrite($pack->{handle}, $data)) == $lenght or do {
+ warn "Can't write all data in archive";
+ };
+ $outsize += $l;
+ }
+ close($hin);
+ $pack->{cstream_data} = undef;
+ }
+ ($insize, $outsize - $filesize)
+}
+
+sub extern_uncompress {
+ my ($pack, $destfh, $fileinfo) = @_;
+
+ # We have to first extract the bloc to a temp file, burk !
+ my ($tempfh, $tempname) = tempfile();
+
+ my $cread = 0;
+ while ($cread < $fileinfo->{csize}) {
+ my $cl = sysread($pack->{handle}, my $data,
+ $cread + $pack->{bufsize} > $fileinfo->{csize} ?
+ $fileinfo->{csize} - $cread :
+ $pack->{bufsize}) or do {
+ warn("Enexpected end of file");
+ close($tempfh);
+ unlink($tempname);
+ return -1;
+ };
+ $cread += $cl;
+ syswrite($tempfh, $data) == length($data) or do {
+ warn "Can't write all data into temp file";
+ close($tempfh);
+ unlink($tempname);
+ return -1;
+ };
+ }
+ close($tempfh);
+
+ CORE::open(my $hc, "$pack->{uncompress_method} < '$tempname' |") or do {
+ warn "Can't start $pack->{uncompress_method} to uncompress data";
+ unlink($tempname);
+ return -1;
+ };
+
+ my $byteswritten = 0;
+ my $read = 0;
+
+ while ($byteswritten < $fileinfo->{size}) {
+ my $length = sysread($hc, my $data, $pack->{bufsize}) or do {
+ warn "unexpected end of stream";
+ close($hc);
+ return -1;
+ };
+
+
+ if ($read < $fileinfo->{off} && $read + $length > $fileinfo->{off}) {
+ $data = substr($data, $fileinfo->{off} - $read);
+ }
+ $read += $length;
+ if ($read <= $fileinfo->{off}) { next }
+
+ my $bw = $byteswritten + length($data) > $fileinfo->{size} ? $fileinfo->{size} - $byteswritten : length($data);
+ syswrite($destfh, $data, $bw) == $bw or do {
+ warn "Can't write data into dest";
+ return -1;
+ };
+ $byteswritten += $bw;
+ }
+
+ close($hc);
+ unlink($tempname); # deleting temp file
+ $byteswritten
+
+}
+
+sub gzip_compress {
+ my ($pack, $sourcefh) = @_;
+ my ($insize, $outsize) = (0, 0); # aka uncompressed / compressed data length
+
+ # If $sourcefh is not set, this mean we want a flush(), for end_bloc()
+ # EOF, flush compress stream, adding crc
+ if (!defined($sourcefh)) {
+ if (defined($pack->{cstream_data}{object})) {
+ my ($cbuf, $status) = $pack->{cstream_data}{object}->flush();
+ $outsize += syswrite($pack->{handle}, $cbuf);
+ $outsize += syswrite($pack->{handle}, pack("V V", $pack->{cstream_data}{crc}, $pack->{cstream_data}{object}->total_in()));
+ }
+ $pack->{cstream_data} = undef;
+ return(undef, $outsize);
+ }
+
+ if (!defined $pack->{cstream_data}{object}) {
+ # Writing gzip header file
+ $outsize += syswrite($pack->{handle}, $gzip_header);
+ $pack->{cstream_data}{object} = deflateInit(
+ -Level => $pack->{level},
+ # Zlib do not create gzip header, except with this flag
+ -WindowBits => - MAX_WBITS(),
+ );
+ }
+
+ binmode $sourcefh;
+
+ while (my $lenght = sysread($sourcefh, my $buf, $pack->{bufsize})) {
+ $pack->{cstream_data}{crc} = crc32($buf, $pack->{cstream_data}{crc});
+ my ($cbuf, $status) = $pack->{cstream_data}{object}->deflate($buf);
+ $outsize += syswrite($pack->{handle}, $cbuf);
+ $insize += $lenght;
+ }
+
+ ($insize, $outsize)
+}
+
+sub gzip_uncompress {
+ my ($pack, $destfh, $fileinfo) = @_;
+ my $x = inflateInit(
+ -WindowBits => - MAX_WBITS(),
+ );
+ my $cread = 0; # Compressed data read
+ {
+ my $buf;
+ # get magic
+ if (sysread($pack->{handle}, $buf, 2) == 2) {
+ my @magic = unpack("C*", $buf);
+ $magic[0] == Compress::Zlib::MAGIC1 && $magic[1] == Compress::Zlib::MAGIC2 or do {
+ warn("Wrong magic header found");
+ return -1;
+ };
+ } else {
+ warn("Unexpect end of file while reading magic");
+ return -1;
+ }
+ my ($method, $flags);
+ if (sysread($pack->{handle}, $buf, 2) == 2) {
+ ($method, $flags) = unpack("C2", $buf);
+ } else {
+ warn("Unexpect end of file while reading flags");
+ return -1;
+ }
+
+ if (sysread($pack->{handle}, $buf, 6) != 6) {
+ warn("Unexpect end of file while reading gzip header");
+ return -1;
+ }
+
+ $cread += 12; #Gzip header fixed size is already read
+ if ($flags & 0x04) {
+ if (sysread($pack->{handle}, $buf, 2) == 2) {
+ my $len = unpack("I", $buf);
+ $cread += $len;
+ if (sysread($pack->{handle}, $buf, $len) != $len) {
+ warn("Unexpect end of file while reading gzip header");
+ return -1;
+ }
+ } else {
+ warn("Unexpect end of file while reading gzip header");
+ return -1;
+ }
+ }
+ }
+ my $byteswritten = 0;
+ my $read = 0; # uncompressed data read
+ while ($byteswritten < $fileinfo->{size}) {
+ my $cl=sysread($pack->{handle}, my $buf,
+ $cread + $pack->{bufsize} > $fileinfo->{csize} ?
+ $fileinfo->{csize} - $cread :
+ $pack->{bufsize}) or do {
+ warn("Enexpected end of file");
+ return -1;
+ };
+ $cread += $cl;
+ my ($out, $status) = $x->inflate(\$buf);
+ $status == Z_OK || $status == Z_STREAM_END or do {
+ warn("Unable to uncompress data");
+ return -1;
+ };
+ my $l = length($out) or next;
+ if ($read < $fileinfo->{off} && $read + $l > $fileinfo->{off}) {
+ $out = substr($out, $fileinfo->{off} - $read);
+ }
+ $read += $l;
+ if ($read <= $fileinfo->{off}) { next }
+
+ my $bw = $byteswritten + length($out) > $fileinfo->{size} ? $fileinfo->{size} - $byteswritten : length($out);
+ syswrite($destfh, $out, $bw) == $bw or do {
+ warn "Can't write data into dest";
+ return -1;
+ };
+ $byteswritten += $bw;
+
+ }
+ $byteswritten
+}
+
+###################
+# Debug functions #
+###################
+
+# This function extract in $dest the whole bloc containing $file, can be usefull for debugging
+sub extract_bloc {
+ my ($pack, $dest, $file) = @_;
+
+ sysopen(my $handle, $dest, O_WRONLY | O_TRUNC | O_CREAT) or do {
+ warn "Can't open $dest";
+ return -1;
+ };
+
+ sysseek($pack->{handle}, $pack->{files}{$file}->{coff}, 0) == $pack->{files}{$file}->{coff} or do {
+ warn("Can't seek to offset $pack->{files}{$file}->{coff}");
+ close($handle);
+ return -1;
+ };
+
+ {
+ my $l;
+ $l = sysread($pack->{handle}, my $buf, $pack->{files}{$file}->{csize}) == $pack->{files}{$file}->{csize} or warn "Read only $l / $pack->{files}{$file}->{csize} bytes";
+ syswrite($handle, $buf);
+ }
+
+ foreach (sort {
+ $pack->{files}{$a}{coff} == $pack->{files}{$b}{coff} ?
+ $pack->{files}{$a}{off} <=> $pack->{files}{$b}{off} :
+ $pack->{files}{$a}{coff} <=> $pack->{files}{$b}{coff}
+ } keys %{$pack->{files}}) {
+ $pack->{files}{$_}{coff} == $pack->{files}{$file}->{coff} or next;
+ }
+
+ close($handle);
+
+}
+
+##################################
+# Really working functions #
+# Aka function poeple should use #
+##################################
+
+sub add_virtual {
+ my ($pack, $type, $filename, $data) = @_;
+ $type eq 'l' and do {
+ $pack->{'symlink'}{$filename} = $data;
+ $pack->{need_build_toc} = 1;
+ return 1;
+ };
+ $type eq 'd' and do {
+ $pack->{dir}{$filename}++;
+ $pack->{need_build_toc} = 1;
+ return 1;
+ };
+ $type eq 'f' and do {
+ # Be sure we are at the end, allow extract + add in only one instance
+ $pack->end_seek() or do {
+ warn("Can't seek to offset $pack->{coff}");
+ next;
+ };
+
+ my $m = $pack->{subcompress};
+ my ($size, $csize) = $pack->$m($data);
+ $pack->{current_bloc_files}{$filename} = {
+ size => $size,
+ off => $pack->{current_bloc_off},
+ coff => $pack->{current_bloc_coff},
+ csize => -1, # Still unknown, will be fill by end_bloc
+ }; # Storing in toc structure availlable info
+
+ # Updating internal info about current bloc
+ $pack->{current_bloc_off} += $size;
+ $pack->{current_bloc_csize} += $csize;
+ $pack->{need_build_toc} = 1;
+ if ($pack->{bloc_size} > 0 && $pack->{current_bloc_csize} >= $pack->{bloc_size}) {
+ $pack->end_bloc();
+ }
+ return 1;
+ };
+ 0
+}
+
+sub add {
+ my ($pack, $prefix, @files) = @_;
+ $prefix ||= ""; $prefix =~ s://+:/:;
+ foreach my $file (@files) {
+ $file =~ s://+:/:;
+ my $srcfile = $prefix ? "$prefix/$file" : $file;
+
+ -l $file and do {
+ $pack->add_virtual('l', $file, readlink($srcfile));
+ next;
+ };
+ -d $file and do { # dir simple case
+ $pack->add_virtual('d', $file);
+ next;
+ };
+ -f $file and do {
+ sysopen(my $htocompress, $srcfile, O_RDONLY) or next;
+ $pack->add_virtual('f', $file, $htocompress);
+ close($htocompress);
+ next;
+ };
+ }
+ 1
+}
+
+sub extract_virtual {
+ my ($pack, $destfh, $filename) = @_;
+ defined($pack->{files}{$filename}) or return -1;
+ sysseek($pack->{handle}, $pack->{files}{$filename}->{coff}, 0) == $pack->{files}{$filename}->{coff} or do {
+ warn("Can't seek to offset $pack->{files}{$filename}->{coff}");
+ return -1;
+ };
+ my $m = $pack->{subuncompress};
+ $pack->$m($destfh, $pack->{files}{$filename});
+}
+
+sub extract {
+ my ($pack, $dir, @file) = @_;
+ foreach my $f (@file) {
+ my $dest = $dir ? "$dir/$f" : "$f";
+ my ($dir) = $dest =~ m!(.*)/.*!;
+ if (exists($pack->{dir}{$f})) {
+ -d $dest || mkpath($dest)
+ or warn "Unable to create dir $dest";
+ next;
+ } elsif (exists($pack->{'symlink'}{$f})) {
+ -d $dir || mkpath($dir) or do {
+ warn "Unable to create dir $dir";
+ };
+ symlink($dest, $pack->{'symlink'}{$f})
+ or warn "Unable to extract symlink $f";
+ next;
+ } elsif (exists($pack->{files}{$f})) {
+ -d $dir || mkpath($dir) or do {
+ warn "Unable to create dir $dir";
+ };
+ sysopen(my $destfh, $dest, O_CREAT | O_TRUNC | O_WRONLY)
+ or do {
+ warn "Unable to extract $dest";
+ next;
+ };
+ my $written = $pack->extract_virtual($destfh, $f);
+ $written == -1 and warn "Unable to extract file $f";
+ close($destfh);
+ next;
+ } else {
+ warn "Can't find $f in archive";
+ }
+ }
+ 1
+}
+
+# Return \@dir, \@files, \@symlink list
+sub getcontent {
+ my ($pack) = @_;
+ return([ keys(%{$pack->{dir}})], [ keys(%{$pack->{files}}) ], [ keys(%{$pack->{'symlink'}}) ]);
+}
+
+sub list {
+ my ($pack) = @_;
+ foreach my $file (keys %{$pack->{dir}}) {
+ printf "d %13c %s\n", ' ', $file;
+ }
+ foreach my $file (keys %{$pack->{'symlink'}}) {
+ printf "l %13c %s -> %s\n", ' ', $file, $pack->{'symlink'}{$file};
+ }
+ foreach my $file (sort {
+ $pack->{files}{$a}{coff} == $pack->{files}{$b}{coff} ?
+ $pack->{files}{$a}{off} <=> $pack->{files}{$b}{off} :
+ $pack->{files}{$a}{coff} <=> $pack->{files}{$b}{coff}
+ } keys %{$pack->{files}}) {
+ printf "f %12d %s\n", $pack->{files}{$file}{size}, $file;
+ }
+}
+
+# Print toc info
+sub dump {
+ my ($pack) = @_;
+ foreach my $file (keys %{$pack->{dir}}) {
+ printf "d %13c %s\n", ' ', $file;
+ }
+ foreach my $file (keys %{$pack->{'symlink'}}) {
+ printf "l %13c %s -> %s\n", ' ', $file, $pack->{'symlink'}{$file};
+ }
+ foreach my $file (sort {
+ $pack->{files}{$a}{coff} == $pack->{files}{$b}{coff} ?
+ $pack->{files}{$a}{off} <=> $pack->{files}{$b}{off} :
+ $pack->{files}{$a}{coff} <=> $pack->{files}{$b}{coff}
+ } keys %{$pack->{files}}) {
+ printf "f %d %d %d %d %s\n", $pack->{files}{$file}{size}, $pack->{files}{$file}{off}, $pack->{files}{$file}{csize}, $pack->{files}{$file}{coff}, $file;
+ }
+}
+
+1
+
+__END__
+
+=head1 NAME
+
+packdrakeng - Simple Archive Extractor/Builder
+
+=head1 SYNOPSIS
+
+ use packdrakeng;
+
+ # creating an archive
+ $pack = packdrakeng->new(archive => "myarchive.cz");
+ # Adding few files
+ $pack->add("/path/", "file1", "file2");
+ # Adding an unamed file
+ open($handle, "file");
+ $pack->add_virtual("filename", $handle);
+ close($handle);
+
+ $pack = undef;
+
+ # extracting an archive
+ $pack = packdrakeng->open(archive => "myarchive.cz");
+ # listing files
+ $pack->list();
+ # extracting few files
+ $pack->extract("/path/", "file1", "file2");
+ # extracting data into a file handle
+ open($handle, "file");
+ $pack->extract_virtual($handle, "filename");
+ close($handle);
+
+=head1 DESCRIPTION
+
+C<packdrakeng> is a simple indexed archive builder and extractor using
+standard compression method.
+
+This module is a rewrite from scratch of original packdrake, used format is
+fully compatible with old packdrake.
+
+=head1 IMPLEMENTATION
+
+Compressed data are stored by bloc:
+
+ UncompresseddatA1UncompresseddatA2 UncompresseddatA3UncompresseddatA4
+ |--- size 1 ---||--- size 2 ---| |--- size 3 ---||--- size 4 ---|
+ |<-offset1 |<-offset2 |<-offset3 |<-offset4
+
+give:
+
+ CompresseD1CompresseD2 CompresseD3CompresseD4
+ |--- c. size 1, 2 ---| |--- c. size 3, 4 ---|
+ |<-c. offset 1, 2 |<-c. offset 3, 4
+
+A new bloc is started when its size exceed the C<bloc_size> value.
+
+Compressed data are followed by the toc, ie a simple list of packed files.
+Each file name is terminated by the "\n" character:
+
+dir1
+dir2
+...
+dirN
+symlink1
+point_file1
+symlink2
+point_file2
+...
+...
+symlinkN
+point_fileN
+file1
+file2
+...
+fileN
+
+Follow the files sizes, 4 values for each files are stored:
+offset into archive of compressed bloc, size of compressed bloc,
+offset into bloc of the file and the file's size.
+
+Finally the archive contain a trailer, of 64 bytes length, about the
+toc and the archive itself:
+'cz[0', strings 4 bytes
+number of directory, 4 bytes
+number of symlinks, 4 bytes
+number of files, 4 bytes
+the toc size, 4 bytes
+the uncompressed command, strings of 40 bytes length
+'0]cz', strings 4 bytes
+
+=head1 FUNCTIONS
+
+=over
+
+=item B<new(%options)>
+
+Create a new archive.
+Options:
+
+=over 4
+
+=item archive
+
+The file name of the archive. If the file don't exists, it is create, else it is owerwritten.
+see C<open>.
+
+=item compress
+
+The application to use to compress, if unset, gzip is used.
+
+=item uncompress
+
+The application to use to extract data from archive. This option is useless if
+you're opening an existing archive (except you want to force it).
+If unset, this value is based on compress command followed by '-d' argument.
+
+=item extern
+
+If you're using gzip, by default packdrakeng use perl-zlib to limit system
+coast. This options force packdrakeng to use the extern gzip command. This
+has no with other compress programs until internal functions are not implement
+yet.
+
+=item comp_level
+
+The compression level passed as argument to the compress program. By default
+this is set to 6.
+
+=item bloc_size
+
+The limit size from which we start a new compressed bloc. The default value is
+400KB. Setting it to 0 to be sure a new bloc will be started for each packed
+files, -1 to never start a new bloc. Be aware a big size of bloc will slower
+the file extraction.
+
+=item quiet
+
+Do not ouput anythings, shut up.
+
+=item debug
+
+Print debug messages
+
+=back
+
+=item B<open(%options)>
+
+Open an existing archive for extracting or adding files.
+
+The uncompressed command is found into the archive, the compressed command is
+found from it.
+
+In case you add files, an new compressed bloc will be started regardless the
+latest bloc is smaller than the bloc_size. All compression options can't be
+find in the archive, so new preference will be applied.
+
+Options are same than the C<new()> function.
+
+=head1 AUTHOR
+
+Olivier Thauvin <nanardon@mandrake.org>
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of GNU General Public License as
+published by the Free Software Foundation; either version 2 of
+the License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+If you do not have a copy of the GNU General Public License write to
+the Free Software Foundation, Inc., 675 Mass Ave, Cambridge,
+MA 02139, USA.
+
+=cut