diff options
author | Rafael Garcia-Suarez <rgarciasuarez@mandriva.org> | 2005-11-15 12:21:27 +0000 |
---|---|---|
committer | Rafael Garcia-Suarez <rgarciasuarez@mandriva.org> | 2005-11-15 12:21:27 +0000 |
commit | b571220cbbbde8891200514f1ff2121a930190f6 (patch) | |
tree | 0e798981b9ba7f2c7464ad455725945619f1ea92 | |
parent | 2467af4e8aad36e46336e1e260fbe9064e0392a1 (diff) | |
download | rpmtools-b571220cbbbde8891200514f1ff2121a930190f6.tar rpmtools-b571220cbbbde8891200514f1ff2121a930190f6.tar.gz rpmtools-b571220cbbbde8891200514f1ff2121a930190f6.tar.bz2 rpmtools-b571220cbbbde8891200514f1ff2121a930190f6.tar.xz rpmtools-b571220cbbbde8891200514f1ff2121a930190f6.zip |
Replace modules by wrappers around new MDV:: namespace. Add a deprecation warning.
-rw-r--r-- | Distribconf.pm | 402 | ||||
-rw-r--r-- | Distribconf/Build.pm | 211 | ||||
-rw-r--r-- | Packdrakeng.pm | 900 | ||||
-rw-r--r-- | Packdrakeng/zlib.pm | 179 |
4 files changed, 28 insertions, 1664 deletions
diff --git a/Distribconf.pm b/Distribconf.pm index 8c7735c..1bebf57 100644 --- a/Distribconf.pm +++ b/Distribconf.pm @@ -2,406 +2,18 @@ package Distribconf; (our $VERSION) = q$Id$ =~ /(\d+\.\d+)/; -=head1 NAME - -Distribconf - perl module to get config from a Mandriva Linux distribution tree - -=head1 SYNOPSIS - - use Distribconf; - - my $d = Distribconf->new("/path/to/the/distribution/root"); - $d->load() - or die "This doesn't seem to be a distribution tree\n"; - - print $d->getpath(undef, "root") ."\n"; - foreach ($d->listmedia) { - printf "%s -> %s\n", $d->getpath($_, "hdlist"), $d->getpath($_, path); - } - -=head1 DESCRIPTION - -Distribconf is a module to get/write the configuration of a Mandriva Linux -distribution tree. This configuration is stored in a file called F<media.cfg>, -aimed at replacing the old-style F<hdlists> file. - -The format of the F<hdlists> file is limited and doesn't allow to add new -values without breaking compatibility, while F<media.cfg> is designed for -extensibility. To keep compatibility with old tools, this module is able -to generate an F<hdlists> file based on F<media.cfg>. - -This module is able to manage both configuration of old-style trees -(F<Mandrake/base/> for OS versions 10.0 and older) and of new-style ones -(F<media/media_info/> for 10.1 and newer). - -=head1 media.cfg - -The F<media.cfg> is structured like a classical F<.ini> file. All -parameters are optional; this means that a readable empty file is ok, if -this is what you want :) - -F<media.cfg> contains sections, each section corresponding to a media, -except the C<[media_info]> section wich is used to store global info. The -section name is the (relative) path where the rpms are located. It is -sufficient to uniquely identify a media. - -Some values have specific signification: - -=over 4 - -=item media specific values: - -=over 4 - -=item B<hdlist> - -The path or basename of the hdlist. By default, this is -C<hdlist_mediapath.cz>, with slashes and spaces being replaced by '_'. - -=item B<synthesis> - -The path or basename of the synthesis. By default, this is the hdlist -name prefixed by C<synthesis>. - -=item B<pubkey> - -The path or basename of the gpg public key file. By default, this is -the media name prefixed by C<pubkey_>. - -=item B<name> - -A human-readable name for the media. By default this is the media path -(that is, the section name), where slashes have been replaced by -underscores. - -=back - -=item global specific values: - -=over 4 - -=item B<version> - -OS version. - -=item B<branch> - -OS branch (cooker, etc.) - -=item B<arch> - -Media target architecture. - -=item B<root> - -The root path of the distribution tree. This value is not set in -F<media.cfg>, can't be owerwritten, and is only used internally. - -=item B<mediadir> - -The default path relative to the 'root' path where media are -located. Distribconf is supposed to configure this automatically -to C<Mandrake> or to C<media>, depending on the OS version. - -=item B<infodir> - -The default path relative to the 'root' path where distrib metadata -are located. Distribconf is supposed to configure this automatically -to C<Mandrake/base> or to C<media/media_info>, depending on the OS -version. - -=back - -=back - -For the paths of the hdlist and synthesis files, if only a basename is -provided, the path is assumed to be relative to the mediadir or infodir. -(hdlist and synthesis are created in both directories.) If it's a complete -path, it's assumed to be relative to the 'root'. For example, - - hdlist.cz -> <root>/<infodir>/hdlist.cz - ./hdlist.cz -> <root>/./hdlist.cz - -Here's a complete example of a F<media.cfg> file: - - # Comment - [media_info] - # some tools can use those values - version=2006.0 - branch=cooker - - [main] - hdlist=hdlist_main.cz - name=Main - - [../SRPMS/main] - hdlist=hdlist_main.src.cz - name=Main Sources - noauto=1 - - [contrib] - hdlist=hdlist_contrib.cz - name=Contrib - - [../SRPMS/contrib] - hdlist=hdlist_contrib.src.cz - name=Contrib Sources - noauto=1 - -=head1 METHODS - -=cut - -use strict; -use warnings; -use Config::IniFiles; - -=head2 Distribconf->new($root) - -Returns a new Distribconf object, C<$root> being the top level -directory of the tree. - -=cut - -sub new { - my ($class, $path) = @_; - bless { - root => $path, - infodir => '', - mediadir => '', - cfg => new Config::IniFiles(-default => 'media_info', -allowcontinue => 1), - }, $class; -} - -=head2 $distrib->load() - -Finds and loads the configuration of the distrib: locate the path where -information is found; if available loads F<media.cfg>, if available loads -F<hdlists>. - -Returns 1 on success, 0 error (that is, if no directory containing media -information is found, or if no F<media.cfg>, neither F<hdlists> files are -found). - -See also L<loadtree>, L<parse_hdlists> and L<parse_mediacfg>. - -=cut - -sub load { - my ($distrib) = @_; - $distrib->loadtree() or return 0; - $distrib->parse_mediacfg() || $distrib->parse_hdlists() or return 0; - return 1; -} - -=head2 $distrib->loadtree() - -Tries to find a valid media information directory, and set infodir and -mediadir. Returns 1 on success, 0 if no media information directory was -found. - -=cut - -sub loadtree { - my ($distrib) = @_; - - if (-d "$distrib->{root}/media/media_info") { - $distrib->{infodir} = "media/media_info"; - $distrib->{mediadir} = "media"; - } elsif (-d "$distrib->{root}/Mandrake/base") { - $distrib->{infodir} = "Mandrake/base"; - $distrib->{mediadir} = "Mandrake"; - } else { - return 0; - } - return 1; -} - -=head2 $distrib->parse_hdlists($hdlists) - -Reads the F<hdlists> file whose path is given by the parameter $hdlist, -or, if no parameter is specified, the F<hdlists> file found in the media -information directory of the distribution. Returns 1 on success, 0 if no -F<hdlists> can be found or parsed. - -=cut - -sub parse_hdlists { - my ($distrib, $hdlists) = @_; - $hdlists ||= "$distrib->{root}/$distrib->{infodir}/hdlists"; - - open my $h_hdlists, "<", $hdlists - or return 0; - $distrib->{cfg} = new Config::IniFiles( -default => 'media_info', -allowcontinue => 1); - my $i = 0; - foreach (<$h_hdlists>) { - s/#.*//; s/^\s*//; - chomp; - length or next; - my ($options, %media); - ($options, @media{qw/hdlist path name size/}) = /^\s*(?:(.*):)?(\S+)\s+(\S+)\s+([^(]*)(?:\s+\((\w+)\))?$/; - if ($options) { - $media{$_} = 1 foreach split /:/, $options; - } - $media{name} =~ s/\s*$//; - $media{path} =~ s!^$distrib->{mediadir}/+!!; - foreach (qw/hdlist name size/, $options ? split(/:/, $options) : ()) { - $distrib->{cfg}->newval($media{path}, $_, $media{$_}) - or die "Can't set value [$_]\n"; - } - } - close($h_hdlists); - - return 1; -} - -=head2 $distrib->parse_version($fversion) - -Reads the F<VERSION> file whose path is given by the parameter $fversion, -or, if no parameter is specified, the F<VERSION> file found in the media -information directory of the distribution. Returns 1 on success, 0 if no -F<VERSION> can be found or parsed. - -=cut - -sub parse_version { - my ($distrib, $fversion) = @_; - $fversion ||= $distrib->getfullpath(undef, 'VERSION'); - open my $h_ver, "<", $fversion - or return 0; - my $l = <$h_ver>; - close $h_ver; - chomp $l; - # XXX heuristics ahead. This breaks regularly. - my ($version, $branch, $product, $arch) = $l =~ /^(?:mandrake|mandriva) ?linux\s+(\w+)\s+([^- ]*)-([^- ]*)-([^- ]*)/i; - $distrib->{cfg}->newval('media_info', 'version', $version); - $distrib->{cfg}->newval('media_info', 'branch', $branch); - $distrib->{cfg}->newval('media_info', 'product', $product); - $distrib->{cfg}->newval('media_info', 'arch', $arch); - return 1; -} - -=head2 $distrib->parse_mediacfg($mediacfg) - -Reads the F<media.cfg> file whose path is given by the parameter -$mediacfg, or, if no parameter is specified, the F<media.cfg> file found -in the media information directory of the distribution. Returns 1 on -success, 0 if no F<media.cfg> can be found or parsed. - -=cut - -sub parse_mediacfg { - my ($distrib, $mediacfg) = @_; - $mediacfg ||= "$distrib->{root}/$distrib->{infodir}/media.cfg"; - (-f $mediacfg && -r _) && - ($distrib->{cfg} = new Config::IniFiles( -file => $mediacfg, -default => 'media_info', -allowcontinue => 1)) - or return 0; - return 1; -} - -=head2 $distrib->listmedia() - -Returns an array of existing media in the configuration - -=cut - -sub listmedia { - my ($distrib) = @_; - return grep { $_ ne 'media_info' } $distrib->{cfg}->Sections; -} - -=head2 $distrib->getvalue($media, $var) - -Returns the $var value for $media, or C<undef> if the value is not set. - -If $var is "name", "hdlist" or "synthesis", and if the value is not explicitly -defined, the return value is expanded from $media. - -If $media is "media_info" or C<undef>, you'll get the global value. - -This function doesn't take care about path, see L<getpath>. - -=cut - -sub getvalue { - my ($distrib, $media, $var) = @_; - $media ||= 'media_info'; - - my $default = ""; - for ($var) { - /^synthesis$/ and $default = 'synthesis.' . lc($distrib->getvalue($media, 'hdlist')); - /^hdlist$/ and $default = 'hdlist_' . lc($distrib->getvalue($media, 'name')) . '.cz'; - /^pubkey$/ and $default = 'pubkey_' . lc($distrib->getvalue($media, 'name')); - /^name$/ and $default = $media; - $default =~ s![/ ]+!_!g; - /^path$/ and return $media; - /^root$/ and return $distrib->{root}; - /^VERSION$/ and do { $default = 'VERSION'; last }; - /^product$/ and do { $default = 'Download'; last }; - /^(?:tag|branch)$/ and do { $default = ''; last }; - /^(?:media|info)dir$/ and do { $default = $distrib->{$var}; last }; - } - return $distrib->{cfg}->val($media, $var, $default); -} - -=head2 $distrib->getpath($media, $var) - -Gives relative path of $var from the root of the distrib. This function is -useful to know where files are actually located. It takes care of location -of media, location of index files, and paths set in the configuration. - -=cut - -sub getpath { - my ($distrib, $media, $var) = @_; - - my $val = $distrib->getvalue($media, $var); - $var =~ /^(?:root|VERSION)$/ and return $val; - return ($val =~ m!/! ? "" : ($var eq 'path' ? $distrib->{mediadir} : $distrib->{infodir} ) . "/") . $val; -} - -=head2 $distrib->getfullpath($media, $var) - -Does the same thing than getpath(), but the return value will be -prefixed by the 'root' path. This is a shortcut for: - - $distrib->getpath(undef, 'root') . '/' . $distrib->getpath($media, $var). - -=cut - -sub getfullpath { - my $distrib = shift; - return $distrib->getpath(undef, 'root') . '/' . $distrib->getpath(@_); -} +use MDV::Distribconf; +*Distribconf:: = *MDV::Distribconf::; +warn "Warning: Distribconf is deprecated, use MDV::Distribconf instead.\n"; 1; -__END__ - -=head1 SEE ALSO - -gendistrib(1) - -=head1 AUTHOR - -The code has been written by Olivier Thauvin <nanardon@mandriva.org> and is -currently maintained by Rafael Garcia-Suarez <rgarciasuarez@mandriva.com>. -Thanks to Sylvie Terjan <erinmargault@mandriva.org> for the spell checking. - -(c) 2005 Olivier Thauvin +=head1 NAME -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. +Distribconf - Compatibility wrapper around MDV::Distribconf -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. +=head1 DESCRIPTION -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. +Don't use this module. Use MDV::Distribconf instead. =cut diff --git a/Distribconf/Build.pm b/Distribconf/Build.pm index 1d5cb4c..6956637 100644 --- a/Distribconf/Build.pm +++ b/Distribconf/Build.pm @@ -1,217 +1,20 @@ -##- Nanar <nanardon@mandriva.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 Distribconf::Build; -=head1 NAME - -Distribconf::Build - Extension to Distribconf to build configuration - -=head1 METHODS - -=over 4 - -=cut - -use strict; -use warnings; use Distribconf; +use MDV::Distribconf::Build; -our @ISA = qw(Distribconf); our $VERSION = $Distribconf::VERSION; -=item Distribconf::Build->new($root_of_distrib) - -Returns a new Distribconf::Build object. - -=cut - -sub new { - my $class = shift; - my $self = $class->SUPER::new(@_); - bless $self, $class; -} - -=item $distrib->setvalue($media, $var, $val) - -Sets or adds $var parameter from $media to $val. If $media doesn't exist, -it is implicitly created. If $var is C<undef>, a new media is created with -no defined parameters. - -=cut - -sub setvalue { - my ($distrib, $media, $var, $val) = @_; - if ($var) { - $var =~ /^(?:media|info)dir\z/ and do { - $distrib->{$var} = $val; - return; - }; - $distrib->{cfg}->newval($media, $var, $val) - or die "Can't set value [$var=$val] for $media\n"; - } else { - $distrib->{cfg}->AddSection($media); - } -} - -=item $distrib->write_hdlists($hdlists) - -Writes the F<hdlists> file to C<$hdlists>, or if no parameter is given, in -the media information directory. C<$hdlists> can be a file path or a file -handle. Returns 1 on success, 0 on error. - -=cut - -sub write_hdlists { - my ($distrib, $hdlists) = @_; - my $h_hdlists; - if (ref $hdlists eq 'GLOB') { - $h_hdlists = $hdlists; - } else { - $hdlists ||= "$distrib->{root}/$distrib->{infodir}/hdlists"; - open $h_hdlists, ">", $hdlists - or return 0; - } - foreach my $media ($distrib->listmedia) { - printf($h_hdlists "%s%s\t%s\t%s\t%s\n", - join('', map { "$_:" } grep { $distrib->getvalue($media, $_) } qw/askmedia suppl noauto/) || "", - $distrib->getvalue($media, 'hdlist'), - $distrib->getpath($media, 'path'), - $distrib->getvalue($media, 'name'), - $distrib->getvalue($media, 'size') ? '('.$distrib->getvalue($media, 'size'). ')' : "", - ) or return 0; - } - return 1; -} - -=item $distrib->write_mediacfg($mediacfg) - -Write the media.cfg file into the media information directory, or into the -$mediacfg given as argument. $mediacfg can be a file path, or a glob reference -(\*STDOUT for example). - -Returns 1 on success, 0 on error. - -=cut - -sub write_mediacfg { - my ($distrib, $hdlistscfg) = @_; - $hdlistscfg ||= "$distrib->{root}/$distrib->{infodir}/media.cfg"; - $distrib->{cfg}->WriteConfig($hdlistscfg); -} - -=item $distrib->write_version($version) - -=cut - -sub write_version { - my ($distrib, $version) = @_; - my $h_version; - if (ref($version) eq 'GLOB') { - $h_version = $version; - } else { - $version ||= $distrib->getfullpath(undef, 'VERSION'); - open($h_version, ">", $version) or return 0; - } - - my @gmt = gmtime(time); - - printf($h_version "Mandriva Linux %s %s-%s-%s%s %s\n", - $distrib->getvalue(undef, 'version') || 'cooker', - $distrib->getvalue(undef, 'branch') || 'cooker', - $distrib->getvalue(undef, 'arch') || 'noarch', - $distrib->getvalue(undef, 'product'), - $distrib->getvalue(undef, 'tag') ? '-' . $distrib->getvalue(undef, 'tag') : '', - sprintf("%04d%02d%02d %02d:%02d", $gmt[5] + 1900, $gmt[4]+1, $gmt[3], $gmt[2], $gmt[1]) - ); - - if (ref($version) ne 'GLOB') { - close($h_version); - } - return 1; -} - - -=item $distrib->check($fhout) - -Performs basic checks on the distribution and prints to $fhout (STDERR by -default) warnings and errors found. Returns the number of errors reported. - -=cut - -sub check { - my ($distrib, $fhout) = @_; - $fhout ||= \*STDERR; - - my $error = 0; - - my $report_err = sub { - my ($l, $f, @msg) = @_; - $l eq 'E' and $error++; - printf $fhout "$l: $f\n", @msg; - }; - - $distrib->listmedia or $report_err->('W', "No media found in this config"); - - # Checking no overlap - foreach my $var (qw/hdlist synthesis path/) { - my %e; - foreach ($distrib->listmedia) { - my $v = $distrib->getpath($_, $var); - push @{$e{$v}}, $_; - } - - foreach my $key (keys %e) { - if (@{$e{$key}} > 1) { - $report_err->('E', "media %s have same %s (%s)", - join (", ", @{$e{$key}}), - $var, - $key - ); - } - } - } - - foreach my $media ($distrib->listmedia) { - -d $distrib->getfullpath($media, 'path') or $report_err->( - 'E', "dir %s does't exist for media '%s'", - $distrib->getpath($media, 'path'), - $media - ); - foreach (qw/hdlist synthesis pubkey/) { - -f $distrib->getfullpath($media, $_) or $report_err->( - 'E', "$_ %s doesn't exist for media '%s'", - $distrib->getpath($media, $_), - $media - ); - } - } - return $error; -} - +*Distribconf::Build:: = *MDV::Distribconf::Build::; +warn "Warning: Distribconf::Build is deprecated, use MDV::Distribconf::Build instead.\n"; 1; -__END__ +=head1 NAME -=back +Distribconf::Build - Compatibility wrapper around MDV::Distribconf::Build -=head1 SEE ALSO +=head1 DESCRIPTION -L<Distribconf> +Don't use this module. Use MDV::Distribconf::Build instead. =cut diff --git a/Packdrakeng.pm b/Packdrakeng.pm index 8757242..57b4ca8 100644 --- a/Packdrakeng.pm +++ b/Packdrakeng.pm @@ -1,909 +1,19 @@ -##- Nanar <nanardon@mandriva.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. - package Packdrakeng; -use strict; -use POSIX qw(O_WRONLY O_TRUNC O_CREAT O_RDONLY O_APPEND); - (our $VERSION) = q($Id$) =~ /(\d+\.\d+)/; -my ($toc_header, $toc_footer) = - ('cz[0', '0]cz'); - -# File::Temp qw(tempfile) hack to not require it -sub tempfile { - my ($count, $fname, $handle) = (0, undef, undef); - do { - ++$count > 10 and do { - warn "Can't create temporary file ($fname)"; - return (undef, undef); - }; - $fname = sprintf("%s/packdrakeng.%s.%s", - $ENV{TMPDIR} || '/tmp', - $$, - # Generating an random name - join("", map { $_=rand(51); $_ += $_ > 25 && $_ < 32 ? 91 : 65 ; chr($_) } (0 .. 4))); - } while !sysopen($handle, $fname, O_WRONLY | O_APPEND | O_CREAT); - return ($handle, $fname); -} - -# File::Path hack to not require it -sub mkpath { - my ($path) = @_; - $path =~ s:/*$::; # removing leading '/' - -d $path and return 1; - # need parent creation ? - if (index($path, '/') > 0) { - mkpath(substr($path, 0, rindex($path, '/'))) or return 0; - } - mkdir($path) -} - -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 - noargs => $options{noargs}, - - # compression level, aka -X gzip or bzip option - level => defined($options{comp_level}) ? $options{comp_level} : 6, - - # A compressed block will contain 400k of compressed data - block_size => defined($options{block_size}) ? $options{block_size} : 400 * 1024, - 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_block_files => {}, # Files in pending compressed block - current_block_csize => 0, # Actual size in pending compressed block - current_block_coff => 0, # The block block location (offset) - current_block_off => 0, # Actual uncompressed file offset within the pending block - - 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->{debug}->("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() or return undef; - $pack->{debug}->("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}) { - eval { - require Compress::Zlib; #- need this to ensure that Packdrakeng::zlib will load properly - require Packdrakeng::zlib; - $pack->{subcompress} = \&Packdrakeng::zlib::gzip_compress; - $pack->{subuncompress} = \&Packdrakeng::zlib::gzip_uncompress; - $pack->{use_extern} = 0; - $pack->{direct_write} = 1; - }; - } - }; - if (!$pack->{noargs}) { - $pack->{uncompress_method} ||= "$pack->{compress_method} -d"; - $pack->{compress_method} = $pack->{compress_method} ? "$pack->{compress_method} -$pack->{level}" : ""; - } -} - -sub DESTROY { - my ($pack) = @_; - $pack->{subuncompress}($pack, undef, undef); - $pack->build_toc(); - close($pack->{handle}) if $pack->{handle}; - close($pack->{ustream_data}{handle}) if $pack->{ustream_data}{handle}; -} - -# Flush current compressed block -# Write -sub build_toc { - my ($pack) = @_; - $pack->{need_build_toc} or return 1; - $pack->end_block(); - $pack->end_seek() or do { - $pack->{log}("Can't seek into archive"); - return 0; - }; - my ($toc_length, $cf, $cd, $cl) = (0, 0, 0, 0); - - foreach my $entry (keys %{$pack->{'dir'}}) { - $cd++; - my $w = syswrite($pack->{handle}, $entry . "\n") or do { - $pack->{log}("Can't write toc into archive"); - return 0; - }; - $toc_length += $w; - } - foreach my $entry (keys %{$pack->{'symlink'}}) { - $cl++; - my $w = syswrite($pack->{handle}, sprintf("%s\n%s\n", $entry, $pack->{'symlink'}{$entry})) or do { - $pack->{log}("Can't write toc into archive"); - return 0; - }; - $toc_length += $w - } - foreach my $entry (sort keys %{$pack->{files}}) { - $cf++; - my $w = syswrite($pack->{handle}, $entry ."\n") or do { - $pack->{log}("Can't write toc into archive"); - return 0; - }; - $toc_length += $w; - } - 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 do { - $pack->{log}("Can't write toc into archive"); - return 0; - }; - } - syswrite($pack->{handle}, pack("a4NNNNa40a4", - $toc_header, - $cd, $cl, $cf, - $toc_length, - $pack->{uncompress_method}, - $toc_footer)) or do { - $pack->{log}("Can't write toc into archive"); - 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 { - $pack->{log}("Error reading toc: wrong header/trailer"); - return 0; - }; - - $pack->{uncompress_method} ||= $uncompress; - $pack->choose_compression_method(); - - 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}; - } - $pack->{toc_f_count} = $toc_f_count; - 1; -} - -sub sort_files_by_packing { - my ($pack, @files) = @_; - sort { - defined($pack->{files}{$a}) && defined($pack->{files}{$b}) ? - ($pack->{files}{$a}{coff} == $pack->{files}{$b}{coff} ? - $pack->{files}{$a}{off} <=> $pack->{files}{$b}{off} : - $pack->{files}{$a}{coff} <=> $pack->{files}{$b}{coff}) : - $a cmp $b - } @files; -} - -# Goto to the end of written compressed data -sub end_seek { - my ($pack) = @_; - my $seekvalue = $pack->{direct_write} ? $pack->{coff} + $pack->{current_block_csize} : $pack->{coff}; - sysseek($pack->{handle}, $seekvalue, 0) == $seekvalue -} - -#- To terminate a compressed block, flush the pending compressed data, -#- fill toc data still unknown -sub end_block { - my ($pack) = @_; - $pack->end_seek() or return 0; - my (undef, $csize) = $pack->{subcompress}($pack, undef); - $pack->{current_block_csize} += $csize; - foreach (keys %{$pack->{current_block_files}}) { - $pack->{files}{$_} = $pack->{current_block_files}{$_}; - $pack->{files}{$_}{csize} = $pack->{current_block_csize}; - } - $pack->{coff} += $pack->{current_block_csize}; - $pack->{current_block_coff} += $pack->{current_block_csize}; - $pack->{current_block_csize} = 0; - $pack->{current_block_files} = {}; - $pack->{current_block_off} = 0; -} - -####################### -# Compression wrapper # -####################### - -sub extern_compress { - my ($pack, $sourcefh) = @_; - my ($insize, $outsize, $filesize) = (0, 0, 0); # aka uncompressed / compressed data length - my $hout; # handle for gzip - - if (defined($pack->{cstream_data})) { - $hout = $pack->{cstream_data}{hout}; - $filesize = (stat($pack->{cstream_data}{file_block}))[7]; - } - if (defined($sourcefh)) { - if (!defined($pack->{cstream_data})) { - my $hin; - ($hin, $pack->{cstream_data}{file_block}) = tempfile(); - close($hin); # ensure the flush - $pack->{cstream_data}{pid} = CORE::open($hout, - "|$pack->{compress_method} > $pack->{cstream_data}{file_block}") or do { - $pack->{log}("Unable to start $pack->{compress_method}"); - return 0, 0; - }; - $pack->{cstream_data}{hout} = $hout; - binmode $hout; - } - # 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 { - $pack->{log}("Can't push all data to compressor"); - }; - $insize += $l; - $outsize = (stat($pack->{cstream_data}{file_block}))[7]; - } - } elsif (defined($pack->{cstream_data})) { - # If $sourcefh is not set, this mean we want a flush(), for end_block() - close($hout); - waitpid $pack->{cstream_data}{pid}, 0; - sysopen(my $hin, $pack->{cstream_data}{file_block}, O_RDONLY) or do { - $pack->{log}("Can't open temp block file"); - return 0, 0; - }; - $outsize = (stat($pack->{cstream_data}{file_block}))[7]; - unlink($pack->{cstream_data}{file_block}); - while (my $lenght = sysread($hin, my $data, $pack->{bufsize})) { - (my $l = syswrite($pack->{handle}, $data)) == $lenght or do { - $pack->{log}("Can't write all data in archive"); - }; - } - close($hin); - $pack->{cstream_data} = undef; - } - ($insize, $outsize - $pack->{current_block_csize}) -} - -sub extern_uncompress { - my ($pack, $destfh, $fileinfo) = @_; - - if (defined($pack->{ustream_data}) && ( - !defined($fileinfo) || - ($fileinfo->{coff} != $pack->{ustream_data}{coff} || $fileinfo->{off} < $pack->{ustream_data}{off}) - )) { - close($pack->{ustream_data}{handle}); - unlink($pack->{ustream_data}{tempname}); # deleting temp file - $pack->{ustream_data} = undef; - } - - defined($fileinfo) or return 0; - # We have to first extract the block to a temp file, burk ! - - if (!defined($pack->{ustream_data})) { - my $tempfh; - $pack->{ustream_data}{coff} = $fileinfo->{coff}; - $pack->{ustream_data}{read} = 0; - - ($tempfh, $pack->{ustream_data}{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 { - $pack->{log}("Unexpected end of file"); - close($tempfh); - unlink($pack->{ustream_data}{tempname}); - $pack->{ustream_data} = undef; - return -1; - }; - $cread += $cl; - syswrite($tempfh, $data) == length($data) or do { - $pack->{log}("Can't write all data into temp file"); - close($tempfh); - unlink($pack->{ustream_data}{tempname}); - $pack->{ustream_data} = undef; - return -1; - }; - } - close($tempfh); - - my $cmd = $pack->{uncompress_method} eq 'gzip -d' || $pack->{uncompress_method} eq 'bzip2 -d' ? - "$pack->{uncompress_method} -c '$pack->{ustream_data}{tempname}'" : - "$pack->{uncompress_method} < '$pack->{ustream_data}{tempname}'"; - CORE::open($pack->{ustream_data}{handle}, "$cmd |") or do { - $pack->{log}("Can't start $pack->{uncompress_method} to uncompress data"); - unlink($pack->{ustream_data}{tempname}); - $pack->{ustream_data} = undef; - return -1; - }; - binmode($pack->{ustream_data}{handle}); - } - - my $byteswritten = 0; - $pack->{ustream_data}{off} = $fileinfo->{off}; - #my $read = 0; - - while ($byteswritten < $fileinfo->{size}) { - my $data = $pack->{ustream_data}{buf}; - $pack->{ustream_data}{buf} = undef; - my $length; - if (!defined($data)) { - $length = sysread($pack->{ustream_data}{handle}, $data, $pack->{bufsize}) or do { - $pack->{log}("Unexpected end of stream $pack->{ustream_data}{tempname}"); - unlink($pack->{ustream_data}{tempname}); - close($pack->{ustream_data}{handle}); - $pack->{ustream_data} = undef; - return -1; - }; - } else { - $length = length($data); - } - - if ($pack->{ustream_data}{read} < $fileinfo->{off} && $pack->{ustream_data}{read} + $length > $fileinfo->{off}) { - $data = substr($data, $fileinfo->{off} - $pack->{ustream_data}{read}); - } - $pack->{ustream_data}{read} += $length; - if ($pack->{ustream_data}{read} <= $fileinfo->{off}) { next } - - my $bw; - if ($byteswritten + length($data) > $fileinfo->{size}) { - $bw = $fileinfo->{size} - $byteswritten; - $pack->{ustream_data}{buf} = substr($data, $bw); # keeping track of unwritten uncompressed data - $pack->{ustream_data}{read} -= length($pack->{ustream_data}{buf}); - } else { - $bw = length($data); - } - - syswrite($destfh, $data, $bw) == $bw or do { - $pack->{log}("Can't write data into dest"); - return -1; - }; - $byteswritten += $bw; - } - - $byteswritten - -} - -################### -# Debug functions # -################### - -# This function extracts in $dest the whole block containing $file, can be useful for debugging -sub extract_block { - my ($pack, $dest, $file) = @_; - - sysopen(my $handle, $dest, O_WRONLY | O_TRUNC | O_CREAT) or do { - $pack->{log}("Can't open $dest"); - return -1; - }; - - sysseek($pack->{handle}, $pack->{files}{$file}->{coff}, 0) == $pack->{files}{$file}->{coff} or do { - $pack->{log}("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 $pack->{log}("Read only $l / $pack->{files}{$file}->{csize} bytes"); - syswrite($handle, $buf); - } - - foreach ($pack->sort_files_by_packing(keys %{$pack->{files}})) { - $pack->{files}{$_}{coff} == $pack->{files}{$file}->{coff} or next; - } - - close($handle); - -} - -################################## -# Really working functions # -# Aka function people 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 { - $pack->{log}("Can't seek to offset $pack->{coff}"); - next; - }; - - my ($size, $csize) = $pack->{subcompress}($pack, $data); - $pack->{current_block_files}{$filename} = { - size => $size, - off => $pack->{current_block_off}, - coff => $pack->{current_block_coff}, - csize => -1, # Still unknown, will be fill by end_block - }; # Storing in toc structure availlable info - - # Updating internal info about current block - $pack->{current_block_off} += $size; - $pack->{current_block_csize} += $csize; - $pack->{need_build_toc} = 1; - if ($pack->{block_size} > 0 && $pack->{current_block_csize} >= $pack->{block_size}) { - $pack->end_block(); - } - return 1; - }; - 0 -} - -sub add { - my ($pack, $prefix, @files) = @_; - $prefix ||= ""; - foreach my $file (@files) { - $file =~ s://+:/:; - my $srcfile = $prefix ? "$prefix/$file" : $file; - $pack->{debug}->("Adding '%s' as '%s' into archive", $srcfile, $file); - - -l $srcfile and do { - $pack->add_virtual('l', $file, readlink($srcfile)); - next; - }; - -d $srcfile and do { # dir simple case - $pack->add_virtual('d', $file); - next; - }; - -f $srcfile and do { - sysopen(my $htocompress, $srcfile, O_RDONLY) or do { - $pack->{log}("Can't add $srcfile: $!"); - next; - }; - $pack->add_virtual('f', $file, $htocompress); - close($htocompress); - next; - }; - $pack->{log}("Can't pack $srcfile"); - } - 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 { - $pack->{log}("Can't seek to offset $pack->{files}{$filename}->{coff}"); - return -1; - }; - $pack->{subuncompress}($pack, $destfh, $pack->{files}{$filename}); -} - -sub extract { - my ($pack, $destdir, @files) = @_; - foreach my $f ($pack->sort_files_by_packing(@files)) { - my $dest = $destdir ? "$destdir/$f" : "$f"; - my ($dir) = $dest =~ m!(.*)/.*!; - $dir ||= "."; - if (exists($pack->{dir}{$f})) { - -d $dest || mkpath($dest) - or $pack->{log}("Unable to create dir $dest: $!"); - next; - } elsif (exists($pack->{'symlink'}{$f})) { - -d $dir || mkpath($dir) or - $pack->{log}("Unable to create dir $dest: $!"); - -l $dest and unlink $dest; - symlink($pack->{'symlink'}{$f}, $dest) - or $pack->{log}("Unable to extract symlink $f: $!"); - next; - } elsif (exists($pack->{files}{$f})) { - -d $dir || mkpath($dir) or do { - $pack->{log}("Unable to create dir $dir"); - }; - if (-l $dest) { - unlink($dest) or do { - $pack->{log}("Can't remove link $dest: $!"); - next; # Don't overwrite a file because where the symlink point to - }; - } - my $destfh; - if (defined $destdir) { - sysopen($destfh, $dest, O_CREAT | O_TRUNC | O_WRONLY) or do { - $pack->{log}("Unable to extract $dest"); - next; - }; - } else { - $destfh = \*STDOUT; - } - my $written = $pack->extract_virtual($destfh, $f); - $written == -1 and $pack->{log}("Unable to extract file $f"); - close($destfh); - next; - } else { - $pack->{log}("Can't find $f in archive"); - } - } - 1; -} - -# Return \@dir, \@files, \@symlink list -sub getcontent { - my ($pack) = @_; - return( - [ keys(%{$pack->{dir}})], - [ $pack->sort_files_by_packing(keys %{$pack->{files}}) ], - [ keys(%{$pack->{'symlink'}}) ] - ); -} - -sub infofile { - my ($pack, $file) = @_; - if (defined($pack->{files}{$file})) { - return ('f', $pack->{files}{$file}{size}); - } elsif (defined($pack->{'symlink'}{$file})) { - return ('l', $pack->{'symlink'}{$file}); - } elsif (defined($pack->{dir}{$file})) { - return ('d', undef); - } else { - return(undef, undef); - } -} - -sub list { - my ($pack, $handle) = @_; - $handle ||= *STDOUT; - 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 ($pack->sort_files_by_packing(keys %{$pack->{files}})) { - printf "f %12d %s\n", $pack->{files}{$file}{size}, $file; - } -} - -# Print toc info -sub dumptoc { - my ($pack, $handle) = @_; - $handle ||= *STDOUT; - foreach my $file (keys %{$pack->{dir}}) { - printf $handle "d %13c %s\n", ' ', $file; - } - foreach my $file (keys %{$pack->{'symlink'}}) { - printf $handle "l %13c %s -> %s\n", ' ', $file, $pack->{'symlink'}{$file}; - } - foreach my $file ($pack->sort_files_by_packing(keys %{$pack->{files}})) { - printf $handle "f %d %d %d %d %s\n", $pack->{files}{$file}{size}, $pack->{files}{$file}{off}, $pack->{files}{$file}{csize}, $pack->{files}{$file}{coff}, $file; - } -} +use MDV::Packdrakeng; +*Packdrakeng:: = *MDV::Packdrakeng::; +warn "Warning: Packdrakeng is deprecated, use MDV::Packdrakeng instead.\n"; 1; -__END__ - =head1 NAME -Packdrakeng - Simple Archive Extractor/Builder - -=head1 SYNOPSIS - - use Packdrakeng; - - # creating an archive - $pack = Packdrakeng->new(archive => "myarchive.cz"); - # Adding a 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); +Packdrakeng - Compatibility wrapper around MDV::Packdrakeng =head1 DESCRIPTION -C<Packdrakeng> is a simple indexed archive builder and extractor using -standard compression methods. - -This module is a from scratch rewrite of the original packdrake. Its format is -fully compatible with old packdrake. - -=head1 IMPLEMENTATION - -Compressed data are stored by block. For example, - - UncompresseddatA1UncompresseddatA2 UncompresseddatA3UncompresseddatA4 - |--- size 1 ---||--- size 2 ---| |--- size 3 ---||--- size 4 ---| - |<-offset1 |<-offset2 |<-offset3 |<-offset4 - -gives: - - CompresseD1CompresseD2 CompresseD3CompresseD4 - |--- c. size 1, 2 ---| |--- c. size 3, 4 ---| - |<-c. offset 1, 2 |<-c. offset 3, 4 - -A new block is started when its size exceeds the C<block_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 - -The file sizes follows, 4 values are stored for each file: -offset into archive of compressed block, size of compressed block, -offset into block of the file and the file's size. - -Finally the archive contains a 64-byte trailer, 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 uncompression command, string of 40 bytes length - '0]cz', string 4 bytes - -=head1 FUNCTIONS - -=over 2 - -=item B<new(%options)> - -Creates a new archive. -Options: - -=over 4 - -=item archive - -The file name of the archive. If the file doesn't exist, it will be created, -else it will be owerwritten. See C<open>. - -=item compress - -The application to use to compress, if unspecified, gzip is used. - -=item uncompress - -The application used to extract data from archive. This option is useless if -you're opening an existing archive (unless 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 will use perl-zlib to save system -ressources. This option forces Packdrakeng to use the external gzip command. This -has no meaning with other compress programs as internal functions are not implemented -yet. - -=item comp_level - -The compression level passed as an argument to the compression program. By default, -this is set to 6. - -=item block_size - -The limit size after which we start a new compressed block. The default value -is 400KB. Set it to 0 to be sure a new block will be started for each packed -files, and -1 to never start a new block. Be aware that a big block size will -slow down the file extraction. - -=item quiet - -Do not output anything, shut up. - -=item debug - -Print debug messages. - -=back - -=item B<open(%options)> - -Opens an existing archive for extracting or adding files. - -The uncompression command is found into the archive, and the compression -command is deduced from it. - -If you add files, a new compressed block will be started even if the -last block is smaller than C<block_size>. If some compression options can't be -found in the archive, the new preference will be applied. - -Options are same than the C<new()> function. - -=item B<< Packdrakeng->add_virtual($type, $filename, $data) >> - -Add a file into archive according passed information. - -$type gives the type of the file: - -- 'd', the file will be a directory, store as '$filename'. $data is not use; -- 'l', the file will be a symlink named $filename, pointing to the file whose path - is given by the string $data; -- 'f', the file is a normal file, $filename will be its name, $data is an handle to - open file, data will be read from current position to the end of file. - -=item B<< Packdrakeng->add($prefix, @files) >> - -Add @files into archive located into $prefix. Only directory, files and symlink -will be added. For each file, the path should be relative to $prefix and is -stored as is. - -=item B<< Packdrakeng->extract_virtual(*HANDLE, $filename) >> - -Extract $filename data from archive into the *HANDLE. $filename should be a -normal file. - -=item B<< Packdrakeng->extract($destdir, @files) >> - -Extract @files from the archive into $destdir prefix. - -=item B<< Packdrakeng->getcontent() >> - -Return 3 arrayref about found files into archive, respectively directory list, -files list and symlink list. - -=item B<< Packdrakeng->infofile($file) >> - -Return the type and information about a file into the archive. - -- return 'f' and the the size of the file for a plain file -- return 'l' and the point file for a link -- return 'd' and undef for a directory -- return undef if the file can't be found into archive. - -=item B<< Packdrakeng->infofile($handle) >> - -Print to $handle (STDOUT if not specified) the content of the archive. - -=item B<< Packdrakeng->dumptoc($handle) >> - -Print to $handle (STDOUT if not specified) the table of content of the archive. - -=back - -=head1 AUTHOR - -Olivier Thauvin <nanardon@mandriva.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. +Don't use this module. Use MDV::Packdrakeng instead. =cut diff --git a/Packdrakeng/zlib.pm b/Packdrakeng/zlib.pm index c3875f0..576652a 100644 --- a/Packdrakeng/zlib.pm +++ b/Packdrakeng/zlib.pm @@ -1,180 +1,19 @@ -##- 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. - -#- This package provides functions to use Compress::Zlib instead of gzip. - package Packdrakeng::zlib; -use strict; -use Compress::Zlib; - (our $VERSION) = q($Id$) =~ /(\d+\.\d+)/; -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); - -sub gzip_compress { - my ($pack, $sourcefh) = @_; - my ($insize, $outsize) = (0, 0); # aka uncompressed / compressed data length - - # If $sourcefh is not set, this means we want a flush(), for end_block() - # 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 does not create a 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); - my $wres = syswrite($pack->{handle}, $cbuf) || 0; - $wres == length($cbuf) or do { - warn "Can't push all data to compressor\n"; - return 0, 0; - }; - $outsize += $wres; - $insize += $lenght; - } +use MDV::Packdrakeng::zlib; - ($insize, $outsize) -} - -sub gzip_uncompress { - my ($pack, $destfh, $fileinfo) = @_; - - if (!defined $fileinfo) { - $pack->{ustream_data} = undef; - return 0; - } - - if (defined($pack->{ustream_data}) && ($fileinfo->{coff} != $pack->{ustream_data}{coff} || $fileinfo->{off} < $pack->{ustream_data}{off})) { - $pack->{ustream_data} = undef; - } - - if (!defined($pack->{ustream_data})) { - $pack->{ustream_data}{coff} = $fileinfo->{coff}; - $pack->{ustream_data}{read} = 0; # uncompressed data read - $pack->{ustream_data}{x} = inflateInit( - -WindowBits => - MAX_WBITS(), - ); - $pack->{ustream_data}{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\n"); - return -1; - }; - } else { - warn("Unexpected end of file while reading magic\n"); - return -1; - } - my ($method, $flags); - if (sysread($pack->{handle}, $buf, 2) == 2) { - ($method, $flags) = unpack("C2", $buf); - } else { - warn("Unexpected end of file while reading flags\n"); - return -1; - } +*Packdrakeng::zlib:: = *MDV::Packdrakeng::zlib::; +warn "Warning: Packdrakeng::zlib is deprecated, use MDV::Packdrakeng::zlib instead.\n"; +1; - if (sysread($pack->{handle}, $buf, 6) != 6) { - warn("Unexpected end of file while reading gzip header\n"); - return -1; - } +=head1 NAME - $pack->{ustream_data}{cread} += 12; #Gzip header fixed size is already read - if ($flags & 0x04) { - if (sysread($pack->{handle}, $buf, 2) == 2) { - my $len = unpack("I", $buf); - $pack->{ustream_data}{cread} += $len; - if (sysread($pack->{handle}, $buf, $len) != $len) { - warn("Unexpected end of file while reading gzip header\n"); - return -1; - } - } else { - warn("Unexpected end of file while reading gzip header\n"); - return -1; - } - } - } - } else { - sysseek($pack->{handle}, $pack->{ustream_data}{cread} - 2, 1); - } - $pack->{ustream_data}{off} = $fileinfo->{off}; - my $byteswritten = 0; - while ($byteswritten < $fileinfo->{size}) { - my ($l, $out, $status) = (0, $pack->{ustream_data}{buf}); - $pack->{ustream_data}{buf} = undef; - if (!defined($out)) { - my $cl=sysread($pack->{handle}, my $buf, - $pack->{ustream_data}{cread} + $pack->{bufsize} > $fileinfo->{csize} ? - $fileinfo->{csize} - $pack->{ustream_data}{cread} : - $pack->{bufsize}) or do { - warn("Unexpected end of file\n"); - return -1; - }; - $pack->{ustream_data}{cread} += $cl; - ($out, $status) = $pack->{ustream_data}{x}->inflate(\$buf); - $status == Z_OK || $status == Z_STREAM_END or do { - warn("Unable to uncompress data\n"); - return -1; - }; - } - $l = length($out) or next; - if ($pack->{ustream_data}{read} < $fileinfo->{off} && $pack->{ustream_data}{read} + $l > $fileinfo->{off}) { - $out = substr($out, $fileinfo->{off} - $pack->{ustream_data}{read}); - } - $pack->{ustream_data}{read} += $l; - if ($pack->{ustream_data}{read} <= $fileinfo->{off}) { next } +Packdrakeng::zlib - Compatibility wrapper around MDV::Packdrakeng::zlib - my $bw; - if ($byteswritten + length($out) > $fileinfo->{size}) { - $bw = $fileinfo->{size} - $byteswritten; - $pack->{ustream_data}{buf} = substr($out, $bw); # keeping track of unwritten uncompressed data - $pack->{ustream_data}{read} -= length($pack->{ustream_data}{buf}); - } else { - $bw = length($out); - } - syswrite($destfh, $out, $bw) == $bw or do { - warn "Can't write data into dest\n"; - return -1; - }; - $byteswritten += $bw; +=head1 DESCRIPTION - } - $byteswritten -} +Don't use this module. Use MDV::Packdrakeng::zlib instead. -1; +=cut |