This is an automated email from the git hooks/post-receive script. guillem pushed a commit to branch main in repository dpkg.
View the commit online: https://git.dpkg.org/cgit/dpkg/dpkg.git/commit/?id=fbee9f6d46dc89e416c3c586fc712ffe30f89d4a commit fbee9f6d46dc89e416c3c586fc712ffe30f89d4a Author: Guillem Jover <[email protected]> AuthorDate: Mon Jul 8 04:05:41 2024 +0200 Dpkg::Archive::Ar: New module This new module implements the minimal interface needed to write a new local ar command to be used by the test suite, but will also be used (and extended if needed) later on for the upcoming dpkg-sign, once that handles signatures for .deb archives. --- scripts/Dpkg/Archive/Ar.pm | 440 +++++++++++++++++++++++++++++++++++++++++++++ scripts/Makefile.am | 1 + scripts/po/POTFILES.in | 1 + t/pod-spell.t | 1 + 4 files changed, 443 insertions(+) diff --git a/scripts/Dpkg/Archive/Ar.pm b/scripts/Dpkg/Archive/Ar.pm new file mode 100644 index 000000000..97d5711b1 --- /dev/null +++ b/scripts/Dpkg/Archive/Ar.pm @@ -0,0 +1,440 @@ +# Copyright © 2023-2024 Guillem Jover <[email protected]> +# +# 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 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. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see <https://www.gnu.org/licenses/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Archive::Ar - Unix ar archive support + +=head1 DESCRIPTION + +This module provides a class to handle Unix ar archives. +It support the common format, with no GNU or BSD extensions. + +B<Note>: This is a private module, its API can change at any time. + +=cut + +package Dpkg::Archive::Ar 0.01; + +use strict; +use warnings; + +use Carp; +use Fcntl qw(:seek); +use IO::File; + +use Dpkg::ErrorHandling; +use Dpkg::Gettext; + +my $AR_MAGIC = "!<arch>\n"; +my $AR_MAGIC_LEN = 8; +my $AR_FMAG = "\`\n"; +my $AR_HDR_LEN = 60; + +=head1 METHODS + +=over 8 + +=item $ar = Dpkg::Archive::Ar->new(%opts) + +Create a new object to handle Unix ar archives. + +Supported options are: + +=over 8 + +=item filename + +The filename for the archive to open or create. + +=item create + +A boolean denoting whether the archive should be created, +otherwise if it does not exist the constructor will not open, create or +scan it. + +=back + +=cut + +sub new { + my ($this, %opts) = @_; + my $class = ref($this) || $this; + my $self = { + filename => undef, + fh => undef, + # XXX: If we promote this out from internal use, we should make this + # default to the archive mtime, or be overridable like in libdpkg, + # so that it can be initialized from SOURCE_DATE_EPOCH for example. + time => 0, + size => 0, + members => [], + }; + bless $self, $class; + + if ($opts{filename}) { + if ($opts{create}) { + $self->create_archive($opts{filename}); + } elsif (-e $opts{filename}) { + $self->open_archive($opts{filename}); + } + if (-e $opts{filename}) { + $self->scan_archive(); + } + } + + return $self; +} + +sub init_archive { + my $self = shift; + + $self->{fh}->binmode(); + $self->{fh}->stat + or syserr(g_('cannot get archive %s size'), $self->{filename}); + $self->{size} = -s _; + + return; +} + +=item $ar->create_archive($filename) + +Create the archive. + +=cut + +sub create_archive { + my ($self, $filename) = @_; + + if (defined $self->{fh}) { + croak 'the object has already been initialized with another file'; + } + + $self->{filename} = $filename; + $self->{fh} = IO::File->new($filename, '+>') + or syserr(g_('cannot open or create archive %s'), $filename); + $self->init_archive(); + $self->{fh}->write($AR_MAGIC, $AR_MAGIC_LEN) + or syserr(g_('cannot write magic into archive %s'), $filename); + + return; +} + +=item $ar->open_archive($filename) + +Open the archive. + +=cut + +sub open_archive { + my ($self, $filename) = @_; + + if (defined $self->{fh}) { + croak 'the object has already been initialized with another file'; + } + + $self->{filename} = $filename; + $self->{fh} = IO::File->new($filename, '+<') + or syserr(g_('cannot open or create archive %s'), $filename); + $self->init_archive(); + + return; +} + +sub _read_buf { + my ($self, $subject, $size) = @_; + + my $buf; + my $offs = $self->{fh}->tell(); + my $n = $self->{fh}->read($buf, $size); + if (not defined $n) { + # TRANSLATORS: The first %s string is either "archive magic" or + # "file header". + syserr(g_('cannot read %s at offset %d from archive %s'), + $subject, $offs, $self->{filename}); + } elsif ($n == 0) { + return; + } elsif ($n != $size) { + # TRANSLATORS: The first %s string is either "archive magic" or + # "file header". + error(g_('%s at offset %d in archive %s is truncated'), + $subject, $offs, $self->{filename}); + } + + return $buf; +} + +=item $ar->parse_magic() + +Reads and parses the archive magic string, and validates it. + +=cut + +sub parse_magic { + my $self = shift; + + my $magic = $self->_read_buf(g_('archive magic'), $AR_MAGIC_LEN) + or error(g_('archive %s contains no magic'), $self->{filename}); + + if ($magic ne $AR_MAGIC) { + error(g_('archive %s contains bad magic'), $self->{filename}); + } + + return; +} + +=item $ar->parse_member() + +Reads and parses the archive member and tracks it for later handling. + +=cut + +sub parse_member { + my $self = shift; + + my $offs = $self->{fh}->tell(); + + my $hdr = $self->_read_buf(g_('file header'), $AR_HDR_LEN) + or return; + + my $hdr_fmt = 'A16A12A6A6A8A10a2'; + my ($name, $time, $uid, $gid, $mode, $size, $fmag) = unpack $hdr_fmt, $hdr; + + if ($fmag ne $AR_FMAG) { + error(g_('file header at offset %d in archive %s contains bad magic'), + $offs, $self->{filename}); + } + + # Remove trailing spaces from the member name. + $name =~ s{ *$}{}; + + # Remove optional slash terminator (on GNU-style archives). + $name =~ s{/$}{}; + + my $member = { + name => $name, + time => int $time, + uid => int $uid, + gid => int $gid, + mode => oct $mode, + size => int $size, + offs => $offs, + }; + push @{$self->{members}}, $member; + + return $member; +} + +=item $ar->skip_member($member) + +Skip this member to the next one. +Get the value of a given substitution. + +=cut + +sub skip_member { + my ($self, $member) = @_; + + my $size = $member->{size}; + my $offs = $member->{offs} + $AR_HDR_LEN + $size + ($size & 1); + + $self->{fh}->seek($offs, SEEK_SET) + or syserr(g_('cannot seek into next file header at offset %d from archive %s'), + $offs, $self->{filename}); + + return; +} + +=item $ar->scan_archive() + +Scan the archive for all its member files and metadata. + +=cut + +sub scan_archive { + my $self = shift; + + $self->{fh}->seek(0, SEEK_SET) + or syserr(g_('cannot seek into beginning of archive %s'), + $self->{filename}); + + $self->parse_magic(); + + while (my $member = $self->parse_member()) { + $self->skip_member($member); + } + + return; +} + +=item $ar->get_members() + +Get the list of members in the archive. + +=cut + +sub get_members { + my $self = shift; + + return $self->{members}; +} + +sub _copy_fh_fh { + my ($self, $if, $of, $size) = @_; + + while ($size > 0) { + my $buf; + my $buflen = $size > 4096 ? 4096 : $size; + + my $n = $if->{fh}->read($buf, $buflen) + or syserr(g_('cannot read file %s'), $if->{name}); + + $of->{fh}->write($buf, $buflen) + or syserr(g_('cannot write file %s'), $of->{name}); + + $size -= $buflen; + } + + return; +} + +=item $ar->extract_member($member) + +Extract the specified member to the current directory. + +=cut + +sub extract_member { + my ($self, $member) = @_; + + $self->{fh}->seek($member->{offs} + $AR_HDR_LEN, SEEK_SET); + + my $ofh = IO::File->new($member->{name}, '+>') + or syserr(g_('cannot create file %s to extract from archive %s'), + $member->{name}, $self->{filename}); + + $self->_copy_fh_fh({ fh => $self->{fh}, name => $self->{filename} }, + { fh => $ofh, name => $member->{name} }, + $member->{size}); + + $ofh->close() + or syserr(g_('cannot write file %s to the filesystem'), + $member->{name}); + + return; +} + +=item $ar->write_member($member) + +Write the provided $member into the archive. + +=cut + +sub write_member { + my ($self, $member) = @_; + + my $size = $member->{size}; + my $mode = sprintf '%o', $member->{mode}; + + my $hdr_fmt = 'A16A12A6A6A8A10A2'; + my $data = pack $hdr_fmt, @{$member}{qw(name time uid gid)}, $mode, $size, $AR_FMAG; + + $self->{fh}->write($data, $AR_HDR_LEN, $member->{offs}) + or syserr(g_('cannot write file header into archive %s'), + $self->{filename}); + + return; +} + +=item $ar->add_file($filename) + +Append the specified $filename into the archive. + +=cut + +sub add_file { + my ($self, $filename) = @_; + + if (length $filename > 15) { + error(g_('filename %s is too long'), $filename); + } + + my $fh = IO::File->new($filename, '<') + or syserr(g_('cannot open file %s to append to archive %s'), + $filename, $self->{filename}); + $fh->stat() + or syserr(g_('cannot get file %s size'), $filename); + my $size = -s _; + + my %member = ( + name => $filename, + size => $size, + time => $self->{time}, + mode => 0100644, + uid => 0, + gid => 0, + ); + + $self->write_member(\%member); + $self->_copy_fh_fh({ fh => $fh, name => $filename }, + { fh => $self->{fh}, name => $self->{filename} }, + $size); + if ($size & 1) { + $self->{fh}->write("\n", 1) + or syserr(g_('cannot write file %s padding to archive %s'), + $filename, $self->{filename}); + } + + return; +} + +=item $ar->close_archive() + +Close the archive and release any allocated resource. + +=cut + +sub close_archive { + my $self = shift; + + $self->{fh}->close() if defined $self->{fh}; + $self->{fh} = undef; + $self->{size} = 0; + $self->{members} = []; + + return; +} + +sub DESTROY { + my $self = shift; + + $self->close_archive(); + + return; +} + +=back + +=head1 CHANGES + +=head2 Version 0.xx + +This is a private module. + +=cut + +1; diff --git a/scripts/Makefile.am b/scripts/Makefile.am index 2b79f6111..cc131aaf4 100644 --- a/scripts/Makefile.am +++ b/scripts/Makefile.am @@ -7,6 +7,7 @@ CLEANFILES = nobase_dist_perllib_DATA = \ Dpkg/Arch.pm \ + Dpkg/Archive/Ar.pm \ Dpkg/BuildAPI.pm \ Dpkg/BuildDriver.pm \ Dpkg/BuildDriver/DebianRules.pm \ diff --git a/scripts/po/POTFILES.in b/scripts/po/POTFILES.in index 125792b6c..5850805f8 100644 --- a/scripts/po/POTFILES.in +++ b/scripts/po/POTFILES.in @@ -21,6 +21,7 @@ scripts/dpkg-source.pl scripts/dpkg-vendor.pl scripts/Dpkg.pm scripts/Dpkg/Arch.pm +scripts/Dpkg/Archive/Ar.pm scripts/Dpkg/BuildAPI.pm scripts/Dpkg/BuildEnv.pm scripts/Dpkg/BuildFlags.pm diff --git a/t/pod-spell.t b/t/pod-spell.t index 10218219a..1a1842d8e 100644 --- a/t/pod-spell.t +++ b/t/pod-spell.t @@ -51,6 +51,7 @@ ORed OpenPGP RCS XDG +ar archqual backport build-indep -- Dpkg.Org's dpkg
