scripts/dpkg-ar.pl

   1 #!/usr/bin/perl
   2 #
   3 # dpkg-ar
   4 #
   5 # Copyright © 2024 Guillem Jover <guillem@debian.org>
   6 #
   7 # This program is free software; you can redistribute it and/or modify
   8 # it under the terms of the GNU General Public License as published by
   9 # the Free Software Foundation; either version 2 of the License, or
  10 # (at your option) any later version.
  11 #
  12 # This program is distributed in the hope that it will be useful,
  13 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 # GNU General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU General Public License
  18 # along with this program.  If not, see <https://www.gnu.org/licenses/>.
  19
  20 use warnings;
  21 use strict;
  22
  23 use Dpkg ();
  24 use Dpkg::Gettext;
  25 use Dpkg::ErrorHandling;
  26 use Dpkg::Archive::Ar;
  27
  28 textdomain('dpkg-dev');
  29
  30 my $action;
  31
  32 sub version()
  33 {
  34     printf(g_("Debian %s version %s.\n"), $Dpkg::PROGNAME, $Dpkg::PROGVERSION);
  35 }
  36
  37 sub usage()
  38 {
  39     printf(g_("Usage: %s [<option>...]\n"), $Dpkg::PROGNAME);
  40
  41     print(g_('
  42 Commands:
  43       --create <archive> <file>...      create an ar archive.
  44       --list <archive>                  list the contents of an ar archive.
  45       --extract <archive> [<file>...]   extract the contents of an ar archive.
  46   -?, --help                            show this help message.
  47       --version                         show the version.
  48 '));
  49 }
  50
  51 sub create
  52 {
  53     my ($archive, @files) = @_;
  54
  55     my $ar = Dpkg::Archive::Ar->new(
  56         filename => $archive,
  57         create => 1,
  58     );
  59
  60     foreach my $file (@files) {
  61         $ar->add_file($file);
  62     }
  63 }
  64
  65 sub list
  66 {
  67     my $archive = shift;
  68
  69     my $ar = Dpkg::Archive::Ar->new(filename => $archive);
  70
  71     foreach my $member (@{$ar->get_members()}) {
  72         print "$member->{name}\n";
  73     }
  74 }
  75
  76 sub extract
  77 {
  78     my ($archive, @files) = @_;
  79     my %file = map { $_ => 1 } @files;
  80
  81     my $ar = Dpkg::Archive::Ar->new(filename => $archive);
  82
  83     foreach my $member (@{$ar->get_members()}) {
  84         next if @files && ! exists $file{$member->{name}};
  85
  86         $ar->extract_member($member);
  87     }
  88 }
  89
  90 my @files;
  91
  92 while (@ARGV) {
  93     my $arg = shift @ARGV;
  94     if ($arg eq '-?' or $arg eq '--help') {
  95         usage();
  96         exit(0);
  97     } elsif ($arg eq '-v' or $arg eq '--version') {
  98         version();
  99         exit(0);
 100     } elsif ($arg eq '--create') {
 101         $action = 'create';
 102     } elsif ($arg eq '--list') {
 103         $action = 'list';
 104     } elsif ($arg eq '--extract') {
 105         $action = 'extract';
 106     } elsif ($arg eq '--') {
 107         push @files, @ARGV;
 108         last;
 109     } elsif ($arg =~ m/^-/) {
 110         usageerr(g_("unknown option '%s'"), $arg);
 111     } else {
 112         push @files, $arg;
 113     }
 114 }
 115
 116 @files or usageerr(g_('need at least an archive filename'));
 117
 118 if ($action eq 'create') {
 119     if (@files == 1) {
 120         usageerr(g_('need at least a file to add into the archive'));
 121     }
 122     create(@files);
 123 } elsif ($action eq 'list') {
 124     list(@files);
 125 } elsif ($action eq 'extract') {
 126     extract(@files);
 127 }