From da0d632b7712210af91c2e386a11402eb6079e08 Mon Sep 17 00:00:00 2001 From: Fabian Vogt Date: Wed, 29 Nov 2023 15:59:46 +0100 Subject: [PATCH 1/2] Rewrite bs_mirrorfull as osclib component This has multiple benefits: * Easier to interface with the python code that calls it * Uses the osc python interface for connection and authentication handling * Allows to drop the bundled OBS code in the bs_copy directory --- osclib/repochecks.py | 19 +++--- osclib/repomirror.py | 138 +++++++++++++++++++++++++++++++++++++++++++ pkglistgen/tool.py | 15 +---- 3 files changed, 150 insertions(+), 22 deletions(-) create mode 100644 osclib/repomirror.py diff --git a/osclib/repochecks.py b/osclib/repochecks.py index 5fcf204d0..ec7cbc1d2 100644 --- a/osclib/repochecks.py +++ b/osclib/repochecks.py @@ -8,10 +8,12 @@ from fnmatch import fnmatch from lxml import etree as ET from osc.core import http_GET +from osc.core import makeurl import yaml from osclib.cache_manager import CacheManager +from osclib.repomirror import RepoMirror logger = logging.getLogger('InstallChecker') @@ -192,13 +194,16 @@ def mirrorRepomd(cachedir, url): def mirror(apiurl, project, repository, arch): - """Call bs_mirrorfull script to mirror packages.""" + """ + Mirror repo metadata for the given pra. + Downloads primary.xml for DoD or all RPM headers in the full tree. + """ directory = os.path.join(CACHEDIR, project, repository, arch) if not os.path.exists(directory): os.makedirs(directory) - meta = ET.parse(http_GET('{}/public/source/{}/_meta'.format(apiurl, project))).getroot() + meta = ET.parse(http_GET(makeurl(apiurl, ['source', project, '_meta']))).getroot() repotag = meta.xpath("/project/repository[@name='{}']".format(repository))[0] if arch not in repotag.xpath("./arch/text()"): # Arch not in this project, skip mirroring @@ -213,13 +218,7 @@ def mirror(apiurl, project, repository, arch): raise Exception('repotype {} not supported'.format(repotype)) return mirrorRepomd(directory, download[0].get('url')) - script = os.path.join(SCRIPT_PATH, '..', 'bs_mirrorfull') - path = '/'.join((project, repository, arch)) - logger.info('mirroring {}'.format(path)) - url = '{}/public/build/{}'.format(apiurl, path) - p = subprocess.run(['perl', script, '--nodebug', url, directory]) - - if p.returncode: - raise Exception('failed to mirror {}'.format(path)) + rm = RepoMirror(apiurl) + rm.mirror(directory, project, repository, arch) return directory diff --git a/osclib/repomirror.py b/osclib/repomirror.py new file mode 100644 index 000000000..3f6be091b --- /dev/null +++ b/osclib/repomirror.py @@ -0,0 +1,138 @@ +import fcntl +import itertools +import logging +import os +import osc.conf +import re +import struct +import sys +import tempfile + +from lxml import etree as ET +from osc.core import http_GET +from osc.core import makeurl +from osc.util.cpio import CpioHdr +from urllib.parse import quote_plus + +logger = logging.getLogger('RepoMirror') + + +class RepoMirror: + def __init__(self, apiurl, nameignore: str = '-debug(info|source|info-32bit).rpm$'): + """ + Class to mirror RPM headers of all binaries in a repo on OBS (full tree). + Debug packages are ignored by default, see the nameignore parameter. + """ + self.apiurl = apiurl + self.nameignorere = re.compile(nameignore) + + def extract_cpio_stream(self, destdir: str, stream): + hdr_fmt = '6s8s8s8s8s8s8s8s8s8s8s8s8s8s' + hdr_len = 110 + + name_re = re.compile('^([^/]+)-([0-9a-f]{32})$') + + while True: + # Read and parse the CPIO header + hdrdata = stream.read(hdr_len) + hdrtuples = struct.unpack(hdr_fmt, hdrdata) + if hdrtuples[0] != b'070701': + raise NotImplementedError(f'CPIO format {hdrtuples[0]} not implemented') + + # The new-ascii format has padding for 4 byte alignment + def align(): + stream.read((4 - (stream.tell() % 4)) % 4) + + hdr = CpioHdr(*hdrtuples) + hdr.filename = stream.read(hdr.namesize - 1).decode('ascii') + stream.read(1) # Skip terminator + align() + + binarymatch = name_re.match(hdr.filename) + if hdr.filename == '.errors': + content = stream.read(hdr.filesize) + raise RuntimeError('Download has errors: ' + content.decode('ascii')) + elif binarymatch: + name = binarymatch.group(1) + md5 = binarymatch.group(2) + destpath = os.path.join(destdir, f'{md5}-{name}.rpm') + with tempfile.NamedTemporaryFile(mode='wb', dir=destdir) as tmpfile: + # Probably not big enough to need chunking + tmpfile.write(stream.read(hdr.filesize)) + os.link(tmpfile.name, destpath) + # Would be nice to use O_TMPFILE + link here, but python passes + # O_EXCL which breaks that. + # os.link(f'/proc/self/fd/{tmpfile.fileno()}', destpath) + + align() + elif hdr.filename == 'TRAILER!!!': + if stream.read(1): + raise RuntimeError('Expected end of CPIO') + break + else: + raise NotImplementedError(f'Unhandled file {hdr.filename} in archive') + + def _mirror(self, destdir: str, prj: str, repo: str, arch: str) -> None: + "Using the _repositories endpoint, download all RPM headers into destdir." + logger.info(f'Mirroring {prj}/{repo}/{arch}') + pkglistxml = http_GET(makeurl(self.apiurl, ['build', prj, repo, arch, '_repository'], + query={'view': 'binaryversions', 'nometa': 1})) + root = ET.parse(pkglistxml).getroot() + remotebins: dict[str, str] = {} + for binary in root.findall('binary'): + name = binary.get('name') + if name.endswith('.rpm') and not self.nameignorere.search(name): + hdrmd5 = binary.get('hdrmd5') + remotebins[f'{hdrmd5}-{name}'] = name[:-4] + + to_delete: list[str] = [] + for filename in os.listdir(destdir): + if not filename.endswith('.rpm'): + continue + + if filename in remotebins: + del remotebins[filename] # Already downloaded + else: + to_delete.append(os.path.join(destdir, filename)) + + if to_delete: + logger.info(f'Deleting {len(to_delete)} old packages') + for path in to_delete: + os.unlink(path) + + if remotebins: + logger.info(f'Downloading {len(remotebins)} new packages') + binaries = remotebins.values() + + # Download in batches of 50 + for chunk in range(0, len(binaries), 50): + query = 'view=cpioheaders' + for binary in itertools.islice(binaries, chunk, chunk + 50): + query += '&binary=' + quote_plus(binary) + + req = http_GET(makeurl(self.apiurl, ['build', prj, repo, arch, '_repository'], + query=query)) + self.extract_cpio_stream(destdir, req) + + def mirror(self, destdir: str, prj: str, repo: str, arch: str) -> None: + "Creates destdir and locks destdir/.lock before mirroring." + os.makedirs(destdir, exist_ok=True) + + with open(os.path.join(destdir, '.lock'), 'w') as lockfile: + try: + fcntl.flock(lockfile, fcntl.LOCK_EX | fcntl.LOCK_NB) + except IOError: + logger.info(destdir + 'is locked, waiting... ', end='') + fcntl.flock(lockfile, fcntl.LOCK_EX) + logger.info('acquired!') + + return self._mirror(destdir, prj, repo, arch) + + +if __name__ == '__main__': + if len(sys.argv) != 6: + print("Usage: repomirror.py apiurl destdir prj repo arch") + else: + osc.conf.get_config() + rm = RepoMirror(sys.argv[1]) + rm.mirror(sys.argv[2], sys.argv[3], sys.argv[4], sys.argv[5]) diff --git a/pkglistgen/tool.py b/pkglistgen/tool.py index d7c6b190a..9854691c6 100644 --- a/pkglistgen/tool.py +++ b/pkglistgen/tool.py @@ -25,6 +25,7 @@ from osclib.core import repository_arch_state from osclib.cache_manager import CacheManager from osclib.pkglistgen_comments import PkglistComments +from osclib.repomirror import RepoMirror from urllib.parse import urlparse @@ -354,18 +355,8 @@ def update_one_repo(self, project, repo, arch, solv_file, solv_file_hash): self.logger.debug('updating %s', d) - # only there to parse the repos - bs_mirrorfull = os.path.join(SCRIPT_PATH, '..', 'bs_mirrorfull') - - args = [bs_mirrorfull] - args.append('--nodebug') - args.append('{}/public/build/{}/{}/{}'.format(self.apiurl, project, repo, arch)) - args.append(d) - with subprocess.Popen(args, stdout=subprocess.PIPE) as p: - for line in p.stdout: - self.logger.info(line.decode('utf-8').rstrip()) - if p.wait() != 0: - raise Exception("Mirroring repository failed") + rm = RepoMirror(self.apiurl) + rm.mirror(d, project, repo, arch) files = [os.path.join(d, f) for f in os.listdir(d) if f.endswith('.rpm')] From 0888a8f1a0981957214a966957b55827fbb81cf2 Mon Sep 17 00:00:00 2001 From: Fabian Vogt Date: Wed, 29 Nov 2023 16:03:18 +0100 Subject: [PATCH 2/2] Drop bs_mirrorfull Superseded by osclib.repomirror. --- .github/workflows/ci-test.yml | 2 +- CONTENTS.md | 9 - Makefile | 2 +- bs_copy/BSHTTP.pm | 401 ------ bs_copy/BSRPC.pm | 354 ----- bs_copy/BSSSL.pm | 140 -- bs_copy/BSUtil.pm | 593 -------- bs_copy/BSXML.pm | 1671 ---------------------- bs_copy/XML/Structured.pm | 532 ------- bs_mirrorfull | 99 -- dist/package/openSUSE-release-tools.spec | 5 - 11 files changed, 2 insertions(+), 3806 deletions(-) delete mode 100644 bs_copy/BSHTTP.pm delete mode 100644 bs_copy/BSRPC.pm delete mode 100644 bs_copy/BSSSL.pm delete mode 100644 bs_copy/BSUtil.pm delete mode 100644 bs_copy/BSXML.pm delete mode 100644 bs_copy/XML/Structured.pm delete mode 100755 bs_mirrorfull diff --git a/.github/workflows/ci-test.yml b/.github/workflows/ci-test.yml index 8474c7cfc..8790e6f9f 100644 --- a/.github/workflows/ci-test.yml +++ b/.github/workflows/ci-test.yml @@ -83,7 +83,7 @@ jobs: run: | for f in $(find . -maxdepth 1 -type f -executable -print); do # skip completely broken scripts or those without --help - [[ " ./checknewer.py ./repo2fileprovides.py ./openqa-maintenance.py ./docker_publisher.py ./publish_distro ./bs_mirrorfull ./findfileconflicts ./write_repo_susetags_file.pl ./issue-diff.py " =~ "$f" ]] || "$f" --help + [[ " ./checknewer.py ./repo2fileprovides.py ./openqa-maintenance.py ./docker_publisher.py ./publish_distro ./findfileconflicts ./write_repo_susetags_file.pl ./issue-diff.py " =~ "$f" ]] || "$f" --help done linters: diff --git a/CONTENTS.md b/CONTENTS.md index 727d208b8..0395e8356 100644 --- a/CONTENTS.md +++ b/CONTENTS.md @@ -108,15 +108,6 @@ Manages bugowner information * Package: openSUSE-release-tools * Usage: ? -#### bs_mirrorfull - -Mirrors repositories from the build service to a local directory. - -* Souces: [bs_mirrorfull](bs_mirrorfull) -* Documentation: -- -* Package: openSUSE-release-tools -* Usage: Used by other tools like `pkglistgen` or `repocheck` - #### biarchtool Manages biarch packages diff --git a/Makefile b/Makefile index 8e637fe26..1075f238a 100644 --- a/Makefile +++ b/Makefile @@ -4,7 +4,7 @@ include Makefile.common pkgdata_BINS = $(shell find * -maxdepth 0 -executable -type f) pkgdata_SCRIPTS=$(wildcard *.py *.pl *.sh) -pkgdata_SCRIPTS+=bs_mirrorfull findfileconflicts publish_distro +pkgdata_SCRIPTS+=findfileconflicts publish_distro pkgdata_DATA+=bs_copy metrics osclib pkglistgen $(wildcard *.pm *.testcase) VERSION = "build-$(shell date +%F)" diff --git a/bs_copy/BSHTTP.pm b/bs_copy/BSHTTP.pm deleted file mode 100644 index 994a22382..000000000 --- a/bs_copy/BSHTTP.pm +++ /dev/null @@ -1,401 +0,0 @@ -# -# Copyright (c) 2006, 2007 Michael Schroeder, Novell Inc. -# -# This program is free software; you can redistribute it and/or modify -# it under the terms of the GNU General Public License version 2 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 -# -################################################################ -# -# HTTP protocol functions. Also contains file/cpio sender/receiver. -# - -package BSHTTP; - -use Digest::MD5 (); - -use strict; - -sub gethead { - my ($h, $t) = @_; - - my ($field, $data); - for (split(/[\r\n]+/, $t)) { - next if $_ eq ''; - if (/^[ \t]/) { - next unless defined $field; - s/^\s*/ /; - $h->{$field} .= $_; - } else { - ($field, $data) = split(/\s*:\s*/, $_, 2); - $field =~ tr/A-Z/a-z/; - if ($h->{$field} && $h->{$field} ne '') { - $h->{$field} = $h->{$field}.','.$data; - } else { - $h->{$field} = $data; - } - } - } -} - -# -# read data from socket, do chunk decoding -# hdr: header data -# maxl = undef: read as much as you can -# exact = 1: read maxl data, maxl==undef -> read to eof; -# -sub read_data { - my ($hdr, $maxl, $exact) = @_; - - my $ret = ''; - local *S = $hdr->{'__socket'}; - if ($hdr->{'transfer-encoding'} && lc($hdr->{'transfer-encoding'}) eq 'chunked') { - my $cl = $hdr->{'__cl'} || 0; - if ($cl < 0) { - die("unexpected EOF\n") if $exact && defined($maxl) && length($ret) < $maxl; - return $ret; - } - my $qu = $hdr->{'__data'}; - while(1) { - if (defined($maxl) && $maxl <= $cl) { - while(length($qu) < $maxl) { - my $r = sysread(S, $qu, 8192, length($qu)); - die("unexpected EOF\n") unless $r; - } - $ret .= substr($qu, 0, $maxl); - $hdr->{'__cl'} = $cl - $maxl; - $hdr->{'__data'} = substr($qu, $maxl); - return $ret; - } - if ($cl) { - # no maxl or maxl > cl, read full cl - while(length($qu) < $cl) { - my $r = sysread(S, $qu, 8192, length($qu)); - die("unexpected EOF\n") unless $r; - } - $ret .= substr($qu, 0, $cl); - $qu = substr($qu, $cl); - $maxl -= $cl if defined $maxl; - $cl = 0; - if (!defined($maxl) && !$exact) { # no maxl, return every chunk - $hdr->{'__cl'} = $cl; - $hdr->{'__data'} = $qu; - return $ret; - } - } - while ($qu !~ /\r?\n/s) { - my $r = sysread(S, $qu, 8192, length($qu)); - die("unexpected EOF\n") unless $r; - } - if (substr($qu, 0, 1) eq "\n") { - $qu = substr($qu, 1); - next; - } - if (substr($qu, 0, 2) eq "\r\n") { - $qu = substr($qu, 2); - next; - } - die("bad CHUNK data: $qu\n") unless $qu =~ /^([0-9a-fA-F]+)/; - $cl = hex($1); - die if $cl < 0; - $qu =~ s/^.*?\r?\n//s; - if ($cl == 0) { - $hdr->{'__cl'} = -1; # mark EOF - die("unexpected EOF\n") if $exact && defined($maxl) && length($ret) < $maxl; - # read trailer - $qu = "\r\n$qu"; - while ($qu !~ /\n\r?\n/s) { - my $r = sysread(S, $qu, 8192, length($qu)); - die("unexpected EOF\n") unless $r; - } - $qu =~ /^(.*?)\n\r?\n/; - gethead($hdr, length($1) >= 2 ? substr($1, 2) : ''); - return $ret; - } - } - } else { - my $qu = $hdr->{'__data'}; - my $cl = $hdr->{'__cl'}; - $cl = $hdr->{'content-length'} unless defined $cl; - if (defined($cl) && (!defined($maxl) || $maxl > $cl)) { - die("unexpected EOF\n") if $exact && defined($maxl); - $maxl = $cl >= 0 ? $cl : 0; - } - while (!defined($maxl) || length($qu) < $maxl) { - my $m = ($maxl || 0) - length($qu); - $m = 8192 if $m < 8192; - my $r = sysread(S, $qu, $m, length($qu)); - if (!$r) { - die("unexpected EOF\n") if defined($cl) || ($exact && defined($maxl)); - $cl = $maxl = length($qu); - } - } - $cl -= $maxl if defined($cl); - $ret = substr($qu, 0, $maxl); - $hdr->{'__cl'} = $cl; - $hdr->{'__data'} = substr($qu, $maxl); - return $ret; - } -} - -sub str2hdr { - my ($str) = @_; - my $hdr = { - '__data' => $str, - '__cl' => length($str), - }; - return $hdr; -} - -sub fd2hdr { - my ($fd) = @_; - my $hdr = { - '__data' => '', - '__socket' => $fd, - '__cl' => -s *$fd, - }; - return $hdr; -} - -sub file_receiver { - my ($hdr, $param) = @_; - - die("file_receiver: no filename\n") unless defined $param->{'filename'}; - my $fn = $param->{'filename'}; - my $withmd5 = $param->{'withmd5'}; - local *F; - my $ctx; - $ctx = Digest::MD5->new if $withmd5; - open(F, '>', $fn) || die("$fn: $!\n"); - my $size = 0; - while(1) { - my $s = read_data($hdr, 8192); - last if $s eq ''; - (syswrite(F, $s) || 0) == length($s) || die("syswrite: $!\n"); - $size += length($s); - $ctx->add($s) if $ctx; - } - close(F) || die("close: $!\n"); - my $res = {size => $size}; - $res->{'md5'} = $ctx->hexdigest if $ctx; - return $res; -} - -sub cpio_receiver { - my ($hdr, $param) = @_; - my @res; - my $dn = $param->{'directory'}; - my $withmd5 = $param->{'withmd5'}; - local *F; - while(1) { - my $cpiohead = read_data($hdr, 110, 1); - die("cpio: not a 'SVR4 no CRC ascii' cpio\n") unless substr($cpiohead, 0, 6) eq '070701'; - my $mode = hex(substr($cpiohead, 14, 8)); - my $mtime = hex(substr($cpiohead, 46, 8)); - my $size = hex(substr($cpiohead, 54, 8)); - if ($size == 0xffffffff) { - # build service length extension - $cpiohead .= read_data($hdr, 16, 1); - $size = hex(substr($cpiohead, 62, 8)) * 4294967296. + hex(substr($cpiohead, 70, 8)); - substr($cpiohead, 62, 16) = ''; - } - my $nsize = hex(substr($cpiohead, 94, 8)); - die("ridiculous long filename\n") if $nsize > 8192; - my $nsizepad = $nsize; - $nsizepad += 4 - ($nsize + 2 & 3) if $nsize + 2 & 3; - my $name = read_data($hdr, $nsizepad, 1); - $name =~ s/\0.*//s; - $name =~ s/^\.\///s; - my $sizepad = $size; - $sizepad += 4 - ($size % 4) if $size % 4; - last if !$size && $name eq 'TRAILER!!!'; - if ($param->{'acceptsubdirs'} || $param->{'createsubdirs'}) { - die("cpio filename is illegal: $name\n") if "/$name/" =~ /\/\.{0,2}\//s; - } else { - die("cpio filename contains a '/': $name\n") if $name =~ /\//s; - } - die("cpio filename is '.' or '..'\n") if $name eq '.' || $name eq '..'; - my $ent = {'name' => $name, 'size' => $size, 'mtime' => $mtime, 'mode' => $mode}; - if ($param->{'accept'}) { - if (ref($param->{'accept'})) { - die("illegal file in cpio archive: $name\n") unless $param->{'accept'}->($param, $name, $ent); - } else { - die("illegal file in cpio archive: $name\n") unless $name =~ /$param->{'accept'}/; - } - } - if ($param->{'map'}) { - $ent->{'unmappedname'} = $name; - if (ref($param->{'map'})) { - $ent->{'name'} = $name = $param->{'map'}->($param, $name); - } else { - $ent->{'name'} = $name = "$param->{'map'}$name"; - } - } - if (!defined($name)) { - # skip entry - while ($sizepad) { - my $m = $sizepad > 8192 ? 8192 : $sizepad; - read_data($hdr, $m, 1); - $sizepad -= $m; - } - next; - } - push @res, $ent; - my $ctx; - $ctx = Digest::MD5->new if $withmd5; - if (defined($dn)) { - my $filename = "$dn/$name"; - if (($mode & 0xf000) == 0x4000 && $param->{'createsubdirs'}) { - die("directory has non-zero size\n") if $sizepad; - if (! -d $filename) { - unlink($filename) unless $param->{'no_unlink'}; - mkdir($filename) || die("mkdir $filename: $!\n"); - } - } else { - die("can only unpack plain files from cpio archive, file $name, mode was $mode\n") unless ($mode & 0xf000) == 0x8000; - unlink($filename) unless $param->{'no_unlink'}; - open(F, '>', $filename) || die("$filename: $!\n"); - } - } else { - $ent->{'data'} = ''; - } - while ($sizepad) { - my $m = $sizepad > 8192 ? 8192 : $sizepad; - my $data = read_data($hdr, $m, 1); - $sizepad -= $m; - $size -= $m; - $m += $size if $size < 0; - if (defined($dn)) { - (syswrite(F, $data, $m) || 0) == $m || die("syswrite: $!\n"); - } else { - $ent->{'data'} .= substr($data, 0, $m); - } - $ctx->add($size >= 0 ? $data : substr($data, 0, $m)) if $ctx; - } - if (defined($dn) && ($mode & 0xf000) != 0x4000) { - close(F) || die("close: $!\n"); - utime($mtime, $mtime, "$dn/$name"); - } - $ent->{'md5'} = $ctx->hexdigest if $ctx && ($mode & 0xf000) != 0x4000; - $param->{'cpiopostfile'}->($param, $ent) if $param->{'cpiopostfile'}; - } - return \@res; -} - -sub swrite { - my ($sock, $data) = @_; - local *S = $sock; - while (length($data)) { - my $l = syswrite(S, $data, length($data)); - die("socket write: $!\n") unless $l; - $data = substr($data, $l); - } -} - -sub cpio_sender { - my ($param, $sock) = @_; - - my $errors = ''; - local *F; - my $data; - for my $file (@{$param->{'cpiofiles'} || []}, {'__errors' => 1}) { - my @s; - if ($file->{'error'}) { - $errors .= "$file->{'name'}: $file->{'error'}\n"; - next; - } - if (exists $file->{'filename'}) { - if (ref($file->{'filename'})) { - *F = $file->{'filename'}; - } elsif (!open(F, '<', $file->{'filename'})) { - $errors .= "$file->{'name'}: $file->{'filename'}: $!\n"; - next; - } - @s = stat(F); - } else { - if ($file->{'__errors'}) { - next if $errors eq ''; - $file->{'data'} = $errors; - $file->{'name'} = ".errors"; - } - $s[7] = length($file->{'data'}); - $s[9] = time; - } - my $mode = $file->{'mode'} || 0x81a4; - $data = sprintf("07070100000000%08x000000000000000000000001", $mode); - if ($s[7] > 0xffffffff) { - # build service length extension - my $top = int($s[7] / 4294967296.); - $data .= sprintf("%08xffffffff%08x%08x", $s[9], $top, $s[7] - $top * 4294967296.); - } else { - $data .= sprintf("%08x%08x", $s[9], $s[7]); - } - $data .= "00000000000000000000000000000000"; - $data .= sprintf("%08x", length($file->{'name'}) + 1); - $data .= "00000000"; - $data .= "$file->{'name'}\0"; - $data .= substr("\0\0\0\0", (length($data) & 3)) if length($data) & 3; - if (exists $file->{'filename'}) { - my $l = $s[7]; - my $r = 0; - while(1) { - $r = sysread(F, $data, $l > 8192 ? 8192 : $l, length($data)) if $l; - $data .= substr("\0\0\0\0", ($s[7] % 4)) if $r == $l && ($s[7] % 4) != 0; - $data = sprintf("%X\r\n", length($data)).$data."\r\n" if $param->{'chunked'}; - swrite($sock, $data); - $data = ''; - $l -= $r; - last unless $l; - } - die("internal error\n") if $l; - close F unless ref $file->{'filename'}; - } else { - $data .= $file->{'data'}; - $data .= substr("\0\0\0\0", (length($data) & 3)) if length($data) & 3; - $data = sprintf("%X\r\n", length($data)).$data."\r\n" if $param->{'chunked'}; - swrite($sock, $data); - } - } - $data = "07070100000000000000000000000000000000000000010000000000000000000000000000000000000000000000000000000b00000000TRAILER!!!\0\0\0\0"; - $data = sprintf("%X\r\n", length($data)).$data."\r\n" if $param->{'chunked'}; - swrite($sock, $data); - return ''; -} - -sub file_sender { - my ($param, $sock) = @_; - local *F; - - my $bytes = $param->{'bytes'}; - my $data; - if (ref($param->{'filename'})) { - *F = $param->{'filename'}; - } else { - open(F, '<', $param->{'filename'}) || die("$param->{'filename'}: $!\n") - } - while(1) { - last if defined($bytes) && !$bytes; - my $r = sysread(F, $data, 8192); - last unless $r; - if ($bytes) { - $data = substr($data, 0, $bytes) if length($data) > $bytes; - $bytes -= length($data); - } - $data = sprintf("%X\r\n", length($data)).$data."\r\n" if $param->{'chunked'}; - swrite($sock, $data); - } - close F unless ref $param->{'filename'}; - return ''; -} - -1; diff --git a/bs_copy/BSRPC.pm b/bs_copy/BSRPC.pm deleted file mode 100644 index c3b3fac30..000000000 --- a/bs_copy/BSRPC.pm +++ /dev/null @@ -1,354 +0,0 @@ -# -# Copyright (c) 2006, 2007 Michael Schroeder, Novell Inc. -# -# This program is free software; you can redistribute it and/or modify -# it under the terms of the GNU General Public License version 2 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 -# -################################################################ -# -# Run a HTTP query operation. Single thread only. -# - -package BSRPC; - -use Socket; -use XML::Structured; -use Symbol; -use MIME::Base64; -use Data::Dumper; - -use BSHTTP; - -use strict; - -our $useragent = 'BSRPC 0.9.1'; - -my %hostlookupcache; -my %cookiestore; # our session store to keep iChain fast -my $tossl; - -my $noproxy; - -sub import { - if (grep {$_ eq ':https'} @_) { - require BSSSL; - $tossl = \&BSSSL::tossl; - } -} - - -my $tcpproto = getprotobyname('tcp'); - -sub urlencode { - my $url = $_[0]; - $url =~ s/([\000-\040<>;\"#\?&\+=%[\177-\377])/sprintf("%%%02X",ord($1))/sge; - return $url; -} - -sub createuri { - my ($param, @args) = @_; - my $uri = $param->{'uri'}; - if (!$param->{'verbatim_uri'} && $uri =~ /^(https?:\/\/[^\/]*\/)(.*)$/s) { - $uri = $1; - $uri .= BSRPC::urlencode($2); - } - if (@args) { - for (@args) { - $_ = urlencode($_); - s/%3D/=/; # convert first now escaped '=' back - } - if ($uri =~ /\?/) { - $uri .= '&'.join('&', @args); - } else { - $uri .= '?'.join('&', @args); - } - } - return $uri; -} - -sub useproxy { - my ($host, $noproxy) = @_; - - # strip leading and tailing whitespace - $noproxy =~ s/^\s+//; - $noproxy =~ s/\s+$//; - # noproxy is a list separated by commas and optional whitespace - for (split(/\s*,\s*/, $noproxy)) { - return 0 if $host =~ m/(^|\.)$_$/; - } - return 1; -} - -sub createreq { - my ($param, $uri, $proxy, $cookiestore, @xhdrs) = @_; - - my $act = $param->{'request'} || 'GET'; - if (exists($param->{'socket'})) { - my $req = "$act $uri HTTP/1.1\r\n".join("\r\n", @xhdrs)."\r\n\r\n"; - return ('', undef, undef, $req, undef); - } - my ($proxyauth, $proxytunnel); - die("bad uri: $uri\n") unless $uri =~ /^(https?):\/\/(?:([^\/\@]*)\@)?([^\/:]+)(:\d+)?(\/.*)$/; - my ($proto, $auth, $host, $port, $path) = ($1, $2, $3, $4, $5); - my $hostport = $port ? "$host$port" : $host; - undef $proxy if $proxy && defined($noproxy) && !useproxy($host, $noproxy); - if ($proxy) { - die("bad proxy uri: $proxy\n") unless "$proxy/" =~ /^(https?):\/\/(?:([^\/\@]*)\@)?([^\/:]+)(:\d+)?(\/.*)$/; - ($proto, $proxyauth, $host, $port) = ($1, $2, $3, $4); - $path = $uri unless $uri =~ /^https:/; - } - $port = substr($port || ($proto eq 'http' ? ":80" : ":443"), 1); - unshift @xhdrs, "Connection: close" unless $param->{'noclose'}; - unshift @xhdrs, "User-Agent: $useragent" unless !defined($useragent) || grep {/^user-agent:/si} @xhdrs; - unshift @xhdrs, "Host: $hostport" unless grep {/^host:/si} @xhdrs; - if (defined $auth) { - $auth =~ s/%([a-fA-F0-9]{2})/chr(hex($1))/ge; - unshift @xhdrs, "Authorization: Basic ".encode_base64($auth, ''); - } - if (defined $proxyauth) { - $proxyauth =~ s/%([a-fA-F0-9]{2})/chr(hex($1))/ge; - unshift @xhdrs, "Proxy-Authorization: Basic ".encode_base64($proxyauth, ''); - } - if ($proxy && $uri =~ /^https/) { - if ($hostport =~ /:\d+$/) { - $proxytunnel = "CONNECT $hostport HTTP/1.1\r\nHost: $hostport\r\n"; - } else { - $proxytunnel = "CONNECT $hostport:443 HTTP/1.1\r\nHost: $hostport:443\r\n"; - } - $proxytunnel .= shift(@xhdrs)."\r\n" if defined $proxyauth; - $proxytunnel .= "\r\n"; - } - if ($cookiestore && %$cookiestore) { - if ($uri =~ /((:?https?):\/\/(?:([^\/]*)\@)?(?:[^\/:]+)(?::\d+)?)(?:\/.*)$/) { - push @xhdrs, map {"Cookie: $_"} @{$cookiestore->{$1} || []}; - } - } - my $req = "$act $path HTTP/1.1\r\n".join("\r\n", @xhdrs)."\r\n\r\n"; - return ($proto, $host, $port, $req, $proxytunnel); -} - -# -# handled paramters: -# timeout -# uri -# data -# headers (array) -# chunked -# request -# verbatim_uri -# socket -# https -# continuation -# verbose -# sender -# async -# replyheaders -# receiver -# ignorestatus -# receiverarg -# maxredirects -# proxy -# - -sub rpc { - my ($uri, $xmlargs, @args) = @_; - - my $data = ''; - my @xhdrs; - my $chunked; - my $param = {'uri' => $uri}; - - if (ref($uri) eq 'HASH') { - $param = $uri; - my $timeout = $param->{'timeout'}; - if ($timeout) { - my %paramcopy = %$param; - delete $paramcopy{'timeout'}; - my $ans; - local $SIG{'ALRM'} = sub {alarm(0); die("rpc timeout\n");}; - eval { - eval { - alarm($timeout); - $ans = rpc(\%paramcopy, $xmlargs, @args); - }; - alarm(0); - die($@) if $@; - }; - die($@) if $@; - return $ans; - } - $uri = $param->{'uri'}; - $data = $param->{'data'}; - @xhdrs = @{$param->{'headers'} || []}; - $chunked = 1 if $param->{'chunked'}; - if (!defined($data) && $param->{'request'} && $param->{'request'} eq 'POST' && @args && grep {/^content-type:\sapplication\/x-www-form-urlencoded$/i} @xhdrs) { - for (@args) { - $_ = urlencode($_); - s/%3D/=/; # convert now escaped = back - } - $data = join('&', @args); - @args = (); - } - push @xhdrs, "Content-Length: ".length($data) if defined($data) && !ref($data) && !$chunked && !grep {/^content-length:/i} @xhdrs; - push @xhdrs, "Transfer-Encoding: chunked" if $chunked; - $data = '' unless defined $data; - } - $uri = createuri($param, @args); - my $proxy = $param->{'proxy'}; - my ($proto, $host, $port, $req, $proxytunnel) = createreq($param, $uri, $proxy, \%cookiestore, @xhdrs); - if ($proto eq 'https' || $proxytunnel) { - die("https not supported\n") unless $tossl || $param->{'https'}; - } - local *S; - if (exists($param->{'socket'})) { - *S = $param->{'socket'}; - } else { - if (!$hostlookupcache{$host}) { - my $hostaddr = inet_aton($host); - die("unknown host '$host'\n") unless $hostaddr; - $hostlookupcache{$host} = $hostaddr; - } - socket(S, PF_INET, SOCK_STREAM, $tcpproto) || die("socket: $!\n"); - setsockopt(S, SOL_SOCKET, SO_KEEPALIVE, pack("l",1)); - connect(S, sockaddr_in($port, $hostlookupcache{$host})) || die("connect to $host:$port: $!\n"); - if ($proxytunnel) { - BSHTTP::swrite(\*S, $proxytunnel); - my $ans = ''; - do { - die("received truncated answer\n") if !sysread(S, $ans, 1024, length($ans)); - } while ($ans !~ /\n\r?\n/s); - die("bad answer\n") unless $ans =~ s/^HTTP\/\d+?\.\d+?\s+?(\d+[^\r\n]*)/Status: $1/s; - my $status = $1; - die("proxy tunnel: CONNECT method failed: $status\n") unless $status =~ /^200[^\d]/; - } - ($param->{'https'} || $tossl)->(\*S, $param->{'ssl_keyfile'}, $param->{'ssl_certfile'}, 1) if $proto eq 'https' || $proxytunnel; - } - if (!$param->{'continuation'}) { - if ($param->{'verbose'}) { - print "> $_\n" for split("\r\n", $req); - #print "> $data\n" unless ref($data); - } - $req .= "$data" unless ref($data); - if ($param->{'sender'}) { - $param->{'sender'}->($param, \*S, $req); - } else { - while(1) { - BSHTTP::swrite(\*S, $req); - last unless ref $data; - $req = &$data($param, \*S); - if (!defined($req) || !length($req)) { - $req = $data = ''; - $req = "0\r\n\r\n" if $chunked; - next; - } - $req = sprintf("%X\r\n", length($req)).$req."\r\n" if $chunked; - } - } - if ($param->{'async'}) { - my $ret = {}; - $ret->{'uri'} = $uri; - my $fd = gensym; - *$fd = \*S; - $ret->{'socket'} = $fd; - $ret->{'async'} = 1; - $ret->{'continuation'} = 1; - $ret->{'request'} = $param->{'request'} || 'GET'; - $ret->{'verbose'} = $param->{'verbose'} if $param->{'verbose'}; - $ret->{'replyheaders'} = $param->{'replyheaders'} if $param->{'replyheaders'}; - $ret->{'receiver'} = $param->{'receiver'} if $param->{'receiver'}; - $ret->{$_} = $param->{$_} for grep {/^receiver:/} keys %$param; - $ret->{'receiverarg'} = $xmlargs if $xmlargs; - return $ret; - } - } - my $ans = ''; - do { - die("received truncated answer\n") if !sysread(S, $ans, 1024, length($ans)); - } while ($ans !~ /\n\r?\n/s); - die("bad answer\n") unless $ans =~ s/^HTTP\/\d+?\.\d+?\s+?(\d+[^\r\n]*)/Status: $1/s; - my $status = $1; - $ans =~ /^(.*?)\n\r?\n(.*)$/s; - my $headers = $1; - $ans = $2; - if ($param->{'verbose'}) { - print "< $_\n" for split(/\r?\n/, $headers); - } - my %headers; - BSHTTP::gethead(\%headers, $headers); - if ($status =~ /^200[^\d]/) { - undef $status; - } elsif ($status =~ /^302[^\d]/) { - # XXX: should we do the redirect if $param->{'ignorestatus'} is defined? - close S; - die("error: no redirects allowed\n") unless defined $param->{'maxredirects'}; - die("error: status 302 but no 'location' header found\n") unless exists $headers{'location'}; - die("error: max number of redirects reached\n") if $param->{'maxredirects'} < 1; - my %myparam = %$param; - $myparam{'uri'} = $headers{'location'}; - $myparam{'maxredirects'} = $param->{'maxredirects'} - 1; - return rpc(\%myparam, $xmlargs, @args); - } else { - #if ($param->{'verbose'}) { - # 1 while sysread(S, $ans, 1024, length($ans)); - # print "< $ans\n"; - #} - if ($status =~ /^(\d+) +(.*?)$/) { - die("$1 remote error: $2\n") unless $param->{'ignorestatus'}; - } else { - die("remote error: $status\n") unless $param->{'ignorestatus'}; - } - } - if ($headers{'set-cookie'} && $param->{'uri'}) { - my @cookie = split(',', $headers{'set-cookie'}); - s/;.*// for @cookie; - if ($param->{'uri'} =~ /((:?https?):\/\/(?:([^\/]*)\@)?(?:[^\/:]+)(?::\d+)?)(?:\/.*)$/) { - my %cookie = map {$_ => 1} @cookie; - push @cookie, grep {!$cookie{$_}} @{$cookiestore{$1} || []}; - splice(@cookie, 10) if @cookie > 10; - $cookiestore{$1} = \@cookie; - } - } - if (($param->{'request'} || '') eq 'HEAD') { - close S; - ${$param->{'replyheaders'}} = \%headers if $param->{'replyheaders'}; - return \%headers; - } - $headers{'__socket'} = \*S; - $headers{'__data'} = $ans; - my $receiver; - $receiver = $param->{'receiver:'.lc($headers{'content-type'} || '')}; - $receiver ||= $param->{'receiver'}; - $xmlargs ||= $param->{'receiverarg'}; - if ($receiver) { - $ans = $receiver->(\%headers, $param, $xmlargs); - $xmlargs = undef; - } else { - $ans = BSHTTP::read_data(\%headers, undef, 1); - } - close S; - delete $headers{'__socket'}; - delete $headers{'__data'}; - ${$param->{'replyheaders'}} = \%headers if $param->{'replyheaders'}; - #if ($param->{'verbose'}) { - # print "< $ans\n"; - #} - if ($xmlargs) { - die("answer is not xml\n") if $ans !~ /<.*?>/s; - my $res = XMLin($xmlargs, $ans); - return $res; - } - return $ans; -} - -1; diff --git a/bs_copy/BSSSL.pm b/bs_copy/BSSSL.pm deleted file mode 100644 index 8b5ec5d3d..000000000 --- a/bs_copy/BSSSL.pm +++ /dev/null @@ -1,140 +0,0 @@ -# -# Copyright (c) 2007 Michael Schroeder, Novell Inc. -# -# This program is free software; you can redistribute it and/or modify -# it under the terms of the GNU General Public License version 2 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 -# -################################################################ -# -# SSL Socket wrapper. Like Net::SSLeay::Handle, but can tie -# inplace and also supports servers. Plus, it uses the more useful -# Net::SSLeay::read instead of Net::SSLeay::ssl_read_all. -# - -package BSSSL; - -use Socket; -use Net::SSLeay; - -use strict; - -my $sslctx; - -sub initctx { - my ($keyfile, $certfile) = @_; - Net::SSLeay::load_error_strings(); - Net::SSLeay::SSLeay_add_ssl_algorithms(); - Net::SSLeay::randomize(); - $sslctx = Net::SSLeay::CTX_new() or die("CTX_new failed!\n"); - Net::SSLeay::CTX_set_options($sslctx, &Net::SSLeay::OP_ALL); - if ($keyfile) { - Net::SSLeay::CTX_use_RSAPrivateKey_file($sslctx, $keyfile, &Net::SSLeay::FILETYPE_PEM) || die("RSAPrivateKey $keyfile failed\n"); - } - if ($certfile) { - Net::SSLeay::CTX_use_certificate_file($sslctx, $certfile, &Net::SSLeay::FILETYPE_PEM) || die("certificate $keyfile failed\n"); - } -} - -sub freectx { - Net::SSLeay::CTX_free($sslctx); - undef $sslctx; -} - -sub tossl { - local *S = $_[0]; - tie(*S, 'BSSSL', @_); -} - -sub TIEHANDLE { - my ($self, $socket, $keyfile, $certfile, $forceconnect) = @_; - - initctx() unless $sslctx; - my $ssl = Net::SSLeay::new($sslctx) or die("SSL_new failed\n"); - Net::SSLeay::set_fd($ssl, fileno($socket)); - if ($keyfile) { - Net::SSLeay::use_RSAPrivateKey_file($ssl, $keyfile, &Net::SSLeay::FILETYPE_PEM) || die("RSAPrivateKey $keyfile failed\n"); - } - if ($certfile) { - Net::SSLeay::use_certificate_file($ssl, $certfile, &Net::SSLeay::FILETYPE_PEM) || die("certificate $certfile failed\n"); - } - if (defined($keyfile) && !$forceconnect) { - Net::SSLeay::accept($ssl) == 1 || die("SSL_accept\n"); - } else { - Net::SSLeay::connect($ssl) || die("SSL_connect"); - } - return bless [$ssl, $socket]; -} - -sub PRINT { - my $sslr = shift; - my $r = 0; - for my $msg (@_) { - next unless defined $msg; - $r = Net::SSLeay::write($sslr->[0], $msg) or last; - } - return $r; -} - -sub READLINE { - my ($sslr) = @_; - return Net::SSLeay::ssl_read_until($sslr->[0]); -} - -sub READ { - my ($sslr, undef, $len, $offset) = @_; - my $buf = \$_[1]; - my $r = Net::SSLeay::read($sslr->[0], $len); - return undef unless defined $r; - return length($$buf = $r) unless defined $offset; - my $bl = length($$buf); - $$buf .= chr(0) x ($offset - $bl) if $offset > $bl; - substr($$buf, $offset) = $r; - return length($r); -} - -sub WRITE { - my ($sslr, $buf, $len, $offset) = @_; - return $len unless $len; - return Net::SSLeay::write($sslr->[0], substr($buf, $offset || 0, $len)) ? $len : undef; -} - -sub FILENO { - my ($sslr) = @_; - return Net::SSLeay::get_fd($sslr->[0]); -} - -sub CLOSE { - my ($sslr) = @_; - if (tied($sslr->[1]) && tied($sslr->[1]) eq $sslr) { - untie($sslr->[1]); - close($sslr->[1]); - } else { - Net::SSLeay::free($sslr->[0]); - undef $sslr->[0]; - } - undef $sslr->[1]; -} - -sub UNTIE { - my ($sslr) = @_; - Net::SSLeay::free($sslr->[0]); - undef $sslr->[0]; -} - -sub DESTROY { - my ($sslr) = @_; - UNTIE($sslr) if $sslr && $sslr->[0]; -} - -1; diff --git a/bs_copy/BSUtil.pm b/bs_copy/BSUtil.pm deleted file mode 100644 index 915c1b9e1..000000000 --- a/bs_copy/BSUtil.pm +++ /dev/null @@ -1,593 +0,0 @@ -# -# Copyright (c) 2006, 2007 Michael Schroeder, Novell Inc. -# -# This program is free software; you can redistribute it and/or modify -# it under the terms of the GNU General Public License version 2 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 -# -################################################################ -# -# collection of useful functions -# - -package BSUtil; - -require Exporter; -@ISA = qw(Exporter); -@EXPORT = qw{writexml writestr readxml readstr ls mkdir_p xfork str2utf8 data2utf8 str2utf8xml data2utf8xml}; - -use XML::Structured; -use POSIX; -use Fcntl qw(:DEFAULT :flock); -use Encode; -use Storable (); -use IO::Handle; - -use strict; - -our $fdatasync_before_rename; - -sub set_fdatasync_before_rename { - $fdatasync_before_rename = 1; - if (!defined(&File::Sync::fdatasync_fd)) { - eval { - require File::Sync; - }; - warn($@) if $@; - *File::Sync::fdatasync_fd = sub {} unless defined &File::Sync::fdatasync_fd; - } -} - -sub do_fdatasync { - my ($fd) = @_; - set_fdatasync_before_rename() unless defined &File::Sync::fdatasync_fd; - File::Sync::fdatasync_fd($fd); -} - -sub writexml { - my ($fn, $fnf, $dd, $dtd) = @_; - my $d = XMLout($dtd, $dd); - local *F; - open(F, '>', $fn) || die("$fn: $!\n"); - (syswrite(F, $d) || 0) == length($d) || die("$fn write: $!\n"); - do_fdatasync(fileno(F)) if defined($fnf) && $fdatasync_before_rename; - close(F) || die("$fn close: $!\n"); - return unless defined $fnf; - $! = 0; - rename($fn, $fnf) || die("rename $fn $fnf: $!\n"); -} - -sub writestr { - my ($fn, $fnf, $d) = @_; - local *F; - open(F, '>', $fn) || die("$fn: $!\n"); - if (length($d)) { - (syswrite(F, $d) || 0) == length($d) || die("$fn write: $!\n"); - } - do_fdatasync(fileno(F)) if defined($fnf) && $fdatasync_before_rename; - close(F) || die("$fn close: $!\n"); - return unless defined $fnf; - rename($fn, $fnf) || die("rename $fn $fnf: $!\n"); -} - -sub appendstr { - my ($fn, $d) = @_; - local *F; - open(F, '>>', $fn) || die("$fn: $!\n"); - if (length($d)) { - (syswrite(F, $d) || 0) == length($d) || die("$fn write: $!\n"); - } - close(F) || die("$fn close: $!\n"); -} - -sub readstr { - my ($fn, $nonfatal) = @_; - local *F; - if (!open(F, '<', $fn)) { - die("$fn: $!\n") unless $nonfatal; - return undef; - } - my $d = ''; - 1 while sysread(F, $d, 8192, length($d)); - close F; - return $d; -} - -sub readxml { - my ($fn, $dtd, $nonfatal) = @_; - my $d = readstr($fn, $nonfatal); - return $d unless defined $d; - if ($d !~ /<.*?>/s) { - die("$fn: not xml\n") unless $nonfatal; - return undef; - } - return XMLin($dtd, $d) unless $nonfatal; - eval { $d = XMLin($dtd, $d); }; - return $@ ? undef : $d; -} - -sub fromxml { - my ($d, $dtd, $nonfatal) = @_; - return XMLin($dtd, $d) unless $nonfatal; - eval { $d = XMLin($dtd, $d); }; - return $@ ? undef : $d; -} - -sub toxml { - my ($d, $dtd) = @_; - return XMLout($dtd, $d); -} - -sub touch($) { - my ($file) = @_; - if (-e $file) { - utime(time, time, $file); - } else { - # create new file, mtime is anyway current - local *F; - open(F, '>>', $file) || die("$file: $!\n"); - close(F) || die("$file close: $!\n"); - } -} - -sub ls { - local *D; - opendir(D, $_[0]) || return (); - my @r = grep {$_ ne '.' && $_ ne '..'} readdir(D); - closedir D; - return @r; -} - -sub mkdir_p { - my ($dir) = @_; - - return 1 if -d $dir; - my $pdir; - if ($dir =~ /^(.+)\//) { - $pdir = $1; - mkdir_p($pdir) || return undef; - } - while (!mkdir($dir, 0777)) { - my $e = $!; - return 1 if -d $dir; - if (defined($pdir) && ! -d $pdir) { - mkdir_p($pdir) || return undef; - next; - } - $! = $e; - warn("mkdir: $dir: $!\n"); - return undef; - } - return 1; -} - -# calls mkdir_p and changes ownership of the created directory to the -# supplied user and group if provided. -sub mkdir_p_chown { - my ($dir, $user, $group) = @_; - - if (!(-d $dir)) { - mkdir_p($dir) || return undef; - } - return 1 unless defined($user) || defined($group); - - $user = -1 unless defined $user; - $group = -1 unless defined $group; - - if ($user !~ /^-?\d+$/ && !($user = getpwnam($user))) { - warn "user $user unknown\n"; return undef - } - if ($group !~ /^-?\d+$/ && !($group = getgrnam($group))) { - warn "group $group unknown\n"; return undef - } - - my @s = stat($dir); - if ($s[4] != $user || $s[5] != $group) { - if (!chown $user, $group, $dir) { - warn "failed to chown $dir to $user:$group\n"; return undef; - } - } - return 1; -} - -sub drop_privs_to { - my ($user, $group) = @_; - - if (defined($group)) { - $group = getgrnam($group) unless $group =~ /^\d+$/; - die("unknown group\n") unless defined $group; - if ($) != $group || $( != $group) { - ($), $() = ($group, $group); - die("setgid: $!\n") if $) != $group; - } - } - if (defined($user)) { - $user = getpwnam($user) unless $user =~ /^\d+$/; - die("unknown user\n") unless defined $user; - if ($> != $user || $< != $user) { - ($>, $<) = ($user, $user); - die("setuid: $!\n") if $> != $user; - } - } -} - -sub cleandir { - my ($dir) = @_; - - my $ret = 1; - return 1 unless -d $dir; - for my $c (ls($dir)) { - if (! -l "$dir/$c" && -d _) { - cleandir("$dir/$c"); - $ret = undef unless rmdir("$dir/$c"); - } else { - $ret = undef unless unlink("$dir/$c"); - } - } - return $ret; -} - -sub linktree { - my ($from, $to) = @_; - return unless -d $from; - mkdir_p($to); - my @todo = sort(ls($from)); - while (@todo) { - my $f = shift @todo; - if (! -l "$from/$f" && -d _) { - mkdir_p("$to/$f"); - unshift @todo, map {"$f/$_"} ls("$from/$f"); - } else { - link("$from/$f", "$to/$f") || die("link $from/$f $to/$f: $!\n"); - } - } -} - -sub treeinfo { - my ($dir) = @_; - my @info; - my @todo = sort(ls($dir)); - while (@todo) { - my $f = shift @todo; - my @s = lstat("$dir/$f"); - next unless @s; - if (-d _) { - push @info, "$f"; - unshift @todo, map {"$f/$_"} ls("$dir/$f"); - } else { - push @info, "$f $s[9]/$s[7]/$s[1]"; - } - } - return \@info; -} - -sub xfork { - my $pid; - while (1) { - $pid = fork(); - last if defined $pid; - die("fork: $!\n") if $! != POSIX::EAGAIN; - sleep(5); - } - return $pid; -} - -sub cp { - my ($from, $to, $tof) = @_; - local *F; - local *T; - open(F, '<', $from) || die("$from: $!\n"); - open(T, '>', $to) || die("$to: $!\n"); - my $buf; - while (sysread(F, $buf, 8192)) { - (syswrite(T, $buf) || 0) == length($buf) || die("$to write: $!\n"); - } - close(F); - close(T) || die("$to: $!\n"); - if (defined($tof)) { - rename($to, $tof) || die("rename $to $tof: $!\n"); - } -} - -sub checkutf8 { - my ($oct) = @_; - Encode::_utf8_off($oct); - return 1 unless defined $oct; - return 1 unless $oct =~ /[\200-\377]/; - eval { - Encode::_utf8_on($oct); - encode('UTF-8', $oct, Encode::FB_CROAK); - }; - return $@ ? 0 : 1; -} - -sub str2utf8 { - my ($oct) = @_; - return $oct unless defined $oct; - return $oct unless $oct =~ /[^\011\012\015\040-\176]/s; - eval { - Encode::_utf8_on($oct); - $oct = encode('UTF-8', $oct, Encode::FB_CROAK); - }; - if ($@) { - # assume iso-8859-1 - eval { - Encode::_utf8_off($oct); - $oct = encode('UTF-8', $oct, Encode::FB_CROAK); - }; - if ($@) { - Encode::_utf8_on($oct); - $oct = encode('UTF-8', $oct, Encode::FB_XMLCREF); - } - } - Encode::_utf8_off($oct); # just in case... - return $oct; -} - -sub data2utf8 { - my ($d) = @_; - if (ref($d) eq 'ARRAY') { - for my $dd (@$d) { - if (ref($dd) eq '') { - $dd = str2utf8($dd); - } else { - data2utf8($dd); - } - } - } elsif (ref($d) eq 'HASH') { - for my $dd (keys %$d) { - if (ref($d->{$dd}) eq '') { - $d->{$dd} = str2utf8($d->{$dd}); - } else { - data2utf8($d->{$dd}); - } - } - } -} - -sub str2utf8xml { - my ($oct) = @_; - return $oct unless defined $oct; - return $oct unless $oct =~ /[^\011\012\015\040-\176]/s; - $oct = str2utf8($oct); - Encode::_utf8_on($oct); - # xml does not accept all utf8 chars, escape the illegal - $oct =~ s/([\000-\010\013\014\016-\037\177])/sprintf("&#x%x;",ord($1))/sge; - $oct =~ s/([\x{d800}-\x{dfff}\x{fffe}\x{ffff}])/sprintf("&#x%x;",ord($1))/sge; - Encode::_utf8_off($oct); - return $oct; -} - -sub data2utf8xml { - my ($d) = @_; - if (ref($d) eq 'ARRAY') { - for my $dd (@$d) { - if (ref($dd) eq '') { - $dd = str2utf8xml($dd); - } else { - data2utf8xml($dd); - } - } - } elsif (ref($d) eq 'HASH') { - for my $dd (keys %$d) { - if (ref($d->{$dd}) eq '') { - $d->{$dd} = str2utf8xml($d->{$dd}); - } else { - data2utf8xml($d->{$dd}); - } - } - } -} - -sub waituntilgone { - my ($fn, $timeout) = @_; - while (1) { - return 1 unless -e $fn; - return 0 if defined($timeout) && $timeout <= 0; - select(undef, undef, undef, .1); - $timeout -= .1 if defined $timeout; - } -} - -sub lockopen { - my ($fg, $op, $fn, $nonfatal) = @_; - - local *F = $fg; - while (1) { - if (!open(F, $op, $fn)) { - return undef if $nonfatal; - die("$fn: $!\n"); - } - flock(F, LOCK_EX) || die("flock $fn: $!\n"); - my @s = stat(F); - return 1 if @s && $s[3]; - close F; - } -} - -sub lockcheck { - my ($op, $fn) = @_; - local *F; - while (1) { - if (!open(F, $op, $fn)) { - return -1; - } - if (!flock(F, LOCK_EX | LOCK_NB)) { - close(F); - return 0; - } - my @s = stat(F); - close F; - return 1 if @s && $s[3]; - } -} - -sub lockopenxml { - my ($fg, $op, $fn, $dtd, $nonfatal) = @_; - if (!lockopen($fg, $op, $fn, $nonfatal)) { - die("$fn: $!\n") unless $nonfatal; - return undef; - } - my $d = readxml($fn, $dtd, $nonfatal); - if (!$d) { - local *F = $fg; - close F; - } - return $d; -} - -sub lockcreatexml { - my ($fg, $fn, $fnf, $dd, $dtd) = @_; - - local *F = $fg; - writexml($fn, undef, $dd, $dtd); - open(F, '<', $fn) || die("$fn: $!\n"); - flock(F, LOCK_EX | LOCK_NB) || die("lock: $!\n"); - if (!link($fn, $fnf)) { - unlink($fn); - close F; - return undef; - } - unlink($fn); - return 1; -} - -sub isotime { - my ($t) = @_; - my @lt = localtime($t || time()); - return sprintf "%04d-%02d-%02d %02d:%02d:%02d", $lt[5] + 1900, $lt[4] + 1, @lt[3,2,1,0]; -} - -# XXX: does that really belong here? -# -# Algorithm: -# each enable/disable has a score: -# +1 if it's a disable -# +2 if the arch matches -# +4 if the repo matches -# -sub enabled { - my ($repoid, $disen, $default, $arch) = @_; - - # filter matching elements, check for shortcuts - return $default unless $disen; - my @dis = grep { (!defined($_->{'arch'}) || $_->{'arch'} eq $arch) && - (!defined($_->{'repository'}) || $_->{'repository'} eq $repoid) - } @{$disen->{'disable'} || []}; - return 1 if !@dis && $default; - my @ena = grep { (!defined($_->{'arch'}) || $_->{'arch'} eq $arch) && - (!defined($_->{'repository'}) || $_->{'repository'} eq $repoid) - } @{$disen->{'enable'} || []}; - return @dis ? 0 : $default unless @ena; - return @ena ? 1 : $default unless @dis; - - # have @dis and @ena, need to do score thing... - my $disscore = 0; - for (@dis) { - my $score = 1; - $score += 2 if defined($_->{'arch'}); - $score += 4 if defined($_->{'repository'}); - if ($score > $disscore) { - return 0 if $score == 7; # can't max this! - $disscore = $score; - } - } - my $enascore = 0; - for (@ena) { - my $score = 0; - $score += 2 if defined($_->{'arch'}); - $score += 4 if defined($_->{'repository'}); - if ($score > $enascore) { - return 1 if $enascore == 6; # can't max this! - $enascore = $score; - } - } - return $enascore > $disscore ? 1 : 0; -} - -sub store { - my ($fn, $fnf, $dd) = @_; - if ($fdatasync_before_rename && defined($fnf)) { - local *F; - open(F, '>', $fn) || die("$fn: $!\n"); - if (!Storable::nstore_fd($dd, \*F)) { - die("nstore_fd $fn: $!\n"); - } - (\*F)->flush(); - do_fdatasync(fileno(F)); - close(F) || die("$fn close: $!\n"); - } else { - if (!Storable::nstore($dd, $fn)) { - die("nstore $fn: $!\n"); - } - } - return unless defined $fnf; - $! = 0; - rename($fn, $fnf) || die("rename $fn $fnf: $!\n"); -} - -sub retrieve { - my ($fn, $nonfatal) = @_; - my $dd; - if (!$nonfatal) { - $dd = ref($fn) ? Storable::fd_retrieve($fn) : Storable::retrieve($fn); - die("retrieve $fn: $!\n") unless $dd; - } else { - eval { - $dd = ref($fn) ? Storable::fd_retrieve($fn) : Storable::retrieve($fn); - }; - if (!$dd && $nonfatal == 2) { - if ($@) { - warn($@); - } else { - warn("retrieve $fn: $!\n"); - } - } - } - return $dd; -} - -sub ping { - my ($pingfile) = @_; - local *F; - if (sysopen(F, $pingfile, POSIX::O_WRONLY|POSIX::O_NONBLOCK)) { - syswrite(F, 'x'); - close(F); - } -} - -sub restartexit { - my ($arg, $name, $runfile, $pingfile) = @_; - return unless $arg; - if ($arg eq '--stop' || $arg eq '--exit') { - if (!(-e "$runfile.lock") || lockcheck('>>', "$runfile.lock")) { - print "$name not running.\n"; - exit 0; - } - print "exiting $name...\n"; - BSUtil::touch("$runfile.exit"); - ping($pingfile) if $pingfile; - BSUtil::waituntilgone("$runfile.exit"); - exit(0); - } - if ($ARGV[0] eq '--restart') { - die("$name not running.\n") if !(-e "$runfile.lock") || BSUtil::lockcheck('>>', "$runfile.lock"); - print "restarting $name...\n"; - BSUtil::touch("$runfile.restart"); - ping($pingfile) if $pingfile; - BSUtil::waituntilgone("$runfile.restart"); - exit(0); - } -} - -1; diff --git a/bs_copy/BSXML.pm b/bs_copy/BSXML.pm deleted file mode 100644 index c9e10fabe..000000000 --- a/bs_copy/BSXML.pm +++ /dev/null @@ -1,1671 +0,0 @@ -# -# Copyright (c) 2006, 2007 Michael Schroeder, Novell Inc. -# Copyright (c) 2008 Adrian Schroeter, Novell Inc. -# -# This program is free software; you can redistribute it and/or modify -# it under the terms of the GNU General Public License version 2 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 -# -################################################################ -# -# XML templates for the BuildService. See XML/Structured. -# - -package BSXML; - -use strict; - -# -# an explained example entry of this file -# -#our $pack = [ creates space -# 'package' => -# 'name', -# 'project', -# [], before the [] all strings become attributes to -# 'title', from here on all strings become children like -# 'description', -# [[ 'person' => creates children, the [[ ]] syntax allows any number of them including zero -# 'role', again role and userid attributes, both are required -# 'userid', -# ]], this block describes a construct -# @flags, copies in the block of possible flag definitions -# [ $repo ], refers to the repository construct and allows again any number of them (0-X) -#]; closes the child with - -our $repo = [ - 'repository' => - 'name', - 'rebuild', - 'block', - 'linkedbuild', - [[ 'releasetarget' => - 'project', - 'repository', - 'trigger', - ]], - [[ 'path' => - 'project', - 'repository', - ]], - [ 'hostsystem' => - 'project', - 'repository', - ], - [ 'base' => # expanded repo only! - 'project', - 'repository', - ], - [ 'arch' ], - 'status', -]; - -our @disableenable = ( - [[ 'disable' => - 'arch', - 'repository', - ]], - [[ 'enable' => - 'arch', - 'repository', - ]], -); - -our @flags = ( - [ 'lock' => @disableenable ], - [ 'build' => @disableenable ], - [ 'publish' => @disableenable ], - [ 'debuginfo' => @disableenable ], - [ 'useforbuild' => @disableenable ], - [ 'binarydownload' => @disableenable ], - [ 'sourceaccess' => @disableenable ], - [ 'access' => @disableenable ], -); - -our @roles = ( - [[ 'person' => - 'role', - 'userid', - ]], - [[ 'group' => - 'role', - 'groupid', - ]], -); - -our $download = [ - 'download' => - 'baseurl', - 'metafile', - 'mtype', - 'arch', -]; - -our $maintenance = [ - 'maintenance' => - [[ 'maintains' => - 'project', - ]], -]; - -our $proj = [ - 'project' => - 'name', - 'kind', - [], - 'title', - 'description', - [[ 'link' => - 'project', - ]], - 'remoteurl', - 'remoteproject', - 'mountproject', - [ 'devel', => - 'project', - ], - @roles, - [ $download ], - $maintenance, - @flags, - [ $repo ], -]; - -our $pack = [ - 'package' => - 'name', - 'project', - [], - 'title', - 'description', - [ 'devel', => - 'project', - 'package', - ], - @roles, - @disableenable, - @flags, - 'url', - 'bcntsynctag', -]; - -our $packinfo = [ - 'info' => - 'repository', - 'name', - 'file', - 'error', - [ 'dep' ], - [ 'prereq' ], - [ 'imagetype' ], # kiwi - [ 'imagearch' ], # kiwi - 'nodbgpkgs', # kiwi - 'nosrcpkgs', # kiwi - [[ 'path' => - 'project', - 'repository', - ]], - [[ 'extrasource' => - 'project', - 'package', - 'srcmd5', - 'file', - ]], -]; - -our $linked = [ - 'linked' => - 'project', - 'package', -]; - -our $aggregatelist = [ - 'aggregatelist' => - [[ 'aggregate' => - 'project', - [], - 'nosources', - [ 'package' ], - [ 'binary' ], - [[ 'repository' => - 'target', - 'source', - ]], - ]], -]; - -# former: kernel - 123 - 1 123: incident -# now: sec-123 - 1 -1 -our $patchinfo = [ - 'patchinfo' => - 'incident', # optional, gets replaced on with updateinfoid on release - 'version', # optional, defaults to 1 - [], - [ 'package' ],# optional - [ 'binary' ], # optional - [[ 'releasetarget' => # optional - 'project', - 'repository', - ]], - [[ 'issue' => - 'tracker', - 'id', - 'documented', - [], - '_content', - ]], - 'category', - 'rating', - 'name', # optional, old patchinfo name which will become part of incident string - 'summary', - 'description', - 'swampid', # obsolete - 'packager', - 'stopped', - 'zypp_restart_needed', - 'reboot_needed', - 'relogin_needed', -]; - -our $channel = [ - 'channel' => - [ 'product' => - 'project', - 'name', - ], - [[ 'target' => - 'project', - 'repository', - 'tag', # optional - ]], - [[ 'binaries' => - 'project', - 'repository', - 'arch', - [[ 'binary' => - 'name', - 'binaryarch', - 'project', - 'repository', - 'package', - 'arch', - 'supportstatus', - ]], - ]], -]; - -our $projpack = [ - 'projpack' => - 'repoid', - [[ 'project' => - 'name', - 'kind', - [], - 'title', - 'description', - 'config', - 'patternmd5', - [[ 'link' => - 'project', - ]], - 'remoteurl', - 'remoteproject', - @flags, - @roles, - [ $repo ], - [ $download ], - [[ 'package' => - 'name', - 'rev', - 'srcmd5', # commit id - 'versrel', - 'verifymd5', # tree id - 'originproject', - 'revtime', - 'constraintsmd5', # md5sum of constraints file in srcmd5 - [ $linked ], - 'error', - [ $packinfo ], - $aggregatelist, - $patchinfo, - $channel, - @flags, - 'bcntsynctag', - ]], - 'missingpackages', - ]], - [[ 'remotemap' => - 'project', - 'root', - 'remoteurl', - 'remoteproject', - 'remoteroot', - 'partition', - 'proto', # project data not included - [], - 'config', - @flags, - @roles, - [ $repo ], - 'error', - ]], -]; - -our $linkinfo = [ - 'linkinfo' => - # information from link - 'project', - 'package', - 'rev', - 'srcmd5', - 'baserev', - 'missingok', - # expanded / unexpanded srcmd5 - 'xsrcmd5', - 'lsrcmd5', - 'error', - 'lastworking', - [ $linked ], -]; - -our $serviceinfo = [ - 'serviceinfo' => - # information in case a source service is part of package - 'code', # can be "running", "failed", "succeeded" - 'xsrcmd5', - 'lsrcmd5', - [], - 'error', # contains error message (with new lines) in case of error -]; - -our $dir = [ - 'directory' => - 'name', - 'count', # obsolete, the API sets this for some requests - 'rev', - 'vrev', - 'srcmd5', - 'tproject', # obsolete, use linkinfo - 'tpackage', # obsolete, use linkinfo - 'trev', # obsolete, use linkinfo - 'tsrcmd5', # obsolete, use linkinfo - 'lsrcmd5', # obsolete, use linkinfo - 'error', - 'xsrcmd5', # obsolete, use linkinfo - $linkinfo, - $serviceinfo, - [[ 'entry' => - 'name', - 'md5', - 'size', - 'mtime', - 'error', - 'id', - 'originproject', # for package listing - ]] -]; - -our $fileinfo = [ - 'fileinfo' => - 'filename', - [], - 'name', - 'epoch', - 'version', - 'release', - 'arch', - 'source', - 'summary', - 'description', - 'size', - 'mtime', - [ 'provides' ], - [ 'requires' ], - [ 'prerequires' ], - [ 'conflicts' ], - [ 'obsoletes' ], - [ 'recommends' ], - [ 'supplements' ], - [ 'suggests' ], - [ 'enhances' ], - - [[ 'provides_ext' => - 'dep', - [[ 'requiredby' => - 'name', - 'epoch', - 'version', - 'release', - 'arch', - 'project', - 'repository', - ]], - ]], - [[ 'requires_ext' => - 'dep', - [[ 'providedby' => - 'name', - 'epoch', - 'version', - 'release', - 'arch', - 'project', - 'repository', - ]], - ]], -]; - -our $sourceinfo = [ - 'sourceinfo' => - 'package', - 'rev', - 'vrev', - 'srcmd5', - 'lsrcmd5', - 'verifymd5', - [], - 'filename', - 'error', - 'originproject', - [ $linked ], - 'revtime', - 'changesmd5', - - 'name', - 'version', - 'release', - [ 'subpacks' ], - [ 'deps' ], - [ 'prereqs' ], - [ 'exclarch' ], - [ 'badarch' ], -]; - -our $sourceinfolist = [ - 'sourceinfolist' => - [ $sourceinfo ], -]; - -our $buildinfo = [ - 'buildinfo' => - 'project', - 'repository', - 'package', - 'srcserver', - 'reposerver', - 'downloadurl', - [], - 'job', - 'arch', - 'hostarch', # for cross build - 'error', - 'srcmd5', - 'verifymd5', - 'rev', - 'disturl', - 'reason', # just for the explain string of a build reason - 'needed', # number of blocked - 'revtime', # time of last commit - 'readytime', - 'specfile', # obsolete - 'file', - 'versrel', - 'bcnt', - 'release', - 'debuginfo', - 'constraintsmd5', - [ 'prjconfconstraint' ], - [ 'subpack' ], - [ 'imagetype' ], # kiwi - 'nodbgpkgs', # kiwi - 'nosrcpkgs', # kiwi - [ 'dep' ], - [[ 'bdep' => - 'name', - 'preinstall', - 'vminstall', - 'cbpreinstall', - 'cbinstall', - 'runscripts', - 'notmeta', - 'noinstall', - - 'epoch', - 'version', - 'release', - 'arch', - 'project', - 'repository', - 'repoarch', - 'binary', - 'package', - 'srcmd5', - ]], - [ 'pdep' ], # obsolete - [[ 'path' => - 'project', - 'repository', - 'server', - ]], - [[ 'syspath' => - 'project', - 'repository', - 'server', - ]], - 'expanddebug', - 'followupfile', # for two-stage builds - 'masterdispatched', # dispatched through a master dispatcher -]; - -our $jobstatus = [ - 'jobstatus' => - 'code', - 'result', # succeeded, failed or unchanged - 'details', - [], - 'starttime', - 'endtime', - 'workerid', - 'hostarch', - - 'uri', # uri to reach worker - - 'arch', # our architecture - 'job', # our jobname - 'jobid', # md5 of job info file -]; - -our $buildreason = [ - 'reason' => - [], - 'explain', # Readable reason - 'time', # unix time from start build - 'oldsource', # last build source md5 sum, if a source change was the reason - [[ 'packagechange' => # list changed files which are used for building - 'change', # kind of change (content/meta change, additional file or removed file) - 'key', # file name - ]], -]; - -our $buildstatus = [ - 'status' => - 'package', - 'code', - 'status', # obsolete, now code - 'error', # obsolete, now details - [], - 'details', - - 'workerid', # last build data - 'hostarch', - 'readytime', - 'starttime', - 'endtime', - - 'job', # internal, job when building - - 'uri', # obsolete - 'arch', # obsolete -]; - -our $builddepinfo = [ - 'builddepinfo' => - [[ 'package' => - 'name', - [], - 'source', - [ 'pkgdep' ], - [ 'subpkg' ], - ]], - [[ 'cycle' => - [ 'package' ], - ]], -]; - -our $event = [ - 'event' => - 'type', - [], - 'project', - 'repository', - 'arch', - 'package', - 'job', - 'due', -]; - -our $events = [ - 'events' => - 'next', - 'sync', - [ $event ], -]; - -our $revision = [ - 'revision' => - 'rev', - 'vrev', - [], - 'srcmd5', - 'version', - 'time', - 'user', - 'comment', - 'requestid', -]; - -our $revision_acceptinfo = [ - @$revision, - [ 'acceptinfo' => - 'rev', - 'srcmd5', - 'osrcmd5', - 'xsrcmd5', - 'oxsrcmd5', - ], -]; - -our $revisionlist = [ - 'revisionlist' => - [ $revision ] -]; - -our $buildhist = [ - 'buildhistory' => - [[ 'entry' => - 'rev', - 'srcmd5', - 'versrel', - 'bcnt', - 'time', - ]], -]; - -our $binaryversionlist = [ - 'binaryversionlist' => - [[ 'binary' => - 'name', # should be filename instead. sigh. - 'sizek', - 'error', - 'hdrmd5', - 'metamd5', - 'leadsigmd5', - ]], -]; - -our $packagebinaryversionlist = [ - 'packagebinaryversionlist' => - [[ 'binaryversionlist' => - 'package', - 'code', - [[ 'binary' => - 'name', - 'sizek', - 'error', - 'hdrmd5', - 'metamd5', - 'leadsigmd5', - ]], - ]], -]; - -our $worker = [ - 'worker' => - 'hostarch', - 'ip', - 'port', - 'workerid', - [ 'buildarch' ], - [ 'hostlabel' ], - 'sandbox', - [ 'linux' => - [], - 'version', - 'flavor' - ], - [ 'hardware' => - [ 'cpu' => - [ 'flag' ], - ], - 'processors', - 'memory', # in MBytes - 'swap', # in MBytes - 'disk', # in MBytes - ], - 'owner', - 'tellnojob', - - 'job', # set when worker is busy - 'arch', # set when worker is busy - 'jobid', # set when worker is busy - 'reposerver', # set when worker is busy and job was masterdispatched -]; - -our $packstatuslist = [ - 'packstatuslist' => - 'project', - 'repository', - 'arch', - [[ 'packstatus' => - 'name', - 'status', - 'error', - ]], - [[ 'packstatussummary' => - 'status', - 'count', - ]], -]; - -our $linkpatch = [ - '' => - [ 'add' => - 'name', - 'type', - 'after', - 'popt', - 'dir', - ], - [ 'apply' => - 'name', - ], - [ 'delete' => - 'name', - ], - 'branch', - 'topadd', -]; - -our $link = [ - 'link' => - 'project', - 'package', - 'rev', - 'vrev', - 'cicount', - 'baserev', - 'missingok', - [ 'patches' => - [ $linkpatch ], - ], -]; - -our $workerstatus = [ - 'workerstatus' => - 'clients', - [[ 'idle' => - 'uri', - 'workerid', - 'hostarch', - ]], - [[ 'building' => - 'uri', - 'workerid', - 'hostarch', - 'project', - 'repository', - 'package', - 'arch', - 'starttime', - ]], - [[ 'waiting', => - 'arch', - 'jobs', - ]], - [[ 'blocked', => - 'arch', - 'jobs', - ]], - [[ 'buildavg', => - 'arch', - 'buildavg', - ]], - [[ 'partition' => - 'name', - [[ 'daemon' => - 'type', # scheduler/dispatcher/signer/publisher/warden - 'arch', # scheduler only - 'state', - 'starttime', - [ 'queue' => # scheduler only - 'high', - 'med', - 'low', - 'next', - ], - ]], - ]], -]; - -our $workerstate = [ - 'workerstate' => - 'state', - 'nextstate', # for exit/restart - 'jobid', -]; - -our $jobhistlay = [ - 'package', - 'rev', - 'srcmd5', - 'versrel', - 'bcnt', - 'readytime', - 'starttime', - 'endtime', - 'code', - 'uri', - 'workerid', - 'hostarch', - 'reason', - 'verifymd5', -]; - -our $jobhist = [ - 'jobhist' => - @$jobhistlay, -]; - -our $jobhistlist = [ - 'jobhistlist' => - [ $jobhist ], -]; - -our $ajaxstatus = [ - 'ajaxstatus' => - [[ 'watcher' => - 'filename', - 'state', - [[ 'job' => - 'id', - 'ev', - 'fd', - 'peer', - 'request', - ]], - ]], - [[ 'rpc' => - 'uri', - 'state', - 'ev', - 'fd', - [[ 'job' => - 'id', - 'ev', - 'fd', - 'peer', - 'starttime', - 'request', - ]], - ]], - [[ 'serialize' => - 'filename', - [[ 'job' => - 'id', - 'ev', - 'fd', - 'peer', - 'request', - ]], - ]], -]; - -our $serverstatus = [ - 'serverstatus' => - [[ 'job' => - 'id', - 'starttime', - 'pid', - 'peer', - 'request', - 'group', - ]], -]; - -##################### new api stuff - -our $binarylist = [ - 'binarylist' => - 'package', - [[ 'binary' => - 'filename', - 'size', - 'mtime', - ]], -]; - -our $summary = [ - 'summary' => - [[ 'statuscount' => - 'code', - 'count', - ]], -]; - -our $schedulerstats = [ - 'stats' => - 'lastchecked', - 'checktime', - 'lastfinished', - 'lastpublished', -]; - -our $result = [ - 'result' => - 'project', - 'repository', - 'arch', - 'code', # pra state, can be "unknown", "broken", "scheduling", "blocked", "building", "finished", "publishing", "published" or "unpublished" - 'state', # old name of 'code', to be removed - 'details', - 'dirty', # marked for re-scheduling if element exists, state might not be correct anymore - [ $buildstatus ], - [ $binarylist ], - $summary, - $schedulerstats, -]; - -our $resultlist = [ - 'resultlist' => - 'state', - 'retryafter', - [ $result ], -]; - -our $opstatus = [ - 'status' => - 'code', - 'origin', - [], - 'summary', - 'details', - [[ 'data' => - 'name', - '_content', - ]], - [ 'exception' => - 'type', - 'message', - [ 'backtrace' => - [ 'line' ], - ], - ], -]; - -my $rpm_entry = [ - 'rpm:entry' => - 'kind', - 'name', - 'epoch', - 'ver', - 'rel', - 'flags', -]; - -our $pattern = [ - 'pattern' => - 'xmlns', # obsolete, moved to patterns - 'xmlns:rpm', # obsolete, moved to patterns - [], - 'name', - 'arch', - [[ 'version' => - 'epoch', - 'ver', - 'rel', - ]], - [[ 'summary' => - 'lang', - '_content', - ]], - [[ 'description' => - 'lang', - '_content', - ]], - 'default', - 'uservisible', - [[ 'category' => - 'lang', - '_content', - ]], - 'icon', - 'script', - [ 'rpm:provides' => [ $rpm_entry ], ], - [ 'rpm:conflicts' => [ $rpm_entry ], ], - [ 'rpm:obsoletes' => [ $rpm_entry ], ], - [ 'rpm:requires' => [ $rpm_entry ], ], - [ 'rpm:suggests' => [ $rpm_entry ], ], - [ 'rpm:enhances' => [ $rpm_entry ], ], - [ 'rpm:supplements' => [ $rpm_entry ], ], - [ 'rpm:recommends' => [ $rpm_entry ], ], -]; - -our $patterns = [ - 'patterns' => - 'count', - 'xmlns', - 'xmlns:rpm', - [], - [ $pattern ], -]; - -our $ymp = [ - 'metapackage' => - 'xmlns:os', - 'xmlns', - [], - [[ 'group' => - 'recommended', - 'distversion', - [], - 'name', - 'summary', - 'description', - 'remainSubscribed', - [ 'repositories' => - [[ 'repository' => - 'recommended', - 'format', - 'producturi', - [], - 'name', - 'summary', - 'description', - 'url', - ]], - ], - [ 'software' => - [[ 'item' => - 'type', - 'recommended', - 'architectures', - 'action', - [], - 'name', - 'summary', - 'description', - ]], - ], - ]], -]; - -our $binary_id = [ - 'binary' => - 'name', - 'project', - 'package', - 'repository', - 'version', - 'release', - 'arch', - 'filename', - 'filepath', - 'baseproject', - 'type', -]; - -our $pattern_id = [ - 'pattern' => - 'name', - 'project', - 'repository', - 'arch', - 'filename', - 'filepath', - 'baseproject', - 'type', -]; - -our $request = [ - 'request' => - 'id', - 'type', # obsolete, still here to handle OBS pre-1.5 requests - 'key', # cache key, not really in request - 'retryafter', # timed out waiting for a key change - [[ 'action' => - 'type', # currently submit, delete, change_devel, add_role, maintenance_release, maintenance_incident, set_bugowner - [ 'source' => - 'project', - 'package', - 'rev', # belongs to package attribute - 'repository', # for merge request - ], - [ 'target' => - 'project', - 'package', - 'releaseproject', # for incident request - 'repository', # for release and delete request - ], - [ 'person' => - 'name', - 'role', - ], - [ 'group' => - 'name', - 'role', - ], - [ 'options' => - [], - 'sourceupdate', # can be cleanup, update or noupdate - 'updatelink', # can be true or false - ], - [ 'acceptinfo' => - 'rev', - 'srcmd5', - 'osrcmd5', - 'xsrcmd5', - 'oxsrcmd5', - ], - ]], - [ 'submit' => # this is old style, obsolete by request, but still supported - [ 'source' => - 'project', - 'package', - 'rev', - ], - [ 'target' => - 'project', - 'package', - ], - ], - [ 'state' => - 'name', - 'who', - 'when', - 'superseded_by', # set when state.name is "superseded" - [], - 'comment', - ], - [[ 'review' => - 'state', # review state (new/accepted or declined) - 'by_user', # this user shall review it - 'by_group', # one of this groupd shall review it - # either user or group must be used, never both - 'by_project', # any maintainer of this project can review it - 'by_package', # any maintainer of this package can review it (requires by_project) - 'who', # this user has reviewed it - 'when', - [], - 'comment', - ]], - [[ 'history' => - 'name', - 'who', - 'when', - 'superseded_by', - [], - 'comment', - ]], - 'accept_at', - 'title', - 'description', -]; - -our $repositorystate = [ - 'repositorystate' => - [ 'blocked' ], -]; - -our $collection = [ - 'collection' => - 'matches', - 'limited', - [ $request ], - [ $proj ], - [ $pack ], - [ $binary_id ], - [ $pattern_id ], - [ 'value' ], -]; - -our $quota = [ - 'quota' => - 'packages', - [[ 'project' => - 'name', - 'packages', - ]], -]; - -our $schedulerinfo = [ - 'schedulerinfo' => - 'arch', - 'started', - 'time', - [], - 'slept', - 'notready', - [ 'queue' => - 'high', - 'med', - 'low', - 'next', - ], - 'projects', - 'repositories', - [[ 'worst' => - 'project', - 'repository', - 'packages', - 'time', - ]], - 'buildavg', - 'avg', - 'variance', -]; - -our $person = [ - 'person' => - 'login', - 'email', - 'realname', - 'state', - [ 'globalrole' ], - [ 'watchlist' => - [[ 'project' => - 'name', - ]], - ], -]; - -our $comps = [ - 'comps' => - [[ 'group' => - [], - 'id', - [[ 'description' => - 'xml:lang', - '_content', - ]], - [[ 'name' => - 'xml:lang', - '_content', - ]], - [ 'packagelist' => - [[ 'packagereq' => - 'type', - '_content', - ]], - ], - ]], -]; - -our $dispatchprios = [ - 'dispatchprios' => - [[ 'prio' => - 'project', - 'repository', - 'arch', - 'adjust', - ]], -]; - -# list of used services for a package or project -our $services = [ - 'services' => - [[ 'service' => - 'name', - 'mode', # "localonly" is skipping this service on server side, "trylocal" is trying to merge changes directly in local files, "disabled" is just skipping it - [[ 'param' => - 'name', - '_content' - ]], - ]], -]; - -# service type definitions -our $servicetype = [ - 'service' => - 'name', - 'hidden', # "true" to suppress it from service list in GUIs - [], - 'summary', - 'description', - [[ 'parameter' => - 'name', - [], - 'description', - 'required', # don't run without this parameter - 'allowmultiple', # This parameter can be used multiple times - [ 'allowedvalue' ], # list of possible values - ]], -]; - -our $servicelist = [ - 'servicelist' => - [ $servicetype ], -]; - -our $updateinfoitem = [ - 'update' => - 'from', - 'status', - 'type', - 'version', - [], - 'id', - 'title', - 'severity', - 'release', - [ 'issued' => - 'date', - ], - [ 'updated' => - 'date', - ], - 'reboot_suggested', - [ 'references' => - [[ 'reference' => - 'href', - 'id', - 'title', - 'type', - ]], - ], - 'description', - [ 'pkglist', - [[ 'collection' => - 'short', - [], - 'name', - [[ 'package' => - 'name', - 'epoch', - 'version', - 'release', - 'arch', - 'src', - 'supportstatus', - [], - 'filename', - [ 'sum' => # obsolete? - 'type', - '_content', - ], - 'reboot_suggested', - 'restart_suggested', - 'relogin_suggested', - ]], - ]], - ], -]; - -our $updateinfo = [ - 'updates' => - 'xmlns', - [ $updateinfoitem ], -]; - -our $deltapackage = [ - 'newpackage' => - 'name', - 'epoch', - 'version', - 'release', - 'arch', - [[ 'delta' => - 'oldepoch', - 'oldversion', - 'oldrelease', - [], - 'filename', - 'sequence', - 'size', - [ 'checksum' => - 'type', - '_content', - ], - ]], -]; - -our $deltainfo = [ - 'deltainfo' => - [ $deltapackage ], -]; - -our $prestodelta = [ - 'prestodelta' => - [ $deltapackage ], -]; - -our $sourcediff = [ - 'sourcediff' => - 'key', - [ 'old' => - 'project', - 'package', - 'rev', - 'srcmd5', - ], - [ 'new' => - 'project', - 'package', - 'rev', - 'srcmd5', - ], - [ 'files' => - [[ 'file' => - 'state', # added, deleted, changed - [ 'old' => - 'name', - 'md5', - 'size', - 'mtime', - ], - [ 'new' => - 'name', - 'md5', - 'size', - 'mtime', - ], - [ 'diff' => - 'binary', - 'lines', - 'shown', - '_content', - ], - ]], - ], - [ 'issues' => - [[ 'issue' => - 'state', - 'tracker', - 'name', - 'label', - 'url', - ]] - ], -]; - -our $configuration = [ - 'configuration' => - [], - 'title', #webui only - 'description', #webui only - 'name', #obsname - 'anonymous', - 'registration', - 'default_access_disabled', - 'allow_user_to_create_home_project', - 'multiaction_notify_support', - 'disallow_group_creation', - 'change_password', - 'cleanup_after_days', - 'hide_private_options', - 'gravatar', - 'enforce_project_keys', - 'download_on_demand', - 'download_url', - 'ymp_url', - 'errbit_url', - 'bugzilla_url', - 'http_proxy', - 'no_proxy', - 'admin_email', - 'theme', - 'cleanup_empty_projects', - 'disable_publish_for_branches', - [ 'schedulers' => - [ 'arch' ], - ], -]; - -our $issue_trackers = [ - 'issue-trackers' => - [[ 'issue-tracker' => - [], - 'name', - 'description', - 'kind', - 'label', - 'enable-fetch', - 'regex', - 'user', -# 'password', commented out on purpose, should not reach backend - 'show-url', - 'url', - 'issues-updated', - ]], -]; - -our $appdataitem = [ - 'application' => - [ 'id' => - 'type', - '_content' - ], - 'pkgname', - 'name', - 'summary', - [ 'icon' => - 'type', - [], - 'name', - [[ 'filecontent' => - 'file', - '_content' - ]], - ], - [ 'appcategories' => - [ 'appcategory' ] - ], - [ 'mimetypes' => - [ 'mimetype' ] - ], - [ 'keywords' => - [ 'keyword' ] - ], - [ 'url' => - 'type', - '_content' - ] -]; - -our $appdata = [ - 'applications' => - 'version', - [ $appdataitem ] -]; - -our $attribute = [ - 'attribute' => - 'namespace', - 'name', - 'binary', - [ 'value' ], - [[ 'issue' => - 'name', - 'tracker' - ]], -]; - -our $attributes = [ - 'attributes' => - [ $attribute ], -]; - -our $size = [ - 'size' => - 'unit', - [], - '_content', -]; - -our $time = [ - 'time' => - 'unit', - [], - '_content', -]; - -# define constraints for build jobs in packages or projects. -our @constraint = ( - [[ 'hostlabel' => - 'exclude', # true or false. default is false. - [], - '_content' # workers might get labels defined by admin, for example for benchmarking. - ]], - [ 'sandbox' => - 'exclude', # true or false. default is false. - [], - '_content' # xen/kvm/zvm/lxc/emulator/chroot/secure - ], - [ 'linux' => - [ 'version' => - [], - 'max' , - 'min' , - ], - 'flavor', - ], - [ 'hardware' => - [ 'cpu' => - [ 'flag' ], - ], - 'processors', - [ 'disk' => $size ], - [ 'memory' => $size ], - [ 'physicalmemory' => $size ], - ] -); -our $constraints = [ - 'constraints' => - @constraint, - [[ 'overwrite' => - [ 'conditions' => - [ 'arch' ], - [ 'package' ], - ], - @constraint, - ]] -]; - -our $buildstatistics = [ - 'buildstatistics' => - [ 'disk' => - [ 'usage' => - [ 'size' => - 'unit', - [], - '_content', - ], - 'io_requests', - 'io_sectors', - ], - ], - [ 'memory' => - [ 'usage' => $size ], - ], - [ 'times' => - [ 'total' => $time ], - [ 'preinstall' => $time ], - [ 'install' => $time ], - [ 'main' => $time ], - [ 'download' => $time ], - ], - [ 'download' => - [], - $size, - 'binaries', - 'cachehits', - 'preinstallimage', - ], -]; - -our $notifications = [ - 'notifications' => - 'next', - 'sync', - [[ 'notification' => - 'type', - 'time', - [[ 'data' => - 'key', - '_content', - ]], - ]], -]; - -our $frozenlinks = [ - 'frozenlinks' => - [[ 'frozenlink' => - 'project', - [[ 'package' => - 'name', - 'srcmd5', - 'vrev', - ]], - ]], -]; - -1; diff --git a/bs_copy/XML/Structured.pm b/bs_copy/XML/Structured.pm deleted file mode 100644 index 40a3c794a..000000000 --- a/bs_copy/XML/Structured.pm +++ /dev/null @@ -1,532 +0,0 @@ - -package XML::Structured; - -use vars qw($VERSION @ISA @EXPORT); - -require Exporter; -@ISA = qw(Exporter); -@EXPORT = qw(XMLin XMLinfile XMLout); -$VERSION = '1.0'; - -use XML::Parser; -use Encode; - -use strict; - -our $bytes; - -sub import { - $bytes = 1 if grep {$_ eq ':bytes'} @_; - __PACKAGE__->export_to_level(1, grep {$_ ne ':bytes'} @_); -} - -sub _workin { - my ($how, $out, $ain, @in) = @_; - my @how = @$how; - my $am = shift @how; - - my %known = map {ref($_) ? (!@$_ ? () : (ref($_->[0]) ? $_->[0]->[0] : $_->[0] => $_)) : ($_=> $_)} @how; - for my $a (keys %$ain) { - die("unknown attribute: $a\n") unless $known{$a}; - if (ref($known{$a})) { - die("attribute '$a' must be element\n") if @{$known{$a}} > 1 || ref($known{$a}->[0]); - push @{$out->{$a}}, $ain->{$a}; - } else { - die("attribute '$a' must be singleton\n") if exists $out->{$a}; - $out->{$a} = $ain->{$a}; - Encode::_utf8_off($out->{$a}) if $bytes; - } - } - while (@in) { - my ($e, $v) = splice(@in, 0, 2); - my $ke = $known{$e}; - if ($e eq '0') { - next if $v =~ /^\s*$/s; - die("element '$am' contains content\n") unless $known{'_content'}; - Encode::_utf8_off($v) if $bytes; - $v =~ s/\s+$/ /s; - $v =~ s/^\s+/ /s; - if (exists $out->{'_content'}) { - $out->{'_content'} =~ s/ $//s if $v =~ /^ /s; - $out->{'_content'} .= $v; - } else { - $out->{'_content'} = $v; - } - next; - } - if (!$ke && $known{''}) { - $ke = $known{''}; - $v = [{}, $e, $v]; - $e = ''; - } - die("unknown element: $e\n") unless $ke; - if (!ref($ke)) { - push @$v, '0', '' if @$v == 1; - die("element '$e' contains attributes @{[keys %{$v->[0]}]}\n") if %{$v->[0]}; - die("element '$e' has subelements\n") if $v->[1] ne '0'; - die("element '$e' must be singleton\n") if exists $out->{$e}; - Encode::_utf8_off($v->[2]) if $bytes; - $out->{$e} = $v->[2]; - } elsif (@$ke == 1 && !ref($ke->[0])) { - push @$v, '0', '' if @$v == 1; - die("element '$e' contains attributes\n") if %{$v->[0]}; - die("element '$e' has subelements\n") if $v->[1] ne '0'; - Encode::_utf8_off($v->[2]) if $bytes; - push @{$out->{$e}}, $v->[2]; - } else { - if (@$ke == 1) { - push @{$out->{$e}}, {}; - _workin($ke->[0], $out->{$e}->[-1], @$v); - } else { - die("element '$e' must be singleton\n") if exists $out->{$e}; - $out->{$e} = {}; - _workin($ke, $out->{$e}, @$v); - } - } - } - if (exists $out->{'_content'}) { - $out->{'_content'} =~ s/^ //s; - $out->{'_content'} =~ s/ $//s; - } -} - -sub _escape { - my ($d) = @_; - $d =~ s/&/&/sg; - $d =~ s//>/sg; - $d =~ s/"/"/sg; - return $d; -} - -sub _workout { - my ($how, $d, $indent) = @_; - my @how = @$how; - my $am = _escape(shift @how); - my $ret = "$indent<$am"; - my $inelem; - my %d2 = %$d; - my $gotel = 0; - if ($am eq '') { - $ret = ''; - $gotel = $inelem = 1; - $indent = substr($indent, 2); - } - for my $e (@how) { - if (!$inelem && !ref($e) && $e ne '_content') { - next unless exists $d2{$e}; - $ret .= _escape(" $e=").'"'._escape($d2{$e}).'"'; - delete $d2{$e}; - next; - } - $inelem = 1; - next if ref($e) && !@$e; # magic inelem marker - my $en = $e; - $en = $en->[0] if ref($en); - $en = $en->[0] if ref($en); - next unless exists $d2{$en}; - my $ee = _escape($en); - if (!ref($e) && $e eq '_content' && !$gotel) { - $gotel = 2; # special marker to strip indent - $ret .= ">"._escape($d2{$e})."\n"; - delete $d2{$e}; - next; - } - $ret .= ">\n" unless $gotel; - $gotel = 1; - if (!ref($e)) { - die("'$e' must be scalar\n") if ref($d2{$e}); - if ($e eq '_content') { - my $c = $d2{$e}; - $ret .= "$indent "._escape("$c\n"); - delete $d2{$e}; - next; - } - if (defined($d2{$e})) { - $ret .= "$indent <$ee>"._escape($d2{$e})."\n"; - } else { - $ret .= "$indent <$ee/>\n"; - } - delete $d2{$e}; - next; - } elsif (@$e == 1 && !ref($e->[0])) { - die("'$en' must be array\n") unless UNIVERSAL::isa($d2{$en}, 'ARRAY'); - for my $se (@{$d2{$en}}) { - $ret .= "$indent <$ee>"._escape($se)."\n"; - } - delete $d2{$en}; - } elsif (@$e == 1) { - die("'$en' must be array\n") unless UNIVERSAL::isa($d2{$en}, 'ARRAY'); - for my $se (@{$d2{$en}}) { - die("'$en' must be array of hashes\n") unless UNIVERSAL::isa($se, 'HASH'); - $ret .= _workout($e->[0], $se, "$indent "); - } - delete $d2{$en}; - } else { - die("'$en' must be hash\n") unless UNIVERSAL::isa($d2{$en}, 'HASH'); - $ret .= _workout($e, $d2{$en}, "$indent "); - delete $d2{$en}; - } - } - die("excess hash entries: ".join(', ', sort keys %d2)."\n") if %d2; - if ($gotel == 2 && $ret =~ s/\n$//s) { - $ret .= "\n" unless $am eq ''; - } elsif ($gotel) { - $ret .= "$indent\n" unless $am eq ''; - } else { - $ret .= " />\n"; - } - return $ret; -} - -package XML::Structured::saxparser; - -sub new { - return bless []; -} - -sub start_document { - my ($self) = @_; - $self->[0] = []; -} - -sub start_element { - my ($self, $e) = @_; - my %as = map {$_->{'Name'} => $_->{'Value'}} values %{$e->{'Attributes'} || {}}; - push @{$self->[0]}, $e->{'Name'}, [ $self->[0], \%as ]; - $self->[0] = $self->[0]->[-1]; -} - -sub end_element { - my ($self) = @_; - $self->[0] = shift @{$self->[0]}; -} - -sub characters { - my ($self, $c) = @_; - - my $cl = $self->[0]; - if (@$cl > 2 && $cl->[-2] eq '0') { - $cl->[-1] .= $c->{'Data'}; - } else { - push @$cl, '0' => $c->{'Data'}; - } -} - -sub end_document { - my ($self) = @_; - return $self->[0]; -} - -package XML::Structured; - -my $xmlinparser; - -sub _xmlparser { - my ($str) = @_; - my $p = new XML::Parser(Style => 'Tree'); - return $p->parse($str); -} - -sub _saxparser { - my ($str) = @_; - my $handler = new XML::Structured::saxparser; - my $sp = XML::SAX::ParserFactory->parser('Handler' => $handler); - if (ref(\$str) eq 'GLOB' || UNIVERSAL::isa($str, 'IO::Handle')) { - return $sp->parse_file($str); - } - return $sp->parse_string($str); -} - -sub _chooseparser { - eval { require XML::SAX; }; - my $saxok; - if (!$@) { - $saxok = 1; - my $parsers = XML::SAX->parsers(); - return \&_saxparser if $parsers && @$parsers && (@$parsers > 1 || $parsers->[0]->{'Name'} ne 'XML::SAX::PurePerl'); - } - eval { require XML::Parser; }; - return \&_xmlparser unless $@; - return \&_saxparser if $saxok; - die("XML::Structured needs either XML::SAX or XML::Parser\n"); -} - -sub XMLin { - my ($dtd, $str) = @_; - $xmlinparser = _chooseparser() unless defined $xmlinparser; - my $d = $xmlinparser->($str); - my $out = {}; - $d = ['', [{}, @$d]] if $dtd->[0] eq ''; - die("document element must be '$dtd->[0]', was '$d->[0]'\n") if $d->[0] ne $dtd->[0]; - _workin($dtd, $out, @{$d->[1]}); - return $out; -} - -sub XMLinfile { - my ($dtd, $fn) = @_; - local *F; - open(F, '<', $fn) || die("$fn: $!\n"); - my $out = XMLin($dtd, *F); - close F; - return $out; -} - -sub XMLout { - my ($dtd, $d) = @_; - die("parameter is not a hash\n") unless UNIVERSAL::isa($d, 'HASH'); - if ($dtd->[0] eq '') { - die("excess hash elements\n") if keys %$d > 1; - for my $el (@$dtd) { - return _workout($el, $d->{$el->[0]}, '') if ref($el) && $d->{$el->[0]}; - } - die("no match for alternative\n"); - } - return _workout($dtd, $d, ''); -} - -1; - -__END__ - -=head1 NAME - -XML::Structured - simple conversion API from XML to perl structures and back - -=head1 SYNOPSIS - - use XML::Structured; - - $dtd = [ - 'element' => - 'attribute1', - 'attribute2', - [], - 'element1', - [ 'element2' ], - [ 'element3' => - ... - ], - [[ 'element4' => - ... - ]], - ]; - - $hashref = XMLin($dtd, $xmlstring); - $hashref = XMLinfile($dtd, $filename_or_glob); - $xmlstring = XMLout($dtd, $hashref); - -=head1 DESCRIPTION - -The XML::Structured module provides a way to convert xml data into -a predefined perl data structure and back to xml. Unlike with modules -like XML::Simple it is an error if the xml data does not match -the provided skeleton (the "dtd"). Another advantage is that the -order of the attributes and elements is taken from the dtd when -converting back to xml. - -=head2 XMLin() - -The XMLin() function takes the dtd and a string as arguments and -returns a hash reference containing the data. - -=head2 XMLinfile() - -This function works like C, but takes a filename or a -file descriptor glob as second argument. - -=head2 XMLout() - -C provides the reverse operation to C, it takes -a dtd and a hash reference as arguments and returns an XML string. - -=head1 The DTD - -The dtd parameter specifies the structure of the allowed xml data. -It consists of nested perl arrays. - -=head2 simple attributes and elements - -The very simple example for a dtd is: - - $dtd = [ 'user' => - 'login', - 'password', - ]; - -This dtd will accept/create XML like: - - - -XMLin doesn't care if "login" or "password" are attributes or -elements, so - - - foo - bar - - -is also valid input (but doesn't get re-created by C). - -=head2 multiple elements of the same name - -If an element may appear multiple times, it must be declared as -an array in the dtd: - - $dtd = [ 'user' => - 'login', - [ 'favorite_fruits' ], - ]; - -XMLin will create an array reference as value in this case, even if -the xml data contains only one element. Valid XML looks like: - - - apple - peach - - -As attributes may not appear multiple times, XMLout will create -elements for this case. Note also that all attributes must come -before the first element, thus the first array in the dtd ends -the attribute list. As an example, the following dtd - - $dtd = [ 'user' => - 'login', - [ 'favorite_fruits' ], - 'password', - ]; - -will create xml like: - - - apple - peach - bar - - -"login" is translated to an attribute and "password" to an element. - -You can use an empty array reference to force the end of the attribute -list, e.g.: - - $dtd = [ 'user' => - [], - 'login', - 'password', - ]; - -will translate to - - - foo - bar - - -instead of - - - -=head2 sub-elements - -sub-elements are elements that also contain attributes or other -elements. They are specified in the dtd as arrays with more than -one element. Here is an example: - - $dtd = [ 'user' => - 'login', - [ 'address' => - 'street', - 'city', - ], - ]; - -Valid xml for this dtd looks like: - - -
- - -It is sometimes useful to specify such dtds in multiple steps: - - $addressdtd = [ 'address' => - 'street', - 'city', - ]; - - $dtd = [ 'user' => - 'login', - $addressdtd, - ]; - -=head2 multiple sub-elements with the same name - -As with simple elements, one can allow sub-elements to occur multiple -times. C creates an array of hash references in this case. -The dtd specification uses an array reference to an array for this -case, for example: - - $dtd = [ 'user' => - 'login', - [[ 'address' => - 'street', - 'city', - ]], - ]; -Or, with the $addressdtd definition used in the previous example: - - $dtd = [ 'user' => - 'login', - [ $addressdtd ], - ]; - -Accepted XML is: - - -
-
- - -=head2 the _content pseudo-element - -All of the non-whitespace parts between elements get collected -into a single "_content" element. As example, - - -
hello -
world - - -would set the _content element to C (the dtd must allow -a _content element, of course). If the dtd is - - $dtd = [ 'user' => - 'login', - [ $addressdtd ], - '_content', - ]; - -the xml string created by XMLout() will be: - - -
-
- hello world - - -The exact input cannot be re-created, as the positions and the -fragmentation of the content data is lost. - -=head1 SEE ALSO - -B requires either L or L. - -=head1 COPYRIGHT - -Copyright 2006 Michael Schroeder Emls@suse.deE - -This library is free software; you can redistribute it and/or modify it -under the same terms as Perl itself. - -=cut - diff --git a/bs_mirrorfull b/bs_mirrorfull deleted file mode 100755 index 71a7754ac..000000000 --- a/bs_mirrorfull +++ /dev/null @@ -1,99 +0,0 @@ -#!/usr/bin/perl -w - -BEGIN { - my ($wd) = $0 =~ m-(.*)/- ; - $wd ||= '.'; - unshift @INC, "$wd/bs_copy"; -} - -use lib 'bs_copy'; -use BSUtil; -use BSRPC ':https'; -use BSXML; -use BSHTTP; -use Fcntl qw/:flock/; -use File::Path qw/make_path/; - -use strict; - -my $nodebug; - -while (@ARGV) { - if ($ARGV[0] eq '--nodebug') { - $nodebug = 1; - } elsif ($ARGV[0] eq '--') { - shift @ARGV; - last; - } elsif ($ARGV[0] =~ /^-/) { - die("unknown option $ARGV[0]\n"); - } else { - last; - } - shift @ARGV; -} - -if (@ARGV != 2) { - my $message = "Usage: $0 url dir - - Example: $0 https://api.opensuse.org/public/build/YaST:Head/openSUSE_Tumbleweed/x86_64 my-mirror\n"; - die($message); -} -my ($url, $dir) = @ARGV; -$url =~ s/\/$//; - -unless (-d $dir) { - make_path($dir); -} - -open(my $fh, '>', $dir.'/.lock') or die "failed to open lock file: $!\n"; -unless(flock($fh, LOCK_EX|LOCK_NB)) { - print "$dir is locked, waiting ...\n"; - flock($fh, LOCK_EX) or die "failed to lock: $!\n"; - print "... lock released\n"; -} - -#print "receiving tree state\n"; -my $bvl = BSRPC::rpc("$url/_repository", $BSXML::binaryversionlist, "view=binaryversions", "nometa=1"); -my @localbins = grep {/^[0-9a-f]{32}-.+\.rpm$/} ls($dir); -my %localbins = map {$_ => 1} @localbins; -my %remotebins; -for my $bv (@{$bvl->{'binary'} || []}) { - next unless $bv->{'name'} =~ /\.rpm$/; - next if $nodebug && $bv->{'name'} =~ /-debug(?:info|source|info-32bit)\.rpm$/; - $remotebins{"$bv->{'hdrmd5'}-$bv->{'name'}"} = $bv; -} -my @todelete = grep {!$remotebins{$_}} sort keys %localbins; -my @todownload = grep {!$localbins{$_}} sort keys %remotebins; -if (@todelete) { - print "deleting ".@todelete." old packages\n"; - for my $bin (@todelete) { - unlink("$dir/$bin") || die("unlink: $!\n"); - } -} -if (@todownload) { - print "downloading ".@todownload." new packages\n"; - my $todo = @todownload; - my $did = 0; - while (@todownload) { - my @fetch = splice(@todownload, 0, 50); - my @args; - for (@fetch) { - die unless /^[0-9a-f]{32}-(.+)\.rpm$/; - push @args, "binary=$1"; - } - my $param = { - 'uri' => "$url/_repository", - 'directory' => $dir, - 'map' => sub { - my ($param, $name) = @_; - return undef unless $name =~ /^(.+)-([0-9a-f]{32})$/; - return "$2-$1.rpm"; - }, - 'receiver' => \&BSHTTP::cpio_receiver, - }; - BSRPC::rpc($param, undef, 'view=cpioheaders', @args); - $did += @fetch; - #print "$did/$todo\n"; - } -} -#print "done, we now have ".(keys %remotebins)." packages.\n"; diff --git a/dist/package/openSUSE-release-tools.spec b/dist/package/openSUSE-release-tools.spec index 99a9310c8..6ffef65a5 100644 --- a/dist/package/openSUSE-release-tools.spec +++ b/dist/package/openSUSE-release-tools.spec @@ -63,10 +63,6 @@ Requires: python3-requests Requires: python3-typing_extensions %endif -# bs_mirrorfull -Requires: perl-Net-SSLeay -Requires: perl-XML-Parser - # Spec related requirements. Requires: osclib = %{version} @@ -363,7 +359,6 @@ exit 0 %files %doc README.md %{_bindir}/osrt-biarchtool -%{_bindir}/osrt-bs_mirrorfull %{_bindir}/osrt-bugowner %{_bindir}/osrt-build-fail-reminder %{_bindir}/osrt-checknewer