File extractbuild of Package build

#!/usr/bin/perl -w

################################################################
#
# Copyright (c) 1995-2021 SUSE Linux Products GmbH
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License version 2 or 3 as
# published by the Free Software Foundation.
#
# 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 (see the file COPYING); if not, write to the
# Free Software Foundation, Inc.,
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA
#
################################################################

use strict;

sub read_blob {
  my ($fd, $l, $off) = @_;
  !defined($off) || sysseek($fd, $off, 0) || die("sysseek $off: $!\n");
  my $buf = '';
  while ($l > 0) {
    my $r = sysread($fd, $buf, $l, length($buf));
    die("sysread: $!\n") unless defined $r;
    die("sysread: EOF\n") unless $r > 0;
    $l -= $r;
  }
  return $buf;
}

sub qcow_open {
  my ($fd) = @_;
  my @hdr = unpack("N*", read_blob($fd, 72, 0));
  die("not a qcow2 image\n") unless $hdr[0] == 0x514649fb;
  die("unsupported qcow2 version $hdr[1]\n") unless $hdr[1] == 2 || $hdr[1] == 3;
  die("illegal cluster bits size $hdr[5]\n") if $hdr[5] < 9 || $hdr[5] > 24;
  die("encrypted qcow2 image\n") if $hdr[8];
  if ($hdr[1] == 3) {
    push @hdr, unpack("N*", read_blob($fd, 32));
    die("incompatible qcow2 feature ($hdr[18]/$hdr[19])\n") if $hdr[18] || ($hdr[19] & 0xfffffffc);
  }
  my @l1 = unpack("N*", read_blob($fd, $hdr[9] * 8, $hdr[10] * 4294967296 + $hdr[11]));
  my @l;
  while (@l1) {
    my ($l1a, $l1b) = splice(@l1, 0, 2);
    die("bad l1 table entry\n") if $l1b & 0x1ff;
    my $l2off = ($l1b & 0xfffffe00) + ($l1a & 0xffffff) * 4294967296;
    if (!$l2off) {
      push @l, (undef) x (1 << ($hdr[5] - 3));
      next;	# unallocated
    }
    my @l2 = unpack("N*", read_blob($fd, (1 << $hdr[5]), $l2off));
    while (@l2) {
      my ($l2a, $l2b) = splice(@l2, 0, 2);
      if ($l2a & 0x40000000) {
	die("compressed clusters are not yet supported\n");
      } else {
	die("all zero clusters are not supported\n") if $l2b & 1;
	my $coff = ($l2b & 0xfffffe00) + ($l2a & 0xffffff) * 4294967296;
	push @l, $coff ? $coff : undef;
      }
    }
  }
  my $qcow = [ $fd, (1 << $hdr[5]), \@l, \@hdr];
  return $qcow;
}

sub qcow_copy {
  my ($qcow, $out, $start, $len) = @_;
  my $csize = $qcow->[1];
  while ($len > 0) {
    my ($c, $co)  = (int($start / $csize), $start % $csize);
    die("cluster outside of mapping table\n") if $c < 0 || $c >= @{$qcow->[2]};
    my $off = $qcow->[2]->[$c];
    die("unmapped qcow2 cluster $c\n") unless defined $off;
    my $l = $csize - $co;
    my $chunk = read_blob($qcow->[0], $l > $len ? $len : $l, $off + $co);
    (syswrite($out, $chunk) || 0) == length($chunk) || die("write error\n");
    $len -= length($chunk);
    $start += length($chunk);
  }
}

# buffer size for reading
my $bufsize = 4*1024*1024;

my ($opt_skip, $opt_disk, $opt_input, $opt_verbose, $opt_qcow);
$opt_verbose = 0;

while (@ARGV)  {
  if ($ARGV[0] eq '--skip') {
    shift @ARGV;
    $opt_skip = shift @ARGV;
    next;
  }
  if ($ARGV[0] eq '--disk') {
    shift @ARGV;
    $opt_disk = shift @ARGV;
    next;
  }
  if ($ARGV[0] eq '--input') {
    shift @ARGV;
    $opt_input = shift @ARGV;
    next;
  }
  if ($ARGV[0] eq '--qcow' || $ARGV[0] eq '--qcow2') {
    shift @ARGV;
    $opt_qcow = 1;
    next;
  }
  if ($ARGV[0] eq '--verbose' || $ARGV[0] eq '-v') {
    shift @ARGV;
    $opt_verbose++;
    next;
  }
  last;
}

die "usage: extractbuild [--qcow2] [--verbose] [--skip n] [--input <manifest] --disk <image>\n" unless $opt_disk;

open(F, '<', $opt_disk) || die "$opt_disk: $!\n";

