File Build.obscpio of Package build
07070100000000000081a400000000000000000000000163e504b900000759000000000000000000000000000000000000001200000000Build/Appimage.pm################################################################
#
# Copyright (c) 2017 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
#
################################################################
package Build::Appimage;
use strict;
use Build::Deb;
use Build::Rpm;
eval { require YAML::XS; $YAML::XS::LoadBlessed = 0; };
*YAML::XS::LoadFile = sub {die("YAML::XS is not available\n")} unless defined &YAML::XS::LoadFile;
sub parse {
my ($cf, $fn) = @_;
my $yml;
eval { $yml = YAML::XS::LoadFile($fn); };
return {'error' => "Failed to parse yml file"} unless $yml;
my $ret = {};
$ret->{'name'} = $yml->{'app'};
$ret->{'version'} = $yml->{'version'} || "0";
my @packdeps;
if ($yml->{'ingredients'}) {
for my $pkg (@{$yml->{'ingredients'}->{'packages'} || {}}) {
push @packdeps, $pkg;
}
}
if ($yml->{'build'} && $yml->{'build'}->{'packages'}) {
for my $pkg (@{$yml->{'build'}->{'packages'}}) {
push @packdeps, $pkg;
}
}
$ret->{'deps'} = \@packdeps;
my @sources;
if ($yml->{'build'} && $yml->{'build'}->{'files'}) {
for my $source (@{$yml->{'build'}->{'files'}}) {
push @sources, $source;
}
}
$ret->{'sources'} = \@sources;
return $ret;
}
1;
07070100000001000081a400000000000000000000000163e504b900002b62000000000000000000000000000000000000000e00000000Build/Arch.pm################################################################
#
# Copyright (c) 1995-2014 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
#
################################################################
package Build::Arch;
use strict;
use Digest::MD5;
eval { require Archive::Tar; };
*Archive::Tar::new = sub {die("Archive::Tar is not available\n")} unless defined &Archive::Tar::new;
# Archlinux support, based on the GSoC work of Nikolay Rysev <mad.f3ka@gmail.com>
# parse a PKGBUILD file
sub expandvars {
my ($str, $vars) = @_;
$str =~ s/\$([a-zA-Z0-9_]+|\{([^\}]+)\})/join(' ', @{$vars->{$2 || $1} || []})/ge;
return $str;
}
sub quote {
my ($str, $q, $vars) = @_;
$str = expandvars($str, $vars) if $q ne "'" && $str =~ /\$/;
$str =~ s/([ \t\"\'\$])/sprintf("%%%02X", ord($1))/ge;
return $str;
}
sub unquotesplit {
my ($str, $vars) = @_;
$str =~ s/%/%25/g;
$str =~ s/^[ \t]+//;
while ($str =~ /([\"\'])/) {
my $q = $1;
last unless $str =~ s/$q(.*?)$q/quote($1, $q, $vars)/e;
}
$str = expandvars($str, $vars) if $str =~ /\$/;
my @args = split(/[ \t]+/, $str);
for (@args) {
s/%([a-fA-F0-9]{2})/chr(hex($1))/ge
}
return @args;
}
sub get_assets {
my ($vars, $asuf) = @_;
my @digests;
for my $digesttype ('sha512', 'sha256', 'sha1', 'md5') {
@digests = map {$_ eq 'SKIP' ? $_ : "$digesttype:$_"} @{$vars->{"${digesttype}sums$asuf"} || []};
last if @digests;
}
# work around bug in source parser
my @sources;
for (@{$vars->{"source$asuf"} || []}) {
push @sources, $_;
splice(@sources, -1, 1, $1, "$1.sig") if /(.*)\{,\.sig\}$/;
}
my @assets;
for my $s (@sources) {
my $digest = shift @digests;
next unless $s =~ /^https?:\/\/.*\/([^\.\/][^\/]+)$/s;
my $asset = { 'url' => $s };
$asset->{'digest'} = $digest if $digest && $digest ne 'SKIP';
push @assets, $asset;
}
return @assets;
}
sub parse {
my ($config, $pkgbuild) = @_;
my $ret;
local *PKG;
if (!open(PKG, '<', $pkgbuild)) {
$ret->{'error'} = "$pkgbuild: $!";
return $ret;
}
my %vars;
my @ifs;
while (<PKG>) {
chomp;
next if /^\s*$/;
next if /^\s*#/;
s/^\s+//;
if (/^(el)?if\s+(?:(?:test|\[)\s+(-n|-z)\s+)?(.*?)\s*\]?\s*;\s*then\s*$/) {
if ($1) {
$ifs[-1] += 1;
next if $ifs[-1] != 1;
pop @ifs;
}
my $flag = $2 || '-n';
my $t = join('', unquotesplit($3, \%vars));
$t = $t eq '' ? 'true' : '' if $flag eq '-z';
push @ifs, $t ne '' ? 1 : 0;
next;
}
if (@ifs) {
if (/^fi\s*$/) {
pop @ifs;
next;
} elsif (/^else\s*$/) {
$ifs[-1] += 1;
next;
}
next if grep {$_ != 1} @ifs;
}
last unless /^([a-zA-Z0-9_]*)(\+?)=(\(?)(.*?)$/;
my $var = $1;
my $app = $2;
my $val = $4;
if ($3) {
while ($val !~ s/\)\s*(?:#.*)?$//s) {
my $nextline = <PKG>;
last unless defined $nextline;
chomp $nextline;
$val .= ' ' . $nextline;
}
}
if ($app) {
push @{$vars{$var}}, unquotesplit($val, \%vars);
} else {
$vars{$var} = [ unquotesplit($val, \%vars) ];
}
}
close PKG;
$ret->{'name'} = $vars{'pkgname'}->[0] if $vars{'pkgname'};
$ret->{'version'} = $vars{'pkgver'}->[0] if $vars{'pkgver'};
$ret->{'deps'} = [];
push @{$ret->{'deps'}}, @{$vars{$_} || []} for qw{makedepends checkdepends depends};
# get arch from macros
my ($arch) = Build::gettargetarchos($config);
# map to arch linux name and add arch dependent
$arch = 'i686' if $arch =~ /^i[345]86$/;
push @{$ret->{'deps'}}, @{$vars{"${_}_$arch"} || []} for qw{makedepends checkdepends depends};
# Maintain architecture-specific sources for officially supported architectures
for my $asuf ('', '_i686', '_x86_64') {
$ret->{"source$asuf"} = $vars{"source$asuf"} if $vars{"source$asuf"};
}
# find remote assets
for my $asuf ('', "_$arch") {
next unless @{$vars{"source$asuf"} || []};
my @assets = get_assets(\%vars, $asuf);
push @{$ret->{'remoteassets'}}, @assets if @assets;
}
return $ret;
}
sub islzma {
my ($fn) = @_;
local *F;
return 0 unless open(F, '<', $fn);
my $h;
return 0 unless read(F, $h, 5) == 5;
close F;
return $h eq "\3757zXZ";
}
sub iszstd {
my ($fn) = @_;
local *F;
return 0 unless open(F, '<', $fn);
my $h;
return 0 unless read(F, $h, 4) == 4;
close F;
return $h eq "(\265\057\375";
}
sub lzmadec {
my ($fn) = @_;
my $nh;
my $pid = open($nh, '-|');
return undef unless defined $pid;
if (!$pid) {
$SIG{'PIPE'} = 'DEFAULT';
exec('xzdec', '-dc', $fn);
die("xzdec: $!\n");
}
return $nh;
}
sub zstddec {
my ($fn) = @_;
my $nh;
my $pid = open($nh, '-|');
return undef unless defined $pid;
if (!$pid) {
$SIG{'PIPE'} = 'DEFAULT';
exec('zstdcat', $fn);
die("zstdcat $!\n");
}
return $nh;
}
sub queryvars {
my ($handle) = @_;
if (ref($handle)) {
die("arch pkg query not implemented for file handles\n");
}
if ($handle =~ /\.zst$/ || iszstd($handle)) {
$handle = zstddec($handle);
} elsif ($handle =~ /\.xz$/ || islzma($handle)) {
$handle = lzmadec($handle);
}
my $tar = Archive::Tar->new;
my @read = $tar->read($handle, 1, {'filter' => '^\.PKGINFO$', 'limit' => 1});
die("$handle: not an arch package file\n") unless @read == 1;
my $pkginfo = $read[0]->get_content;
die("$handle: not an arch package file\n") unless $pkginfo;
my %vars;
$vars{'_pkginfo'} = $pkginfo;
for my $l (split('\n', $pkginfo)) {
next unless $l =~ /^(.*?) = (.*)$/;
push @{$vars{$1}}, $2;
}
return \%vars;
}
sub queryfiles {
my ($handle) = @_;
if (ref($handle)) {
die("arch pkg query not implemented for file handles\n");
}
if ($handle =~ /\.zst$/ || iszstd($handle)) {
$handle = zstddec($handle);
} elsif ($handle =~ /\.xz$/ || islzma($handle)) {
$handle = lzmadec($handle);
}
my @files;
my $tar = Archive::Tar->new;
# we use filter_cb here so that Archive::Tar skips the file contents
$tar->read($handle, 1, {'filter_cb' => sub {
my ($entry) = @_;
push @files, $entry->name unless $entry->is_longlink || (@files && $files[-1] eq $entry->name);
return 0;
}});
shift @files if @files && $files[0] eq '.PKGINFO';
return \@files;
}
sub query {
my ($handle, %opts) = @_;
my $vars = queryvars($handle);
my $ret = {};
$ret->{'name'} = $vars->{'pkgname'}->[0] if $vars->{'pkgname'};
$ret->{'hdrmd5'} = Digest::MD5::md5_hex($vars->{'_pkginfo'});
$ret->{'provides'} = $vars->{'provides'} || [];
$ret->{'requires'} = $vars->{'depend'} || [];
if ($vars->{'pkgname'} && $opts{'addselfprovides'}) {
my $selfprovides = $vars->{'pkgname'}->[0];
$selfprovides .= "=$vars->{'pkgver'}->[0]" if $vars->{'pkgver'};
push @{$ret->{'provides'}}, $selfprovides unless @{$ret->{'provides'} || []} && $ret->{'provides'}->[-1] eq $selfprovides;
}
if ($opts{'evra'}) {
if ($vars->{'pkgver'}) {
my $evr = $vars->{'pkgver'}->[0];
if ($evr =~ /^([0-9]+):(.*)$/) {
$ret->{'epoch'} = $1;
$evr = $2;
}
$ret->{'version'} = $evr;
if ($evr =~ /^(.*)-(.*?)$/) {
$ret->{'version'} = $1;
$ret->{'release'} = $2;
}
}
$ret->{'arch'} = $vars->{'arch'}->[0] if $vars->{'arch'};
}
if ($opts{'description'}) {
$ret->{'description'} = $vars->{'pkgdesc'}->[0] if $vars->{'pkgdesc'};
}
if ($opts{'conflicts'}) {
$ret->{'conflicts'} = $vars->{'conflict'} if $vars->{'conflict'};
$ret->{'obsoletes'} = $vars->{'replaces'} if $vars->{'replaces'};
}
if ($opts{'weakdeps'}) {
my @suggests = @{$vars->{'optdepend'} || []};
s/:.*// for @suggests;
$ret->{'suggests'} = \@suggests if @suggests;
}
# arch packages don't seem to have a source :(
# fake it so that the package isn't confused with a src package
$ret->{'source'} = $ret->{'name'} if defined $ret->{'name'};
$ret->{'buildtime'} = $vars->{'builddate'}->[0] if $opts{'buildtime'} && $vars->{'builddate'};
return $ret;
}
sub queryhdrmd5 {
my ($handle) = @_;
if (ref($handle)) {
die("arch pkg query not implemented for file handles\n");
}
if ($handle =~ /\.zst$/ || iszstd($handle)) {
$handle = zstddec($handle);
} elsif ($handle =~ /\.xz$/ || islzma($handle)) {
$handle = lzmadec($handle);
}
my $tar = Archive::Tar->new;
my @read = $tar->read($handle, 1, {'filter' => '^\.PKGINFO$', 'limit' => 1});
die("$handle: not an arch package file\n") unless @read == 1;
my $pkginfo = $read[0]->get_content;
die("$handle: not an arch package file\n") unless $pkginfo;
return Digest::MD5::md5_hex($pkginfo);
}
sub parserepodata {
my ($d, $data) = @_;
$d ||= {};
$data =~ s/^\n+//s;
my @parts = split(/\n\n+/s, $data);
for my $part (@parts) {
my @p = split("\n", $part);
my $p = shift @p;
if ($p eq '%NAME%') {
$d->{'name'} = $p[0];
} elsif ($p eq '%VERSION%') {
$d->{'version'} = $p[0];
} elsif ($p eq '%ARCH%') {
$d->{'arch'} = $p[0];
} elsif ($p eq '%BUILDDATE%') {
$d->{'buildtime'} = $p[0];
} elsif ($p eq '%FILENAME%') {
$d->{'filename'} = $p[0];
} elsif ($p eq '%PROVIDES%') {
push @{$d->{'provides'}}, @p;
} elsif ($p eq '%DEPENDS%') {
push @{$d->{'requires'}}, @p;
} elsif ($p eq '%OPTDEPENDS%') {
push @{$d->{'suggests'}}, @p;
} elsif ($p eq '%CONFLICTS%') {
push @{$d->{'conflicts'}}, @p;
} elsif ($p eq '%REPLACES%') {
push @{$d->{'obsoletes'}}, @p;
} elsif ($p eq '%MD5SUM%') {
$d->{'checksum_md5'} = $p[0];
} elsif ($p eq '%SHA256SUM%') {
$d->{'checksum_sha256'} = $p[0];
}
}
return $d;
}
sub queryinstalled {
my ($root, %opts) = @_;
$root = '' if !defined($root) || $root eq '/';
local *D;
local *F;
opendir(D, "$root/var/lib/pacman/local") || return [];
my @pn = sort(grep {!/^\./} readdir(D));
closedir(D);
my @pkgs;
for my $pn (@pn) {
next unless open(F, '<', "$root/var/lib/pacman/local/$pn/desc");
my $data = '';
1 while sysread(F, $data, 8192, length($data));
close F;
my $d = parserepodata(undef, $data);
next unless defined $d->{'name'};
my $q = {};
for (qw{name arch buildtime version}) {
$q->{$_} = $d->{$_} if defined $d->{$_};
}
$q->{'epoch'} = $1 if $q->{'version'} =~ s/^(\d+)://s;
$q->{'release'} = $1 if $q->{'version'} =~ s/-([^-]*)$//s;
push @pkgs, $q;
}
return \@pkgs;
}
1;
07070100000002000081a400000000000000000000000163e504b900000d87000000000000000000000000000000000000001200000000Build/Archrepo.pm################################################################
#
# Copyright (c) 1995-2014 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
#
################################################################
package Build::Archrepo;
use strict;
use Build::Arch;
eval { require Archive::Tar; };
if (!defined &Archive::Tar::iter) {
*Archive::Tar::iter = sub {
my ($class, $filename) = @_;
die("Archive::Tar is not available\n") unless defined &Archive::Tar::new;
Archive::Tar->new();
my $handle = $class->_get_handle($filename, 1, 'rb') or return undef;
my @data;
return sub {
return shift(@data) if !$handle || @data;
my $files = $class->_read_tar($handle, { limit => 1 });
@data = @$files if (ref($files) || '') eq 'ARRAY';
undef $handle unless @data;
return shift @data;
};
};
}
sub addpkg {
my ($res, $data, $options) = @_;
return unless defined $data->{'version'};
if ($options->{'addselfprovides'}) {
my $selfprovides = $data->{'name'};
$selfprovides .= "=$data->{'version'}" if defined $data->{'version'};
push @{$data->{'provides'}}, $selfprovides unless @{$data->{'provides'} || []} && $data->{'provides'}->[-1] eq $selfprovides;
}
if ($options->{'normalizedeps'}) {
# our normalized dependencies have spaces around the op
for my $dep (qw {provides requires conflicts obsoletes suggests}) {
next unless $data->{$dep};
s/ ?([<=>]+) ?/ $1 / for @{$data->{$dep}};
}
}
if (defined($data->{'version'})) {
# split version into evr
$data->{'epoch'} = $1 if $data->{'version'} =~ s/^(\d+)://s;
$data->{'release'} = $1 if $data->{'version'} =~ s/-([^-]*)$//s;
}
$data->{'location'} = delete($data->{'filename'}) if exists $data->{'filename'};
if ($options->{'withchecksum'}) {
for (qw {md5 sha1 sha256}) {
my $c = delete($data->{"checksum_$_"});
$data->{'checksum'} = "$_:$c" if $c;
}
} else {
delete $data->{"checksum_$_"} for qw {md5 sha1 sha256};
}
if (ref($res) eq 'CODE') {
$res->($data);
} else {
push @$res, $data;
}
}
sub parse {
my ($in, $res, %options) = @_;
$res ||= [];
die("Build::Archrepo::parse needs a filename\n") if ref($in);
die("$in: $!\n") unless -e $in;
my $repodb = Archive::Tar->iter($in, 1);
die("$in is not a tar archive\n") unless $repodb;
my $e;
my $lastfn = '';
my $d;
while ($e = $repodb->()) {
next unless $e->type() == Archive::Tar::Constant::FILE();
my $fn = $e->name();
next unless $fn =~ s/\/(?:depends|desc|files)$//s;
if ($lastfn ne $fn) {
addpkg($res, $d, \%options) if $d->{'name'};
$d = {};
$lastfn = $fn;
}
Build::Arch::parserepodata($d, $e->get_content());
}
addpkg($res, $d, \%options) if $d->{'name'};
return $res;
}
1;
07070100000003000081a400000000000000000000000163e504b900000645000000000000000000000000000000000000001000000000Build/Collax.pm#
# Copyright 2015 Zarafa B.V. and its licensors
#
# 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.
#
package Build::Collax;
use strict;
sub parse {
my($buildconf, $fn) = @_;
my @bscript;
if (ref($fn) eq "ARRAY") {
@bscript = @$fn;
$fn = undef;
} elsif (ref($fn) ne "") {
die "Unhandled ref type in collax";
} else {
local *FH;
if (!open(FH, "<", $fn)) {
return {"error" => "$fn: $!"};
}
@bscript = <FH>;
chomp(@bscript);
close(FH);
}
my $ret = {"deps" => []};
for (my $i = 0; $i <= $#bscript; ++$i) {
next unless $bscript[$i] =~ m{^\w+=};
my $key = lc(substr($&, 0, -1));
my $value = $';
if ($value =~ m{^([\'\"])}) {
$value = substr($value, 1);
while ($value !~ m{[\'\"]}) {
my @cut = splice(@bscript, $i + 1, 1);
$value .= $cut[0];
}
$value =~ s{[\'\"]}{}s;
$value =~ s{\n}{ }gs;
}
if ($key eq "package") {
$ret->{"name"} = $value;
} elsif ($key eq "version") {
$ret->{$key} = $value;
} elsif ($key eq "builddepends" || $key eq "extradepends") {
$value =~ s{^\s+}{}gs;
$value =~ s{\s+$}{}gs;
$value =~ s{,}{ }gs;
push(@{$ret->{"deps"}}, split(/\s+/, $value));
}
}
return $ret;
}
1;
07070100000004000081a400000000000000000000000163e504b9000038e5000000000000000000000000000000000000000d00000000Build/Deb.pm################################################################
#
# Copyright (c) 1995-2014 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
#
################################################################
package Build::Deb;
use strict;
use Digest::MD5;
my $have_zlib;
my $have_rawlzma;
eval {
require Compress::Zlib;
$have_zlib = 1;
};
eval {
require Compress::Raw::Lzma;
$have_rawlzma = 1;
};
my %obs2debian = (
"i486" => "i386",
"i586" => "i386",
"i686" => "i386",
"ppc" => "powerpc",
"ppc64le" => "ppc64el",
"x86_64" => "amd64",
"armv4l" => "armel",
"armv5l" => "armel",
"armv6l" => "armel",
"armv7el" => "armel",
"armv7l" => "armhf",
"armv7hl" => "armhf",
"aarch64" => "arm64",
);
sub basearch {
my ($arch) = @_;
return 'all' if !defined($arch) || $arch eq 'noarch';
return $obs2debian{$arch} || $arch;
}
sub obsarch {
my ($arch) = @_;
my @obs = grep {$obs2debian{$_} eq $arch} sort keys %obs2debian;
return @obs if @obs;
return $arch;
}
sub parse {
my ($bconf, $fn) = @_;
# get arch and os from macros and map to debian names
my ($arch, $os) = Build::gettargetarchos($bconf);
$os = 'linux' unless defined $os;
$arch = basearch($arch);
my @control;
if (ref($fn) eq 'ARRAY') {
@control = @$fn;
} else {
local *F;
return { 'error' => "$fn: $!" } unless open(F, '<', $fn);
@control = <F>;
close F;
chomp @control;
}
splice(@control, 0, 3) if @control > 3 && $control[0] =~ /^-----BEGIN/;
my $name;
my $version;
my @deps;
my @exclarch;
while (@control) {
my $c = shift @control;
last if $c eq ''; # new paragraph
my ($tag, $data) = split(':', $c, 2);
next unless defined $data;
$tag = uc($tag);
while (@control && $control[0] =~ /^\s/) {
$data .= "\n".substr(shift @control, 1);
}
$data =~ s/^\s+//s;
$data =~ s/\s+$//s;
if ($tag eq 'VERSION') {
$version = $data;
$version =~ s/-[^-]+$//;
} elsif ($tag eq 'ARCHITECTURE') {
my @archs = split('\s+', $data);
map { s/\Q$os\E-//; s/any-// } @archs;
next if grep { $_ eq "any" || $_ eq "all" } @archs;
@exclarch = map { obsarch($_) } @archs;
# unify
my %exclarch = map {$_ => 1} @exclarch;
@exclarch = sort keys %exclarch;
} elsif ($tag eq 'SOURCE') {
$name = $data;
} elsif ($tag eq 'BUILD-DEPENDS' || $tag eq 'BUILD-CONFLICTS' || $tag eq 'BUILD-IGNORE' ||
$tag eq 'BUILD-DEPENDS-INDEP' || $tag eq 'BUILD-DEPENDS-ARCH' || $tag eq 'BUILD-CONFLICTS-ARCH' ) {
my @d = split(/\s*,\s*/, $data);
for my $d (@d) {
my @alts = split('\s*\|\s*', $d);
my @needed;
for my $c (@alts) {
if ($c =~ /\s+<[^>]+>$/) {
my @build_profiles; # Empty for now
my $bad = 1;
while ($c =~ s/\s+<([^>]+)>$//) {
next if (!$bad);
my $list_valid = 1;
for my $term (split(/\s+/, $1)) {
my $isneg = ($term =~ s/^\!//);
my $profile_match = grep(/^$term$/, @build_profiles);
if (( $profile_match && $isneg) ||
(!$profile_match && !$isneg)) {
$list_valid = 0;
last;
}
}
$bad = 0 if ($list_valid);
}
next if ($bad);
}
if ($c =~ /^(.*?)\s*\[(.*)\]$/) {
$c = $1;
my $isneg = 0;
my $bad;
for my $q (split('[\s,]', $2)) {
$isneg = 1 if $q =~ s/^\!//;
$bad = 1 if !defined($bad) && !$isneg;
if ($isneg) {
if ($q eq $arch || $q eq 'any' || $q eq "$os-$arch" || $q eq "$os-any" || $q eq "any-$arch") {
$bad = 1;
last;
}
} elsif ($q eq $arch || $q eq 'any' || $q eq "$os-$arch" || $q eq "$os-any" || $q eq "any-$arch") {
$bad = 0;
}
}
next if ($bad);
}
$c =~ s/^([^:\s]*):(any|native)(.*)$/$1$3/;
push @needed, $c;
}
next unless @needed;
$d = join(' | ', @needed);
$d =~ s/ \(([^\)]*)\)/ $1/g;
$d =~ s/>>/>/g;
$d =~ s/<</</g;
if ($tag eq 'BUILD-DEPENDS' || $tag eq 'BUILD-DEPENDS-INDEP' || $tag eq 'BUILD-DEPENDS-ARCH') {
push @deps, $d;
} else {
push @deps, "-$d";
}
}
}
}
my $ret = {};
$ret->{'name'} = $name;
$ret->{'version'} = $version;
$ret->{'deps'} = \@deps;
$ret->{'exclarch'} = \@exclarch if @exclarch;
return $ret;
}
sub uncompress_rawlzma {
my ($in) = @_;
return undef unless defined($in) && $in ne '';
my $out = '';
my ($lz, $status) = Compress::Raw::Lzma::AutoDecoder->new('ConsumeInput' => 1, 'AppendOutput' => 1);
return undef unless $lz;
while (1) {
$status = $lz->code($in, $out);
return $out if $status == Compress::Raw::Lzma::LZMA_STREAM_END();
return undef if $status != Compress::Raw::Lzma::LZMA_OK();
}
}
sub uncompress {
my ($data, $tool) = @_;
return $data if $tool eq 'cat';
return Compress::Zlib::memGunzip($data) if $have_zlib && $tool eq 'gunzip';
return uncompress_rawlzma($data) if $have_rawlzma && $tool eq 'unxz';
local (*TMP, *TMP2);
open(TMP, "+>", undef) or die("could not open tmpfile\n");
syswrite TMP, $data;
my $pid = open(TMP2, "-|");
die("fork: $!\n") unless defined $pid;
if (!$pid) {
open(STDIN, "<&TMP");
seek(STDIN, 0, 0); # these two lines are a workaround for a perl bug mixing up FD
sysseek(STDIN, 0, 0);
exec($tool);
die("$tool: $!\n");
}
close(TMP);
$data = '';
1 while sysread(TMP2, $data, 1024, length($data)) > 0;
if (!close(TMP2)) {
warn("$tool error: $?\n");
return undef;
}
return $data;
}
sub control2res {
my ($control) = @_;
my %res;
my @control = split("\n", $control);
while (@control) {
my $c = shift @control;
last if $c eq ''; # new paragraph
my ($tag, $data) = split(':', $c, 2);
next unless defined $data;
$tag = uc($tag);
while (@control && $control[0] =~ /^\s/) {
$data .= "\n".substr(shift @control, 1);
}
$data =~ s/^\s+//s;
$data =~ s/\s+$//s;
$res{$tag} = $data;
}
return %res;
}
sub debq {
my ($fn) = @_;
local *DEBF;
if (ref($fn) eq 'GLOB') {
*DEBF = *$fn;
} elsif (!open(DEBF, '<', $fn)) {
warn("$fn: $!\n");
return ();
}
my $data = '';
sysread(DEBF, $data, 4096);
if (length($data) < 8+60) {
warn("$fn: not a debian package - header too short\n");
close DEBF unless ref $fn;
return ();
}
if (substr($data, 0, 8+16) ne "!<arch>\ndebian-binary " &&
substr($data, 0, 8+16) ne "!<arch>\ndebian-binary/ ") {
close DEBF unless ref $fn;
return ();
}
my $len = substr($data, 8+48, 10);
$len += $len & 1;
if (length($data) < 8+60+$len+60) {
my $r = 8+60+$len+60 - length($data);
$r -= length($data);
if ((sysread(DEBF, $data, $r < 4096 ? 4096 : $r, length($data)) || 0) < $r) {
warn("$fn: unexpected EOF\n");
close DEBF unless ref $fn;
return ();
}
}
$data = substr($data, 8 + 60 + $len);
my $controlname = substr($data, 0, 16);
my $decompressor;
if ($controlname eq 'control.tar.gz ' || $controlname eq 'control.tar.gz/ ') {
$decompressor = 'gunzip';
} elsif ($controlname eq 'control.tar.xz ' || $controlname eq 'control.tar.xz/ ') {
$decompressor = 'unxz';
} elsif ($controlname eq 'control.tar.zst ' || $controlname eq 'control.tar.zst/') {
$decompressor = 'unzstd';
} elsif ($controlname eq 'control.tar ' || $controlname eq 'control.tar/ ') {
$decompressor = 'cat';
} else {
warn("$fn: control.tar is not second ar entry\n");
close DEBF unless ref $fn;
return ();
}
$len = substr($data, 48, 10);
if (length($data) < 60+$len) {
my $r = 60+$len - length($data);
if ((sysread(DEBF, $data, $r, length($data)) || 0) < $r) {
warn("$fn: unexpected EOF\n");
close DEBF unless ref $fn;
return ();
}
}
close DEBF unless ref($fn);
$data = substr($data, 60, $len);
my $controlmd5 = Digest::MD5::md5_hex($data); # our header signature
$data = uncompress($data, $decompressor);
if (!$data) {
warn("$fn: corrupt control.tar file\n");
return ();
}
my $control;
while (length($data) >= 512) {
my $n = substr($data, 0, 100);
$n =~ s/\0.*//s;
my $len = oct('00'.substr($data, 124,12));
my $blen = ($len + 1023) & ~511;
if (length($data) < $blen) {
warn("$fn: corrupt control.tar file\n");
return ();
}
if ($n eq './control' || $n eq "control") {
$control = substr($data, 512, $len);
last;
}
$data = substr($data, $blen);
}
my %res = control2res($control);
$res{'CONTROL_MD5'} = $controlmd5;
return %res;
}
sub query {
my ($handle, %opts) = @_;
my %res = debq($handle);
return undef unless %res;
my $name = $res{'PACKAGE'};
my @provides = split(',\s*', $res{'PROVIDES'} || '');
if ($opts{'addselfprovides'}) {
push @provides, "$name (= $res{'VERSION'})";
}
my @depends = split(',\s*', $res{'DEPENDS'} || '');
push @depends, split(',\s*', $res{'PRE-DEPENDS'} || '');
my $data = {
name => $name,
hdrmd5 => $res{'CONTROL_MD5'},
provides => \@provides,
requires => \@depends,
};
my $src = $name;
if ($res{'SOURCE'}) {
$src = $res{'SOURCE'};
$data->{'sourcedep'} = $src;
$src =~ s/\s.*$//;
}
$data->{'source'} = $src if $src ne '';
if ($opts{'conflicts'}) {
my @conflicts = split(',\s*', $res{'CONFLICTS'} || '');
push @conflicts, split(',\s*', $res{'BREAKS'} || '');
$data->{'conflicts'} = \@conflicts if @conflicts;
}
if ($opts{'weakdeps'}) {
for my $dep ('SUGGESTS', 'RECOMMENDS', 'ENHANCES') {
$data->{lc($dep)} = [ split(',\s*', $res{$dep} || '') ] if defined $res{$dep};
}
}
if ($opts{'evra'}) {
$res{'VERSION'} =~ /^(?:(\d+):)?(.*?)(?:-([^-]*))?$/s;
$data->{'epoch'} = $1 if defined $1;
$data->{'version'} = $2;
$data->{'release'} = $3 if defined $3;
$data->{'arch'} = $res{'ARCHITECTURE'};
$data->{'multiarch'} = $res{'MULTI-ARCH'} if $res{'MULTI-ARCH'};
}
if ($opts{'description'}) {
$data->{'description'} = $res{'DESCRIPTION'};
}
if ($opts{'normalizedeps'}) {
for my $dep (qw{provides requires conflicts suggests enhances recommends}) {
next unless $data->{$dep};
for (@{$data->{$dep}}) {
s/ \(([^\)]*)\)/ $1/g;
s/<</</g;
s/>>/>/g;
}
}
}
return $data;
}
sub queryhdrmd5 {
my ($bin) = @_;
local *F;
open(F, '<', $bin) || die("$bin: $!\n");
my $data = '';
sysread(F, $data, 4096);
if (length($data) < 8+60) {
warn("$bin: not a debian package - header too short\n");
close F;
return undef;
}
if (substr($data, 0, 8+16) ne "!<arch>\ndebian-binary " &&
substr($data, 0, 8+16) ne "!<arch>\ndebian-binary/ ") {
warn("$bin: not a debian package - no \"debian-binary\" entry\n");
close F;
return undef;
}
my $len = substr($data, 8+48, 10);
$len += $len & 1;
if (length($data) < 8+60+$len+60) {
my $r = 8+60+$len+60 - length($data);
$r -= length($data);
if ((sysread(F, $data, $r < 4096 ? 4096 : $r, length($data)) || 0) < $r) {
warn("$bin: unexpected EOF\n");
close F;
return undef;
}
}
$data = substr($data, 8 + 60 + $len);
my $controlname = substr($data, 0, 16);
if ($controlname ne 'control.tar.gz ' && $controlname ne 'control.tar.gz/ ' &&
$controlname ne 'control.tar.xz ' && $controlname ne 'control.tar.xz/ ' &&
$controlname ne 'control.tar.zst ' && $controlname ne 'control.tar.zst/' &&
$controlname ne 'control.tar ' && $controlname ne 'control.tar/ ') {
warn("$bin: control.tar is not second ar entry\n");
close F;
return undef;
}
$len = substr($data, 48, 10);
if (length($data) < 60+$len) {
my $r = 60+$len - length($data);
if ((sysread(F, $data, $r, length($data)) || 0) < $r) {
warn("$bin: unexpected EOF\n");
close F;
return undef;
}
}
close F;
$data = substr($data, 60, $len);
return Digest::MD5::md5_hex($data);
}
sub verscmp_part {
my ($s1, $s2) = @_;
return 0 if $s1 eq $s2;
$s1 =~ s/([0-9]+)/substr("00000000000000000000000000000000$1", -32, 32)/ge;
$s2 =~ s/([0-9]+)/substr("00000000000000000000000000000000$1", -32, 32)/ge;
$s1 .= "\0";
$s2 .= "\0";
$s1 =~ tr[\176\000-\037\060-\071\101-\132\141-\172\040-\057\072-\100\133-\140\173-\175][\000-\176];
$s2 =~ tr[\176\000-\037\060-\071\101-\132\141-\172\040-\057\072-\100\133-\140\173-\175][\000-\176];
return $s1 cmp $s2;
}
sub verscmp {
my ($s1, $s2) = @_;
my ($e1, $v1, $r1) = $s1 =~ /^(?:(\d+):)?(.*?)(?:-([^-]*))?$/s;
$e1 = 0 unless defined $e1;
my ($e2, $v2, $r2) = $s2 =~ /^(?:(\d+):)?(.*?)(?:-([^-]*))?$/s;
$e2 = 0 unless defined $e2;
if ($e1 ne $e2) {
my $r = verscmp_part($e1, $e2);
return $r if $r;
}
my $r = verscmp_part($v1, $v2);
return $r if $r;
$r1 = '' unless defined $r1;
$r2 = '' unless defined $r2;
return verscmp_part($r1, $r2);
}
sub queryinstalled {
my ($root, %opts) = @_;
$root = '' if !defined($root) || $root eq '/';
my @pkgs;
local *F;
if (open(F, '<', "$root/var/lib/dpkg/status")) {
my $ctrl = '';
while(<F>) {
if ($_ eq "\n") {
my %res = control2res($ctrl);
if (defined($res{'PACKAGE'})) {
my $data = {'name' => $res{'PACKAGE'}};
$res{'VERSION'} =~ /^(?:(\d+):)?(.*?)(?:-([^-]*))?$/s;
$data->{'epoch'} = $1 if defined $1;
$data->{'version'} = $2;
$data->{'release'} = $3 if defined $3;
$data->{'arch'} = $res{'ARCHITECTURE'};
push @pkgs, $data;
}
$ctrl = '';
next;
}
$ctrl .= $_;
}
close F;
}
return \@pkgs;
}
1;
07070100000005000081a400000000000000000000000163e504b900001489000000000000000000000000000000000000001100000000Build/Debrepo.pm################################################################
#
# Copyright (c) 1995-2014 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
#
################################################################
package Build::Debrepo;
use strict;
sub addpkg {
my ($res, $data, $options) = @_;
return unless defined $data->{'version'};
my $selfprovides;
$selfprovides = "= $data->{'version'}" if $options->{'addselfprovides'};
# split version into evr
$data->{'epoch'} = $1 if $data->{'version'} =~ s/^(\d+)://s;
$data->{'release'} = $1 if $data->{'version'} =~ s/-([^-]*)$//s;
for my $d (qw{provides requires conflicts recommends suggests enhances breaks prerequires}) {
next unless $data->{$d};
if ($options->{'normalizedeps'}) {
$data->{$d} =~ s/\(([^\)]*)\)/$1/g;
$data->{$d} =~ s/<</</g;
$data->{$d} =~ s/>>/>/g;
}
$data->{$d} = [ split(/\s*,\s*/, $data->{$d}) ];
}
push @{$data->{'requires'}}, @{$data->{'prerequires'}} if $data->{'prerequires'};
delete $data->{'prerequires'};
push @{$data->{'conflicts'}}, @{$data->{'breaks'}} if $data->{'breaks'};
delete $data->{'breaks'};
if (defined($selfprovides)) {
$selfprovides = "($selfprovides)" unless $options->{'normalizedeps'};
$selfprovides = "$data->{'name'} $selfprovides";
push @{$data->{'provides'}}, $selfprovides unless @{$data->{'provides'} || []} && $data->{'provides'}->[-1] eq $selfprovides;
}
if ($options->{'withchecksum'}) {
for (qw {md5 sha1 sha256}) {
my $c = delete($data->{"checksum_$_"});
$data->{'checksum'} = "$_:$c" if $c;
}
}
$data->{'sourcedep'} = $data->{'source'} if $data->{'source'};
$data->{'source'} =~ s/\s.*// if $data->{'source'};
if (ref($res) eq 'CODE') {
$res->($data);
} else {
push @$res, $data;
}
}
my %tmap = (
'package' => 'name',
'version' => 'version',
'architecture' => 'arch',
'provides' => 'provides',
'depends' => 'requires',
'pre-depends' => 'prerequires',
'conflicts' => 'conflicts',
'breaks' => 'breaks',
'recommends' => 'recommends',
'suggests' => 'suggests',
'enhances' => 'enhances',
'filename' => 'location',
'source' => 'source',
'multi-arch' => 'multiarch',
);
my %tmap_checksums = (
'md5sum' => 'checksum_md5',
'sha1' => 'checksum_sha1',
'sha256' => 'checksum_sha256',
);
sub parse {
my ($in, $res, %options) = @_;
$res ||= [];
my $fd;
if (ref($in)) {
$fd = $in;
} else {
if ($in =~ /\.gz$/) {
open($fd, '-|', "gzip", "-dc", $in) || die("$in: $!\n");
} else {
open($fd, '<', $in) || die("$in: $!\n");
}
}
my $pkg = {};
my $tag;
my %ltmap = %tmap;
%ltmap = (%ltmap, %tmap_checksums) if $options{'withchecksum'};
while (<$fd>) {
chomp;
if ($_ eq '') {
addpkg($res, $pkg, \%options) if %$pkg;
$pkg = {};
next;
}
if (/^\s/) {
next unless $tag;
$pkg->{$tag} .= "\n".substr($_, 1);
next;
}
my $data;
($tag, $data) = split(':', $_, 2);
next unless defined $data;
$tag = $ltmap{lc($tag)};
next unless $tag;
$data =~ s/^\s*//;
$pkg->{$tag} = $data;
}
addpkg($res, $pkg, \%options) if %$pkg;
if (!ref($in)) {
close($fd) || die("close $in: $!\n");
}
return $res;
}
sub urldecode {
my ($str, $iscgi) = @_;
$str =~ tr/+/ / if $iscgi;
$str =~ s/%([a-fA-F0-9]{2})/chr(hex($1))/sge;
return $str;
}
sub parserepourl {
my ($url) = @_;
my @components;
my $baseurl;
if ($url =~ /\?/) {
my ($base, $query) = split(/\?/, $url, 2);
if ("&$query" =~ /\&dist=/) {
my $dist;
for my $querypart (split('&', $query)) {
my ($k, $v) = split('=', $querypart, 2);
$k = urldecode($k, 1);
$v = urldecode($v, 1);
$dist = $v if $k eq 'dist';
push @components, split(/[,+]/, $v) if $k eq 'component';
}
$baseurl = $base;
$baseurl .= '/' unless $baseurl =~ /\/$/;
$url = "${baseurl}dists/${dist}/";
push @components, 'main' unless @components;
}
}
if (@components) {
; # all done above
} elsif ($url =~ /^(.*\/)\.(\/.*)?$/) {
# flat repo
$baseurl = $1;
@components = ('.');
$url = defined($2) ? "$1$2" : $1;
$url .= '/' unless $url =~ /\/$/;
} else {
if ($url =~ /([^\/]+)$/) {
@components = split(/[,+]/, $1);
$url =~ s/([^\/]+)$//;
}
push @components, 'main' unless @components;
$url .= '/' unless $url =~ /\/$/;
$baseurl = $url;
$url =~ s/([^\/]+\/)$/dists\/$1/;
$baseurl =~ s/([^\/]+\/)$//;
}
return $baseurl, $url, \@components;
}
1;
07070100000006000081a400000000000000000000000163e504b900003a3d000000000000000000000000000000000000001000000000Build/Docker.pm################################################################
#
# Copyright (c) 2017 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
#
################################################################
package Build::Docker;
use Build::SimpleXML; # to parse the annotation
use Build::SimpleJSON;
use strict;
sub unify {
my %h = map {$_ => 1} @_;
return grep(delete($h{$_}), @_);
}
sub gettargetarch {
my ($config) = @_;
my $arch = 'noarch';
for (@{$config->{'macros'} || []}) {
$arch = $1 if /^%define _target_cpu (\S+)/;
}
return $arch;
}
sub slurp {
my ($fn) = @_;
local *F;
return undef unless open(F, '<', $fn);
local $/ = undef; # Perl slurp mode
my $content = <F>;
close F;
return $content;
}
sub expandvar_cplx {
my ($cplx, $vars) = @_;
if ($cplx =~ /^\!([a-zA-Z0-9_]+)/) {
return [] unless @{$vars->{$1} || []};
my $n = $vars->{$1}->[0];
return $vars->{$n} || [];
}
return [] unless $cplx =~ /^([^\}:]+):([-+])([^}]*)$/s;
my ($n, $m, $v) = ($1, $2, $3);
$v = expandvars($v, $vars) if $v =~ /\$/;
my $o = join(' ', @{$vars->{$n} || []});
return $o ne '' ? $vars->{$n} : [ $v ] if $m eq '-';
return $o ne '' ? [ $v ] : [] if $m eq '+';
return [];
}
sub expandvars {
my ($str, $vars) = @_;
$str =~ s/\$([a-zA-Z0-9_]+)|\$\{([^\}:\!]+)\}|\$\{([^}]+)\}/join(' ', @{$3 ? expandvar_cplx($3, $vars) : $vars->{$2 || $1} || []})/ge;
return $str;
}
sub quote {
my ($str, $q, $vars) = @_;
$str = expandvars($str, $vars) if $vars && $q ne "'" && $str =~ /\$/;
$str =~ s/([ \t\"\'\$\(\)])/sprintf("%%%02X", ord($1))/ge;
return $str;
}
sub addrepo {
my ($ret, $url, $prio) = @_;
unshift @{$ret->{'imagerepos'}}, { 'url' => $url };
$ret->{'imagerepos'}->[0]->{'priority'} = $prio if defined $prio;
if (defined($Build::Kiwi::urlmapper) && !$Build::Kiwi::urlmapper) {
unshift @{$ret->{'path'}}, { %{$ret->{'imagerepos'}->[0]} };
return 1;
}
if ($Build::Kiwi::urlmapper) {
my $prp = $Build::Kiwi::urlmapper->($url);
if (!$prp) {
$ret->{'error'} = "cannot map '$url' to obs";
return undef;
}
my ($projid, $repoid) = split('/', $prp, 2);
unshift @{$ret->{'path'}}, {'project' => $projid, 'repository' => $repoid};
$ret->{'path'}->[0]->{'priority'} = $prio if defined $prio;
return 1;
} else {
# this is just for testing purposes...
$url =~ s/^\/+$//;
$url =~ s/:\//:/g;
my @url = split('/', $url);
unshift @{$ret->{'path'}}, {'project' => $url[-2], 'repository' => $url[-1]} if @url >= 2;
$ret->{'path'}->[0]->{'priority'} = $prio if defined $prio;
return 1;
}
}
sub cmd_zypper {
my ($ret, @args) = @_;
# skip global options
while (@args && $args[0] =~ /^-/) {
shift @args if $args[0] eq '-R' || $args[0] eq '--root' || $args[0] eq '--installroot';
shift @args;
}
return unless @args;
if ($args[0] eq 'in' || $args[0] eq 'install') {
shift @args;
while (@args && $args[0] =~ /^-/) {
shift @args if $args[0] =~ /^--(?:from|repo|type)$/ || $args[0] =~ /^-[tr]$/;
shift @args;
}
my @deps = grep {/^[a-zA-Z_0-9]/} @args;
s/^([^<=>]+)([<=>]+)/$1 $2 / for @deps;
push @{$ret->{'deps'}}, @deps;
} elsif ($args[0] eq 'ar' || $args[0] eq 'addrepo') {
my $prio;
shift @args;
while (@args && $args[0] =~ /^-/) {
if ($args[0] eq '-p' || $args[0] eq '--priority') {
$prio = 99 - $args[1];
splice(@args, 0, 2);
next;
}
shift @args if $args[0] =~ /^--(?:repo|type)$/ || $args[0] =~ /^-[rt]$/;
shift @args;
}
if (@args) {
my $path = $args[0];
$path =~ s/\/[^\/]*\.repo$//;
addrepo($ret, $path, $prio);
}
}
}
sub cmd_obs_pkg_mgr {
my ($ret, @args) = @_;
return unless @args;
if ($args[0] eq 'add_repo') {
shift @args;
addrepo($ret, $args[0]) if @args;
} elsif ($args[0] eq 'install') {
shift @args;
push @{$ret->{'deps'}}, @args;
}
}
sub cmd_dnf {
my ($ret, @args) = @_;
# skip global options
shift @args while @args && $args[0] =~ /^-/;
return unless @args;
if ($args[0] eq 'in' || $args[0] eq 'install') {
shift @args;
while (@args && $args[0] =~ /^-/) {
shift @args;
}
push @{$ret->{'deps'}}, grep {/^[a-zA-Z_0-9]/} @args;
}
}
sub cmd_apt_get {
my ($ret, @args) = @_;
shift @args while @args && $args[0] =~ /^-/;
return unless @args;
if ($args[0] eq 'install') {
shift @args;
push @{$ret->{'deps'}}, grep {/^[a-zA-Z_0-9]/} @args;
}
}
sub cmd_curl {
my ($ret, @args) = @_;
my @urls;
while (@args) {
my $arg = shift @args;
if ($arg eq '--url') {
$arg = shift @args;
push @urls, $arg if $arg =~ /^https?:\/\//;
} elsif ($arg =~ /^-/) {
shift @args if $arg eq '-d' || $arg =~ /^--data/ || $arg eq '-F' || $arg =~ /^--form/ || $arg eq '-m' || $arg =~ /^--max/ || $arg eq '-o' || $arg eq '--output' || $arg =~ /^--retry/ || $arg eq '-u' || $arg eq '--user' || $arg eq '-A' || $arg eq '--user-agent' || $arg eq '-H' || $arg eq '--header';
} else {
push @urls, $arg if $arg =~ /^https?:\/\//;
}
}
for my $url (@urls) {
my $asset = { 'url' => $url, 'type' => 'webcache' };
push @{$ret->{'remoteassets'}}, $asset;
}
}
sub parse {
my ($cf, $fn) = @_;
my $unorderedrepos;
my $useobsrepositories;
my $nosquash;
my $dockerfile_data;
my $remoteasset;
if (ref($fn) eq 'SCALAR') {
$dockerfile_data = $$fn;
} else {
$dockerfile_data = slurp($fn);
return { 'error' => 'could not open Dockerfile' } unless defined $dockerfile_data;
}
my @lines = split(/\r?\n/, $dockerfile_data);
my $ret = {
'deps' => [],
'path' => [],
'imagerepos' => [],
};
my %build_vars;
if ($cf->{'buildflags:dockerarg'}) {
for (@{$cf->{'buildflags'} || []}) {
$build_vars{$1} = [ $2 ] if /^dockerarg:(.*?)=(.*)$/s;
}
}
my $excludedline;
my $vars = {};
my $vars_env = {};
my $vars_meta = {};
my %as_container;
my $from_seen;
my @requiredarch;
my @badarch;
my @containerrepos;
while (@lines) {
my $line = shift @lines;
$line =~ s/^\s+//;
if ($line =~ /^#/) {
if ($line =~ /^#!BuildTag:\s*(.*?)$/) {
my @tags = split(' ', $1);
push @{$ret->{'containertags'}}, @tags if @tags;
}
if ($line =~ /^#!BuildName:\s*(\S+)\s*$/) {
$ret->{'name'} = $1;
}
if ($line =~ /^#!BuildVersion:\s*(\S+)\s*$/) {
$ret->{'version'} = $1;
}
if ($line =~ /^#!UnorderedRepos\s*$/) {
$unorderedrepos = 1;
}
if ($line =~ /^#!UseOBSRepositories\s*$/) {
$useobsrepositories = 1;
}
if ($line =~ /^#!NoSquash\s*$/) {
$nosquash = 1;
}
if ($line =~ /^#!Milestone:\s*(\S+)\s*$/) {
$ret->{'milestone'} = $1;
}
if ($line =~ /^#!ExcludeArch:\s*(.*?)$/) {
push @badarch, split(' ', $1) ;
}
if ($line =~ /^#!ExclusiveArch:\s*(.*?)$/) {
push @requiredarch, split(' ', $1) ;
}
if ($line =~ /^#!ArchExclusiveLine:\s*(.*?)$/) {
my $arch = gettargetarch($cf);
$excludedline = (grep {$_ eq $arch} split(' ', $1)) ? undef : 1;
}
if ($line =~ /^#!ArchExcludedLine:\s*(.*?)$/) {
my $arch = gettargetarch($cf);
$excludedline = (grep {$_ eq $arch} split(' ', $1)) ? 1 : undef;
}
if ($line =~ /^\#\!RemoteAssetUrl:\s*(\S+)\s*$/i) {
$remoteasset->{'url'} = $1;
push @{$ret->{'remoteassets'}}, $remoteasset;
$remoteasset = undef;
}
next;
}
$ret->{'exclarch'} = [ unify(@requiredarch) ] if @requiredarch;
$ret->{'badarch'} = [ unify(@badarch) ] if @badarch;
# add continuation lines
while (@lines && $line =~ s/\\[ \t]*$//) {
shift @lines while @lines && $lines[0] =~ /^\s*#/;
$line .= shift(@lines) if @lines;
}
$line =~ s/^\s+//;
$line =~ s/\s+$//;
next unless $line;
if ($excludedline) {
undef $excludedline;
next;
}
my ($cmd, @args);
($cmd, $line) = split(' ', $line, 2);
$cmd = uc($cmd);
# escape and unquote
$line =~ s/%/%25/g;
$line =~ s/\\(.)/sprintf("%%%02X", ord($1))/ge;
while ($line =~ /([\"\'])/) {
my $q = $1;
last unless $line =~ s/$q(.*?)$q/quote($1, $q, $vars)/e;
}
if ($cmd eq 'FROM') {
$vars = { %$vars_meta }; # reset vars
}
# split into args then expand
@args = split(/[ \t]+/, $line);
for my $arg (@args) {
$arg = expandvars($arg, $vars) if $arg =~ /\$/;
$arg =~ s/%([a-fA-F0-9]{2})/chr(hex($1))/ge;
}
# process commands
if ($cmd eq 'FROM') {
shift @args if @args && $args[0] =~ /^--platform=/;
if (@args && !$as_container{$args[0]}) {
$as_container{$args[2]} = $args[0] if @args > 2 && lc($args[1]) eq 'as';
my $container = $args[0];
if ($container ne 'scratch') {
if ($Build::Kiwi::urlmapper && $container =~ /^([^\/]+\.[^\/]+)\/[a-zA-Z0-9]/) {
my $prp = $Build::Kiwi::urlmapper->("registry://$1/");
push @containerrepos, $prp if $prp;
}
$container .= ':latest' unless $container =~ /:[^:\/]+$/;
$container = "container:$container";
if ($container && !grep {$_ eq $container} @{$ret->{'deps'}}) {
push @{$ret->{'deps'}}, $container;
}
}
}
$vars_env = {}; # should take env from base container
$vars = { %$vars_env };
$from_seen = 1;
} elsif ($cmd eq 'RUN') {
$line =~ s/#.*//; # get rid of comments
for my $l (split(/(?:\||\|\||\&|\&\&|;|\)|\()/, $line)) {
$l =~ s/^\s+//;
$l =~ s/\s+$//;
$l = expandvars($l, $vars) if $l =~ /\$/;
@args = split(/[ \t]+/, $l);
s/%([a-fA-F0-9]{2})/chr(hex($1))/ge for @args;
next unless @args;
my $rcmd = shift @args;
$rcmd = shift @args if @args && ($rcmd eq 'then' || $rcmd eq 'else' || $rcmd eq 'elif' || $rcmd eq 'if' || $rcmd eq 'do');
if ($rcmd eq 'zypper') {
cmd_zypper($ret, @args);
} elsif ($rcmd eq 'yum' || $rcmd eq 'dnf') {
cmd_dnf($ret, @args);
} elsif ($rcmd eq 'apt-get') {
cmd_apt_get($ret, @args);
} elsif ($rcmd eq 'curl') {
cmd_curl($ret, @args);
} elsif ($rcmd eq 'obs_pkg_mgr') {
cmd_obs_pkg_mgr($ret, @args);
}
}
} elsif ($cmd eq 'ENV') {
@args=("$args[0]=$args[1]") if @args == 2 && $args[0] !~ /=/;
for (@args) {
next unless /^(.*?)=(.*)$/;
$vars->{$1} = [ $2 ];
$vars_env->{$1} = [ $2 ];
}
} elsif ($cmd eq 'ARG') {
for (@args) {
next unless /^([^=]+)(?:=(.*))?$/;
next if $vars_env->{$1};
$vars->{$1} = $build_vars{$1} || (defined($2) ? [ $2 ] : $vars_meta->{$1} || []);
$vars_meta->{$1} = $vars->{$1} unless $from_seen;
}
}
}
push @{$ret->{'deps'}}, '--unorderedimagerepos' if $unorderedrepos;
my $version = $ret->{'version'};
my $release = $cf->{'buildrelease'};
for (@{$ret->{'containertags'} || []}) {
s/<VERSION>/$version/g if defined $version;
s/<RELEASE>/$release/g if defined $release;
}
$ret->{'name'} = 'docker' if !defined($ret->{'name'}) && !$cf->{'__dockernoname'};
$ret->{'path'} = [ { 'project' => '_obsrepositories', 'repository' => '' } ] if $useobsrepositories;
$ret->{'nosquash'} = 1 if $nosquash;
if (@containerrepos) {
for (unify(@containerrepos)) {
my @s = split('/', $_, 2);
push @{$ret->{'containerpath'}}, {'project' => $s[0], 'repository' => $s[1] };
}
}
return $ret;
}
sub showcontainerinfo {
my ($disturl, $release);
while (@ARGV) {
if (@ARGV > 2 && $ARGV[0] eq '--disturl') {
(undef, $disturl) = splice(@ARGV, 0, 2);
} elsif (@ARGV > 2 && $ARGV[0] eq '--release') {
(undef, $release) = splice(@ARGV, 0, 2);
} else {
last;
}
}
my ($fn, $image, $taglist, $annotationfile) = @ARGV;
local $Build::Kiwi::urlmapper = sub { return $_[0] };
my $cf = { '__dockernoname' => 1 };
$cf->{'buildrelease'} = $release if defined $release;
my $d = {};
$d = parse($cf, $fn) if $fn;
die("$d->{'error'}\n") if $d->{'error'};
$image =~ s/.*\/// if defined $image;
my @tags = split(' ', $taglist);
for (@tags) {
$_ .= ':latest' unless /:[^:\/]+$/;
if (/:([0-9][^:]*)$/) {
$d->{'version'} = $1 unless defined $d->{'version'};
}
}
my @repos = @{$d->{'imagerepos'} || []};
if ($annotationfile) {
my $annotation = slurp($annotationfile);
$annotation = Build::SimpleXML::parse($annotation) if $annotation;
$annotation = $annotation && ref($annotation) eq 'HASH' ? $annotation->{'annotation'} : undef;
$annotation = $annotation && ref($annotation) eq 'ARRAY' ? $annotation->[0] : undef;
my $annorepos = $annotation && ref($annotation) eq 'HASH' ? $annotation->{'repo'} : undef;
$annorepos = undef unless $annorepos && ref($annorepos) eq 'ARRAY';
for my $annorepo (@{$annorepos || []}) {
next unless $annorepo && ref($annorepo) eq 'HASH' && $annorepo->{'url'};
push @repos, { 'url' => $annorepo->{'url'}, '_type' => {'priority' => 'number'} };
$repos[-1]->{'priority'} = $annorepo->{'priority'} if defined $annorepo->{'priority'};
}
}
my $buildtime = time();
my $containerinfo = {
'buildtime' => $buildtime,
'_type' => {'buildtime' => 'number'},
};
$containerinfo->{'tags'} = \@tags if @tags;
$containerinfo->{'repos'} = \@repos if @repos;
$containerinfo->{'file'} = $image if defined $image;
$containerinfo->{'disturl'} = $disturl if defined $disturl;
$containerinfo->{'name'} = $d->{'name'} if defined $d->{'name'};
$containerinfo->{'version'} = $d->{'version'} if defined $d->{'version'};
$containerinfo->{'release'} = $release if defined $release;
$containerinfo->{'milestone'} = $d->{'milestone'} if defined $d->{'milestone'};
print Build::SimpleJSON::unparse($containerinfo)."\n";
}
sub show {
my ($release);
while (@ARGV) {
if (@ARGV > 2 && $ARGV[0] eq '--release') {
(undef, $release) = splice(@ARGV, 0, 2);
} else {
last;
}
}
my ($fn, $field) = @ARGV;
local $Build::Kiwi::urlmapper = sub { return $_[0] };
my $cf = {};
$cf->{'buildrelease'} = $release if defined $release;
my $d = {};
$d = parse($cf, $fn) if $fn;
die("$d->{'error'}\n") if $d->{'error'};
my $x = $d->{$field};
$x = [ $x ] unless ref $x;
print "@$x\n";
}
1;
07070100000007000081a400000000000000000000000163e504b9000016b6000000000000000000000000000000000000001200000000Build/Download.pm################################################################
#
# Copyright (c) 2021 SUSE LLC
#
# 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
#
################################################################
package Build::Download;
use strict;
use LWP::UserAgent;
use Digest::MD5 ();
use Digest::SHA ();
#
# Create a user agent used to access remote servers
#
sub create_ua {
my (%opt) = @_;
my $agent = $opt{'agent'} || 'openSUSE build script';
my $timeout = $opt{'timeout'} || 60;
my $ssl_opts = $opt{'ssl_opts'} || { verify_hostname => 1 };
my $ua = LWP::UserAgent->new(agent => $agent, timeout => $timeout, ssl_opts => $ssl_opts);
$ua->env_proxy;
return $ua;
}
#
# Create a hash context from a digest
#
sub digest2ctx {
my ($digest) = @_;
return Digest::SHA->new(1) if $digest =~ /^sha1?:/i;
return Digest::SHA->new($1) if $digest =~ /^sha(\d+):/i;
return Digest::MD5->new() if $digest =~ /^md5:/i;
return undef;
}
#
# Verify that some data matches a digest
#
sub checkdigest {
my ($data, $digest) = @_;
my $ctx = digest2ctx($digest);
die("unsupported digest algo '$digest'\n") unless $ctx;
$ctx->add($data);
my $hex = $ctx->hexdigest();
if (lc($hex) ne lc((split(':', $digest, 2))[1])) {
die("digest mismatch: $digest, got $hex\n");
}
}
#
# Call the get method with the correct max size setting
#
sub ua_get {
my ($ua, $url, $maxsize, @hdrs) = @_;
my $res;
if (defined($maxsize)) {
my $oldmaxsize = $ua->max_size($maxsize);
$res = $ua->get($url, @hdrs);
$ua->max_size($oldmaxsize);
die("download of $url failed: ".$res->header('X-Died')) if $res->header('Client-Aborted') && $res->header('X-Died');
die("download of $url failed: max size exceeded\n") if $res->header('Client-Aborted');
} else {
$res = $ua->get($url, @hdrs);
}
return $res;
}
sub ua_head {
my ($ua, $url, $maxsize, @hdrs) = @_;
return $ua->head($url, @hdrs);
}
#
# Download a file with the correct max size setting
#
sub ua_mirror {
my ($ua, $url, $dest, $maxsize, @hdrs) = @_;
my $res = ua_get($ua, $url, $maxsize, ':content_file', $dest, @hdrs);
die("download of $url failed: ".$res->header('X-Died')) if $res->header('X-Died');
if ($res->is_success) {
my @s = stat($dest);
die("download of $url did not create $dest: $!\n") unless @s;
my ($cl) = $res->header('Content-length');
die("download of $url size mismatch: $cl != $s[7]\n") if defined($cl) && $cl != $s[7];
}
return $res;
}
#
# Download data from a server
#
sub fetch {
my ($url, %opt) = @_;
my $ua = $opt{'ua'} || create_ua();
my $retry = $opt{'retry'} || 0;
my $res;
my @accept;
@accept = ('Accept', join(', ', @{$opt{'accept'}})) if $opt{'accept'};
while (1) {
$res = ua_get($ua, $url, $opt{'maxsize'}, @accept, @{$opt{'headers'} || []});
last if $res->is_success;
return undef if $opt{'missingok'} && $res->code == 404;
my $status = $res->status_line;
die("download of $url failed: $status\n") unless $retry-- > 0 && $res->previous;
warn("retrying $url\n");
}
my $data = $res->decoded_content;
my $ct = $res->header('content_type');
checkdigest($data, $opt{'digest'}) if $opt{'digest'};
return ($data, $ct);
}
#
# Do a HEAD request
#
sub head {
my ($url, %opt) = @_;
my $ua = $opt{'ua'} || create_ua();
my $retry = $opt{'retry'} || 0;
my $res;
my @accept;
@accept = ('Accept', join(', ', @{$opt{'accept'}})) if $opt{'accept'};
while (1) {
$res = ua_head($ua, $url, $opt{'maxsize'}, @accept, @{$opt{'headers'} || []});
last if $res->is_success;
return undef if $opt{'missingok'} && $res->code == 404;
my $status = $res->status_line;
die("head request of $url failed: $status\n") unless $retry-- > 0 && $res->previous;
warn("retrying $url\n");
}
my $data = { $res->flatten() };
$data = { map {lc($_) => $data->{$_}} sort keys %$data };
my $ct = $res->header('content_type');
return ($data, $ct);
}
#
# Verify that the content of a file matches a digest
#
sub checkfiledigest {
my ($file, $digest) = @_;
my $ctx = digest2ctx($digest);
die("$file: unsupported digest algo '$digest'\n") unless $ctx;
my $fd;
open ($fd, '<', $file) || die("$file: $!\n");
$ctx->addfile($fd);
close($fd);
my $hex = $ctx->hexdigest();
if (lc($hex) ne lc((split(':', $digest, 2))[1])) {
die("$file: digest mismatch: $digest, got $hex\n");
}
}
#
# Download a file from a server
#
sub download {
my ($url, $dest, $destfinal, %opt) = @_;
my $ua = $opt{'ua'} || create_ua();
my $retry = $opt{'retry'} || 0;
while (1) {
unlink($dest); # just in case
my $res = eval { ua_mirror($ua, $url, $dest, $opt{'maxsize'}, @{$opt{'headers'} || []}) };
if ($@) {
unlink($dest);
die($@);
}
last if $res->is_success;
return undef if $opt{'missingok'} && $res->code == 404;
my $status = $res->status_line;
die("download of $url failed: $status\n") unless $retry-- > 0 && $res->previous;
warn("retrying $url\n");
}
checkfiledigest($dest, $opt{'digest'}) if $opt{'digest'};
if ($destfinal) {
rename($dest, $destfinal) || die("rename $dest $destfinal: $!\n");
}
return 1;
}
1;
07070100000008000081a400000000000000000000000163e504b900004d97000000000000000000000000000000000000001000000000Build/Expand.pm################################################################
#
# Copyright (c) 1995-2014 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
#
################################################################
package Build::Expand;
use strict;
our $expand_dbg;
# XXX: should also check the package EVR
sub nevrmatch {
my ($config, $r, @p) = @_;
my $rn = $r;
$rn =~ s/\s*([<=>]{1,2}).*$//;
return grep {$_ eq $rn} @p;
}
# check if package $q has a conflict against an installed package.
# if yes, add message to @$eq and return true
sub checkconflicts {
my ($config, $ins, $q, $eq, @r) = @_;
my $whatprovides = $config->{'whatprovidesh'};
my $ret = 0;
for my $r (@r) {
if ($r =~ /^\(.*\)$/) {
# note the []: we ignore errors here. they will be reported if the package is chosen.
my $n = normalizerich($config, $q, $r, 1, []);
$ret = 1 if check_conddeps_notinst($q, $n, $eq, $ins);
next;
}
my @eq = grep {$ins->{$_}} @{$whatprovides->{$r} || Build::addproviders($config, $r)};
next unless @eq;
push @$eq, map {"(provider $q conflicts with $_)"} @eq;
$ret = 1;
}
return $ret;
}
sub checkobsoletes {
my ($config, $ins, $q, $eq, @r) = @_;
my $whatprovides = $config->{'whatprovidesh'};
my $ret = 0;
for my $r (@r) {
my @eq = grep {$ins->{$_}} nevrmatch($config, $r, @{$whatprovides->{$r} || Build::addproviders($config, $r)});
next unless @eq;
push @$eq, map {"(provider $q obsoletes $_)"} @eq;
$ret = 1;
}
return $ret;
}
sub todo2recommended {
my ($config, $recommended, $todo) = @_;
my $whatprovides = $config->{'whatprovidesh'};
my $pkgrecommends = $config->{'recommendsh'} || {};
for my $p (splice @$todo) {
for my $r (@{$pkgrecommends->{$p} || []}) {
$recommended->{$_} = 1 for @{$whatprovides->{$r} || Build::addproviders($config, $r)}
}
}
}
sub cplx_mix {
my ($q1, $q2, $todnf) = @_;
my @q;
for my $qq1 (@$q1) {
for my $qq2 (@$q2) {
my %qq = map {$_ => 1} (@$qq1, @$qq2);
my @qq = sort keys %qq;
push @q, \@qq unless grep {$qq{"-$_"}} @qq;
}
}
return $todnf ? 0 : 1 unless @q;
return (-1, @q);
}
sub cplx_inv {
my ($f, @q) = @_;
return 1 - $f if $f == 0 || $f == 1;
my @iq;
for my $q (@q) {
$q = [ map {"-$_"} @$q ];
s/^--// for @$q;
}
return (-1, @q);
}
sub normalize_cplx_rec {
my ($c, $r, $todnf) = @_;
if ($r->[0] == 0) {
my $ri = (split(/[ <=>]/, $r->[1], 2))[0];
my ($config, $p, $ignore, $xignore) = @$c;
if (!$todnf) {
return 1 if $ignore->{$ri} || $xignore->{$ri};
return 1 if defined($p) && ($ignore->{"$p:$ri"} || $xignore->{"$p:$ri"});
}
my $whatprovides = $config->{'whatprovidesh'};
my @q = @{$whatprovides->{$r->[1]} || Build::addproviders($config, $r->[1])};
return 0 unless @q;
if ($todnf) {
return (-1, map { [ $_ ] } @q);
} else {
return (-1, [ @q ]);
}
}
if ($r->[0] == 3 && @$r == 4) {
# complex if/else case: A IF (B ELSE C) -> (A OR ~B) AND (C OR B)
my ($n1, @q1) = normalize_cplx_rec($c, [3, $r->[1], $r->[2]], $todnf);
my ($n2, @q2) = normalize_cplx_rec($c, [2, $r->[2], $r->[3]], $todnf);
return 0 if $n1 == 0 || $n2 == 0;
return ($n2, @q2) if $n1 == 1;
return ($n1, @q1) if $n2 == 1;
if (!$todnf) {
return (-1, @q1, @q2);
} else {
return cplx_mix(\@q1, \@q2, $todnf);
}
}
if ($r->[0] == 4 && @$r == 4) {
# complex unless/else case: A UNLESS (B ELSE C) -> (A AND ~B) OR (C AND B)
my ($n1, @q1) = normalize_cplx_rec($c, [4, $r->[1], $r->[2]], $todnf);
my ($n2, @q2) = normalize_cplx_rec($c, [1, $r->[2], $r->[3]], $todnf);
return 1 if $n1 == 1 || $n2 == 1;
return ($n2, @q2) if $n1 == 0;
return ($n1, @q1) if $n2 == 0;
if ($todnf) {
return (-1, @q1, @q2);
} else {
return cplx_mix(\@q1, \@q2, $todnf);
}
}
if ($r->[0] == 1 || $r->[0] == 4) {
# and / unless
my $todnf2 = $r->[0] == 4 ? !$todnf : $todnf;
my ($n1, @q1) = normalize_cplx_rec($c, $r->[1], $todnf);
my ($n2, @q2) = normalize_cplx_rec($c, $r->[2], $todnf);
($n2, @q2) = cplx_inv($n2, @q2) if $r->[0] == 4;
return 0 if $n1 == 0 || $n2 == 0;
return ($n2, @q2) if $n1 == 1;
return ($n1, @q1) if $n2 == 1;
if (!$todnf) {
return (-1, @q1, @q2);
} else {
return cplx_mix(\@q1, \@q2, $todnf);
}
}
if ($r->[0] == 2 || $r->[0] == 3) {
# or / if
my $todnf2 = $r->[0] == 3 ? !$todnf : $todnf;
my ($n1, @q1) = normalize_cplx_rec($c, $r->[1], $todnf);
my ($n2, @q2) = normalize_cplx_rec($c, $r->[2], $todnf2);
($n2, @q2) = cplx_inv($n2, @q2) if $r->[0] == 3;
return 1 if $n1 == 1 || $n2 == 1;
return ($n2, @q2) if $n1 == 0;
return ($n1, @q1) if $n2 == 0;
if ($todnf) {
return (-1, @q1, @q2);
} else {
return cplx_mix(\@q1, \@q2, $todnf);
}
}
if ($r->[0] == 6 || $r->[0] == 7) {
# with / without
my ($n1, @q1) = normalize_cplx_rec($c, $r->[1], 0);
my ($n2, @q2) = normalize_cplx_rec($c, $r->[2], 0);
if ($n2 == 0 && $r->[0] == 7) {
@q2 = ( [] );
$n2 = -1;
}
return 0 if $n1 != -1 || $n2 != -1;
return 0 if @q1 != 1 || @q2 != 1;
@q1 = @{$q1[0]};
@q2 = @{$q2[0]};
return 0 if grep {/^-/} @q1;
return 0 if grep {/^-/} @q2;
my %q2 = map {$_ => 1} @q2;
my @q;
if ($r->[0] == 6) {
@q = grep {$q2{$_}} @q1;
} else {
@q = grep {!$q2{$_}} @q1;
}
return 0 unless @q;
if ($todnf) {
return (-1, map { [ $_ ] } @q);
} else {
return (-1, [ @q ]);
}
}
return 0;
}
sub normalizerich {
my ($config, $p, $dep, $deptype, $error, $ignore, $xignore) = @_;
my $r = Build::Rpm::parse_rich_dep($dep);
if (!$r) {
if (defined($p)) {
push @$error, "cannot parse dependency $dep from $p";
} else {
push @$error, "cannot parse dependency $dep";
}
return [];
}
my $c = [$config, $p, $ignore || {}, $xignore || {}];
my ($n, @q);
if ($deptype == 0) {
($n, @q) = normalize_cplx_rec($c, $r);
return () if $n == 1;
if (!$n) {
if (defined($p)) {
push @$error, "nothing provides $dep needed by $p";
} else {
push @$error, "nothing provides $dep";
}
return [];
}
} else {
($n, @q) = normalize_cplx_rec($c, $r, 1);
($n, @q) = cplx_inv($n, @q);
if (!$n) {
if (defined($p)) {
push @$error, "$p conflicts with always true $dep";
} else {
push @$error, "conflict with always true $dep";
}
}
}
for my $q (@q) {
my @neg = @$q;
@neg = grep {s/^-//} @neg;
@neg = grep {$_ ne $p} @neg if defined $p;
@$q = grep {!/^-/} @$q;
$q = [$dep, $deptype, \@neg, @$q];
}
return \@q;
}
# handle a normalized rich dependency from install of package p
# todo_cond is undef if we are re-checking the cond queue
sub check_conddeps_inst {
my ($p, $n, $error, $installed, $aconflicts, $todo, $todo_cond) = @_;
for my $c (@$n) {
my ($r, $rtype, $cond, @q) = @$c;
next unless defined $cond; # already handled?
next if grep {$installed->{$_}} @q; # already fulfilled
my @cx = grep {!$installed->{$_}} @$cond; # open conditions
if (!@cx) {
$c->[2] = undef; # mark as handled to avoid dups
if (@q) {
push @$todo, $c, $p;
} elsif (@$cond) {
if (!$rtype) {
if (defined($p)) {
push @$error, "nothing provides $r needed by $p";
} else {
push @$error, "nothing provides $r";
}
next;
}
if (defined($p)) {
push @$error, map {"$p conflicts with $_"} sort(@$cond);
} else {
push @$error, map {"conflicts with $_"} sort(@$cond);
}
}
} else {
if (!@q && @cx == 1) {
if (defined($p)) {
$aconflicts->{$cx[0]} = "is in conflict with $p";
} else {
$aconflicts->{$cx[0]} = "is in conflict";
}
} elsif ($todo_cond) {
push @{$todo_cond->{$_}}, [ $c, $p ] for @cx;
}
}
}
}
# handle a normalized rich dependency from a not-yet installed package
# (we just check conflicts)
sub check_conddeps_notinst {
my ($p, $n, $eq, $installed) = @_;
my $ret = 0;
for my $c (@$n) {
my ($r, $rtype, $cond, @q) = @$c;
next if @q || !@$cond || grep {!$installed->{$_}} @$cond;
push @$eq, map {"(provider $p conflicts with $_)"} sort(@$cond);
$ret = 1;
}
return $ret;
}
sub extractnative {
my ($config, $r, $p, $foreign) = @_;
my $ma = $config->{'multiarchh'}->{$p} || '';
if ($ma eq 'foreign' || ($ma eq 'allowed' && $r =~ /:any/)) {
if ($expand_dbg && !grep {$r eq $_} @$foreign) {
print "added $r to foreign dependencies\n";
}
push @$foreign, $r;
return 1;
}
return 0;
}
sub expand {
my ($config, @p) = @_;
my $conflicts = $config->{'conflicth'};
my $pkgconflicts = $config->{'pkgconflictsh'} || {};
my $pkgobsoletes = $config->{'pkgobsoletesh'} || {};
my $prefer = $config->{'preferh'};
my $ignore = $config->{'ignoreh'};
my $ignoreconflicts = $config->{'expandflags:ignoreconflicts'};
my $ignoreignore;
my $userecommendsforchoices = 1;
my $whatprovides = $config->{'whatprovidesh'};
my $requires = $config->{'requiresh'};
my $xignore = { map {substr($_, 1) => 1} grep {/^-/} @p };
$ignoreconflicts = 1 if $xignore->{'-ignoreconflicts--'};
$ignore = {} if $xignore->{'-ignoreignore--'};
if ($ignoreignore) {
$xignore = {};
$ignore = {};
}
my @directdepsend;
if ($xignore->{'-directdepsend--'}) {
delete $xignore->{'-directdepsend--'};
@directdepsend = @p;
for my $p (splice @p) {
last if $p eq '--directdepsend--';
push @p, $p;
}
@directdepsend = grep {!/^-/} splice(@directdepsend, @p + 1);
}
my $extractnative;
(undef, $extractnative) = splice(@p, 0, 2) if @p > 1 && $p[0] eq '--extractnative--' && ref($p[1]);
undef $extractnative if $extractnative && !%{$config->{'multiarchh'} || {}};
my %p; # expanded packages
my @todo; # dependencies to install
my @todo_inst; # packages we decided to install
my %todo_cond;
my %recommended; # recommended by installed packages
my @rec_todo; # installed todo
my @error;
my %aconflicts; # packages we are conflicting with
my @native;
# handle direct conflicts
for (grep {/^!/} @p) {
my $r = /^!!/ ? substr($_, 2) : substr($_, 1);
if ($r =~ /^\(.*\)$/) {
my $n = normalizerich($config, undef, $r, 1, \@error);
my %naconflicts;
check_conddeps_inst(undef, $n, \@error, \%p, \%naconflicts, \@todo, \%todo_cond);
push @{$aconflicts{$_}}, $naconflicts{$_} for keys %naconflicts;
next;
}
my @q = @{$whatprovides->{$r} || Build::addproviders($config, $r)};
@q = nevrmatch($config, $r, @q) if /^!!/;
push @{$aconflicts{$_}}, "is in conflict" for @q;
}
@p = grep {!/^[-!]/} @p;
# add direct dependency packages. this is different from below,
# because we add packages even if the dep is already provided and
# we break ambiguities if the name is an exact match.
for my $r (splice @p) {
if ($r =~ /^\(.*\)$/) {
push @p, $r; # rich deps are never direct
next;
}
my @q = @{$whatprovides->{$r} || Build::addproviders($config, $r)};
my $pn = $r;
$pn =~ s/ .*//;
@q = grep {$_ eq $pn} @q;
if (@q != 1) {
push @p, $r;
next;
}
my $p = $q[0];
next if $extractnative && extractnative($config, $r, $p, \@native);
print "added $p because of $r (direct dep)\n" if $expand_dbg;
push @todo_inst, $p;
}
for my $r (@p, @directdepsend) {
if ($r =~ /^\(.*\)$/) {
# rich dep. normalize, put on todo.
my $n = normalizerich($config, undef, $r, 0, \@error);
my %naconflicts;
check_conddeps_inst(undef, $n, \@error, \%p, \%naconflicts, \@todo, \%todo_cond);
push @{$aconflicts{$_}}, $naconflicts{$_} for keys %naconflicts;
} else {
push @todo, $r, undef;
}
}
for my $p (@todo_inst) {
push @error, map {"$p $_"} @{$aconflicts{$p}} if $aconflicts{$p};
}
return (undef, @error) if @error;
push @native, '--directdepsend--' if $extractnative;
while (@todo || @todo_inst) {
# install a set of chosen packages
# ($aconficts must not be set for any of them)
if (@todo_inst) {
if (@todo_inst > 1) {
my %todo_inst = map {$_ => 1} @todo_inst;
@todo_inst = grep {delete($todo_inst{$_})} @todo_inst;
}
# check aconflicts (just in case)
for my $p (@todo_inst) {
push @error, map {"$p $_"} @{$aconflicts{$p}} if $aconflicts{$p};
}
return (undef, @error) if @error;
# check against old cond dependencies. we do this step by step so we don't get dups.
for my $p (@todo_inst) {
$p{$p} = 1;
if ($todo_cond{$p}) {
for my $c (@{delete $todo_cond{$p}}) {
my %naconflicts;
check_conddeps_inst($c->[1], [ $c->[0] ], \@error, \%p, \%naconflicts, \@todo);
push @{$aconflicts{$_}}, $naconflicts{$_} for keys %naconflicts;
}
}
delete $aconflicts{$p}; # no longer needed
}
return undef, @error if @error;
# now check our own dependencies
for my $p (@todo_inst) {
my %naconflicts;
my %naobsoletes;
$naconflicts{$_} = "is in conflict with $p" for @{$conflicts->{$p} || []};
for my $r (@{$requires->{$p} || []}) {
if ($r =~ /^\(.*\)$/) {
my $n = normalizerich($config, $p, $r, 0, \@error, $ignore, $xignore);
check_conddeps_inst($p, $n, \@error, \%p, \%naconflicts, \@todo, \%todo_cond);
next;
}
my $ri = (split(/[ <=>]/, $r, 2))[0];
next if $ignore->{"$p:$ri"} || $xignore->{"$p:$ri"};
next if $ignore->{$ri} || $xignore->{$ri};
next if $ri =~ /^rpmlib\("/;
next if $ri =~ /^\// && !@{$whatprovides->{$ri} || []};
push @todo, ($r, $p);
}
if (!$ignoreconflicts) {
for my $r (@{$pkgconflicts->{$p}}) {
if ($r =~ /^\(.*\)$/) {
my $n = normalizerich($config, $p, $r, 1, \@error);
check_conddeps_inst($p, $n, \@error, \%p, \%naconflicts, \@todo, \%todo_cond);
next;
}
$naconflicts{$_} = "is in conflict with $p" for @{$whatprovides->{$r} || Build::addproviders($config, $r)};
}
for my $r (@{$pkgobsoletes->{$p}}) {
$naobsoletes{$_} = "is obsoleted by $p" for nevrmatch($config, $r, @{$whatprovides->{$r} || Build::addproviders($config, $r)});
}
}
if (%naconflicts) {
push @error, map {"$p conflicts with $_"} grep {$_ ne $p && $p{$_}} sort keys %naconflicts;
push @{$aconflicts{$_}}, $naconflicts{$_} for keys %naconflicts;
}
if (%naobsoletes) {
push @error, map {"$p obsoletes $_"} grep {$_ ne $p && $p{$_}} sort keys %naobsoletes;
push @{$aconflicts{$_}}, $naobsoletes{$_} for keys %naobsoletes;
}
push @rec_todo, $p if $userecommendsforchoices;
}
return undef, @error if @error;
@todo_inst = ();
}
for my $pass (0, 1, 2, 3, 4, 5) {
my @todo_next;
while (@todo) {
my ($r, $p) = splice(@todo, 0, 2);
my $rtodo = $r;
my @q;
if (ref($r)) {
($r, undef, undef, @q) = @$r;
} else {
@q = @{$whatprovides->{$r} || Build::addproviders($config, $r)};
}
next if grep {$p{$_}} @q;
my $pp = defined($p) ? "$p:" : '';
my $pn = defined($p) ? " needed by $p" : '';
if (defined($p) && !$ignoreignore) {
next if grep {$ignore->{$_} || $xignore->{$_}} @q;
next if grep {$ignore->{"$pp$_"} || $xignore->{"$pp$_"}} @q;
}
if (!@q) {
next if defined($p) && ($r =~ /^\// || $r =~ /^rpmlib\(/);
push @error, "nothing provides $r$pn";
next;
}
if (@q > 1 && $pass == 0) {
push @todo_next, $rtodo, $p;
next;
}
# pass 0: only one provider
# pass 1: conflict pruning
my $nq = @q;
my @eq;
for my $q (@q) {
push @eq, map {"(provider $q $_)"} @{$aconflicts{$q}} if $aconflicts{$q};
}
@q = grep {!$aconflicts{$_}} @q;
if (!$ignoreconflicts) {
for my $q (splice @q) {
push @q, $q unless @{$pkgconflicts->{$q} || []} && checkconflicts($config, \%p, $q, \@eq, @{$pkgconflicts->{$q}});
}
for my $q (splice @q) {
push @q, $q unless @{$pkgobsoletes->{$q} || []} && checkobsoletes($config, \%p, $q, \@eq, @{$pkgobsoletes->{$q}});
}
}
if (!@q) {
push @error, "conflict for providers of $r$pn", sort(@eq);
next;
}
if (@q == 1) {
next if $extractnative && extractnative($config, $r, $q[0], \@native);
print "added $q[0] because of $pp$r\n" if $expand_dbg;
push @todo_inst, $q[0];
next;
}
# pass 2: prune neg prefers and simple pos prefers
if ($pass < 2) {
print "undecided about $pp$r: @q\n" if $expand_dbg;
push @todo_next, $rtodo, $p;
next;
}
if (@q > 1) {
my @pq = grep {!$prefer->{"-$_"} && !$prefer->{"-$pp$_"}} @q;
@q = @pq if @pq;
@pq = grep {$prefer->{$_} || $prefer->{"$pp$_"}} @q;
@q = @pq if @pq == 1;
}
if (@q == 1) {
next if $extractnative && extractnative($config, $r, $q[0], \@native);
push @todo_inst, $q[0];
print "added $q[0] because of $pp$r\n" if $expand_dbg;
next;
}
# pass 3: prune pos prefers and debian choice deps
if ($pass < 3) {
push @todo_next, $rtodo, $p;
next;
}
if (@q > 1) {
my @pq = grep {$prefer->{$_} || $prefer->{"$pp$_"}} @q;
if (@pq > 1) {
my %pq = map {$_ => 1} @pq;
@q = (grep {$pq{$_}} @{$config->{'prefer'}})[0];
} elsif (@pq == 1) {
@q = @pq;
}
}
if (@q > 1 && $r =~ /\|/) {
# choice op, implicit prefer of first match...
my %pq = map {$_ => 1} @q;
for my $rr (split(/\s*\|\s*/, $r)) {
next unless $whatprovides->{$rr};
my @pq = grep {$pq{$_}} @{$whatprovides->{$rr}};
next unless @pq;
@q = @pq;
last;
}
}
if (@q == 1) {
next if $extractnative && extractnative($config, $r, $q[0], \@native);
push @todo_inst, $q[0];
print "added $q[0] because of $pp$r\n" if $expand_dbg;
next;
}
# pass 4: prune recommends
if ($pass < 4) {
push @todo_next, $rtodo, $p;
next;
}
todo2recommended($config, \%recommended, \@rec_todo) if @rec_todo;
my @pq = grep {$recommended{$_}} @q;
print "recommended [@pq] among [@q]\n" if $expand_dbg;
@q = @pq if @pq;
if (@q == 1) {
next if $extractnative && extractnative($config, $r, $q[0], \@native);
push @todo_inst, $q[0];
print "added $q[0] because of $pp$r\n" if $expand_dbg;
next;
}
# pass 5: record error
if ($pass < 5) {
push @todo_next, $rtodo, $p;
next;
}
@q = sort(@q);
if (defined($p)) {
push @error, "have choice for $r needed by $p: @q";
} else {
push @error, "have choice for $r: @q";
}
}
@todo = @todo_next;
last if @todo_inst;
}
return undef, @error if @error;
}
if ($extractnative && @native) {
my %rdone;
for my $r (splice @native) {
next if $rdone{$r}++;
if ($r eq '--directdepsend--') {
push @native, $r;
next;
}
my @q = @{$whatprovides->{$r} || Build::addproviders($config, $r)};
push @native, $r unless grep {$p{$_}} @q;
}
pop @native if @native && $native[-1] eq '--directdepsend--';
push @$extractnative, @native;
}
return 1, (sort keys %p);
}
1;
07070100000009000081a400000000000000000000000163e504b9000005eb000000000000000000000000000000000000001100000000Build/Fissile.pm################################################################
#
# Copyright (c) 2017 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
#
################################################################
package Build::Fissile;
use strict;
eval { require YAML::XS; };
*YAML::XS::LoadFile = sub {die("YAML::XS is not available\n")} unless defined &YAML::XS::LoadFile;
sub parse {
my ($cf, $fn) = @_;
my $yml;
eval { $yml = YAML::XS::LoadFile($fn); };
return {'error' => "Failed to parse yml file"} unless $yml;
my $ret = {};
$ret->{'name'} = $yml->{'Name'} || 'fissile';
$ret->{'version'} = $yml->{'Version'} if $yml->{'Version'};
my @deps;
for (@{$yml->{'DockerImageDeps'} || []}) {
# This generates something like: "container:fissile-dev:201707081450"
push @deps, "container:$_";
}
$ret->{'deps'} = \@deps;
return $ret;
}
1;
0707010000000a000081a400000000000000000000000163e504b9000012d6000000000000000000000000000000000000001100000000Build/Flatpak.pm################################################################
#
# Copyright (c) 2017 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
#
################################################################
package Build::Flatpak;
use strict;
use warnings;
use Build::Deb;
use Build::Rpm;
#use URI; # not installed in kvm?
#use JSON::PP; # not installed in kvm?
my $yamlxs = eval { require YAML::XS; $YAML::XS::LoadBlessed = 0; return 1 };
my $yamlpp = eval { require YAML::PP; return YAML::PP->new };
sub _have_yaml_parser {
return $yamlpp || $yamlxs ? 1 : undef;
}
sub _load_yaml {
my ($yaml) = @_;
my $data;
if ($yamlpp) {
$data = eval { $yamlpp->load_string($yaml) };
return $data;
}
if ($yamlxs) {
eval { $data = YAML::XS::Load($yaml) };
return $data;
}
die "Neither YAML::PP nor YAML::XS available\n";
}
sub _load_yaml_file {
my ($fn) = @_;
my $data;
if ($yamlpp) {
$data = eval { $yamlpp->load_file($fn) };
return $data;
}
if ($yamlxs) {
eval { $data = YAML::XS::LoadFile($fn) };
return $data;
}
die "Neither YAML::PP nor YAML::XS available\n";
}
sub _read_manifest {
my ($fn) = @_;
my $data;
if ($fn =~ m/\.ya?ml\z/) {
$data = _load_yaml_file($fn);
return { error => "Failed to parse YAML file '$fn'" } unless defined $data;
} elsif ($fn =~ m/\.json\z/) {
# We don't have JSON::PP, but YAML is a superset of JSON anyway
$data = _load_yaml_file($fn);
return { error => "Failed to parse JSON file '$fn'" } unless defined $data;
} elsif (ref($fn) eq 'SCALAR') {
$data = _load_yaml($$fn); # used in the unit test
return { error => "Failed to parse '$fn'" } unless defined $data;
} else {
$data = _load_yaml_file($fn);
return { error => "Failed to parse file '$fn'" } unless defined $data;
}
return $data;
}
sub parse {
my ($cf, $fn) = @_;
my $version = '';
my @lines;
if (ref($fn) eq 'SCALAR') {
@lines = split m/(?<=\n)/, $$fn;
}
else {
open my $fh, '<', $fn or return { error => "Failed to open file '$fn'" };
@lines = <$fh>;
close $fh;
}
for my $line (@lines) {
if ($line =~ m/^#!BuildVersion: (\S+)/) {
my $string = $1;
if ($string =~ m/^[0-9.]+$/) {
$version = $string;
}
else {
return { error => "Invalid BuildVersion" };
}
}
}
my $data = _read_manifest($fn);
my $ret = {};
$ret->{version} = $version if $version;
$ret->{name} = $data->{'app-id'} or die "Flatpak file is missing 'app-id'";
my $runtime = $data->{runtime};
my $runtime_version = $data->{'runtime-version'};
my $sdk = $data->{sdk};
my @packdeps;
push @packdeps, "$sdk-v$runtime_version";
push @packdeps, "$runtime-v$runtime_version";
$ret->{deps} = \@packdeps;
my @sources;
if (my $modules = $data->{modules}) {
for my $module (@$modules) {
if (my $sources = $module->{sources}) {
for my $source (@$sources) {
if ($source->{type} eq 'archive') {
push @sources, $source->{url};
}
}
}
}
}
$ret->{sources} = \@sources;
return $ret;
}
sub show {
my ($fn, $field) = @ARGV;
my $cf = {};
my $d = parse($cf, $fn);
die "$d->{error}\n" if $d->{error};
my $value = $d->{ $field };
if (ref $value eq 'ARRAY') {
print "$_\n" for @$value;
}
else {
print "$value\n";
}
}
# This replaces http urls with local file urls because during build
# flatpak-builder has no network
sub rewrite {
my ($fn) = @ARGV;
my $data = _read_manifest($fn);
if (my $modules = $data->{modules}) {
for my $module (@$modules) {
if (my $sources = $module->{sources}) {
for my $source (@$sources) {
if ($source->{type} eq 'archive') {
my $path = $source->{url};
$path =~ s{.*/}{}; # Get filename
$source->{url} = "file:///usr/src/packages/SOURCES/$path";
}
}
}
}
}
my $yaml = '';
if ($yamlpp) {
# YAML::PP would allow us to keep key order
$yaml = $yamlpp->dump_string($data);
}
elsif ($yamlxs) {
$yaml = YAML::XS::Dump($data);
}
print $yaml;
}
1;
0707010000000b000081a400000000000000000000000163e504b900001283000000000000000000000000000000000000000e00000000Build/Helm.pm################################################################
#
# Copyright (c) 2020 SUSE LLC
#
# 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
#
################################################################
package Build::Helm;
use strict;
use Build::SimpleJSON;
eval { require YAML::XS; $YAML::XS::LoadBlessed = 0; };
*YAML::XS::LoadFile = sub {die("YAML::XS is not available\n")} unless defined &YAML::XS::LoadFile;
sub verify_config {
my ($d) = @_;
die("bad config\n") unless ref($d) eq 'HASH';
for my $k ('name', 'version') {
die("missing element '$k'\n") unless defined $d->{$k};
die("bad element '$k'\n") unless ref($d->{$k}) eq '';
die("empty element '$k'\n") if $d->{$k} eq '';
die("bad element '$k'\n\n") if $d->{$k} =~ /[\/\000-\037]/;
}
die("bad name\n") if $d->{'name'} =~ /^[-\.]/;
}
sub parse {
my ($cf, $fn) = @_;
my $d;
my $fd;
return {'error' => "$fn: $!"} unless open($fd, '<', $fn);
my @tags;
while (<$fd>) {
chomp;
next if /^\s*$/;
last unless /^\s*#/;
push @tags, split(' ', $1) if /^#!BuildTag:\s*(.*?)$/;
}
close($fd);
eval {
$d = YAML::XS::LoadFile($fn);
verify_config($d);
};
if ($@) {
my $err = $@;
chomp $@;
return {'error' => "Failed to parse yml file: $err"};
}
my $res = {};
$res->{'name'} = $d->{'name'};
$res->{'version'} = $d->{'version'};
$res->{'deps'} = [];
my $release = $cf->{'buildrelease'};
for (@tags) {
s/<NAME>/$d->{'name'}/g;
s/<VERSION>/$d->{'version'}/g;
s/<RELEASE>/$release/g;
}
$res->{'containertags'} = \@tags if @tags;
return $res;
}
sub show {
my ($release, $disturl, $chart, $origrecipe);
while (@ARGV) {
if (@ARGV > 2 && $ARGV[0] eq '--release') {
(undef, $release) = splice(@ARGV, 0, 2);
} elsif (@ARGV > 2 && $ARGV[0] eq '--disturl') {
(undef, $disturl) = splice(@ARGV, 0, 2);
} elsif (@ARGV > 2 && $ARGV[0] eq '--chart') {
(undef, $chart) = splice(@ARGV, 0, 2);
} elsif (@ARGV > 2 && $ARGV[0] eq '--origrecipe') {
(undef, $origrecipe) = splice(@ARGV, 0, 2);
} else {
last;
}
}
my ($fn, $field) = @ARGV;
my $d = {};
$d->{'buildrelease'} = $release if defined $release;
$d = parse({}, $fn) if $fn;
die("$d->{'error'}\n") if $d->{'error'};
if ($field eq 'helminfo') {
my $containertags = $d->{'containertags'};
if ($origrecipe) {
# we need to parse the original recipe to get the tags
my $origd = parse({}, $origrecipe);
$containertags = $origd->{'containertags'};
}
my $config_yaml = '';
my $fd;
die("$fn: $!\n") unless open($fd, '<', $fn);
1 while sysread($fd, $config_yaml, 8192, length($config_yaml));
close($fd);
my $config = YAML::XS::Load($config_yaml);
verify_config($config);
my $config_json = Build::SimpleJSON::unparse($config)."\n";
my $helminfo = {};
$helminfo->{'name'} = $d->{'name'};
$helminfo->{'version'} = $d->{'version'};
$helminfo->{'release'} = $release if $release;
$helminfo->{'tags'} = $containertags if $containertags;
$helminfo->{'disturl'} = $disturl if $disturl;
$helminfo->{'buildtime'} = time();
if ($chart) {
require Digest::SHA;
$helminfo->{'chart'} = $chart;
$helminfo->{'chart'} =~ s/.*\///;
my $ctx = Digest::SHA->new(256);
my $cfd;
die("$chart: $!\n") unless open($cfd, '<', $chart);
my @s = stat($cfd);
$ctx->addfile($cfd);
close($cfd);
$helminfo->{'chart_sha256'} = $ctx->hexdigest;
$helminfo->{'chart_size'} = $s[7];
}
$helminfo->{'config_json'} = $config_json;
$helminfo->{'config_yaml'} = $config_yaml;
$helminfo->{'_order'} = [ qw{name version release tags disturl buildtime chart config_json config_yaml chart_sha256 chart_size} ];
$helminfo->{'_type'} = {'buildtime' => 'number', 'chart_size' => 'number' };
print Build::SimpleJSON::unparse($helminfo)."\n";
exit(0);
}
$d->{'nameversion'} = "$d->{'name'}-$d->{'version'}"; # convenience
my $x = $d->{$field};
$x = [ $x ] unless ref $x;
print "@$x\n";
}
1;
0707010000000c000081a400000000000000000000000163e504b9000016b0000000000000000000000000000000000000001100000000Build/Intrepo.pm################################################################
#
# Copyright (c) 2020 SUSE LLC
#
# 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
#
################################################################
package Build::Intrepo;
use strict;
use Build::Rpm;
# This implements reading and writing of build's internal repo format.
#
# The format looks like this:
#
# P:bash.x86_64-1526160002/1526160023/0: bash = 4.4-lp150.7.8
#
# i.e.: type:name.arch-mtime/size/inode: dep dep dep
#
# P:provides C:conflicts R:requires O:Obsoletes
# r:recommends s:supplements
#
# There is also:
# F:...: filename
# I:...: ident where ident == name-evr buildtime-arch
#
# The format is so weird because init_buildsystem of the old autobuild
# system used to create such repos by doing a single 'rpm --qf' call.
#
sub addpkg {
my ($res, $pkg, $pkgid, $options) = @_;
return unless $pkgid =~ /^(.*)\.(.*)-\d+\/\d+\/\d+$/s;
$pkg->{'name'} = $1;
$pkg->{'arch'} = $2 unless $pkg->{'arch'};
# extract evr from self provides if there was no 'I' line
if (!defined($pkg->{'version'})) {
my @sp = grep {/^\Q$pkg->{'name'}\E\s*=\s*/} @{$pkg->{'provides'} || []};
if (@sp) {
my $evr = $sp[-1];
$evr =~ s/^\Q$pkg->{'name'}\E\s*=\s*//;
$pkg->{'epoch'} = $1 if $evr =~ s/^(\d+)://;
$pkg->{'release'} = $1 if $evr =~ s/-([^-]*)$//;
$pkg->{'version'} = $evr;
}
}
if (ref($res) eq 'CODE') {
$res->($pkg);
} else {
push @$res, $pkg;
}
}
sub parse {
my ($in, $res, %options) = @_;
my $nofiledeps = $options{'nofiledeps'};
my $testcaseformat = $options{'testcaseformat'};
if (ref($in)) {
*F = $in;
} else {
open(F, '<', $in) || die("$in: $!\n");
}
$res ||= [];
my $lastpkgid;
my $pkg = {};
while (<F>) {
my @s = split(' ', $_);
my $s = shift @s;
next unless $s && $s =~ /^([a-zA-Z]):(.+):$/s;
my ($tag, $pkgid) = ($1, $2);
if ($lastpkgid && $pkgid ne $lastpkgid) {
addpkg($res, $pkg, $lastpkgid, \%options) if %$pkg;
$pkg = {};
}
$lastpkgid = $pkgid;
if ($tag eq 'I') {
next unless $pkgid =~ /^(.*)\.(.*)-\d+\/\d+\/\d+:$/;
my $name = $1;
my $evr = $s[0];
$pkg->{'arch'} = $1 if $s[1] && $s[1] =~ s/-(.*)$//;
$pkg->{'buildtime'} = $s[1] if $s[1];
if ($evr =~ s/^\Q$name\E-//) {
$pkg->{'epoch'} = $1 if $evr =~ s/^(\d+)://;
$pkg->{'release'} = $1 if $evr =~ s/-([^-]*)$//;
$pkg->{'version'} = $evr;
}
next;
}
if ($tag eq 'F') {
chomp;
my $loc = (split(' ', $_, 2))[1];
$pkg->{'location'} = $loc if defined $loc;
next;
}
if ($tag eq 'M') {
chomp;
my $multiarch = (split(' ', $_, 2))[1];
$pkg->{'multiarch'} = $multiarch if $multiarch;
next;
}
my @ss;
while (@s) {
if ($nofiledeps && $s[0] =~ /^\//) {
shift @s;
next;
}
if ($s[0] =~ /^rpmlib\(/) {
splice(@s, 0, 3);
next;
}
if ($s[0] =~ /^\(/) {
push @ss, Build::Rpm::shiftrich(\@s);
$ss[-1] = Build::Rpm::testcaseformat($ss[-1]) if $testcaseformat;
next;
}
push @ss, shift @s;
while (@s && $s[0] =~ /^\(?[<=>|]/) {
$ss[-1] .= " $s[0] $s[1]";
$ss[-1] =~ s/ \((.*)\)/ $1/;
$ss[-1] =~ s/(<|>){2}/$1/;
splice(@s, 0, 2);
}
}
my %ss;
@ss = grep {!$ss{$_}++} @ss; # unify
$pkg->{'provides'} = \@ss if $tag eq 'P';
$pkg->{'requires'} = \@ss if $tag eq 'R';
$pkg->{'conflicts'} = \@ss if $tag eq 'C';
$pkg->{'obsoletes'} = \@ss if $tag eq 'O';
$pkg->{'recommends'} = \@ss if $tag eq 'r';
$pkg->{'supplements'} = \@ss if $tag eq 's';
}
addpkg($res, $pkg, $lastpkgid, \%options) if $lastpkgid && %$pkg;
close F unless ref($in);
return $res;
}
sub getbuildid {
my ($q) = @_;
my $evr = $q->{'version'};
$evr = "$q->{'epoch'}:$evr" if $q->{'epoch'};
$evr .= "-$q->{'release'}" if defined $q->{'release'};
my $buildtime = $q->{'buildtime'} || 0;
$buildtime .= "-$q->{'arch'}" if defined $q->{'arch'};
return "$q->{'name'}-$evr $buildtime";
}
my $writepkg_inode = 0;
sub writepkg {
my ($fh, $pkg, $locprefix, $inode) = @_;
return unless defined($pkg->{'name'}) && defined($pkg->{'arch'});
return if $pkg->{'arch'} eq 'src' || $pkg->{'arch'} eq 'nosrc';
$locprefix = '' unless defined $locprefix;
my $id = $pkg->{'id'};
if (!$id) {
$inode = $writepkg_inode++ unless defined $inode;
$id = ($pkg->{'buildtime'} || 0)."/".($pkg->{'filetime'} || 0)."/$inode";
}
$id = "$pkg->{'name'}.$pkg->{'arch'}-$id: ";
print $fh "F:$id$locprefix$pkg->{'location'}\n";
print $fh "P:$id".join(' ', @{$pkg->{'provides'} || []})."\n";
print $fh "R:$id".join(' ', @{$pkg->{'requires'}})."\n" if $pkg->{'requires'};
print $fh "C:$id".join(' ', @{$pkg->{'conflicts'}})."\n" if $pkg->{'conflicts'};
print $fh "O:$id".join(' ', @{$pkg->{'obsoletes'}})."\n" if $pkg->{'obsoletes'};
print $fh "r:$id".join(' ', @{$pkg->{'recommends'}})."\n" if $pkg->{'recommends'};
print $fh "s:$id".join(' ', @{$pkg->{'supplements'}})."\n" if $pkg->{'supplements'};
print $fh "M:$id$pkg->{'multiarch'}\n" if $pkg->{'multiarch'};
print $fh "I:$id".getbuildid($pkg)."\n";
}
1;
0707010000000d000081a400000000000000000000000163e504b90000613c000000000000000000000000000000000000000e00000000Build/Kiwi.pm################################################################
#
# Copyright (c) 1995-2014 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
#
################################################################
package Build::Kiwi;
use strict;
use Build::SimpleXML;
use Build::SimpleJSON;
our $bootcallback;
our $urlmapper;
our $repoextras = 0; # priority, flags, ...
sub unify {
my %h = map {$_ => 1} @_;
return grep(delete($h{$_}), @_);
}
sub expandFallBackArchs {
my ($fallbackArchXML, @archs) = @_;
my %fallbacks;
for (@{$fallbackArchXML->{'arch'} || []}) {
$fallbacks{$_->{'id'}} = $_->{'fallback'} if $_->{id} && $_->{'fallback'};
}
my @out;
while (@archs) {
push @out, shift @archs;
push @archs, delete $fallbacks{$out[-1]} if $fallbacks{$out[-1]};
}
return unify(@out);
}
# sles10 perl does not have the version.pm
# implement own hack
sub versionstring {
my ($str) = @_;
my $result = 0;
$result = $result * 100 + $_ for split (/\./, $str, 2);
return $result;
}
my $schemaversion56 = versionstring('5.6');
sub kiwiparse_product {
my ($kiwi, $xml, $arch, $buildflavor) = @_;
my $ret = {};
my @repos;
my %repoprio; # XXX: unused
my @packages;
my @requiredarch;
my @badarch;
my $obsexclusivearch;
my $obsexcludearch;
$obsexclusivearch = $1 if $xml =~ /^\s*<!--\s+OBS-ExclusiveArch:\s+(.*)\s+-->\s*$/im;
$obsexcludearch = $1 if $xml =~ /^\s*<!--\s+OBS-ExcludeArch:\s+(.*)\s+-->\s*$/im;
$ret->{'milestone'} = $1 if $xml =~ /^\s*<!--\s+OBS-Milestone:\s+(.*)\s+-->\s*$/im;
$ret->{'name'} = $kiwi->{'name'} if $kiwi->{'name'};
$ret->{'filename'} = $kiwi->{'name'} if $kiwi->{'name'};
my $description = (($kiwi->{'description'} || [])->[0]) || {};
if (!$ret->{'name'} && $description->{'specification'}) {
$ret->{'name'} = $description->{'specification'}->[0]->{'_content'};
}
# parse the preferences section
my $preferences = $kiwi->{'preferences'} || [];
die("products must have exactly one preferences element\n") unless @$preferences == 1;
# take default version setting
if ($preferences->[0]->{'version'}) {
$ret->{'version'} = $preferences->[0]->{'version'}->[0]->{'_content'};
}
die("products must have exactly one type element in the preferences\n") unless @{$preferences->[0]->{'type'} || []} == 1;
my $preftype = $preferences->[0]->{'type'}->[0];
if (defined $preftype->{'image'}) {
# for kiwi 4.1 and 5.x
die("products must use type 'product'\n") unless $preftype->{'image'} eq 'product';
} else {
# for kiwi 3.8 and before
die("products must use type 'product'\n") unless $preftype->{'_content'} eq 'product';
}
push @packages, "kiwi-filesystem:$preftype->{'filesystem'}" if $preftype->{'filesystem'};
die("boot type not supported in products\n") if defined $preftype->{'boot'};
my $instsource = ($kiwi->{'instsource'} || [])->[0];
die("products must have an instsource element\n") unless $instsource;
# get repositories
for my $repository (sort {$a->{priority} <=> $b->{priority}} @{$instsource->{'instrepo'} || []}) {
my $kiwisource = ($repository->{'source'} || [])->[0];
if ($kiwisource->{'path'} eq 'obsrepositories:/') {
push @repos, '_obsrepositories/'; # special case, OBS will expand it.
} elsif ($kiwisource->{'path'} =~ /^obs:\/\/\/?([^\/]+)\/([^\/]+)\/?$/) {
push @repos, "$1/$2";
} else {
my $prp;
$prp = $urlmapper->($kiwisource->{'path'}) if $urlmapper;
die("instsource repo url not using obs:/ scheme: $kiwisource->{'path'}\n") unless $prp;
push @repos, $prp;
}
}
$ret->{'sourcemedium'} = -1;
$ret->{'debugmedium'} = -1;
if ($instsource->{'productoptions'}) {
my $productoptions = $instsource->{'productoptions'}->[0] || {};
for my $po (@{$productoptions->{'productvar'} || []}) {
$ret->{'drop_repository'} = $po->{'_content'} if $po->{'name'} eq 'DROP_REPOSITORY';
$ret->{'version'} = $po->{'_content'} if $po->{'name'} eq 'VERSION';
}
for my $po (@{$productoptions->{'productoption'} || []}) {
$ret->{'sourcemedium'} = $po->{'_content'} if $po->{'name'} eq 'SOURCEMEDIUM';
$ret->{'debugmedium'} = $po->{'_content'} if $po->{'name'} eq 'DEBUGMEDIUM';
$ret->{'milestone'} = $po->{'_content'} if $po->{'name'} eq 'BETA_VERSION';
}
}
if ($instsource->{'architectures'}) {
my $architectures = $instsource->{'architectures'}->[0] || {};
for my $ra (@{$architectures->{'requiredarch'} || []}) {
push @requiredarch, $ra->{'ref'} if defined $ra->{'ref'};
}
}
# Find packages and possible additional required architectures
my @additionalarchs;
my @pkgs;
push @pkgs, @{$instsource->{'metadata'}->[0]->{'repopackage'} || []} if $instsource->{'metadata'};
push @pkgs, @{$instsource->{'repopackages'}->[0]->{'repopackage'} || []} if $instsource->{'repopackages'};
@pkgs = unify(@pkgs);
for my $package (@pkgs) {
# filter packages, which are not targeted for the wanted plattform
if ($package->{'arch'}) {
my $valid;
for my $ma (@requiredarch) {
for my $pa (split(',', $package->{'arch'})) {
$valid = 1 if $ma eq $pa;
}
}
next unless $valid;
}
# not nice, but optimizes our build dependencies
# FIXME: design a real blacklist option in kiwi
if ($package->{'onlyarch'} && $package->{'onlyarch'} eq 'skipit') {
push @packages, "-$package->{'name'}";
next;
}
push @packages, "-$package->{'replaces'}" if $package->{'replaces'};
# we need this package
push @packages, $package->{'name'};
# find the maximal superset of possible required architectures
push @additionalarchs, split(',', $package->{'addarch'}) if $package->{'addarch'};
push @additionalarchs, split(',', $package->{'onlyarch'}) if $package->{'onlyarch'};
}
@requiredarch = unify(@requiredarch, @additionalarchs);
#### FIXME: kiwi files have no informations where to get -32bit packages from
push @requiredarch, "i586" if grep {/^ia64/} @requiredarch;
push @requiredarch, "i586" if grep {/^x86_64/} @requiredarch;
push @requiredarch, "ppc" if grep {/^ppc64/} @requiredarch;
push @requiredarch, "s390" if grep {/^s390x/} @requiredarch;
@requiredarch = expandFallBackArchs($instsource->{'architectures'}->[0], @requiredarch);
push @packages, "kiwi-packagemanager:instsource";
push @requiredarch, split(' ', $obsexclusivearch) if $obsexclusivearch;
push @badarch , split(' ', $obsexcludearch) if $obsexcludearch;
$ret->{'exclarch'} = [ unify(@requiredarch) ] if @requiredarch;
$ret->{'badarch'} = [ unify(@badarch) ] if @badarch;
$ret->{'deps'} = [ unify(@packages) ];
$ret->{'path'} = [ unify(@repos) ];
$ret->{'imagetype'} = [ 'product' ];
for (@{$ret->{'path'} || []}) {
my @s = split('/', $_, 2);
$_ = {'project' => $s[0], 'repository' => $s[1]};
$_->{'priority'} = $repoprio{"$s[0]/$s[1]"} if $repoextras && defined $repoprio{"$s[0]/$s[1]"};
}
return $ret;
}
sub unify_repo {
my ($repo) = @_;
my @r;
my %seen;
for (@{$repo || []}) {
if ($_->{'url'}) {
next if $seen{$_->{'url'}};
$seen{$_->{'url'}} = 1;
}
push @r, $_;
}
return \@r;
}
sub kiwiparse {
my ($xml, $arch, $buildflavor, $release, $count) = @_;
$count ||= 0;
die("kiwi config inclusion depth limit reached\n") if $count++ > 10;
my $kiwi = Build::SimpleXML::parse($xml);
die("not a kiwi config\n") unless $kiwi && $kiwi->{'image'};
$kiwi = $kiwi->{'image'}->[0];
# check if this is a product, we currently test for the 'instsource' element
return kiwiparse_product($kiwi, $xml, $arch, $buildflavor) if $kiwi->{'instsource'};
my $ret = {};
my @types;
my @repos;
my @imagerepos;
my @bootrepos;
my @containerrepos;
my @packages;
my @extrasources;
my $obsexclusivearch;
my $obsexcludearch;
my $obsprofiles;
my $unorderedrepos;
my @ignorepackages;
$obsexclusivearch = $1 if $xml =~ /^\s*<!--\s+OBS-ExclusiveArch:\s+(.*)\s+-->\s*$/im;
$obsexcludearch = $1 if $xml =~ /^\s*<!--\s+OBS-ExcludeArch:\s+(.*)\s+-->\s*$/im;
$obsprofiles = $1 if $xml =~ /^\s*<!--\s+OBS-Profiles:\s+(.*)\s+-->\s*$/im;
$ret->{'milestone'} = $1 if $xml =~ /^\s*<!--\s+OBS-Milestone:\s+(.*)\s+-->\s*$/im;
if ($obsprofiles) {
$obsprofiles = [ grep {defined($_)} map {$_ eq '@BUILD_FLAVOR@' ? $buildflavor : $_} split(' ', $obsprofiles) ];
}
$unorderedrepos = 1 if $xml =~ /^\s*<!--\s+OBS-UnorderedRepos\s+-->\s*$/im;
$ret->{'donotappendprofiletocontainername'} = 1 if $xml =~ /^\s*<!--\s+OBS-DoNotAppendProfileToContainername\s+-->\s*$/im;
for ($xml =~ /^\s*<!--\s+OBS-Imagerepo:\s+(.*)\s+-->\s*$/img) {
push @imagerepos, { 'url' => $_ };
}
for ($xml =~ /^\s*<!--\s+OBS-IgnorePackage:\s+(.*)\s+-->\s*$/img) {
push @ignorepackages, split(' ', $_);
}
for ($xml =~ /^\s*<!--\s+OBS-RemoteAsset:\s+(.*)\s+-->\s*$/img) {
my @s = split(' ', $_);
my $remoteasset = { 'url' => $s[0] };
$remoteasset->{'digest'} = $s[1] if $s[1] && $s[1] =~ /^[a-z0-9]+:[0-9a-f]+$/;
push @{$ret->{'remoteassets'}}, $remoteasset;
}
for ($xml =~ /^\s*<!--\s+OBS-CopyToImage:\s+(.*)\s+-->\s*$/img) {
my @s = split(' ', $_);
next if !$s[0] || $s[0] eq '.' || $s[0] eq '..' || $s[0] =~ /\// || $s[0] eq 'root';
push @s, $s[0] unless @s > 1;
push @{$ret->{'copytoimage'}}, "$s[0] $s[1]";
}
my $schemaversion = $kiwi->{'schemaversion'} ? versionstring($kiwi->{'schemaversion'}) : 0;
$ret->{'name'} = $kiwi->{'name'} if $kiwi->{'name'};
$ret->{'filename'} = $kiwi->{'name'} if $kiwi->{'name'};
my $description = (($kiwi->{'description'} || [])->[0]) || {};
if (!$ret->{'name'} && $description->{'specification'}) {
$ret->{'name'} = $description->{'specification'}->[0]->{'_content'};
}
# usedprofiles also include direct wanted profile targets and indirect required profiles
my %usedprofiles;
# obsprofiles arch filtering
if ($obsprofiles && $arch && $kiwi->{'profiles'} && $kiwi->{'profiles'}->[0]->{'profile'}) {
# reduce set of profiles to the ones matching our architecture
my @validprofiles;
for my $prof (@{$kiwi->{'profiles'}[0]->{'profile'}}) {
next unless $prof->{'name'};
if (!$prof->{'arch'}) {
push @validprofiles, $prof;
} else {
my $ma = $arch;
$ma =~ s/i[456]86/i386/;
for my $pa (split(",", $prof->{'arch'})) {
$pa =~ s/i[456]86/i386/;
next unless $ma eq $pa;
push @validprofiles, $prof;
last;
}
}
}
my %validprofiles = map {$_->{'name'} => 1} @validprofiles;
$obsprofiles = [ grep {$validprofiles{$_}} @$obsprofiles ];
my %obsprofiles = map {$_ => 1} @$obsprofiles;
my @todo = grep {$obsprofiles{$_->{'name'}}} @validprofiles;
while (@todo) {
my $prof = shift @todo;
next if $usedprofiles{$prof->{'name'}}; # already done
$usedprofiles{$prof->{'name'}} = 1;
for my $req (@{$prof->{'requires'} || []}) {
push @todo, grep {$_->{'name'} eq $req->{'profile'}} @validprofiles;
}
}
}
# take default version setting
my $preferences = ($kiwi->{'preferences'} || []);
if ($preferences->[0]->{'version'}) {
$ret->{'version'} = $preferences->[0]->{'version'}->[0]->{'_content'};
}
# add extra tags
my @extratags;
if ($xml =~ /^\s*<!--\s+OBS-AddTag:\s+(.*)\s+-->\s*$/im) {
for (split(' ', $1)) {
s/<VERSION>/$ret->{'version'}/g if $ret->{'version'};
s/<RELEASE>/$release/g if $release;
$_ = "$_:latest" unless /:[^\/]+$/;
push @extratags, $_;
}
}
my $containerconfig;
for my $pref (@{$preferences || []}) {
if ($obsprofiles && $pref->{'profiles'}) {
next unless grep {$usedprofiles{$_}} split(",", $pref->{'profiles'});
}
for my $type (@{$pref->{'type'} || []}) {
next unless @{$pref->{'type'}} == 1 || !$type->{'optional'};
if (defined $type->{'image'}) {
# for kiwi 4.1 and 5.x
push @types, $type->{'image'};
push @packages, "kiwi-image:$type->{'image'}" if $schemaversion >= $schemaversion56;
} else {
# for kiwi 3.8 and before
push @types, $type->{'_content'};
}
# save containerconfig so that we can retrieve the tag
$containerconfig = $type->{'containerconfig'}->[0] if $type->{'containerconfig'};
# add derived container dependency
if ($type->{'derived_from'}) {
my $derived = $type->{'derived_from'};
my ($name, $prp);
if ($derived =~ /^obs:\/{1,3}([^\/]+)\/([^\/]+)\/(.*?)(?:#([^\#\/]+))?$/) {
$name = defined($4) ? "$3:$4" : "$3:latest";
$prp = "$1/$2";
$prp = "obs:/$prp" if defined($urlmapper) && !$urlmapper;
} elsif ($derived =~ /^obsrepositories:\/{1,3}([^\/].*?)(?:#([^\#\/]+))?$/) {
$name = defined($2) ? "$1:$2" : "$1:latest";
} elsif ($derived =~ /^file:/) {
next; # just ignore and hope
} elsif (defined($urlmapper) && !$urlmapper) {
if ($derived =~ /^https:\/\/([^\/]+)\/(.*?)(?:#([^\#\/]+))?$/) {
$prp = $1;
$name = defined($3) ? "$2:$3" : "$2:latest";
} elsif ($derived =~ /([^\/]+\.[^\/]+)\/(.*?)(?:#([^\#\/]+))?$/) {
$prp = "https://$1";
$name = defined($3) ? "$2:$3" : "$2:latest";
} elsif ($derived =~ /^(.*?)(?:#([^\#\/]+))?$/) {
$name = defined($2) ? "$1:$2" : "$1:latest";
} else {
die("cannot decode derived_from: $derived\n");
}
} elsif ($derived =~ /^(.*)\/([^\/]+?)(?:#([^\#\/]+))?$/) {
my $url = $1;
$name = defined($3) ? "$2:$3" : "$2:latest";
$prp = $urlmapper->($url) if $urlmapper;
# try again with one element moved from url to name
if (!$prp && $derived =~ /^(.*)\/([^\/]+\/[^\/]+?)(?:#([^\#\/]+))?$/) {
$url = $1;
$name = defined($3) ? "$2:$3" : "$2:latest";
$prp = $urlmapper->($url) if $urlmapper;
}
undef $name unless $prp;
}
die("derived_from url not using obs:/ scheme: $derived\n") unless defined $name;
push @packages, "container:$name";
push @containerrepos, $prp if $prp;
}
push @packages, "kiwi-filesystem:$type->{'filesystem'}" if $type->{'filesystem'};
if (defined $type->{'boot'}) {
if ($type->{'boot'} =~ /^obs:\/\/\/?([^\/]+)\/([^\/]+)\/?$/) {
next unless $bootcallback;
my ($bootxml, $xsrc) = $bootcallback->($1, $2);
next unless $bootxml;
push @extrasources, $xsrc if $xsrc;
my $bret = kiwiparse($bootxml, $arch, $buildflavor, $release, $count);
if (defined($urlmapper) && !$urlmapper) {
push @bootrepos, @{$bret->{'path'} || []};
} else {
push @bootrepos, map {"$_->{'project'}/$_->{'repository'}"} @{$bret->{'path'} || []};
}
push @packages, @{$bret->{'deps'} || []};
push @extrasources, @{$bret->{'extrasource'} || []};
} else {
die("bad boot reference: $type->{'boot'}\n") unless $type->{'boot'} =~ /^([^\/]+)\/([^\/]+)$/;
push @packages, "kiwi-boot:$1";
}
}
}
}
die("image contains 'product' type\n") if grep {$_ eq 'product'} @types;
my $packman = $preferences->[0]->{'packagemanager'}->[0]->{'_content'} || '';
# calculate priority for sorting
for (@{$kiwi->{'repository'} || []}) {
$_->{'sortprio'} = 0;
if (defined($_->{'priority'})) {
$_->{'sortprio'} = $packman eq 'smart' ? $_->{'priority'} : 99 - $_->{'priority'};
}
}
my @repositories = sort {$b->{'sortprio'} <=> $a->{'sortprio'}} @{$kiwi->{'repository'} || []};
my %repoprio;
for my $repository (@repositories) {
my $kiwisource = ($repository->{'source'} || [])->[0];
next unless $kiwisource; # huh?
my $url = $kiwisource->{'path'};
next if !$url || $url eq '/var/lib/empty'; # grr
if ($repository->{'imageonly'} || $repository->{'imageinclude'}) {
# this repo will be configured in the image. Save so that we can write it into the containerinfo
push @imagerepos, { 'url' => $url };
$imagerepos[-1]->{'priority'} = $repository->{'sortprio'} if defined $repository->{'priority'};
}
next if $repository->{'imageonly'};
if (defined($urlmapper) && !$urlmapper) {
# urlmapping disabled
push @repos, { 'url' => $url };
$repos[-1]->{'priority'} = $repository->{'sortprio'} if $repoextras && defined $repository->{'priority'};
next;
}
my $prp;
if ($url eq 'obsrepositories:/') {
$prp = '_obsrepositories/';
} elsif ($url =~ /^obs:\/{1,3}([^\/]+)\/([^\/]+)\/?$/) {
$prp = "$1/$2";
} else {
$prp = $urlmapper->($url) if $urlmapper;
die("repo url not using obs:/ scheme: $kiwisource->{'path'}\n") unless $prp;
}
push @repos, $prp;
$repoprio{$prp} = $repository->{'sortprio'} if defined $repository->{'priority'};
}
# Find packages for the image
my @pkgs;
my $patterntype;
for my $packages (@{$kiwi->{'packages'}}) {
next if $packages->{'type'} && $packages->{'type'} ne 'image' && $packages->{'type'} ne 'bootstrap';
# we could skip the sections also when no profile is used,
# but don't to stay backward compatible
if ($obsprofiles && $packages->{'profiles'}) {
my @section_profiles = split(",", $packages->{'profiles'});
next unless grep {$usedprofiles{$_}} @section_profiles;
}
$patterntype ||= $packages->{'patternType'};
push @pkgs, @{$packages->{'package'}} if $packages->{'package'};
for my $pattern (@{$packages->{'namedCollection'} || []}) {
push @pkgs, { %$pattern, 'name' => "pattern() = $pattern->{'name'}" } if $pattern->{'name'};
}
for my $product (@{$packages->{'product'} || []}) {
push @pkgs, { %$product, 'name' => "product() = $product->{'name'}" } if $product->{'name'};
}
for my $pattern (@{$packages->{'opensusePatterns'} || []}) {
push @pkgs, { %$pattern, 'name' => "pattern() = $pattern->{'name'}" } if $pattern->{'name'};
}
for my $product (@{$packages->{'opensuseProduct'} || []}) {
push @pkgs, { %$product, 'name' => "product() = $product->{'name'}" } if $product->{'name'};
}
}
$patterntype ||= 'onlyRequired';
@pkgs = unify(@pkgs);
for my $package (@pkgs) {
# filter packages which are not targeted for the wanted plattform
if ($package->{'arch'}) {
my $valid;
my $ma = $arch;
$ma =~ s/i[456]86/i386/;
for my $pa (split(",", $package->{'arch'})) {
$pa =~ s/i[456]86/i386/;
$valid = 1 if $ma eq $pa;
}
next unless $valid;
}
# handle replaces as buildignore
push @packages, "-$package->{'replaces'}" if $package->{'replaces'};
# we need this package
push @packages, $package->{'name'};
}
push @packages, map {"-$_"} @ignorepackages;
push @packages, "kiwi-packagemanager:$packman" if $packman;
push @packages, "--dorecommends--", "--dosupplements--" if $patterntype && $patterntype eq 'plusRecommended';
push @packages, '--unorderedimagerepos', if $unorderedrepos;
$ret->{'exclarch'} = [ unify(split(' ', $obsexclusivearch)) ] if $obsexclusivearch;
$ret->{'badarch'} = [ unify(split(' ', $obsexcludearch)) ] if $obsexcludearch;
$ret->{'deps'} = [ unify(@packages) ];
$ret->{'path'} = [ unify(@repos, @bootrepos) ];
$ret->{'containerpath'} = [ unify(@containerrepos) ] if @containerrepos;
$ret->{'imagetype'} = [ unify(@types) ];
$ret->{'extrasource'} = \@extrasources if @extrasources;
if (defined($urlmapper) && !$urlmapper) {
$ret->{'path'} = [ unify_repo($ret->{'path'}) ] if @{$ret->{'path'} || []};
$ret->{'containerpath'} = [ unify_repo($ret->{'containerpath'}) ] if @{$ret->{'containerpath'} || []};
} else {
for (@{$ret->{'path'} || []}) {
my @s = split('/', $_, 2);
$_ = {'project' => $s[0], 'repository' => $s[1]};
$_->{'priority'} = $repoprio{"$s[0]/$s[1]"} if $repoextras && defined $repoprio{"$s[0]/$s[1]"};
}
for (@{$ret->{'containerpath'} || []}) {
my @s = split('/', $_, 2);
$_ = {'project' => $s[0], 'repository' => $s[1]};
}
}
$ret->{'imagerepos'} = \@imagerepos if @imagerepos;
if ($containerconfig) {
my $containername = $containerconfig->{'name'};
my @containertags;
if (defined $containername) {
push @containertags, $containerconfig->{'tag'} if defined $containerconfig->{'tag'};
push @containertags, 'latest' unless @containertags;
if (defined($containerconfig->{'additionaltags'})) {
push @containertags, split(',', $containerconfig->{'additionaltags'});
}
@containertags = map {"$containername:$_"} @containertags;
}
push @containertags, @extratags if @extratags;
$ret->{'container_tags'} = [ unify(@containertags) ] if @containertags;
}
if ($obsprofiles) {
if (@$obsprofiles) {
$ret->{'profiles'} = [ unify(@$obsprofiles) ];
} else {
$ret->{'exclarch'} = []; # all profiles excluded
}
}
return $ret;
}
sub parse {
my ($cf, $fn) = @_;
local *F;
open(F, '<', $fn) || die("$fn: $!\n");
my $xml = '';
1 while sysread(F, $xml, 4096, length($xml)) > 0;
close F;
$cf ||= {};
my $d;
eval { $d = kiwiparse($xml, ($cf->{'arch'} || ''), $cf->{'buildflavor'}, $cf->{'buildrelease'}, 0) };
if ($@) {
my $err = $@;
chomp $err;
return {'error' => $err};
}
return $d;
}
sub show {
my ($fn, $field, $arch, $buildflavor) = @ARGV;
local $urlmapper = sub { return $_[0] };
my $cf = {'arch' => $arch};
$cf->{'buildflavor'} = $buildflavor if defined $buildflavor;
my $d = parse($cf, $fn);
die("$d->{'error'}\n") if $d->{'error'};
if ($field eq 'profiles' && $d->{'exclarch'} && !@{$d->{'exclarch'}}) {
print "__excluded\n";
return;
}
my $x = $d->{$field};
$x = [ $x ] unless ref $x;
if ($field eq 'copytoimage') {
print "$_\n" for @$x;
} else {
print "@$x\n";
}
}
sub showcontainerinfo {
my ($disturl, $arch, $buildflavor, $release);
while (@ARGV) {
if (@ARGV > 2 && $ARGV[0] eq '--disturl') {
(undef, $disturl) = splice(@ARGV, 0, 2);
} elsif (@ARGV > 2 && $ARGV[0] eq '--arch') {
(undef, $arch) = splice(@ARGV, 0, 2);
} elsif (@ARGV > 2 && $ARGV[0] eq '--buildflavor') {
(undef, $buildflavor) = splice(@ARGV, 0, 2);
} elsif (@ARGV > 2 && $ARGV[0] eq '--release') {
(undef, $release) = splice(@ARGV, 0, 2);
} else {
last;
}
}
my ($fn, $image) = @ARGV;
local $urlmapper = sub { return $_[0] };
my $cf = {};
$cf->{'arch'} = $arch if defined $arch;
$cf->{'buildflavor'} = $buildflavor if defined $buildflavor;
$cf->{'buildrelease'} = $release if defined $release;
my $d = parse($cf, $fn);
die("$d->{'error'}\n") if $d->{'error'};
$image =~ s/.*\/// if defined $image;
my $profile;
if (@{$d->{'profiles'} || []} > 1 && $image) {
# try to figure out the used profile from the image name
my @matches = grep {$image =~ /-\Q$_\E-/} @{$d->{'profiles'}};
if (@matches) {
$profile = $matches[0];
# XXX: should re-parse with the correct profile now
}
}
if (!defined($profile) && @{$d->{'profiles'} || []}) {
$profile = $d->{'profiles'}->[0];
}
my @repos;
for my $repo (@{$d->{'imagerepos'} || []}) {
push @repos, { 'url' => $repo->{'url'}, '_type' => {'priority' => 'number'} };
$repos[-1]->{'priority'} = $repo->{'priority'} if defined $repo->{'priority'};
}
my $buildtime = time();
my $containerinfo = {
'name' => $d->{'name'},
'buildtime' => $buildtime,
'_type' => {'buildtime' => 'number'},
};
$containerinfo->{'name'} .= "-$profile" if !$d->{'donotappendprofiletocontainername'} && defined($profile) && $profile ne '';
$containerinfo->{'version'} = $d->{'version'} if defined $d->{'version'};
$containerinfo->{'release'} = $release if defined $release;
$containerinfo->{'tags'} = $d->{'container_tags'} if @{$d->{'container_tags'} || []};
$containerinfo->{'repos'} = \@repos if @repos;
$containerinfo->{'file'} = $image if defined $image;
$containerinfo->{'disturl'} = $disturl if defined $disturl;
$containerinfo->{'milestone'} = $d->{'milestone'} if defined $d->{'milestone'};
print Build::SimpleJSON::unparse($containerinfo)."\n";
}
# not implemented yet.
sub queryiso {
my ($handle, %opts) = @_;
return {};
}
sub queryhdrmd5 {
my ($bin) = @_;
die("Build::Kiwi::queryhdrmd5 unimplemented.\n");
}
1;
0707010000000e000081a400000000000000000000000163e504b900000b51000000000000000000000000000000000000001300000000Build/LiveBuild.pm################################################################
#
# Copyright (c) 2014 Brocade Communications Systems, Inc.
# Author: Jan Blunck <jblunck@infradead.org>
#
# This file is part of build.
#
# 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
#
#################################################################
package Build::LiveBuild;
use strict;
eval { require Archive::Tar; };
*Archive::Tar::new = sub {die("Archive::Tar is not available\n")} unless defined &Archive::Tar::new;
sub filter {
my ($content) = @_;
return '' unless defined $content;
$content =~ s/^#.*$//mg;
$content =~ s/^!.*$//mg;
$content =~ s/^\s*//mg;
return $content;
}
sub parse_package_list {
my ($content) = @_;
my @packages = split /\n/, filter($content);
return @packages;
};
sub parse_archive {
my ($content) = @_;
my @repos;
my @lines = split /\n/, filter($content);
for (@lines) {
next if /^deb-src /;
die("bad path using not obs:/ URL: $_\n") unless $_ =~ /^deb\s+obs:\/\/\/?([^\s\/]+)\/([^\s\/]+)\/?\s+.*$/;
push @repos, "$1/$2";
}
return @repos;
}
sub unify {
my %h = map {$_ => 1} @_;
return grep(delete($h{$_}), @_);
}
sub parse {
my ($config, $filename, @args) = @_;
my $ret = {};
# check that filename is a tar
my $tar = Archive::Tar->new;
unless($tar->read($filename)) {
warn("$filename: " . $tar->error . "\n");
$ret->{'error'} = "$filename: " . $tar->error;
return $ret;
}
# check that directory layout matches live-build directory structure
for my $file ($tar->list_files('')) {
next unless $file =~ /^(.*\/)?config\/archives\/.*\.list.*/;
warn("$filename: config/archives/*.list* files not allowed!\n");
$ret->{'error'} = "$filename: config/archives/*.list* files not allowed!";
return $ret;
}
# always require the list of packages required by live-boot for
# bootstrapping the target distribution image (e.g. with debootstrap)
my @packages = ( 'live-build-desc' );
for my $file ($tar->list_files('')) {
next unless $file =~ /^(.*\/)?config\/package-lists\/.*\.list.*/;
push @packages, parse_package_list($tar->get_content($file));
}
($ret->{'name'} = $filename) =~ s/\.[^.]+$//;
$ret->{'deps'} = [ unify(@packages) ];
return $ret;
}
1;
0707010000000f000081a400000000000000000000000163e504b900000e55000000000000000000000000000000000000001100000000Build/Mdkrepo.pm################################################################
#
# Copyright (c) 2015 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
#
################################################################
package Build::Mdkrepo;
use strict;
#use Data::Dumper;
sub addpkg {
my ($res, $data, $options) = @_;
if ($options->{'addselfprovides'} && defined($data->{'name'}) && defined($data->{'version'})) {
if (($data->{'arch'} || '') ne 'src' && ($data->{'arch'} || '') ne 'nosrc') {
my $evr = $data->{'version'};
$evr = "$data->{'epoch'}:$evr" if $data->{'epoch'};
$evr = "$evr-$data->{'release'}" if defined $data->{'release'};
my $s = "$data->{'name'} = $evr";
push @{$data->{'provides'}}, $s unless grep {$_ eq $s} @{$data->{'provides'} || []};
}
}
if (ref($res) eq 'CODE') {
$res->($data);
} else {
push @$res, $data;
}
}
sub parsedeps {
my ($d) = @_;
my @d = split('@', $d);
for (@d) {
s/\[\*\]//s;
s/\[(.*)\]$/ $1/s;
s/ == / = /;
}
return \@d;
}
sub parse {
my ($in, $res, %options) = @_;
$res ||= [];
my $fd;
if (ref($in)) {
$fd = $in;
} else {
if ($in =~ /\.[gc]z$/) {
# we need to probe, as mageia uses xz for compression
open($fd, '<', $in) || die("$in: $!\n");
my $probe;
sysread($fd, $probe, 5);
close($fd);
if ($probe && $probe eq "\xFD7zXZ") {
open($fd, '-|', "xzdec", "-dc", $in) || die("$in: $!\n");
} else {
open($fd, '-|', "gzip", "-dc", $in) || die("$in: $!\n");
}
} else {
open($fd, '<', $in) || die("$in: $!\n");
}
}
my $s = {};
while (<$fd>) {
chomp;
if (/^\@summary\@/) {
$s->{'summary'} = substr($_, 9);
} elsif (/^\@provides\@/) {
$s->{'provides'} = parsedeps(substr($_, 10));
} elsif (/^\@requires\@/) {
$s->{'requires'} = parsedeps(substr($_, 10));
} elsif (/^\@suggests\@/) {
$s->{'suggests'} = parsedeps(substr($_, 10));
} elsif (/^\@recommends\@/) {
$s->{'recommends'} = parsedeps(substr($_, 12));
} elsif (/^\@obsoletes\@/) {
$s->{'obsoletes'} = parsedeps(substr($_, 11));
} elsif (/^\@conflicts\@/) {
$s->{'conflicts'} = parsedeps(substr($_, 11));
} elsif (/^\@info\@/) {
$s ||= {};
my @s = split('@', substr($_, 6));
$s->{'location'} = "$s[0].rpm";
my $arch;
if ($s[0] =~ /\.([^\.]+)$/) {
$arch = $1;
$s[0] =~ s/\.[^\.]+$//;
}
$s->{'epoch'} = $s[1] if $s[1];
$s[0] =~ s/-\Q$s[4]\E[^-]*$//s if defined($s[4]) && $s[4] ne ''; # strip disttag
$s[0] .= ":$s[5]" if defined($s[5]) && $s[5] ne ''; # add distepoch
$s->{'arch'} = $arch || 'noarch';
if ($s[0] =~ /^(.*)-([^-]+)-([^-]+)$/s) {
($s->{'name'}, $s->{'version'}, $s->{'release'}) = ($1, $2, $3);
# fake source entry for now...
$s->{'source'} = $s->{'name'} if $s->{'arch'} ne 'src' && $s->{'arch'} ne 'nosrc';
addpkg($res, $s, \%options);
}
$s = {};
}
}
return $res;
}
1;
07070100000010000081a400000000000000000000000163e504b90000092d000000000000000000000000000000000000000f00000000Build/Mkosi.pm#
# mkosi specific functions.
#
################################################################
#
# Copyright (c) 2022 Luca Boccassi <bluca@debian.org>
#
# 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
#
################################################################
package Build::Mkosi;
use strict;
eval { require Config::IniFiles; };
*Config::IniFiles::new = sub {die("Config::IniFiles is not available\n")} unless defined &Config::IniFiles::new;
sub parse {
my ($bconf, $fn) = @_;
my $ret = {};
my $file_content = "";
open my $fh, "<", $fn;
unless($fn) {
warn("Cannot open $fn\n");
$ret->{'error'} = "Cannot open $fn\n";
return $ret;
}
# mkosi supports multi-value keys, separated by newlines, so we need to mangle the file
# in order to make Config::IniFiles happy.
# Remove the previous newline if the next line doesn't have a '=' or '[' character.
while( my $line = <$fh>) {
$line =~ s/#.*$//;
if ((index $line, '=') == -1 && (index $line, '[') == -1) {
chomp $file_content;
}
$file_content .= $line;
}
close $fh;
my $cfg = Config::IniFiles->new( -file => \$file_content );
unless($cfg) {
warn("$fn: " . @Config::IniFiles::errors ? ":\n@Config::IniFiles::errors\n" : "\n");
$ret->{'error'} = "$fn: " . @Config::IniFiles::errors ? ":\n@Config::IniFiles::errors\n" : "\n";
return $ret;
}
my @packages;
if (length $cfg->val('Content', 'Packages')) {
push(@packages, split /\s+/, $cfg->val('Content', 'Packages'));
}
if (length $cfg->val('Content', 'BuildPackages')) {
push(@packages, split /\s+/, $cfg->val('Content', 'BuildPackages'));
}
$ret->{'name'} = $fn;
$ret->{'deps'} = \@packages;
return $ret;
}
1;
07070100000011000081a400000000000000000000000163e504b900000ca2000000000000000000000000000000000000001200000000Build/Modulemd.pm################################################################
#
# Copyright (c) 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
#
################################################################
package Build::Modulemd;
use Build::SimpleYAML;
use strict;
# This module provides a modulemd data to yaml converter. It supports
# both the 'modulemd' and 'modulemd-defaults' formats.
my $mdtemplate = {
'_order' => [ 'document', 'version', 'data' ],
'version' => 'number',
'data' => {
'_order' => [ 'name', 'stream', 'version', 'context', 'arch', 'summary', 'description', 'servicelevels', 'license', 'xmd', 'dependencies', 'references', 'profiles', 'api', 'filter', 'buildopts', 'components', 'artifacts' ],
'version' => 'number',
'description' => 'folded',
'license' => {
'_order' => [ 'module', 'content' ],
},
'components' => {
'_order' => [ 'rpms', 'modules' ],
'rpms' => {
'*' => {
'_order' => [ 'rationale', 'name', 'repository', 'cache', 'ref', 'buildroot', 'srpm-buildroot', 'buildorder', 'buildafter', 'buildonly', 'arches', 'multilib' ],
'buildroot' => 'bool',
'srpm-buildroot' => 'bool',
'buildorder' => 'number',
'buildonly' => 'bool',
'arches' => 'inline',
'multilib' => 'inline',
},
},
'modules' => {
'*' => {
'_order' => [ 'rationale', 'repository', 'ref', 'buildorder', 'buildafter', 'buildonly' ],
'buildorder' => 'number',
'buildonly' => 'bool',
},
},
},
'buildopts' => {
'_order' => [ 'rpms', 'arches' ],
'rpms' => {
'_order' => [ 'macros', 'whitelist' ],
'macros' => 'literal',
},
'arches' => 'inline',
},
'dependencies' => {
'requires' => {
'*' => 'inline',
},
'buildrequires' => {
'*' => 'inline',
},
},
},
};
my $mddefaultstemplate = {
'_order' => [ 'document', 'version', 'data' ],
'version' => 'number',
'data' => {
'_order' => [ 'module', 'modified', 'stream', 'profiles', 'intents' ],
'modified' => 'number',
'profiles' => {
'*' => 'inline',
},
'intents' => {
'*' => {
'_order' => [ 'stream', 'profiles' ],
'profiles' => {
'*' => 'inline',
},
},
},
},
};
sub mdtoyaml {
my ($md) = @_;
my $template = $md && $md->{'document'} eq 'modulemd-defaults' ? $mddefaultstemplate : $mdtemplate;
return Build::SimpleYAML::unparse($md, 'template' => $template);
}
1;
07070100000012000081a400000000000000000000000163e504b900000c39000000000000000000000000000000000000001100000000Build/Modules.pm################################################################
#
# Copyright (c) 2019 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
#
################################################################
package Build::Modules;
use strict;
eval { require YAML::XS; $YAML::XS::LoadBlessed = 0; };
*YAML::XS::LoadFile = sub {die("YAML::XS is not available\n")} unless defined &YAML::XS::LoadFile;
#
# return a hash that maps NEVRA to modules
#
sub parse {
my ($in, $res, %options) = @_;
$res ||= {};
# YAML::XS only alows a GLOB, so we need to do this old fashioned
local *FD;
my $fd;
if (ref($in)) {
*FD = $in;
} else {
if ($in =~ /\.gz$/) {
open(FD, '-|', "gzip", "-dc", $in) || die("$in: $!\n");
} else {
open(FD, '<', $in) || die("$in: $!\n");
}
}
my %mods;
my @mod = YAML::XS::LoadFile(\*FD);
for my $mod (@mod) {
next unless $mod->{'document'} eq 'modulemd';
my $data = $mod->{'data'};
next unless $data && ref($data) eq 'HASH';
my $name = $data->{'name'};
my $stream = $data->{'stream'};
my $context = $data->{'context'};
my $module = "$name-$stream";
my @reqs;
my $dependencies = $data->{'dependencies'};
$dependencies = $dependencies->[0] if ref($dependencies) eq 'ARRAY';
if ($dependencies && ref($dependencies) eq 'HASH') {
my $requires = $dependencies->{'requires'};
if ($requires && ref($requires) eq 'HASH') {
for my $r (sort keys %$requires) {
my $rs = $requires->{$r};
$rs = $rs->[0] unless ref($rs) eq 'ARRAY';
if (@$rs) {
push @reqs, "$r-$rs->[0]"; # XXX: what about the rest?
} else {
push @reqs, $r; # unversioned
}
}
}
}
my $moduleinfo = { 'name' => $module, 'stream' => $data->{'stream'} };
$moduleinfo->{'context'} = $context if $context;
$moduleinfo->{'requires'} = \@reqs if @reqs;
$mods{"$module\@$context"} = $moduleinfo;
next unless $data->{'artifacts'};
my $rpms = $data->{'artifacts'}->{'rpms'};
next unless $rpms && ref($rpms) eq 'ARRAY';
for my $rpm (@$rpms) {
my $nrpm = $rpm;
$nrpm =~ s/-0:([^-]*-[^-]*\.[^\.]*)$/-$1/; # normalize the epoch
push @{$res->{$nrpm}}, $module;
push @{$res->{$nrpm}}, "$module\@$context" if $context;
}
}
# unify
for (values %$res) {
$_ = [ sort keys %{ { map {$_ => 1} @$_ } } ] if @$_ > 1;
}
# add moduleinfo
$res->{'/moduleinfo'} = [ map {$mods{$_}} sort keys %mods ];
return $res;
}
1;
07070100000013000081a400000000000000000000000163e504b900000922000000000000000000000000000000000000001100000000Build/Options.pm################################################################
#
# Copyright (c) 2021 SUSE LLC
#
# 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
#
################################################################
package Build::Options;
use strict;
sub getarg {
my ($origopt, $args, $optional) = @_;
return ${shift @$args} if @$args && ref($args->[0]);
return shift @$args if @$args && $args->[0] !~ /^-/;
die("Option $origopt needs an argument\n") unless $optional;
return undef;
}
sub parse_options {
my ($known_options, @args) = @_;
my %opts;
my @back;
while (@args) {
my $opt = shift @args;
if ($opt !~ /^-/) {
push @back, $opt;
next;
}
if ($opt eq '--') {
push @back, @args;
last;
}
my $origopt = $opt;
$opt =~ s/^--?//;
unshift @args, \"$1" if $opt =~ s/=(.*)$//;
my $ko = $known_options->{$opt};
die("Unknown option '$origopt'. Exit.\n") unless defined $ko;
$ko = "$opt$ko" if !ref($ko) && ($ko eq '' || $ko =~ /^:/);
if (ref($ko)) {
$ko->(\%opts, $opt, $origopt, \@args);
} elsif ($ko =~ s/(:.*)//) {
my $arg = getarg($origopt, \@args);
if ($1 eq '::') {
push @{$opts{$ko}}, $arg;
} else {
$opts{$ko} = $arg;
}
} else {
my $arg = 1;
if (@args && ref($args[0])) {
$arg = getarg($origopt, \@args);
$arg = 0 if $arg =~ /^(?:0|off|false|no)$/i;
$arg = 1 if $arg =~ /^(?:1|on|true|yes)$/i;
die("Bad boolean argument for option $origopt: '$arg'\n") unless $arg eq '0' || $arg eq '1';
}
$opts{$ko} = $arg;
}
die("Option $origopt does not take an argument\n") if @args && ref($args[0]);
}
return (\%opts, @back);
}
1;
07070100000014000081a400000000000000000000000163e504b9000007da000000000000000000000000000000000000000e00000000Build/Repo.pm################################################################
#
# Copyright (c) 1995-2014 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
#
################################################################
package Build::Repo;
use strict;
our $do_rpmmd;
our $do_deb;
our $do_arch;
our $do_susetags;
our $do_mdk;
sub import {
for (@_) {
$do_rpmmd = 1 if $_ eq ':rpmmd';
$do_deb = 1 if $_ eq ':deb';
$do_arch = 1 if $_ eq ':arch';
$do_susetags = 1 if $_ eq ':susetags';
$do_mdk = 1 if $_ eq ':mdk';
}
$do_rpmmd = $do_deb = $do_arch = $do_susetags = $do_mdk = 1 unless $do_rpmmd || $do_deb || $do_arch || $do_susetags || $do_mdk;
if ($do_rpmmd) {
require Build::Rpmmd;
}
if ($do_susetags) {
require Build::Susetags;
}
if ($do_deb) {
require Build::Debrepo;
}
if ($do_arch) {
require Build::Archrepo;
}
if ($do_mdk) {
require Build::Mdkrepo;
}
}
sub parse {
my ($type, @args) = @_;
return Build::Rpmmd::parse(@args) if $do_rpmmd && $type eq 'rpmmd';
return Build::Susetags::parse(@args) if $do_susetags && $type eq 'susetags';
return Build::Debrepo::parse(@args) if $do_deb && $type eq 'deb';
return Build::Archrepo::parse(@args) if $do_arch && $type eq 'arch';
return Build::Mdkrepo::parse(@args) if $do_arch && $type eq 'mdk';
die("parse repo: unknown type '$type'\n");
}
1;
07070100000015000081a400000000000000000000000163e504b90000c8a5000000000000000000000000000000000000000d00000000Build/Rpm.pm################################################################
#
# Copyright (c) 1995-2014 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
#
################################################################
package Build::Rpm;
our $unfilteredprereqs = 0;
our $conflictdeps = 0;
our $includecallback;
use strict;
use Digest::MD5;
sub expr_boolify {
my ($v) = @_;
return !defined($v) || $v eq '"' || $v =~ /^(?:0*$|v)/s ? 0 : 1;
}
sub expr_vcmp {
my ($v1, $v2, $rr) = @_;
my $r = verscmp(substr($v1, 1), substr($v2, 1));
return ($r < 0 ? 1 : $r > 0 ? 4 : 2) & $rr ? 1 : 0;
}
sub expr_dummyexpander {
return substr($_[0], 0, 1);
}
sub expr_expand {
my ($v, $expr, $xp, $r) = @_;
while (1) {
if ($expr =~ /^%%/s) {
$v .= substr($expr, 0, 2, '');
} elsif ($expr =~ /^%/s) {
my $m = macroend($expr);
$v .= substr($expr, 0, length($m), '');
} elsif ($expr =~ /$r/) {
$v .= substr($expr, 0, length($1), '');
} else {
return ($xp->($v), $expr);
}
}
}
sub expr {
my ($expr, $lev, $xp) = @_;
$lev ||= 0;
my ($v, $v2);
$expr =~ s/^\s+//;
my $t = substr($expr, 0, 1);
if ($t eq '(') {
($v, $expr) = expr(substr($expr, 1), 0, $xp);
return undef unless defined $v;
return undef unless $expr =~ s/^\)//;
} elsif ($t eq '!') {
($v, $expr) = expr(substr($expr, 1), 6, $xp);
return undef unless defined $v;
$v = expr_boolify($v) ? 0 : 1;
} elsif ($t eq '-') {
($v, $expr) = expr(substr($expr, 1), 6, $xp);
return undef unless defined $v;
$v = -$v;
} elsif ($expr =~ /^([0-9]+)(.*?)$/s || ($xp && $expr =~ /^(%)(.*)$/)) {
$v = $1;
$expr = $2;
($v, $expr) = expr_expand('0', "$1$2", $xp, qr/^([0-9]+)/) if $xp;
$v = 0 + $v;
} elsif ($expr =~ /^v\"(.*?)(\".*)$/s) {
$v = "v$1"; # version
$expr = $2;
($v, $expr) = expr_expand('v', substr("$1$2", 2), $xp, qr/^([^%\"]+)/) if $xp;
$expr =~ s/^\"//s;
} elsif ($expr =~ /^(\".*?)(\".*)$/s) {
$v = $1;
$expr = $2;
($v, $expr) = expr_expand('"', substr("$1$2", 1), $xp, qr/^([^%\"]+)/) if $xp;
$expr =~ s/^\"//s;
} elsif ($expr =~ /^([a-zA-Z][a-zA-Z_0-9]*)(.*)$/s) {
# actually no longer supported with new rpm versions
$v = "\"$1";
$expr = $2;
} else {
return;
}
return ($v, $expr) if $lev >= 6;
while (1) {
$expr =~ s/^\s+//;
if ($expr =~ /^&&/) {
return ($v, $expr) if $lev >= 2;
my $b = expr_boolify($v);
($v2, $expr) = expr(substr($expr, 2), 2, $xp && !$b ? \&expr_dummyexpander : $xp);
return undef unless defined $v2;
$v = $v2 if $b;
} elsif ($expr =~ /^\|\|/) {
return ($v, $expr) if $lev >= 2;
my $b = expr_boolify($v);
($v2, $expr) = expr(substr($expr, 2), 2, $xp && $b ? \&expr_dummyexpander : $xp);
return undef unless defined $v2;
$v = $v2 unless $b;
} elsif ($expr =~ /^>=/) {
return ($v, $expr) if $lev >= 3;
($v2, $expr) = expr(substr($expr, 2), 3, $xp);
return undef unless defined $v2;
$v = (($v =~ /^v/) ? expr_vcmp($v, $v2, 6) : ($v =~ /^\"/) ? $v ge $v2 : $v >= $v2) ? 1 : 0;
} elsif ($expr =~ /^>/) {
return ($v, $expr) if $lev >= 3;
($v2, $expr) = expr(substr($expr, 1), 3, $xp);
return undef unless defined $v2;
$v = (($v =~ /^v/) ? expr_vcmp($v, $v2, 4) : ($v =~ /^\"/) ? $v gt $v2 : $v > $v2) ? 1 : 0;
} elsif ($expr =~ /^<=/) {
return ($v, $expr) if $lev >= 3;
($v2, $expr) = expr(substr($expr, 2), 3, $xp);
return undef unless defined $v2;
$v = (($v =~ /^v/) ? expr_vcmp($v, $v2, 3) : ($v =~ /^\"/) ? $v le $v2 : $v <= $v2) ? 1 : 0;
} elsif ($expr =~ /^</) {
return ($v, $expr) if $lev >= 3;
($v2, $expr) = expr(substr($expr, 1), 3, $xp);
return undef unless defined $v2;
$v = (($v =~ /^v/) ? expr_vcmp($v, $v2, 1) : ($v =~ /^\"/) ? $v lt $v2 : $v < $v2) ? 1 : 0;
} elsif ($expr =~ /^==/) {
return ($v, $expr) if $lev >= 3;
($v2, $expr) = expr(substr($expr, 2), 3, $xp);
return undef unless defined $v2;
$v = (($v =~ /^v/) ? expr_vcmp($v, $v2, 2) : ($v =~ /^\"/) ? $v eq $v2 : $v == $v2) ? 1 : 0;
} elsif ($expr =~ /^!=/) {
return ($v, $expr) if $lev >= 3;
($v2, $expr) = expr(substr($expr, 2), 3, $xp);
return undef unless defined $v2;
$v = (($v =~ /^v/) ? expr_vcmp($v, $v2, 5) : ($v =~ /^\"/) ? $v ne $v2 : $v != $v2) ? 1 : 0;
} elsif ($expr =~ /^\+/) {
return ($v, $expr) if $lev >= 4;
($v2, $expr) = expr(substr($expr, 1), 4, $xp);
return undef unless defined $v2;
if ($v =~ /^\"/ && $v2 =~ s/^\"//) {
$v .= $v2;
} else {
$v += $v2;
}
} elsif ($expr =~ /^-/) {
return ($v, $expr) if $lev >= 4;
($v2, $expr) = expr(substr($expr, 1), 4, $xp);
return undef unless defined $v2;
$v -= $v2;
} elsif ($expr =~ /^\*/) {
($v2, $expr) = expr(substr($expr, 1), 5, $xp);
return undef unless defined $v2;
$v *= $v2;
} elsif ($expr =~ /^\//) {
($v2, $expr) = expr(substr($expr, 1), 5, $xp);
return undef unless defined $v2 && 0 + $v2;
$v /= $v2;
} elsif ($expr =~ /^\?/) {
return ($v, $expr) if $lev > 1;
my $b = expr_boolify($v);
($v, $expr) = expr(substr($expr, 1), 1, $xp && !$b ? \&expr_dummyexpander : $xp);
warn("syntax error while parsing ternary in $_[0]\n") unless defined($v) && $expr =~ s/^://;
($v2, $expr) = expr($expr, 1, $xp && $b ? \&expr_dummyexpander : $xp);
return undef unless defined $v2;
$v = $v2 unless $b;
} elsif ($expr =~ /^([=&|])/) {
warn("syntax error while parsing $1$1\n");
return ($v, $expr);
} else {
return ($v, $expr);
}
}
}
sub adaptmacros {
my ($macros, $optold, $optnew) = @_;
for (keys %$optold) {
delete $macros->{$_};
}
for (keys %$optnew) {
$macros->{$_} = $optnew->{$_};
}
return $optnew;
}
sub grabargs {
my ($macname, $getopt, @args) = @_;
my %m;
$m{'0'} = $macname;
$m{'**'} = join(' ', @args);
my %go;
%go = ($getopt =~ /(.)(:*)/sg) if defined $getopt;
while (@args && $args[0] =~ s/^-//) {
my $o = shift @args;
last if $o eq '-';
while ($o =~ /^(.)(.*)$/) {
if ($go{$1}) {
my $arg = $2;
$arg = shift(@args) if @args && $arg eq '';
$m{"-$1"} = "-$1 $arg";
$m{"-$1*"} = $arg;
last;
}
$m{"-$1"} = "-$1";
$o = $2;
}
}
$m{'#'} = scalar(@args);
my $i = 1;
for (@args) {
$m{$i} = $_;
$i++;
}
$m{'*'} = join(' ', @args);
return \%m;
}
# no support for most special chars yet
sub luapattern {
my ($pat) = @_;
$pat = "\Q$pat\E";
$pat =~ s/^\\\^/\^/;
$pat =~ s/\\\$/\$/;
$pat =~ s/\\\./\./;
$pat =~ s/\\\*/\*/;
$pat =~ s/\\\-/\*\?/;
$pat =~ s/\\\?/\?/;
$pat =~ s/\\\+/\+/;
$pat =~ s/\\%([%ds])/\\$1/g;
return $pat;
}
sub luamacro {
my ($macname, @args) = @_;
push @args, '' unless @args;
return lc($args[0]) if $macname eq 'lower';
return uc($args[0]) if $macname eq 'upper';
return length($args[0]) if $macname eq 'len';
return reverse($args[0]) if $macname eq 'reverse';
return $args[0] x $args[1] if $macname eq 'rep';
if ($macname eq 'sub') {
push @args, 1 if @args < 2;
push @args, -1 if @args < 3;
$args[1] -= 1 if $args[1] > 0;
$args[1] = length($args[0]) + $args[1] if $args[1] < 0;
$args[1] = 0 if $args[1] < 0;
$args[2] -= 1 if $args[2] > 0;
$args[2] = length($args[0]) + $args[2] if $args[2] < 0;
return $args[1] <= $args[2] ? substr($args[0], $args[1], $args[2] - $args[1] + 1) : '';
}
if ($macname eq 'gsub') {
return unless @args >= 3;
my $pat = luapattern($args[1]);
my $rep = $args[3];
eval {
if (!defined($rep)) {
$args[0] =~ s/$pat/$args[2]/g;
} else {
$args[0] =~ s/$pat(?(?{$rep--<=0})(*F))/$args[2]/g;
}
};
return $@ ? '' : $args[0];
}
return '';
}
sub initmacros {
my ($config, $macros, $macros_args) = @_;
for my $line (@{$config->{'macros'} || []}) {
next unless $line =~ /^%define\s*([0-9a-zA-Z_]+)(?:\(([^\)]*)\))?\s*(.*?)$/s;
my $macname = $1;
my $macargs = $2;
my $macbody = $3;
if (defined $macargs) {
$macros_args->{$macname} = $macargs;
} else {
delete $macros_args->{$macname};
}
$macros->{$macname} = $macbody;
}
}
sub macroend {
my ($expr) = @_;
if ($expr =~ /^%([\(\{\[])/s) {
my $o = $1;
my $c = $o eq '[' ? ']' : $o eq '(' ? ')' : '}';
my $m = substr($expr, 0, 2, '');
my $cnt = 1;
my $r = qr/^(.*?)([$o$c\\])/s;
while ($expr =~ /$r/) {
$m .= substr($expr, 0, length($1) + 1, '');
if ($2 eq '\\') {
$m .= substr($expr, 0, 1, '');
} elsif ($2 eq $o) {
$cnt++;
} elsif ($2 eq $c) {
return $m if --$cnt == 0;
}
}
return "$m$expr";
}
return $1 if $expr =~ /^(%[?!]*-?[a-zA-Z0-9_]*(?:\*|\*\*|\#)?)/s;
}
sub expandmacros {
my ($config, $line, $lineno, $macros, $macros_args, $tries) = @_;
if (!$macros) {
$macros = {};
$macros_args = {};
initmacros($config, $macros, $macros_args);
}
my $expandedline = '';
$tries ||= 0;
my @expandstack;
my $optmacros = {};
# newer perls: \{((?:(?>[^{}]+)|(?2))*)\}
reexpand:
while ($line =~ /^(.*?)%(\{([^\}]+)\}|[\?\!]*[0-9a-zA-Z_]+|%|\*\*?|#|\(|\[)(.*?)\z/s) {
if ($tries++ > 1000) {
print STDERR "Warning: spec file parser ",($lineno?" line $lineno":''),": macro too deeply nested\n" if $config->{'warnings'};
$line = 'MACRO';
last;
}
$expandedline .= $1;
$line = $4;
if ($2 eq '%') {
$expandedline .= '%';
next;
}
my $macname = defined($3) ? $3 : $2;
my $macorig = $2;
my $macdata;
my $macalt;
if (defined($3)) {
if ($macname =~ /[{\\]/) { # tricky, use macroend
$macname = macroend("%$macorig$line");
$line = substr("%$macorig$line", length($macname));
$macorig = substr($macname, 1);
$macname =~ s/^%\{//s;
$macname =~ s/\}\z//s;
}
$macdata = '';
if ($macname =~ /^([^\s:]+)([\s:])(.*)\z/s) {
$macname = $1;
if ($2 eq ':') {
$macalt = $3;
} else {
$macdata = $3;
}
}
}
my $mactest = 0;
if ($macname =~ /^\!\?/s || $macname =~ /^\?\!/s) {
$mactest = -1;
} elsif ($macname =~ /^\?/s) {
$mactest = 1;
}
$macname =~ s/^[\!\?]+//s;
if ($macname eq '(') {
print STDERR "Warning: spec file parser",($lineno?" line $lineno":''),": can't expand %(...)\n" if $config->{'warnings'};
$line = 'MACRO';
last;
} elsif ($macname eq '[') {
$macalt = macroend("%[$line");
$line = substr($line, length($macalt) - 2);
$macalt =~ s/^%\[//;
$macalt =~ s/\]$//;
my $xp = sub {expandmacros($config, $_[0], $lineno, $macros, $macros_args, $tries)};
$macalt = (expr($macalt, 0, $xp))[0];
$macalt =~ s/^[v\"]//; # stringify
$expandedline .= $macalt;
} elsif ($macname eq 'define' || $macname eq 'global') {
my $isglobal = $macname eq 'global' ? 1 : 0;
if ($line =~ /^\s*([0-9a-zA-Z_]+)(?:\(([^\)]*)\))?\s*(.*?)$/) {
my $macname = $1;
my $macargs = $2;
my $macbody = $3;
$macbody = expandmacros($config, $macbody, $lineno, $macros, $macros_args, $tries) if $isglobal;
if (defined $macargs) {
$macros_args->{$macname} = $macargs;
} else {
delete $macros_args->{$macname};
}
$macros->{$macname} = $macbody;
}
$line = '';
last;
} elsif ($macname eq 'defined' || $macname eq 'with' || $macname eq 'undefined' || $macname eq 'without' || $macname eq 'bcond_with' || $macname eq 'bcond_without') {
my @args;
if ($macorig =~ /^\{(.*)\}$/) {
@args = split(' ', $1);
shift @args;
} else {
@args = split(' ', $line);
$line = '';
}
next unless @args;
if ($macname eq 'bcond_with') {
$macros->{"with_$args[0]"} = 1 if exists $macros->{"_with_$args[0]"};
next;
}
if ($macname eq 'bcond_without') {
$macros->{"with_$args[0]"} = 1 unless exists $macros->{"_without_$args[0]"};
next;
}
$args[0] = "with_$args[0]" if $macname eq 'with' || $macname eq 'without';
$line = ((exists($macros->{$args[0]}) ? 1 : 0) ^ ($macname eq 'undefined' || $macname eq 'without' ? 1 : 0)).$line;
} elsif ($macname eq 'expand') {
$macalt = $macros->{$macname} unless defined $macalt;
$macalt = '' if $mactest == -1;
push @expandstack, ($expandedline, $line, undef);
$line = $macalt;
$expandedline = '';
} elsif ($macname eq 'expr') {
$macalt = $macros->{$macname} unless defined $macalt;
$macalt = '' if $mactest == -1;
$macalt = expandmacros($config, $macalt, $lineno, $macros, $macros_args, $tries);
$macalt = (expr($macalt))[0];
$macalt =~ s/^[v\"]//; # stringify
$expandedline .= $macalt;
} elsif ($macname eq 'gsub' || $macname eq 'len' || $macname eq 'lower' || $macname eq 'upper' || $macname eq 'rep' || $macname eq 'reverse' || $macname eq 'sub') {
my @args;
if (defined $macalt) {
push @args, $macalt;
} elsif (defined $macdata) {
push @args, split(' ', $macdata);
} else {
$line =~ /^\s*([^\n]*).*$/;
push @args, split(' ', $1);
$line = '';
}
$_ = expandmacros($config, $_, $lineno, $macros, $macros_args, $tries) for @args;
$expandedline .= luamacro($macname, @args);
} elsif (exists($macros->{$macname})) {
if (!defined($macros->{$macname})) {
print STDERR "Warning: spec file parser",($lineno?" line $lineno":''),": can't expand '$macname'\n" if $config->{'warnings'};
$line = 'MACRO';
last;
}
if (defined($macros_args->{$macname})) {
# macro with args!
if (!defined($macdata)) {
$line =~ /^\s*([^\n]*).*$/;
$macdata = $1;
$line = '';
}
push @expandstack, ($expandedline, $line, $optmacros);
$optmacros = adaptmacros($macros, $optmacros, grabargs($macname, $macros_args->{$macname}, split(' ', $macdata)));
$line = $macros->{$macname};
$expandedline = '';
next;
}
$macalt = $macros->{$macname} unless defined $macalt;
$macalt = '' if $mactest == -1;
if ($macalt =~ /%/) {
push @expandstack, ('', $line, 1) if $line ne '';
$line = $macalt;
} else {
$expandedline .= $macalt;
}
} elsif ($mactest) {
$macalt = '' if !defined($macalt) || $mactest == 1;
if ($macalt =~ /%/) {
push @expandstack, ('', $line, 1) if $line ne '';
$line = $macalt;
} else {
$expandedline .= $macalt;
}
} else {
$expandedline .= "%$macorig" unless $macname =~ /^-/;
}
}
$line = $expandedline . $line;
if (@expandstack) {
my $m = pop(@expandstack);
if ($m) {
$optmacros = adaptmacros($macros, $optmacros, $m) if ref $m;
$expandstack[-2] .= $line;
$line = pop(@expandstack);
$expandedline = pop(@expandstack);
} else {
my $todo = pop(@expandstack);
$expandedline = pop(@expandstack);
push @expandstack, ('', $todo, 1) if $todo ne '';
}
goto reexpand;
}
return $line;
}
sub splitexpansionresult {
my ($line, $includelines) = @_;
my @l = split("\n", $line);
$line = shift @l;
s/%/%%/g for @l;
unshift @$includelines, @l;
return $line;
}
# see rpm's copyNextLineFromOFI() function in build/parseSpec.c
sub needmorelines {
my ($line) = @_;
my ($bc, $pc, $xc, $nc) = (0, 0, 0, 0);
while (1) {
$line =~ s/^[^\\\n%\{\}\(\)\[\]]*//s;
last if $line eq '';
if ($line =~ s/^%\{//s) {
$bc++;
} elsif ($line =~ s/^%\(//s) {
$pc++;
} elsif ($line =~ s/^%\[//s) {
$xc++;
} elsif ($line =~ s/^%%?//s) {
next;
} elsif ($line =~ s/^\n//s) {
$nc = 0;
} elsif ($line =~ s/^\\\n//s) {
$nc = 1;
} elsif ($line =~ s/^\\.?//s) {
next;
} elsif ($line =~ s/^([\{\}])//s) {
$bc += $1 eq '{' ? 1 : -1 if $bc;
} elsif ($line =~ s/^([\(\)])//s) {
$pc += $1 eq '(' ? 1 : -1 if $pc;
} elsif ($line =~ s/^([\[\]])//s) {
$xc += $1 eq '[' ? 1 : -1 if $xc;
}
}
return $pc || $bc || $xc || $nc ? 1 : 0;
}
sub splitdeps {
my ($d) = @_;
my @deps;
$d =~ s/^[\s,]+//;
while ($d ne '') {
if ($d =~ /^\(/) {
my @s = split(' ', $d);
push @deps, shiftrich(\@s), undef, undef;
$d = join(' ', @s);
} else {
last unless $d =~ s/([^\s\[,]+)(\s+[<=>]+\s+[^\s\[,]+)?(\s+\[[^\]]+\])?[\s,]*//;
push @deps, $1, $2, $3;
}
}
return @deps;
}
# xspec may be passed as array ref to return the parsed spec files
# an entry in the returned array can be
# - a string: verbatim line from the original file
# - a two element array ref:
# - [0] original line
# - [1] undef: line unused due to %if
# - [1] scalar: line after macro expansion. Only set if it's a build deps
# line and build deps got modified or 'save_expanded' is set in
# config
sub parse {
my ($config, $specfile, $xspec) = @_;
my $packname;
my $exclarch;
my $badarch;
my @subpacks;
my @packdeps;
my @prereqs;
my @alsonative;
my @onlynative;
my $hasnfb;
my $nfbline;
my %macros;
my %macros_args;
my $ret = {};
my $ifdeps;
my %autonum = (patch => 0, source => 0);
my $specdata;
local *SPEC;
if (ref($specfile) eq 'GLOB') {
*SPEC = *$specfile;
} elsif (ref($specfile) eq 'ARRAY') {
$specdata = [ @$specfile ];
} elsif (!open(SPEC, '<', $specfile)) {
warn("$specfile: $!\n");
$ret->{'error'} = "open $specfile: $!";
return $ret;
}
initmacros($config, \%macros, \%macros_args);
my $skip = 0;
my $main_preamble = 1;
my $preamble = 1;
my $hasif = 0;
my $lineno = 0;
my @includelines;
my $includenum = 0;
my $obspackage = defined($config->{'obspackage'}) ? $config->{'obspackage'} : '@OBS_PACKAGE@';
my $buildflavor = defined($config->{'buildflavor'}) ? $config->{'buildflavor'} : '';
my $remoteasset;
my $multilinedefine;
my $multilinecondition;
while (1) {
my $line;
my $doxspec = $xspec ? 1 : 0;
if (@includelines) {
$line = shift(@includelines);
$includenum = 0 unless @includelines;
$doxspec = 0; # only record lines from main file
} elsif ($specdata) {
last unless @$specdata;
$line = shift @$specdata;
++$lineno;
if (ref $line) {
$line = $line->[0]; # verbatim line, used for macro collection
push @$xspec, $line if $doxspec;
$xspec->[-1] = [ $line, undef ] if $doxspec && $skip;
next;
}
} else {
$line = <SPEC>;
last unless defined $line;
chomp $line;
++$lineno;
}
push @$xspec, $line if $doxspec;
if ($line =~ /^#\s*neededforbuild\s*(\S.*)$/) {
if (defined $hasnfb) {
$xspec->[-1] = [ $xspec->[-1], undef ] if $doxspec;
next;
}
$hasnfb = $1;
$nfbline = \$xspec->[-1] if $doxspec;
next;
}
if ($multilinedefine || $line =~ /^\s*%(?:define|global)\s/s) {
# is this a multi-line macro definition?
$line = "$multilinedefine\n$line" if defined $multilinedefine;
undef $multilinedefine;
if ($line =~ /\\\z/s) {
$multilinedefine = $line; # we need another line!
next;
}
}
if ($multilinecondition || $line =~ /^\s*\%\{[?!]*-?[0-9a-zA-Z_]+:\s*$/s) {
# is this a multi-line macro condition?
$line = "$multilinecondition\n$line" if defined $multilinecondition;
undef $multilinecondition;
if (needmorelines($line)) {
$multilinecondition = $line; # we need another line!
next;
}
}
if ($line =~ /^\s*#/) {
next unless $line =~ /^#!/;
}
if (!$skip && ($line =~ /%/)) {
$line = expandmacros($config, $line, $lineno, \%macros, \%macros_args);
$line = splitexpansionresult($line, \@includelines) if $line =~ /\n/s;
}
if ($line =~ /^\s*%(?:elif|elifarch|elifos)\b/) {
$skip = 1 if !$skip;
$skip = 2 - $skip if $skip <= 2;
next if $skip;
$line =~ s/^(\s*%)el/$1/;
$line = expandmacros($config, $line, $lineno, \%macros, \%macros_args);
$line = splitexpansionresult($line, \@includelines) if $line =~ /\n/s;
}
if ($line =~ /^\s*%else\b/) {
$skip = 2 - $skip if $skip <= 2;
next;
}
if ($line =~ /^\s*%endif\b/) {
$skip = $skip > 2 ? $skip - 2 : 0;
next;
}
if ($skip) {
$skip += 2 if $line =~ /^\s*%if/;
$xspec->[-1] = [ $xspec->[-1], undef ] if $doxspec;
$ifdeps = 1 if $line =~ /^(BuildRequires|BuildPrereq|BuildConflicts|\#\!BuildIgnore|\#\!BuildConflicts|\#\!BuildRequires)\s*:\s*(\S.*)$/i;
next;
}
if ($line =~ /\@/) {
$line =~ s/\@BUILD_FLAVOR\@/$buildflavor/g;
$line =~ s/\@OBS_PACKAGE\@/$obspackage/g;
}
if ($line =~ /^\s*%ifarch(.*)$/) {
my $arch = $macros{'_target_cpu'} || 'unknown';
my @archs = grep {$_ eq $arch} split(/\s+/, $1);
$skip = 2 if !@archs;
$hasif = 1;
next;
}
if ($line =~ /^\s*%ifnarch(.*)$/) {
my $arch = $macros{'_target_cpu'} || 'unknown';
my @archs = grep {$_ eq $arch} split(/\s+/, $1);
$skip = 2 if @archs;
$hasif = 1;
next;
}
if ($line =~ /^\s*%ifos(.*)$/) {
my $os = $macros{'_target_os'} || 'unknown';
my @oss = grep {$_ eq $os} split(/\s+/, $1);
$skip = 2 if !@oss;
$hasif = 1;
next;
}
if ($line =~ /^\s*%ifnos(.*)$/) {
my $os = $macros{'_target_os'} || 'unknown';
my @oss = grep {$_ eq $os} split(/\s+/, $1);
$skip = 2 if @oss;
$hasif = 1;
next;
}
if ($line =~ /^\s*%if(.*)$/) {
my ($v, $r) = expr($1);
$v = expr_boolify($v);
$skip = 2 unless $v;
$hasif = 1;
next;
}
if ($includecallback && $line =~ /^\s*%include\s+(.*)\s*$/) {
if ($includenum++ < 10) {
my $data = $includecallback->($1);
unshift @includelines, split("\n", $data) if $data;
} else {
warn("%include statment level too high, ignored\n") if $config->{'warnings'};
}
}
if ($main_preamble) {
if ($line =~ /^(Name|Epoch|Version|Release|Disttag)\s*:\s*(\S+)/i) {
$ret->{lc $1} = $2;
$macros{lc $1} = $2;
} elsif ($line =~ /^ExclusiveArch\s*:\s*(.*)/i) {
$exclarch ||= [];
push @$exclarch, split(' ', $1);
} elsif ($line =~ /^ExcludeArch\s*:\s*(.*)/i) {
$badarch ||= [];
push @$badarch, split(' ', $1);
}
}
if (@subpacks && $preamble && exists($ret->{'version'}) && $line =~ /^Version\s*:\s*(\S+)/i) {
$ret->{'multiversion'} = 1 if $ret->{'version'} ne $1;
}
if ($preamble && $line =~ /^\#\!ForceMultiVersion\s*$/i) {
$ret->{'multiversion'} = 1;
}
if ($preamble && $line =~ /^\#\!NativeBuild\s*$/i) {
$ret->{'nativebuild'} = 1;
}
if ($preamble && $line =~ /^\#\!RemoteAsset(?::\s*([a-z0-9]+:[0-9a-f]+))?\s*$/i) {
$remoteasset = {};
$remoteasset->{'digest'} = $1 if $1;
}
if ($preamble && $line =~ /^\#\!RemoteAssetUrl:\s*(\S+)\s*$/i) {
$remoteasset->{'url'} = $1;
push @{$ret->{'remoteassets'}}, $remoteasset;
$remoteasset = undef;
}
if ($preamble && $line =~ /^\#\!BuildTarget:\s*(\S+)\s*$/i) {
my $bt = $1;
if ($bt =~ s/(.*?)://) {
$bt = '' if $1 ne '' && $1 ne ($macros{'_target_cpu'} || 'unknown');
}
delete $ret->{'buildtarget'};
$ret->{'buildtarget'} = $bt if $bt;
}
if ($preamble && $line =~ /^\#\!BuildConstraint:\s*(\S.+?)\s*$/i) {
push @{$ret->{'buildconstraint'}}, $1;
}
if ($line =~ /^(?:Requires\(pre\)|Requires\(post\)|PreReq)\s*:\s*(\S.*)$/i) {
my $deps = $1;
my @deps;
if (" $deps" =~ /[\s,]\(/) {
@deps = splitdeps($deps);
} else {
@deps = $deps =~ /([^\s\[,]+)(\s+[<=>]+\s+[^\s\[,]+)?(\s+\[[^\]]+\])?[\s,]*/g;
}
while (@deps) {
my ($pack, $vers, $qual) = splice(@deps, 0, 3);
next if $pack eq 'MACRO'; # hope for the best...
if (!$unfilteredprereqs && $pack =~ /^\//) {
$ifdeps = 1;
next unless $config->{'fileprovides'}->{$pack};
}
push @prereqs, $pack unless grep {$_ eq $pack} @prereqs;
}
next;
}
if ($preamble && ($line =~ /^(BuildRequires|BuildPrereq|BuildConflicts|\#\!BuildIgnore|\#\!BuildConflicts|\#\!BuildRequires|\#\!AlsoNative|\#\!OnlyNative)\s*:\s*(\S.*)$/i)) {
my $what = $1;
my $deps = $2;
$ifdeps = 1 if $hasif;
# XXX: weird syntax addition. can append arch or project to dependency
# BuildRequire: foo > 17 [i586,x86_64]
# BuildRequire: foo [home:bar]
# BuildRequire: foo [!home:bar]
my @deps;
if (" $deps" =~ /[\s,]\(/) {
# we need to be careful, there could be a rich dep
@deps = splitdeps($deps);
} else {
@deps = $deps =~ /([^\s\[,]+)(\s+[<=>]+\s+[^\s\[,]+)?(\s+\[[^\]]+\])?[\s,]*/g;
}
my $replace = 0;
my @ndeps = ();
while (@deps) {
my ($pack, $vers, $qual) = splice(@deps, 0, 3);
if (defined($qual)) {
$replace = 1;
my $arch = $macros{'_target_cpu'} || '';
my $proj = $macros{'_target_project'} || '';
$qual =~ s/^\s*\[//;
$qual =~ s/\]$//;
my $isneg = 0;
my $bad;
for my $q (split('[\s,]', $qual)) {
$isneg = 1 if $q =~ s/^\!//;
$bad = 1 if !defined($bad) && !$isneg;
if ($isneg) {
if ($q eq $arch || $q eq $proj) {
$bad = 1;
last;
}
} elsif ($q eq $arch || $q eq $proj) {
$bad = 0;
}
}
next if $bad;
}
$vers = '' unless defined $vers;
$vers =~ s/=(>|<)/$1=/;
push @ndeps, "$pack$vers";
}
$replace = 1 if grep {/^-/} @ndeps;
my $lcwhat = lc($what);
if ($lcwhat eq '#!alsonative') {
push @alsonative, @ndeps;
next;
}
if ($lcwhat eq '#!onlynative') {
push @onlynative, @ndeps;
next;
}
if ($lcwhat ne 'buildrequires' && $lcwhat ne 'buildprereq' && $lcwhat ne '#!buildrequires') {
if ($conflictdeps && $what =~ /conflict/i) {
push @packdeps, map {"!$_"} @ndeps;
next;
}
push @packdeps, map {"-$_"} @ndeps;
next;
}
if (defined($hasnfb)) {
if ((grep {$_ eq 'glibc' || $_ eq 'rpm' || $_ eq 'gcc' || $_ eq 'bash'} @ndeps) > 2) {
# ignore old generated BuildRequire lines.
$xspec->[-1] = [ $xspec->[-1], undef ] if $doxspec;
next;
}
}
push @packdeps, @ndeps;
next unless $doxspec;
if ($replace) {
my @cndeps = grep {!/^-/} @ndeps;
if (@cndeps) {
$xspec->[-1] = [ $xspec->[-1], "$what: ".join(' ', @cndeps) ];
} else {
$xspec->[-1] = [ $xspec->[-1], ''];
}
}
next;
} elsif ($preamble && $line =~ /^(Source\d*|Patch\d*|Url|Icon)\s*:\s*(\S+)/i) {
my ($tag, $val) = (lc($1), $2);
$macros{$tag} = $val if $tag eq 'url';
# associate url and icon tags with the corresponding subpackage
$tag .= scalar @subpacks if ($tag eq 'url' || $tag eq 'icon') && @subpacks;
if ($tag =~ /icon/) {
# there can be a gif and xpm icon
push @{$ret->{$tag}}, $val;
} else {
if ($tag =~ /^(source|patch)(\d+)?$/) {
my $num = defined($2) ? 0 + $2 : $autonum{$1};
$tag = "$1$num";
if ($tag eq 'patch0' && exists($ret->{$tag})) {
# gross hack. Before autonumbering "Patch" and "Patch0" could
# exist. So take out the previous patch and add it back
# without number. This does not exactly work as old rpms
# but hopefully good enough :-)
$ret->{'patch'} = delete $ret->{$tag};
}
print STDERR "Warning: spec file parser: $tag already exists\n" if exists($ret->{$tag}) && $config->{'warnings'};
$autonum{$1} = $num + 1 if $num >= $autonum{$1};
$macros{uc($1) . "URL$num"} = $val;
}
$ret->{$tag} = $val;
}
if ($remoteasset && $tag =~ /^(?:source|patch)/) {
$remoteasset->{'url'} = $val;
push @{$ret->{'remoteassets'}}, $remoteasset;
}
$remoteasset = undef;
} elsif (!$preamble && ($line =~ /^(Source\d*|Patch\d*|Url|Icon|BuildRequires|BuildPrereq|BuildConflicts|\#\!BuildIgnore|\#\!BuildConflicts|\#\!BuildRequires)\s*:\s*(\S.*)$/i)) {
print STDERR "Warning: spec file parser ".($lineno ? " line $lineno" : '').": Ignoring $1 used beyond the preamble.\n" if $config->{'warnings'};
}
if ($line =~ /^\s*%package\s+(-n\s+)?(\S+)/) {
if ($1) {
push @subpacks, $2;
} else {
push @subpacks, $ret->{'name'}.'-'.$2 if defined $ret->{'name'};
}
$preamble = 1;
$main_preamble = 0;
}
if ($line =~ /^\s*%(prep|build|install|check|clean|preun|postun|pretrans|posttrans|pre|post|files|changelog|description|triggerpostun|triggerun|triggerin|trigger|verifyscript)/) {
$main_preamble = 0;
$preamble = 0;
}
# do this always?
if ($doxspec && $config->{'save_expanded'}) {
$xspec->[-1] = [ $xspec->[-1], $line ];
}
}
close SPEC unless ref $specfile;
if (defined($hasnfb)) {
if (!@packdeps) {
@packdeps = split(' ', $hasnfb);
} elsif ($nfbline) {
$$nfbline = [$$nfbline, undef ];
}
}
unshift @subpacks, $ret->{'name'} if defined $ret->{'name'};
$ret->{'subpacks'} = \@subpacks;
$ret->{'exclarch'} = $exclarch if defined $exclarch;
$ret->{'badarch'} = $badarch if defined $badarch;
$ret->{'deps'} = \@packdeps;
$ret->{'prereqs'} = \@prereqs if @prereqs;
$ret->{'onlynative'} = \@onlynative if @onlynative;
$ret->{'alsonative'} = \@alsonative if @alsonative;
$ret->{'configdependent'} = 1 if $ifdeps;
return $ret;
}
###########################################################################
my %rpmstag = (
"SIGMD5" => 261,
"SIGTAG_SIZE" => 1000, # Header+Payload size in bytes. */
"SIGTAG_PGP" => 1002, # RSA signature over Header+Payload
"SIGTAG_MD5" => 1004, # MD5 hash over Header+Payload
"SIGTAG_GPG" => 1005, # DSA signature over Header+Payload
"NAME" => 1000,
"VERSION" => 1001,
"RELEASE" => 1002,
"EPOCH" => 1003,
"SUMMARY" => 1004,
"DESCRIPTION" => 1005,
"BUILDTIME" => 1006,
"VENDOR" => 1011,
"LICENSE" => 1014,
"ARCH" => 1022,
"OLDFILENAMES" => 1027,
"FILEMODES" => 1030,
"FILEDIGESTS" => 1035,
"SOURCERPM" => 1044,
"PROVIDENAME" => 1047,
"REQUIREFLAGS" => 1048,
"REQUIRENAME" => 1049,
"REQUIREVERSION" => 1050,
"NOSOURCE" => 1051,
"NOPATCH" => 1052,
"EXCLUDEARCH" => 1059,
"EXCLUDEOS" => 1060,
"EXCLUSIVEARCH" => 1061,
"EXCLUSIVEOS" => 1062,
"SOURCEPACKAGE" => 1106,
"PROVIDEFLAGS" => 1112,
"PROVIDEVERSION" => 1113,
"DIRINDEXES" => 1116,
"BASENAMES" => 1117,
"DIRNAMES" => 1118,
"DISTURL" => 1123,
"CONFLICTFLAGS" => 1053,
"CONFLICTNAME" => 1054,
"CONFLICTVERSION" => 1055,
"OBSOLETENAME" => 1090,
"OBSOLETEFLAGS" => 1114,
"OBSOLETEVERSION" => 1115,
"OLDSUGGESTSNAME" => 1156,
"OLDSUGGESTSVERSION" => 1157,
"OLDSUGGESTSFLAGS" => 1158,
"OLDENHANCESNAME" => 1159,
"OLDENHANCESVERSION" => 1160,
"OLDENHANCESFLAGS" => 1161,
"FILEDIGESTALGO" => 5011,
"RECOMMENDNAME" => 5046,
"RECOMMENDVERSION" => 5047,
"RECOMMENDFLAGS" => 5048,
"SUGGESTNAME" => 5049,
"SUGGESTVERSION" => 5050,
"SUGGESTFLAGS" => 5051,
"SUPPLEMENTNAME" => 5052,
"SUPPLEMENTVERSION" => 5053,
"SUPPLEMENTFLAGS" => 5054,
"ENHANCENAME" => 5055,
"ENHANCEVERSION" => 5056,
"ENHANCEFLAGS" => 5057,
"MODULARITYLABEL" => 5096,
);
sub rpmq {
my ($rpm, @stags) = @_;
my @sigtags = grep {/^SIGTAG_/} @stags;
@stags = grep {!/^SIGTAG_/} @stags;
my $dosigs = @sigtags && !@stags;
@stags = @sigtags if $dosigs;
my $need_filenames = grep { $_ eq 'FILENAMES' } @stags;
push @stags, 'BASENAMES', 'DIRNAMES', 'DIRINDEXES', 'OLDFILENAMES' if $need_filenames;
@stags = grep { $_ ne 'FILENAMES' } @stags if $need_filenames;
my %stags = map {0 + ($rpmstag{$_} || $_) => $_} @stags;
my ($magic, $sigtype, $headmagic, $cnt, $cntdata, $lead, $head, $index, $data, $tag, $type, $offset, $count);
local *RPM;
my $forcebinary;
if (ref($rpm) eq 'ARRAY') {
($headmagic, $cnt, $cntdata) = unpack('N@8NN', $rpm->[0]);
if ($headmagic != 0x8eade801) {
warn("Bad rpm\n");
return ();
}
if (length($rpm->[0]) < 16 + $cnt * 16 + $cntdata) {
warn("Bad rpm\n");
return ();
}
$index = substr($rpm->[0], 16, $cnt * 16);
$data = substr($rpm->[0], 16 + $cnt * 16, $cntdata);
} else {
if (ref($rpm) eq 'GLOB') {
*RPM = *$rpm;
} elsif (!open(RPM, '<', $rpm)) {
warn("$rpm: $!\n");
return ();
}
if (read(RPM, $lead, 96) != 96) {
warn("Bad rpm $rpm\n");
close RPM unless ref($rpm);
return ();
}
($magic, $sigtype) = unpack('N@78n', $lead);
if ($magic != 0xedabeedb || $sigtype != 5) {
warn("Bad rpm $rpm\n");
close RPM unless ref($rpm);
return ();
}
$forcebinary = 1 if unpack('@6n', $lead) != 1;
if (read(RPM, $head, 16) != 16) {
warn("Bad rpm $rpm\n");
close RPM unless ref($rpm);
return ();
}
($headmagic, $cnt, $cntdata) = unpack('N@8NN', $head);
if ($headmagic != 0x8eade801) {
warn("Bad rpm $rpm\n");
close RPM unless ref($rpm);
return ();
}
if (read(RPM, $index, $cnt * 16) != $cnt * 16) {
warn("Bad rpm $rpm\n");
close RPM unless ref($rpm);
return ();
}
$cntdata = ($cntdata + 7) & ~7;
if (read(RPM, $data, $cntdata) != $cntdata) {
warn("Bad rpm $rpm\n");
close RPM unless ref($rpm);
return ();
}
}
my %res = ();
if (@sigtags && !$dosigs) {
%res = &rpmq(["$head$index$data"], @sigtags);
}
if (ref($rpm) eq 'ARRAY' && !$dosigs && @$rpm > 1) {
my %res2 = &rpmq([ $rpm->[1] ], @stags);
%res = (%res, %res2);
return %res;
}
if (ref($rpm) ne 'ARRAY' && !$dosigs) {
if (read(RPM, $head, 16) != 16) {
warn("Bad rpm $rpm\n");
close RPM unless ref($rpm);
return ();
}
($headmagic, $cnt, $cntdata) = unpack('N@8NN', $head);
if ($headmagic != 0x8eade801) {
warn("Bad rpm $rpm\n");
close RPM unless ref($rpm);
return ();
}
if (read(RPM, $index, $cnt * 16) != $cnt * 16) {
warn("Bad rpm $rpm\n");
close RPM unless ref($rpm);
return ();
}
if (read(RPM, $data, $cntdata) != $cntdata) {
warn("Bad rpm $rpm\n");
close RPM unless ref($rpm);
return ();
}
}
close RPM unless ref($rpm);
# return %res unless @stags;
while($cnt-- > 0) {
($tag, $type, $offset, $count, $index) = unpack('N4a*', $index);
$tag = 0+$tag;
if ($stags{$tag} || !@stags) {
eval {
my $otag = $stags{$tag} || $tag;
if ($type == 0) {
$res{$otag} = [ '' ];
} elsif ($type == 1) {
$res{$otag} = [ unpack("\@${offset}c$count", $data) ];
} elsif ($type == 2) {
$res{$otag} = [ unpack("\@${offset}c$count", $data) ];
} elsif ($type == 3) {
$res{$otag} = [ unpack("\@${offset}n$count", $data) ];
} elsif ($type == 4) {
$res{$otag} = [ unpack("\@${offset}N$count", $data) ];
} elsif ($type == 5) {
$res{$otag} = [ undef ];
} elsif ($type == 6) {
$res{$otag} = [ unpack("\@${offset}Z*", $data) ];
} elsif ($type == 7) {
$res{$otag} = [ unpack("\@${offset}a$count", $data) ];
} elsif ($type == 8 || $type == 9) {
my $d = unpack("\@${offset}a*", $data);
my @res = split("\0", $d, $count + 1);
$res{$otag} = [ splice @res, 0, $count ];
} else {
$res{$otag} = [ undef ];
}
};
if ($@) {
warn("Bad rpm $rpm: $@\n");
return ();
}
}
}
if ($forcebinary && $stags{1044} && !$res{$stags{1044}} && !($stags{1106} && $res{$stags{1106}})) {
$res{$stags{1044}} = [ '(none)' ]; # like rpm does...
}
if ($need_filenames) {
if ($res{'OLDFILENAMES'}) {
$res{'FILENAMES'} = [ @{$res{'OLDFILENAMES'}} ];
} else {
my $i = 0;
$res{'FILENAMES'} = [ map {"$res{'DIRNAMES'}->[$res{'DIRINDEXES'}->[$i++]]$_"} @{$res{'BASENAMES'}} ];
}
}
return %res;
}
sub add_flagsvers {
my ($res, $name, $flags, $vers) = @_;
return unless $res && $res->{$name};
my @flags = @{$res->{$flags} || []};
my @vers = @{$res->{$vers} || []};
for (@{$res->{$name}}) {
if (@flags && ($flags[0] & 0xe) && @vers) {
$_ .= ' ';
$_ .= '<' if $flags[0] & 2;
$_ .= '>' if $flags[0] & 4;
$_ .= '=' if $flags[0] & 8;
$_ .= " $vers[0]";
}
shift @flags;
shift @vers;
}
}
sub filteroldweak {
my ($res, $name, $flags, $data, $strong, $weak) = @_;
return unless $res && $res->{$name};
my @flags = @{$res->{$flags} || []};
my @strong;
my @weak;
for (@{$res->{$name}}) {
if (@flags && ($flags[0] & 0x8000000)) {
push @strong, $_;
} else {
push @weak, $_;
}
shift @flags;
}
$data->{$strong} = \@strong if @strong;
$data->{$weak} = \@weak if @weak;
}
sub verscmp_part {
my ($s1, $s2) = @_;
if (!defined($s1)) {
return defined($s2) ? -1 : 0;
}
return 1 if !defined $s2;
return 0 if $s1 eq $s2;
while (1) {
$s1 =~ s/^[^a-zA-Z0-9~\^]+//;
$s2 =~ s/^[^a-zA-Z0-9~\^]+//;
if ($s1 =~ s/^~//) {
next if $s2 =~ s/^~//;
return -1;
}
return 1 if $s2 =~ /^~/;
if ($s1 =~ s/^\^//) {
next if $s2 =~ s/^\^//;
return $s2 eq '' ? 1 : -1;
}
return $s1 eq '' ? -1 : 1 if $s2 =~ /^\^/;
if ($s1 eq '') {
return $s2 eq '' ? 0 : -1;
}
return 1 if $s2 eq '';
my ($x1, $x2, $r);
if ($s1 =~ /^([0-9]+)(.*?)$/) {
$x1 = $1;
$s1 = $2;
$s2 =~ /^([0-9]*)(.*?)$/;
$x2 = $1;
$s2 = $2;
return 1 if $x2 eq '';
$x1 =~ s/^0+//;
$x2 =~ s/^0+//;
$r = length($x1) - length($x2) || $x1 cmp $x2;
} elsif ($s1 ne '' && $s2 ne '') {
$s1 =~ /^([a-zA-Z]*)(.*?)$/;
$x1 = $1;
$s1 = $2;
$s2 =~ /^([a-zA-Z]*)(.*?)$/;
$x2 = $1;
$s2 = $2;
return -1 if $x1 eq '' || $x2 eq '';
$r = $x1 cmp $x2;
}
return $r > 0 ? 1 : -1 if $r;
}
}
sub verscmp {
my ($s1, $s2, $dtest) = @_;
return 0 if $s1 eq $s2;
my ($e1, $v1, $r1) = $s1 =~ /^(?:(\d+):)?(.*?)(?:-([^-]*))?$/s;
$e1 = 0 unless defined $e1;
my ($e2, $v2, $r2) = $s2 =~ /^(?:(\d+):)?(.*?)(?:-([^-]*))?$/s;
$e2 = 0 unless defined $e2;
if ($e1 ne $e2) {
my $r = verscmp_part($e1, $e2);
return $r if $r;
}
return 0 if $dtest && ($v1 eq '' || $v2 eq '');
if ($v1 ne $v2) {
my $r = verscmp_part($v1, $v2);
return $r if $r;
}
$r1 = '' unless defined $r1;
$r2 = '' unless defined $r2;
return 0 if $dtest && ($r1 eq '' || $r2 eq '');
if ($r1 ne $r2) {
return verscmp_part($r1, $r2);
}
return 0;
}
sub query {
my ($handle, %opts) = @_;
my @tags = qw{NAME SOURCERPM NOSOURCE NOPATCH SIGTAG_MD5 PROVIDENAME PROVIDEFLAGS PROVIDEVERSION REQUIRENAME REQUIREFLAGS REQUIREVERSION SOURCEPACKAGE};
push @tags, qw{EPOCH VERSION RELEASE ARCH};
push @tags, qw{FILENAMES} if $opts{'filelist'};
push @tags, qw{SUMMARY DESCRIPTION} if $opts{'description'};
push @tags, qw{DISTURL} if $opts{'disturl'};
push @tags, qw{BUILDTIME} if $opts{'buildtime'};
push @tags, qw{LICENSE} if $opts{'license'};
push @tags, qw{CONFLICTNAME CONFLICTVERSION CONFLICTFLAGS OBSOLETENAME OBSOLETEVERSION OBSOLETEFLAGS} if $opts{'conflicts'};
push @tags, qw{RECOMMENDNAME RECOMMENDVERSION RECOMMENDFLAGS SUGGESTNAME SUGGESTVERSION SUGGESTFLAGS SUPPLEMENTNAME SUPPLEMENTVERSION SUPPLEMENTFLAGS ENHANCENAME ENHANCEVERSION ENHANCEFLAGS OLDSUGGESTSNAME OLDSUGGESTSVERSION OLDSUGGESTSFLAGS OLDENHANCESNAME OLDENHANCESVERSION OLDENHANCESFLAGS} if $opts{'weakdeps'};
push @tags, qw{MODULARITYLABEL} if $opts{'modularitylabel'};
push @tags, qw{EXCLUDEARCH EXCLUDEOS EXCLUSIVEARCH EXCLUSIVEOS} if $opts{'excludearch'};
my %res = rpmq($handle, @tags);
return undef unless %res;
my $src = $res{'SOURCERPM'}->[0];
$res{'sourcerpm'} = $src if $src;
$src = '' unless defined $src;
$src =~ s/-[^-]*-[^-]*\.[^\.]*\.rpm//;
add_flagsvers(\%res, 'PROVIDENAME', 'PROVIDEFLAGS', 'PROVIDEVERSION');
add_flagsvers(\%res, 'REQUIRENAME', 'REQUIREFLAGS', 'REQUIREVERSION');
my $data = {
name => $res{'NAME'}->[0],
hdrmd5 => unpack('H32', $res{'SIGTAG_MD5'}->[0]),
};
if ($opts{'alldeps'}) {
$data->{'provides'} = [ @{$res{'PROVIDENAME'} || []} ];
$data->{'requires'} = [ @{$res{'REQUIRENAME'} || []} ];
} elsif ($opts{'filedeps'}) {
$data->{'provides'} = [ grep {!/^rpmlib\(/} @{$res{'PROVIDENAME'} || []} ];
$data->{'requires'} = [ grep {!/^rpmlib\(/} @{$res{'REQUIRENAME'} || []} ];
} else {
$data->{'provides'} = [ grep {!/^rpmlib\(/ && !/^\//} @{$res{'PROVIDENAME'} || []} ];
$data->{'requires'} = [ grep {!/^rpmlib\(/ && !/^\//} @{$res{'REQUIRENAME'} || []} ];
}
if ($opts{'conflicts'}) {
add_flagsvers(\%res, 'CONFLICTNAME', 'CONFLICTFLAGS', 'CONFLICTVERSION');
add_flagsvers(\%res, 'OBSOLETENAME', 'OBSOLETEFLAGS', 'OBSOLETEVERSION');
$data->{'conflicts'} = [ @{$res{'CONFLICTNAME'}} ] if $res{'CONFLICTNAME'};
$data->{'obsoletes'} = [ @{$res{'OBSOLETENAME'}} ] if $res{'OBSOLETENAME'};
}
if ($opts{'weakdeps'}) {
for (qw{RECOMMEND SUGGEST SUPPLEMENT ENHANCE}) {
next unless $res{"${_}NAME"};
add_flagsvers(\%res, "${_}NAME", "${_}FLAGS", "${_}VERSION");
$data->{lc($_)."s"} = [ @{$res{"${_}NAME"}} ];
}
if ($res{'OLDSUGGESTSNAME'}) {
add_flagsvers(\%res, 'OLDSUGGESTSNAME', 'OLDSUGGESTSFLAGS', 'OLDSUGGESTSVERSION');
filteroldweak(\%res, 'OLDSUGGESTSNAME', 'OLDSUGGESTSFLAGS', $data, 'recommends', 'suggests');
}
if ($res{'OLDENHANCESNAME'}) {
add_flagsvers(\%res, 'OLDENHANCESNAME', 'OLDENHANCESFLAGS', 'OLDENHANCESVERSION');
filteroldweak(\%res, 'OLDENHANCESNAME', 'OLDENHANCESFLAGS', $data, 'supplements', 'enhances');
}
}
# rpm3 compatibility: retrofit missing self provides
if ($src ne '') {
my $haveselfprovides;
if (@{$data->{'provides'}}) {
if ($data->{'provides'}->[-1] =~ /^\Q$res{'NAME'}->[0]\E =/) {
$haveselfprovides = 1;
} elsif (@{$data->{'provides'}} > 1 && $data->{'provides'}->[-2] =~ /^\Q$res{'NAME'}->[0]\E =/) {
$haveselfprovides = 1;
}
}
if (!$haveselfprovides) {
my $evr = "$res{'VERSION'}->[0]-$res{'RELEASE'}->[0]";
$evr = "$res{'EPOCH'}->[0]:$evr" if $res{'EPOCH'} && $res{'EPOCH'}->[0];
push @{$data->{'provides'}}, "$res{'NAME'}->[0] = $evr";
}
}
$data->{'source'} = $src eq '(none)' ? $data->{'name'} : $src if $src ne '';
if ($opts{'evra'}) {
my $arch = $res{'ARCH'}->[0];
$arch = $res{'NOSOURCE'} || $res{'NOPATCH'} ? 'nosrc' : 'src' unless $src ne '';
$data->{'version'} = $res{'VERSION'}->[0];
$data->{'release'} = $res{'RELEASE'}->[0];
$data->{'arch'} = $arch;
$data->{'epoch'} = $res{'EPOCH'}->[0] if exists $res{'EPOCH'};
}
if ($opts{'filelist'}) {
$data->{'filelist'} = $res{'FILENAMES'};
}
if ($opts{'description'}) {
$data->{'summary'} = $res{'SUMMARY'}->[0];
$data->{'description'} = $res{'DESCRIPTION'}->[0];
}
$data->{'buildtime'} = $res{'BUILDTIME'}->[0] if $opts{'buildtime'};
$data->{'disturl'} = $res{'DISTURL'}->[0] if $opts{'disturl'} && $res{'DISTURL'};
$data->{'license'} = $res{'LICENSE'}->[0] if $opts{'license'} && $res{'LICENSE'};
$data->{'modularitylabel'} = $res{'MODULARITYLABEL'}->[0] if $opts{'modularitylabel'} && $res{'MODULARITYLABEL'};
if ($opts{'excludearch'}) {
for (qw{EXCLUDEARCH EXCLUDEOS EXCLUSIVEARCH EXCLUSIVEOS}) {
$data->{lc($_)} = $res{$_} if @{$res{$_} || []};
}
}
return $data;
}
sub queryhdrmd5 {
my ($bin, $leadsigp) = @_;
local *F;
open(F, '<', $bin) || die("$bin: $!\n");
my $buf = '';
my $l;
while (length($buf) < 96 + 16) {
$l = sysread(F, $buf, 4096, length($buf));
if (!$l) {
warn("$bin: read error\n");
close(F);
return undef;
}
}
my ($magic, $sigtype) = unpack('N@78n', $buf);
if ($magic != 0xedabeedb || $sigtype != 5) {
warn("$bin: not a rpm (bad magic of header type)\n");
close(F);
return undef;
}
my ($headmagic, $cnt, $cntdata) = unpack('@96N@104NN', $buf);
if ($headmagic != 0x8eade801) {
warn("$bin: not a rpm (bad sig header magic)\n");
close(F);
return undef;
}
my $hlen = 96 + 16 + $cnt * 16 + $cntdata;
$hlen = ($hlen + 7) & ~7;
while (length($buf) < $hlen) {
$l = sysread(F, $buf, 4096, length($buf));
if (!$l) {
warn("$bin: read error\n");
close(F);
return undef;
}
}
close F;
$$leadsigp = Digest::MD5::md5_hex(substr($buf, 0, $hlen)) if $leadsigp;
my $idxarea = substr($buf, 96 + 16, $cnt * 16);
if ($idxarea !~ /\A(?:.{16})*\000\000\003\354\000\000\000\007(....)\000\000\000\020/s) {
warn("$bin: no md5 signature header\n");
return undef;
}
my $md5off = unpack('N', $1);
if ($md5off >= $cntdata) {
warn("$bin: bad md5 offset\n");
return undef;
}
$md5off += 96 + 16 + $cnt * 16;
return unpack("\@${md5off}H32", $buf);
}
sub queryinstalled {
my ($root, %opts) = @_;
$root = '' if !defined($root) || $root eq '/';
local *F;
my $dochroot = $root ne '' && !$opts{'nochroot'} && !$< && (-x "$root/usr/bin/rpm" || -x "$root/bin/rpm") ? 1 : 0;
my $pid = open(F, '-|');
die("fork: $!\n") unless defined $pid;
if (!$pid) {
if ($dochroot && chroot($root)) {
chdir('/') || die("chdir: $!\n");
$root = '';
}
my @args;
unshift @args, '--nodigest', '--nosignature' if -e "$root/usr/bin/rpmquery ";
unshift @args, '--dbpath', "$root/var/lib/rpm" if $root ne '';
push @args, '--qf', '%{NAME}/%{ARCH}/%|EPOCH?{%{EPOCH}}:{0}|/%{VERSION}/%{RELEASE}/%{BUILDTIME}\n';
if (-x "$root/usr/bin/rpm") {
exec("$root/usr/bin/rpm", '-qa', @args);
die("$root/usr/bin/rpm: $!\n");
}
if (-x "$root/bin/rpm") {
exec("$root/bin/rpm", '-qa', @args);
die("$root/bin/rpm: $!\n");
}
die("rpm: command not found\n");
}
my @pkgs;
while (<F>) {
chomp;
my @s = split('/', $_);
next unless @s >= 5;
my $q = {'name' => $s[0], 'arch' => $s[1], 'version' => $s[3], 'release' => $s[4]};
$q->{'epoch'} = $s[2] if $s[2];
$q->{'buildtime'} = $s[5] if $s[5];
push @pkgs, $q;
}
if (!close(F)) {
return queryinstalled($root, %opts, 'nochroot' => 1) if !@pkgs && $dochroot;
die("rpm: exit status $?\n");
}
return \@pkgs;
}
# return (lead, sighdr, hdr [, hdrmd5]) of a rpm
sub getrpmheaders {
my ($path, $withhdrmd5) = @_;
my $hdrmd5;
local *F;
open(F, '<', $path) || die("$path: $!\n");
my $buf = '';
my $l;
while (length($buf) < 96 + 16) {
$l = sysread(F, $buf, 4096, length($buf));
die("$path: read error\n") unless $l;
}
die("$path: not a rpm\n") unless unpack('N', $buf) == 0xedabeedb && unpack('@78n', $buf) == 5;
my ($headmagic, $cnt, $cntdata) = unpack('@96N@104NN', $buf);
die("$path: not a rpm (bad sig header)\n") unless $headmagic == 0x8eade801 && $cnt < 16384 && $cntdata < 1048576;
my $hlen = 96 + 16 + $cnt * 16 + $cntdata;
$hlen = ($hlen + 7) & ~7;
while (length($buf) < $hlen + 16) {
$l = sysread(F, $buf, 4096, length($buf));
die("$path: read error\n") unless $l;
}
if ($withhdrmd5) {
my $idxarea = substr($buf, 96 + 16, $cnt * 16);
die("$path: no md5 signature header\n") unless $idxarea =~ /\A(?:.{16})*\000\000\003\354\000\000\000\007(....)\000\000\000\020/s;
my $md5off = unpack('N', $1);
die("$path: bad md5 offset\n") unless $md5off;
$md5off += 96 + 16 + $cnt * 16;
$hdrmd5 = unpack("\@${md5off}H32", $buf);
}
($headmagic, $cnt, $cntdata) = unpack('N@8NN', substr($buf, $hlen));
die("$path: not a rpm (bad header)\n") unless $headmagic == 0x8eade801 && $cnt < 1048576 && $cntdata < 33554432;
my $hlen2 = $hlen + 16 + $cnt * 16 + $cntdata;
while (length($buf) < $hlen2) {
$l = sysread(F, $buf, 4096, length($buf));
die("$path: read error\n") unless $l;
}
close F;
return (substr($buf, 0, 96), substr($buf, 96, $hlen - 96), substr($buf, $hlen, $hlen2 - $hlen), $hdrmd5);
}
sub getnevr_rich {
my ($d) = @_;
my $n = '';
my $bl = 0;
while ($d =~ /^([^ ,\(\)]*)/) {
$n .= $1;
$d = substr($d, length($1));
last unless $d =~ /^([\(\)])/;
$bl += $1 eq '(' ? 1 : -1;
last if $bl < 0;
$n .= $1;
$d = substr($d, 1);
}
return $n;
}
my %richops = (
'and' => 1,
'or' => 2,
'if' => 3,
'unless' => 4,
'else' => 5,
'with' => 6,
'without' => 7,
);
sub parse_rich_rec {
my ($dep, $chainop) = @_;
my $d = $dep;
$chainop ||= 0;
return ($d, undef) unless $d =~ s/^\(\s*//;
my ($r, $r2);
if ($d =~ /^\(/) {
($d, $r) = parse_rich_rec($d);
return ($d, undef) unless $r;
} else {
return ($d, undef) if $d =~ /^\)/;
my $n = getnevr_rich($d);
$d = substr($d, length($n));
$d =~ s/^ +//;
if ($d =~ /^([<=>]+)/) {
$n .= " $1 ";
$d =~ s/^[<=>]+ +//;
my $evr = getnevr_rich($d);
$d = substr($d, length($evr));
$n .= $evr;
}
$r = [0, $n];
}
$d =~ s/^\s+//;
return ($d, undef) unless $d ne '';
return ($d, $r) if $d =~ s/^\)//;
return ($d, undef) unless $d =~ s/([a-z]+)\s+//;
my $op = $richops {$1};
return ($d, undef) unless $op;
return ($d, undef) if $op == 5 && $chainop != 3 && $chainop != 4;
$chainop = 0 if $op == 5;
return ($d, undef) if $chainop && (($chainop != 1 && $chainop != 2 && $chainop != 6) || $op != $chainop);
($d, $r2) = parse_rich_rec("($d", $op);
return ($d, undef) unless $r2;
if (($op == 3 || $op == 4) && $r2->[0] == 5) {
$r = [$op, $r, $r2->[1], $r2->[2]];
} else {
$r = [$op, $r, $r2];
}
return ($d, $r);
}
sub parse_rich_dep {
my ($dep) = @_;
my ($d, $r) = parse_rich_rec($dep);
return undef if !$r || $d ne '';
return $r;
}
my @testcaseops = ('', '&', '|', '<IF>', '<UNLESS>', '<ELSE>', '+', '-');
sub testcaseformat_rec {
my ($r, $addparens) = @_;
my $op = $r->[0];
return $r->[1] unless $op;
my $top = $testcaseops[$op];
my $r1 = testcaseformat_rec($r->[1], 1);
if (($op == 3 || $op == 4) && @$r == 4) {
$r1 = "$r1 $top " . testcaseformat_rec($r->[2], 1);
$top = '<ELSE>';
}
my $addparens2 = 1;
$addparens2 = 0 if $r->[2]->[0] == $op && ($op == 1 || $op == 2 || $op == 6);
my $r2 = testcaseformat_rec($r->[-1], $addparens2);
return $addparens ? "($r1 $top $r2)" : "$r1 $top $r2";
}
sub testcaseformat {
my ($dep) = @_;
my $r = parse_rich_dep($dep);
return $dep unless $r;
return testcaseformat_rec($r);
}
sub shiftrich {
my ($s) = @_;
# FIXME: do this right!
my $dep = shift @$s;
while (@$s && ($dep =~ y/\(/\(/) > ($dep =~ y/\)/\)/)) {
$dep .= ' ' . shift(@$s);
}
return $dep;
}
1;
07070100000016000081a400000000000000000000000163e504b900001ec8000000000000000000000000000000000000000f00000000Build/Rpmmd.pm################################################################
#
# Copyright (c) 1995-2014 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
#
################################################################
package Build::Rpmmd;
use strict;
use Build::Rpm;
use XML::Parser;
sub generic_parse {
my ($how, $in, $res, %options) = @_;
$res ||= [];
my @cursor = ([undef, $how, undef, $res, undef, \%options]);
my $p = new XML::Parser(Handlers => {
Start => sub {
my ($p, $el) = @_;
my $h = $cursor[-1]->[1];
return unless exists $h->{$el};
$h = $h->{$el};
push @cursor, [$el, $h];
$cursor[-1]->[2] = '' if $h->{'_text'};
$h->{'_start'}->($h, \@cursor, @_) if exists $h->{'_start'};
},
End => sub {
my ($p, $el) = @_;
if ($cursor[-1]->[0] eq $el) {
my $h = $cursor[-1]->[1];
$h->{'_end'}->($h, \@cursor, @_) if exists $h->{'_end'};
pop @cursor;
}
},
Char => sub {
my ($p, $text) = @_;
$cursor[-1]->[2] .= $text if defined $cursor[-1]->[2];
},
ExternEnt => sub { undef },
}, ErrorContext => 2);
if (ref($in)) {
$p->parse($in);
} else {
$p->parsefile($in);
}
return $res;
}
sub generic_store_text {
my ($h, $c, $p, $el) = @_;
my $data = $c->[0]->[4];
$data->{$h->{'_tag'}} = $c->[-1]->[2] if defined $c->[-1]->[2];
}
sub generic_store_attr {
my ($h, $c, $p, $el, %attr) = @_;
my $data = $c->[0]->[4];
$data->{$h->{'_tag'}} = $attr{$h->{'_attr'}} if defined $attr{$h->{'_attr'}};
}
sub generic_new_data {
my ($h, $c, $p, $el, %attr) = @_;
$c->[0]->[4] = {};
generic_store_attr(@_) if $h->{'_attr'};
}
sub generic_add_result {
my ($h, $c, $p, $el) = @_;
my $data = $c->[0]->[4];
return unless $data;
my $res = $c->[0]->[3];
if (ref($res) eq 'CODE') {
$res->($data);
} else {
push @$res, $data;
}
undef $c->[0]->[4];
}
my $repomdparser = {
repomd => {
data => {
_start => \&generic_new_data,
_attr => 'type',
_tag => 'type',
_end => \&generic_add_result,
location => { _start => \&generic_store_attr, _attr => 'href', _tag => 'location'},
checksum => { _start => \&generic_store_attr, _attr => 'type', _tag => 'checksum', _text => 1, _end => \&primary_handle_checksum },
size => { _text => 1, _end => \&generic_store_text, _tag => 'size'},
},
},
};
my $primaryparser = {
metadata => {
'package' => {
_start => \&generic_new_data,
_attr => 'type',
_tag => 'type',
_end => \&primary_add_result,
name => { _text => 1, _end => \&generic_store_text, _tag => 'name' },
arch => { _text => 1, _end => \&generic_store_text, _tag => 'arch' },
version => { _start => \&primary_handle_version },
checksum => { _start => \&generic_store_attr, _attr => 'type', _tag => 'checksum', _text => 1, _end => \&primary_handle_checksum },
'time' => { _start => \&primary_handle_time },
format => {
'rpm:provides' => { 'rpm:entry' => { _start => \&primary_handle_dep , _tag => 'provides' }, },
'rpm:requires' => { 'rpm:entry' => { _start => \&primary_handle_dep , _tag => 'requires' }, },
'rpm:conflicts' => { 'rpm:entry' => { _start => \&primary_handle_dep , _tag => 'conflicts' }, },
'rpm:recommends' => { 'rpm:entry' => { _start => \&primary_handle_dep , _tag => 'recommends' }, },
'rpm:suggests' => { 'rpm:entry' => { _start => \&primary_handle_dep , _tag => 'suggests' }, },
'rpm:supplements' => { 'rpm:entry' => { _start => \&primary_handle_dep , _tag => 'supplements' }, },
'rpm:enhances' => { 'rpm:entry' => { _start => \&primary_handle_dep , _tag => 'enhances' }, },
'rpm:obsoletes' => { 'rpm:entry' => { _start => \&primary_handle_dep , _tag => 'obsoletes' }, },
'rpm:buildhost' => { _text => 1, _end => \&generic_store_text, _tag => 'buildhost' },
'rpm:vendor' => { _text => 1, _end => \&generic_store_text, _tag => 'vendor' },
'rpm:license' => { _text => 1, _end => \&generic_store_text, _tag => 'license' },
'rpm:sourcerpm' => { _text => 1, _end => \&primary_handle_sourcerpm , _tag => 'source' },
### currently commented out, as we ignore file provides in expanddeps
# file => { _text => 1, _end => \&primary_handle_file_end, _tag => 'provides' },
},
location => { _start => \&generic_store_attr, _attr => 'href', _tag => 'location'},
},
},
};
sub primary_handle_sourcerpm {
my ($h, $c, $p, $el, %attr) = @_;
my $data = $c->[0]->[4];
return unless defined $c->[-1]->[2];
$data->{'sourcerpm'} = $data->{'source'} = $c->[-1]->[2];
$data->{'source'} =~ s/-[^-]*-[^-]*\.[^\.]*\.rpm$//;
}
sub primary_handle_version {
my ($h, $c, $p, $el, %attr) = @_;
my $data = $c->[0]->[4];
$data->{'epoch'} = $attr{'epoch'} if $attr{'epoch'};
$data->{'version'} = $attr{'ver'};
$data->{'release'} = $attr{'rel'};
}
sub primary_handle_time {
my ($h, $c, $p, $el, %attr) = @_;
my $data = $c->[0]->[4];
$data->{'filetime'} = $attr{'file'} if $attr{'file'};
$data->{'buildtime'} = $attr{'build'} if $attr{'build'};
}
sub primary_handle_checksum {
my ($h, $c, $p, $el) = @_;
my $data = $c->[0]->[4];
my $type = lc(delete($data->{$h->{'_tag'}}) || '');
$type = 'sha1' if $type eq 'sha';
if ($type eq 'md5' || $type eq 'sha1' || $type eq 'sha256' || $type eq 'sha512') {
$data->{$h->{'_tag'}} = "$type:$c->[-1]->[2]" if defined $c->[-1]->[2];
}
}
sub primary_handle_file_end {
my ($h, $c, $p, $el) = @_;
primary_handle_dep($h, $c, $p, $el, 'name', $c->[-1]->[2]);
}
my %flagmap = ( EQ => '=', LE => '<=', GE => '>=', GT => '>', LT => '<', NE => '!=' );
sub primary_handle_dep {
my ($h, $c, $p, $el, %attr) = @_;
my $dep = $attr{'name'};
return if $dep =~ /^rpmlib\(/;
if(exists $attr{'flags'}) {
my $evr = $attr{'ver'};
return unless defined($evr) && exists($flagmap{$attr{'flags'}});
$evr = "$attr{'epoch'}:$evr" if $attr{'epoch'};
$evr .= "-$attr{'rel'}" if defined $attr{'rel'};
$dep .= " $flagmap{$attr{'flags'}} $evr";
}
$dep = Build::Rpm::testcaseformat($dep) if ($dep =~ /^\(/) && ($c->[0]->[5] || {})->{'testcaseformat'};
my $data = $c->[0]->[4];
push @{$data->{$h->{'_tag'}}}, $dep;
}
sub primary_add_result {
my ($h, $c, $p, $el) = @_;
my $options = $c->[0]->[5] || {};
my $data = $c->[0]->[4];
if ($options->{'addselfprovides'} && defined($data->{'name'}) && defined($data->{'version'})) {
if (($data->{'arch'} || '') ne 'src' && ($data->{'arch'} || '') ne 'nosrc') {
my $evr = $data->{'version'};
$evr = "$data->{'epoch'}:$evr" if $data->{'epoch'};
$evr = "$evr-$data->{'release'}" if defined $data->{'release'};
my $s = "$data->{'name'} = $evr";
push @{$data->{'provides'}}, $s unless grep {$_ eq $s} @{$data->{'provides'} || []};
}
}
delete $data->{'checksum'} unless $options->{'withchecksum'};
delete $data->{'license'} unless $options->{'withlicense'};
delete $data->{'vendor'} unless $options->{'withvendor'};
return generic_add_result(@_);
}
sub parse_repomd {
return generic_parse($repomdparser, @_);
}
sub parse {
return generic_parse($primaryparser, @_);
}
1;
07070100000017000081a400000000000000000000000163e504b900000d2a000000000000000000000000000000000000001400000000Build/SimpleJSON.pm################################################################
#
# Copyright (c) 2018 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
#
################################################################
package Build::SimpleJSON;
use strict;
sub unparse_keys {
my ($d, $order, $keepspecial) = @_;
my @k = sort keys %$d;
if (!$keepspecial) {
@k = grep {$_ ne '_start' && $_ ne '_end' && $_ ne '_order' && $_ ne '_type'} @k;
$order = $d->{'_order'} if $d->{'_order'};
}
return @k unless $order;
my %k = map {$_ => 1} @k;
my @ko;
for (@$order) {
push @ko, $_ if delete $k{$_};
}
return (@ko, grep {$k{$_}} @k);
}
my %specialescapes = (
'"' => '\\"',
'\\' => '\\\\',
'/' => '\\/',
"\b" => '\\b',
"\f" => '\\f',
"\n" => '\\n',
"\r" => '\\r',
"\t" => '\\t',
);
sub unparse_string {
my ($d) = @_;
$d =~ s/([\"\\\000-\037])/$specialescapes{$1} || sprintf('\\u%04d', ord($1))/ge;
return "\"$d\"";
}
sub unparse_bool {
my ($d) = @_;
return $d ? 'true' : 'false';
}
sub unparse_number {
my ($d) = @_;
return sprintf("%.f", $d) if $d == int($d);
return sprintf("%g", $d);
}
sub unparse {
my ($d, %opts) = @_;
my $r = '';
my $template = delete $opts{'template'};
$opts{'_type'} ||= $template if $template && !ref($template);
undef $template unless ref($template) eq 'HASH';
if (ref($d) eq 'ARRAY') {
return '[]' unless @$d;
$opts{'template'} = $template if $template;
my $indent = $opts{'ugly'} ? '' : $opts{'indent'} || '';
my $nl = $opts{'ugly'} ? '' : "\n";
my $sp = $opts{'ugly'} ? '' : " ";
my $first = 0;
for my $dd (@$d) {
$r .= ",$nl" if $first++;
$r .= "$indent$sp$sp$sp".unparse($dd, %opts, 'indent' => " $indent");
}
return "\[$nl$r$nl$indent\]";
}
if (ref($d) eq 'HASH') {
my $keepspecial = $opts{'keepspecial'};
my @k = unparse_keys($d, $template ? $template->{'_order'} : undef, $keepspecial);
return '{}' unless @k;
my $indent = $opts{'ugly'} ? '' : $opts{'indent'} || '';
my $nl = $opts{'ugly'} ? '' : "\n";
my $sp = $opts{'ugly'} ? '' : " ";
my $first = 0;
for my $k (@k) {
$opts{'template'} = $template->{$k} || $template->{'*'} if $template;
$r .= ",$nl" if $first++;
my $dd = $d->{$k};
my $type = $keepspecial ? undef : $d->{'_type'};
$r .= "$indent$sp$sp$sp".unparse_string($k)."$sp:$sp".unparse($dd, %opts, 'indent' => " $indent", '_type' => ($type || {})->{$k});
}
return "\{$nl$r$nl$indent\}";
}
return 'null' unless defined $d;
my $type = $opts{'_type'} || '';
return unparse_bool($d) if $type eq 'bool';
return unparse_number($d) if $type eq 'number';
return unparse_string($d);
}
1;
07070100000018000081a400000000000000000000000163e504b9000013b6000000000000000000000000000000000000001300000000Build/SimpleXML.pm################################################################
#
# Copyright (c) 1995-2016 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
#
################################################################
package Build::SimpleXML;
use strict;
# very simple xml parser, just good enough to parse kiwi and _service files...
# can't use standard XML parsers, unfortunatelly, as the build script
# must not rely on external libraries
#
sub parse {
my ($xml, %opts) = @_;
my $record = $opts{'record'};
my $order = $opts{'order'};
my @nodestack;
my $node = {};
my $c = '';
my $xmllen = length($xml);
$xml =~ s/^\s*\<\?.*?\?\>//s;
while ($xml =~ /^(.*?)\</s) {
if ($1 ne '') {
$c .= $1;
$xml = substr($xml, length($1));
}
if (substr($xml, 0, 4) eq '<!--') {
die("bad xml, missing end of comment\n") unless $xml =~ s/.*?-->//s;
next;
}
my $elstart = length($xml);
die("bad xml\n") unless $xml =~ /(.*?\>)/s;
my $tag = $1;
$xml = substr($xml, length($tag));
my $mode = 0;
if ($tag =~ s/^\<\///s) {
chop $tag;
$mode = 1; # end
} elsif ($tag =~ s/\/\>$//s) {
$mode = 2; # start & end
$tag = substr($tag, 1);
} else {
$tag = substr($tag, 1);
chop $tag;
}
my @tag = split(/(=(?:\"[^\"]*\"|\'[^\']*\'|[^\"\s]*))?\s+/, "$tag ");
$tag = shift @tag;
shift @tag;
push @tag, undef if @tag & 1;
my %atts = @tag;
for (values %atts) {
next unless defined $_;
s/^=\"([^\"]*)\"$/=$1/s or s/^=\'([^\']*)\'$/=$1/s;
s/^=//s;
s/</</g;
s/>/>/g;
s/&/&/g;
s/'/\'/g;
s/"/\"/g;
}
if ($mode == 0 || $mode == 2) {
my $n = {};
if ($record) {
$n->{'_start'} = $xmllen - $elstart;
$n->{'_end'} = $xmllen - length($xml) if $mode == 2;
}
if ($order) {
push @{$node->{'_order'}}, $tag;
push @{$n->{'_order'}}, (splice(@tag, 0, 2))[0] while @tag;
}
push @{$node->{$tag}}, $n;
$n->{$_} = $atts{$_} for sort keys %atts;
if ($mode == 0) {
push @nodestack, [ $tag, $node, $c ];
$c = '';
$node = $n;
}
} else {
die("element '$tag' closes without open\n") unless @nodestack;
die("element '$tag' closes, but I expected '$nodestack[-1]->[0]'\n") unless $nodestack[-1]->[0] eq $tag;
if (!$opts{'notrim'}) {
$c =~ s/^\s*//s;
$c =~ s/\s*$//s;
$c = undef if $c eq '';
}
$node->{'_content'} = $c if defined $c;
$node->{'_end'} = $xmllen - length($xml) if $record;
$node = $nodestack[-1]->[1];
$c = $nodestack[-1]->[2];
pop @nodestack;
}
}
$c .= $xml;
if (!$opts{'notrim'}) {
$c =~ s/^\s*//s;
$c =~ s/\s*$//s;
$c = undef if $c eq '';
}
$node->{'_content'} = $c if defined $c;
return $node;
}
sub unparse_keys {
my ($d) = @_;
my @k = grep {$_ ne '_start' && $_ ne '_end' && $_ ne '_order' && $_ ne '_content'} sort keys %$d;
return @k unless $d->{'_order'};
my %k = map {$_ => 1} @k;
my @ko;
for (@{$d->{'_order'}}) {
push @ko, $_ if delete $k{$_};
}
return (@ko, grep {$k{$_}} @k);
}
sub unparse_escape {
my ($d) = @_;
$d =~ s/&/&/sg;
$d =~ s/</</sg;
$d =~ s/>/>/sg;
$d =~ s/"/"/sg;
return $d;
}
sub unparse {
my ($d, %opts) = @_;
my $r = '';
my $indent = $opts{'ugly'} ? '' : $opts{'indent'} || '';
my $nl = $opts{'ugly'} ? '' : "\n";
my @k = unparse_keys($d);
my @e = grep {ref($d->{$_}) ne ''} @k;
for my $e (@e) {
my $en = unparse_escape($e);
my $de = $d->{$e};
$de = [ $de ] unless ref($de) eq 'ARRAY';
for my $se (@$de) {
if (defined($se) && ref($se) eq '') {
$r .= "$indent<$en>".unparse_escape($se)."</$en>$nl";
next;
}
if (!$se || !%$se) {
$r .= "$indent<$en/>$nl";
next;
}
my @sk = unparse_keys($se);
my @sa = grep {ref($se->{$_}) eq ''} @sk;
my @se = grep {ref($se->{$_}) ne ''} @sk;
$r .= "$indent<$en";
for my $sa (@sa) {
$r .= " ".unparse_escape($sa);
$r .= '="'.unparse_escape($se->{$sa}).'"' if defined $se->{$sa};
}
$r .= ">";
$r .= unparse_escape($se->{'_content'}) if defined $se->{'_content'};
$r .= $nl . unparse($se, %opts, 'indent' => " $indent") . "$indent" if @se;
$r .= "</$en>$nl";
}
}
return $r;
}
1;
07070100000019000081a400000000000000000000000163e504b9000019c5000000000000000000000000000000000000001400000000Build/SimpleYAML.pm################################################################
#
# Copyright (c) 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
#
################################################################
package Build::SimpleYAML;
use strict;
use Scalar::Util;
sub unparse_keys {
my ($d, $order) = @_;
my @k = grep {$_ ne '_start' && $_ ne '_end' && $_ ne '_order' && $_ ne '_type'} sort keys %$d;
return @k unless $d->{'_order'} || $order;
my %k = map {$_ => 1} @k;
my @ko;
for (@{$d->{'_order'} || $order}) {
push @ko, $_ if delete $k{$_};
}
return (@ko, grep {$k{$_}} @k);
}
my %specialescapes = (
"\0" => '\\0',
"\a" => '\\a',
"\b" => '\\b',
"\t" => '\\t',
"\n" => '\\n',
"\013" => '\\v',
"\f" => '\\f',
"\r" => '\\r',
"\e" => '\\e',
"\x85" => '\\N',
);
sub unparse_string {
my ($d, $inline) = @_;
return "''" unless length $d;
return "\"$d\"" if Scalar::Util::looks_like_number($d);
if ($d =~ /[\x00-\x1f\x7f-\x9f\']/) {
$d =~ s/\\/\\\\/g;
$d =~ s/\"/\\\"/g;
$d =~ s/([\x00-\x1f\x7f-\x9f])/$specialescapes{$1} || '\x'.sprintf("%X",ord($1))/ge;
return "\"$d\"";
} elsif ($d =~ /^[\!\&*{}[]|>@`"'#%, ]/s) {
return "'$d'";
} elsif ($inline && $d =~ /[,\[\]\{\}]/) {
return "'$d'";
} elsif ($d =~ /: / || $d =~ / #/ || $d =~ /[: \t]\z/) {
return "'$d'";
} elsif ($d eq '~' || $d eq 'null' || $d eq 'true' || $d eq 'false' && $d =~ /^(?:---|\.\.\.)/s) {
return "'$d'";
} elsif ($d =~ /^[-?:](?:\s|\z)/s) {
return "'$d'";
} else {
return $d;
}
}
sub unparse_literal {
my ($d, $indent) = @_;
return unparse_string($d) if !defined($d) || $d eq '' || $d =~ /[\x00-\x09\x0b-\x1f\x7f-\x9f]/;
my @lines = split("\n", $d, -1);
return "''" unless @lines;
my $r = '|';
my @nonempty = grep {$_ ne ''} @lines;
$r .= '2' if @nonempty && $nonempty[0] =~ /^ /;
if ($lines[-1] ne '') {
$r .= '-';
} else {
pop @lines;
$r .= '+' if @lines && $lines[-1] eq '';
}
$r .= $_ ne '' ? "\n$indent$_" : "\n" for @lines;
return $r;
}
sub unparse_folded {
my ($d, $indent) = @_;
return unparse_string($d) if !defined($d) || $d eq '' || $d =~ /[\x00-\x09\x0b-\x1f\x7f-\x9f]/;
my @lines = split("\n", $d, -1);
return "''" unless @lines;
my $r = '>';
my @nonempty = grep {$_ ne ''} @lines;
$r .= '2' if @nonempty && $nonempty[0] =~ /^ /;
if ($lines[-1] ne '') {
$r .= '-';
} else {
pop @lines;
$r .= '+' if @lines && $lines[-1] eq '';
}
my $neednl;
my $ll = 78 - length($indent);
$ll = 40 if $ll < 40;
for (splice(@lines)) {
if ($_ =~ /^ /) {
push @lines, $_;
$neednl = 0;
next;
}
push @lines, '' if $neednl;
while (length($_) > $ll && (/^(.{1,$ll}[^ ]) [^ ]/s || /^(..*?[^ ]) [^ ]/s)) {
push @lines, $1;
$_ = substr($_, length($1) + 1);
}
push @lines, $_;
$neednl = 1;
}
$r .= $_ ne '' ? "\n$indent$_" : "\n" for @lines;
return $r;
}
sub unparse_bool {
my ($d) = @_;
return $d ? 'true' : 'false';
}
sub unparse_number {
my ($d) = @_;
return $1 if $d =~ /\A0*([1-9][0-9]*)\z/s;
return sprintf("%.f", $d) if $d == int($d);
return sprintf("%g", $d);
}
sub unparse {
my ($d, %opts) = @_;
return "---\n".unparse($d, %opts, 'noheader' => 1)."\n...\n" unless $opts{'noheader'};
my $r = '';
my $template = delete $opts{'template'};
$opts{'_type'} ||= $template if $template && !ref($template);
undef $template unless ref($template) eq 'HASH';
if (ref($d) eq 'ARRAY') {
return '[]' unless @$d;
$opts{'template'} = $template if $template;
$opts{'inline'} = 1 if $opts{'_type'} && $opts{'_type'} =~ s/^inline_?//;
if ($opts{'inline'}) {
my $first = 0;
for my $dd (@$d) {
$r .= ", " if $first++;
$r .= unparse($dd, %opts);
}
return "\[$r\]";
}
my $indent = $opts{'indent'} || '';
my $first = 0;
for my $dd (@$d) {
$r .= "\n$indent" if $first++;
$r .= "- ".unparse($dd, %opts, 'indent' => " $indent");
}
return $r;
}
if (ref($d) eq 'HASH') {
my @k = unparse_keys($d, $template ? $template->{'_order'} : undef);
return '{}' unless @k;
$opts{'inline'} = 1 if $opts{'_type'} && $opts{'_type'} =~ s/^inline_?//;
if ($opts{'inline'}) {
my $first = 0;
for my $k (@k) {
$opts{'template'} = $template->{$k} || $template->{'*'} if $template;
$r .= ", " if $first++;
my $dd = $d->{$k};
my $type = ($d->{'_type'} || {})->{$k};
$r .= unparse_string($k).": ".unparse($dd, %opts, '_type' => $type);
}
return "\{$r\}";
}
my $indent = $opts{'indent'} || '';
my $first = 0;
for my $k (@k) {
$opts{'template'} = $template->{$k} || $template->{'*'} if $template;
my $dd = $d->{$k};
my $type = ($d->{'_type'} || {})->{$k} || ($d->{'_type'} || {})->{'*'};
$type = $opts{'template'} if !$type && $opts{'template'} && !ref($opts{'template'});
$r .= "\n$indent" if $first++;
$r .= unparse_string($k).":";
if (ref($dd) eq 'ARRAY' && @$dd && !($type && $type =~ /^inline_?/)) {
$r .= "\n$indent";
$r .= unparse($dd, %opts, 'indent' => "$indent", '_type' => $type);
} elsif (ref($dd) eq 'HASH' && %$dd && !($type && $type =~ /^inline_?/)) {
$r .= "\n$indent ";
$r .= unparse($dd, %opts, 'indent' => " $indent", '_type' => $type);
} else {
$r .= " ".unparse($dd, %opts, 'indent' => " $indent", '_type' => $type);
}
}
return $r;
}
my $type = $opts{'_type'} || '';
return '~' unless defined $d;
return unparse_bool($d) if $type eq 'bool';
return unparse_number($d) if $type eq 'number';
return unparse_literal($d, $opts{'indent'} || '') if $type eq 'literal' && !$opts{'inline'};
return unparse_folded($d, $opts{'indent'} || '') if $type eq 'folded' && !$opts{'inline'};
return unparse_string($d, $opts{'inline'});
}
1;
0707010000001a000081a400000000000000000000000163e504b900000a4a000000000000000000000000000000000000001300000000Build/Snapcraft.pm################################################################
#
# Copyright (c) 1995-2014 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
#
################################################################
package Build::Snapcraft;
use strict;
use Build::Deb;
eval { require YAML::XS; $YAML::XS::LoadBlessed = 0; };
*YAML::XS::LoadFile = sub {die("YAML::XS is not available\n")} unless defined &YAML::XS::LoadFile;
sub parse {
my ($cf, $fn) = @_;
my $yaml;
eval {$yaml = YAML::XS::LoadFile($fn);};
return {'error' => "Failed to parse yaml file"} unless $yaml;
my $ret = {};
$ret->{'name'} = $yaml->{'name'};
$ret->{'version'} = $yaml->{'version'};
$ret->{'epoch'} = $yaml->{'epoch'} if $yaml->{'epoch'};
# how should we report the built apps?
my @packdeps;
for my $p (@{$yaml->{'stage-packages'} || []}) {
push @packdeps, $p;
}
for my $p (@{$yaml->{'build-packages'} || []}) {
push @packdeps, $p;
}
for my $p (@{$yaml->{'after'} || []}) {
push @packdeps, "snapcraft-part:$p";
}
for my $key (sort keys(%{$yaml->{'parts'} || {}})) {
my $part = $yaml->{'parts'}->{$key};
push @packdeps, "snapcraft-plugin:$part->{plugin}" if defined $part->{plugin};
for my $p (@{$part->{'stage-packages'} || []}) {
push @packdeps, $p;
}
for my $p (@{$part->{'build-packages'} || []}) {
push @packdeps, $p;
}
for my $p (@{$part->{'after'} || []}) {
next if $yaml->{'parts'}->{$p};
push @packdeps, "build-snapcraft-part-$p";
}
}
my %exclarchs;
for my $arch (@{$yaml->{architectures} || []}) {
my @obsarchs = Build::Deb::obsarch($arch);
push @obsarchs, $arch unless @obsarchs;
$exclarchs{$_} = 1 for @obsarchs;
}
$ret->{'exclarch'} = [ sort keys %exclarchs ] if %exclarchs;
# $ret->{'badarch'} = $badarch if defined $badarch;
$ret->{'deps'} = \@packdeps;
# $ret->{'prereqs'} = \@prereqs if @prereqs;
# $ret->{'configdependent'} = 1 if $ifdeps;
return $ret;
}
1;
0707010000001b000081a400000000000000000000000163e504b900001113000000000000000000000000000000000000001200000000Build/Susetags.pm################################################################
#
# Copyright (c) 1995-2014 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
#
################################################################
package Build::Susetags;
use strict;
use Build::Rpm;
# compatibility to old OBS code
sub parse_obs_compat {
my ($file, undef, undef, @arches) = @_;
$file = "$file.gz" if ! -e $file && -e "$file.gz";
my $pkgs = {};
parse($file, sub {
my ($data) = @_;
my $medium = delete($data->{'medium'});
my $loc = delete($data->{'location'});
if (defined($medium) && defined($loc)) {
$loc =~ s/^\Q$data->{'arch'}\E\///;
$data->{'path'} = "$medium $loc";
}
return unless !@arches || grep { /$data->{'arch'}/ } @arches;
$pkgs->{"$data->{'name'}-$data->{'version'}-$data->{'release'}-$data->{'arch'}"} = $data;
}, 'addselfprovides' => 1);
return $pkgs;
}
my %tmap = (
'Pkg' => '',
'Loc' => 'location',
'Src' => 'source',
'Prv' => 'provides',
'Req' => 'requires',
'Con' => 'conflicts',
'Obs' => 'obsoletes',
'Rec' => 'recommends',
'Sug' => 'suggests',
'Sup' => 'supplements',
'Enh' => 'enhances',
'Tim' => 'buildtime',
'Cks' => 'checksum',
);
sub addpkg {
my ($res, $data, $options) = @_;
# fixup location and source
if (exists($data->{'location'})) {
my ($medium, $dir, $loc) = split(' ', $data->{'location'}, 3);
$data->{'medium'} = $medium;
$data->{'location'} = defined($loc) ? "$dir/$loc" : "$data->{'arch'}/$dir";
}
$data->{'source'} =~ s/\s.*// if exists $data->{'source'};
if ($options->{'addselfprovides'} && defined($data->{'name'}) && defined($data->{'version'})) {
if (($data->{'arch'} || '') ne 'src' && ($data->{'arch'} || '') ne 'nosrc') {
my $evr = $data->{'version'};
$evr = "$data->{'epoch'}:$evr" if $data->{'epoch'};
$evr = "$evr-$data->{'release'}" if defined $data->{'release'};
my $s = "$data->{'name'} = $evr";
push @{$data->{'provides'}}, $s unless grep {$_ eq $s} @{$data->{'provides'} || []};
}
}
if ($options->{'withchecksum'} && $data->{'checksum'}) {
my ($ctype, $csum) = split(' ', delete($data->{'checksum'}));
$ctype = lc($ctype || '');
$data->{'checksum'} = "$ctype:$csum" if $csum && ($ctype eq 'md5' || $ctype eq 'sha1' || $ctype eq 'sha256' || $ctype eq 'sha512');
}
if (ref($res) eq 'CODE') {
$res->($data);
} else {
push @$res, $data;
}
}
sub parse {
return parse_obs_compat(@_) if @_ > 2 && !defined $_[2];
my ($in, $res, %options) = @_;
$res ||= [];
my $fd;
if (ref($in)) {
$fd = $in;
} else {
if ($in =~ /\.gz$/) {
open($fd, '-|', "gzip", "-dc", $in) || die("$in: $!\n");
} else {
open($fd, '<', $in) || die("$in: $!\n");
}
}
my $cur;
my @tmap = sort keys %tmap;
@tmap = grep {$_ ne 'Cks'} @tmap unless $options{'withchecksum'};
my $r = join('|', @tmap);
$r = qr/^([\+=])($r):\s*(.*)/;
while (<$fd>) {
chomp;
next unless /$r/;
my ($multi, $tag, $data) = ($1, $2, $3);
if ($multi eq '+') {
while (<$fd>) {
chomp;
last if /^-\Q$tag\E/;
next if $tag eq 'Req' && /^rpmlib\(/;
$_ = Build::Rpm::testcaseformat($_) if /^\(/ && $options{'testcaseformat'};
push @{$cur->{$tmap{$tag}}}, $_;
}
} elsif ($tag eq 'Pkg') {
addpkg($res, $cur, \%options) if $cur;
$cur = {};
($cur->{'name'}, $cur->{'version'}, $cur->{'release'}, $cur->{'arch'}) = split(' ', $data);
$cur->{'epoch'} = $1 if $cur->{'version'} =~ s/^(\d+)://;
} else {
$cur->{$tmap{$tag}} = $data;
}
}
addpkg($res, $cur, \%options) if $cur;
if (!ref($in)) {
close($fd) || die("close $in: $!\n");
}
return $res;
}
1;
0707010000001c000081a400000000000000000000000163e504b9000009a8000000000000000000000000000000000000000e00000000Build/Zypp.pm################################################################
#
# Copyright (c) 1995-2014 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
#
################################################################
package Build::Zypp;
use strict;
our $root = '';
sub parsecfg {
my ($repocfg, $reponame, $allrepos) = @_;
local *REPO;
open(REPO, '<', "$root/etc/zypp/repos.d/$repocfg") or return undef;
my $name;
my $repo = {};
while (<REPO>) {
chomp;
next if /^\s*#/;
s/\s+$//;
if (/^\[(.+)\]/) {
if ($allrepos && defined($name)) {
$repo->{'description'} = $repo->{'name'} if defined $repo->{'name'};
$repo->{'name'} = $name;
push @$allrepos, $repo;
undef $name;
$repo = {};
}
last if defined $name;
$name = $1 if !defined($reponame) || $reponame eq $1;
} elsif (defined($name)) {
my ($key, $value) = split(/=/, $_, 2);
$repo->{$key} = $value if defined $key;
}
}
close(REPO);
return undef unless defined $name;
$repo->{'description'} = $repo->{'name'} if defined $repo->{'name'};
$repo->{'name'} = $name;
push @$allrepos, $repo if $allrepos;
return $repo;
}
sub repofiles {
local *D;
return () unless opendir(D, "/etc/zypp/repos.d");
my @r = grep {!/^\./ && /.repo$/} readdir(D);
closedir D;
return sort(@r);
}
sub parseallrepos {
my @r;
for my $r (repofiles()) {
parsecfg($r, undef, \@r);
}
return @r;
}
sub parserepo($) {
my ($reponame) = @_;
# first try matching .repo file
if (-e "$root/etc/zypp/repos.d/$reponame.repo") {
my $repo = parsecfg("$reponame.repo", $reponame);
return $repo if $repo;
}
# then try all repo files
for my $r (repofiles()) {
my $repo = parsecfg($r, $reponame);
return $repo if $repo;
}
die("could not find repo '$reponame'\n");
}
1;
# vim: sw=2
0707010000001d000041ed00000000000000000000000163e504b900000000000000000000000000000000000000000000000600000000Build07070100000000000000000000000000000000000000010000000000000000000000000000000000000000000000000000000b00000000TRAILER!!!
