- rename packdrakeng.pm to Packdrakeng.pm to follow perl policy

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