if ($opt_input) {
  open(S, '<', $opt_input) || die "$opt_input: $!\n";
} else {
  open(S, '<&STDIN') || die "can't dup stdin: $!\n";
}

# skip build status
if ($opt_skip) {
  seek(S, $opt_skip, 0) || die "seek: $!\n";
}

my $qcow;
$qcow = qcow_open(\*F) if $opt_qcow;

my %done;
while (<S>) {
  chomp;
  last unless length $_;
  my ($filetype, $file, $filesize, $blksize, @blocks) = split(' ');
  die("invalid input '$_'\n") unless defined($file);
  $file =~ s/%([a-fA-F0-9]{2})/chr(hex($1))/ge;
  die("bad file '$file' (contains \\0)\n") if $file =~ /\0/;
  die("already processed: $file\n") if $done{$file};
  die("bad file '$file'\n") if "/$file/" =~ /\/\.{0,2}\//s;
  if ($file =~ /^(.*)\//s) {
    die("file without directory: $file\n") unless $done{$1} && $done{$1} eq 'd';
  }
  if ($filetype eq 'd') {	# dir
    print "$file\n" if $opt_verbose && ($opt_verbose > 1 || $file =~ /^KIWI\/[^\/]*$/);
    mkdir($file) || die("mkdir $file: $!\n");
    $done{$file} = 'd';
    next;
  }
  if ($filetype eq 'l') {	# symlink
    my $target = $filesize;
    die("symlink without target\n") unless defined $target;
    $target =~ s/%([a-fA-F0-9]{2})/chr(hex($1))/ge;
    die("bad symlink: $target (contains \\0)\n") if $target =~ /\0/;
    die("bad symlink: $target\n") if "/$target/" =~ /\/\.?\//s;
    if ("/$target/" =~ /^((?:\/\.\.)+)\/(.*?)$/s) {
      my ($head, $tail) = ($1, $2);
      die("bad upref in symlink: $target\n") if "/$tail/" =~ /\/\.\.\//s;
      die("bad upref in symlink: $target\n") if ($head =~ y!/!!) > ($file =~ y!/!!);
    } else {
      die("bad upref in symlink: $target\n") if "/$target/" =~ /\/\.\.\//s;
    }
    print "$file\n" if $opt_verbose && !($opt_verbose == 1 && $file =~ /^KIWI\/.*\//);
    symlink($target, $file) || die("symlink $target $file: $!\n");
    $done{$file} = 'l';
    next;
  }
  die("illegal file type: $filetype\n") unless $filetype eq 'f';
  print "$file\n" if $opt_verbose && !($opt_verbose == 1 && $file =~ /^KIWI\/.*\//);
  $done{$file} = 'f';
  open (O, '>', $file) or die "$file: $!\n";
  if ($filesize == 0) {
    close(O) || die("$file: close error: $!\n");
    next;
  }
  $blksize = int($blksize);
  die "$file: invalid block size $blksize\n" unless $blksize > 0 && $blksize <= $bufsize;
  my $needtruncate;
  my $left = $filesize;
  for my $block (@blocks) {
    die("bad extent '$block'\n") unless $block =~ /^(\d+)(?::(\d+))?(?:-(\d+)(?::(\d+))?)?$/;
    my ($startblk, $startoff, $endblk, $endoff) = ($1, $2, $3, $4);
    $startoff = 0 unless defined $startoff;
    $endblk = $startblk unless defined $endblk;
    $endoff = $blksize - 1 unless defined $endoff;
    my $start = $startblk * $blksize + $startoff;
    my $len = $endblk * $blksize + $endoff + 1 - $start;
    die "$file: bad length\n" if $len <= 0;
    die "$file: extent is outside of file\n" if $left <= 0;
    $len = $left if $len > $left;	# it's ok to overshoot the last block
    $left -= $len;
    if ($start == 0) { # a hole!
      sysseek(O, $len, 1);
      $needtruncate = 1;
      next;
    }
    $needtruncate = undef;
    if ($qcow) {
      qcow_copy($qcow, \*O, $start, $len);
      next;
    }
    sysseek(F, $start, 0) || die "$file: seek: $!\n";
    while ($len > 0) {
      my $size = $len > $bufsize ? $bufsize : $len;
      my $buf;
      (sysread(F, $buf, $size) || 0) == $size || die("$file: read: $!\n");
      (syswrite(O, $buf) || 0) == length($buf) || die("$file: write error\n");
      $len -= $size;
    }
  }
  truncate(O, $filesize) if $needtruncate;
  close(O) || die("$file: close error: $!\n");
  # sanity check
  die "$file: invalid file size ($left bytes left)\n" if $left != 0;
}