yudaike/openSUSE-release-tools
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge pull request #126 from openSUSE/coolo_sync

Browse Source 
Coolo sync
This commit is contained in:
Alberto Planas 2014-03-28 16:36:21 +01:00
commit c3d82eff67
9 changed files with 3800 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

401
bs_copy/BSHTTP.pm Normal file
View File

@ -0,0 +1,401 @@
#
# 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;

354
bs_copy/BSRPC.pm Normal file
View File

@ -0,0 +1,354 @@
#
# 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;

140
bs_copy/BSSSL.pm Normal file
View File

@ -0,0 +1,140 @@
#
# 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;

593
bs_copy/BSUtil.pm Normal file
View File

@ -0,0 +1,593 @@
#
# 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;

1671
bs_copy/BSXML.pm Normal file
View File

File diff suppressed because it is too large Load Diff

532
bs_copy/XML/Structured.pm Normal file
View File

@ -0,0 +1,532 @@
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/&/&amp;/sg;
$d =~ s/</&lt;/sg;
$d =~ s/>/&gt;/sg;
$d =~ s/"/&quot;/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})."</$ee>\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)."</$ee>\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 .= "</$am>\n" unless $am eq '';
} elsif ($gotel) {
$ret .= "$indent</$am>\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<XMLin()>, but takes a filename or a
file descriptor glob as second argument.
=head2 XMLout()
C<XMLout()> provides the reverse operation to C<XMLin()>, 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:
<user login="foo" password="bar" />
XMLin doesn't care if "login" or "password" are attributes or
elements, so
<user>
<login>foo</login>
<password>bar</password>
</user>
is also valid input (but doesn't get re-created by C<XMLout()>).
=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:
<user login="foo">
<favorite_fruits>apple</favorite_fruits>
<favorite_fruits>peach</favorite_fruits>
</user>
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:
<user login="foo">
<favorite_fruits>apple</favorite_fruits>
<favorite_fruits>peach</favorite_fruits>
<password>bar</password>
</user>
"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
<user>
<login>foo</login>
<password>bar</password>
</user>
instead of
<user login="foo" password="bar" />
=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:
<user login="foo">
<address street="broadway 7" city="new york" />
</user>
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<XMLin()> 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:
<user login="foo">
<address street="broadway 7" city="new york" />
<address street="rural road 12" city="tempe" />
</user>
=head2 the _content pseudo-element
All of the non-whitespace parts between elements get collected
into a single "_content" element. As example,
<user login="foo">
<address street="broadway 7" city="new york"/>hello
<address street="rural road 12" city="tempe"/>world
</user>
would set the _content element to C<hello world> (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:
<user login="foo">
<address street="broadway 7" city="new york" />
<address street="rural road 12" city="tempe" />
hello world
</user>
The exact input cannot be re-created, as the positions and the
fragmentation of the content data is lost.
=head1 SEE ALSO
B<XML::Structured> requires either L<XML::Parser> or L<XML::SAX>.
=head1 COPYRIGHT
Copyright 2006 Michael Schroeder E<lt>mls@suse.deE<gt>
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
=cut

75
bs_mirrorfull Executable file
View File

@ -0,0 +1,75 @@
#!/usr/bin/perl -w
use lib 'bs_copy';
use BSUtil;
use BSRPC ':https';
use BSXML;
use BSHTTP;
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;
}
die("uasge: bs_mirrorfull url dir\n") unless @ARGV == 2;
my ($url, $dir) = @ARGV;
$url =~ s/\/$//;
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";

16
osc-check_repo.py
View File

@ -202,6 +202,7 @@ class Package_(object):
def __repr__(self):
return 'PKG: %s\nSRC: %s\nDEPS: %s\n SUBS: %s' % (self.pkg, self.src, self.deps, self.subs)
TMPDIR = '/var/cache/repo-checker' # Where the cache files are stored
def memoize(ttl=None):
"""Decorator function to implement a persistent cache.
@ -260,7 +261,6 @@ def memoize(ttl=None):
"""
# Configuration variables
TMPDIR = '~/.cr-cache' # Where the cache files are stored
SLOTS = 4096 # Number of slots in the cache file
NCLEAN = 1024 # Number of slots to remove when limit reached
TIMEOUT = 60*60*2 # Time to live for every cache slot (seconds)
@ -970,9 +970,8 @@ def _check_repo_group(self, id_, reqs, opts):
os.mkdir(dir)
os.symlink(d, os.path.join(dir, os.path.basename(d)))
repochecker = os.path.dirname(os.path.realpath(os.path.expanduser('~/.osc-plugins/osc-check_repo.py')))
repochecker = os.path.join(repochecker, 'repo-checker.pl')
civs = "LC_ALL=C perl %s '%s' -f %s 2>&1" % (repochecker, destdir, params_file.name)
repochecker = os.path.join(self.repocheckerdir, 'repo-checker.pl')
civs = "LC_ALL=C perl %s '%s' -r %s -f %s 2>&1" % (repochecker, destdir, self.repodir, params_file.name)
#print civs
#continue
#exit(1)
@ -1087,6 +1086,15 @@ def do_check_repo(self, subcmd, opts, *args):
a.append(p)
groups[p.group] = a
self.repocheckerdir = os.path.dirname(os.path.realpath(os.path.expanduser('~/.osc-plugins/osc-check_repo.py')))
self.repodir = "%s/repo-%s-%s" % (TMPDIR, 'openSUSE:Factory', 'standard')
if not os.path.exists(self.repodir):
os.mkdir(self.repodir)
civs = "LC_ALL=C perl %s/bs_mirrorfull --nodebug https://build.opensuse.org/build/%s/%s/x86_64 %s" % (self.repocheckerdir,
'openSUSE:Factory',
'standard', self.repodir)
os.system(civs)
# Sort the groups, from high to low. This put first the stating
# projects also
for id_, reqs in sorted(groups.items(), reverse=True):

37
repo-checker.pl
View File

@ -15,18 +15,24 @@ use Fcntl;
use strict;
my $ret = 0;
my $dir = $ARGV[0];
my $dir = shift @ARGV;
my %toignore;
if ($ARGV[1] eq "-f") {
open(TOIGNORE, $ARGV[2]) || die "can't open $ARGV[2]";
while ( <TOIGNORE> ) {
chomp;
$toignore{$_} = 1;
}
close(TOIGNORE);
} else {
foreach my $name (split(/,/, $ARGV[1])) {
$toignore{$name} = 1;
my $repodir;
while (@ARGV) {
my $switch = shift @ARGV;
if ($switch eq "-f") {
my $toignore = shift @ARGV;
open(TOIGNORE, $toignore) || die "can't open $toignore";
while ( <TOIGNORE> ) {
chomp;
$toignore{$_} = 1;
}
close(TOIGNORE);
} elsif ($switch eq "-r") {
$repodir = shift @ARGV;
} else {
print "read the source luke: $switch ? \n";
exit(1);
}
}
@ -52,7 +58,7 @@ for my $pdir (glob("$dir/*")) {
my %targets;
my %cache;
foreach my $file (glob("~/cache/*")) {
foreach my $file (glob("$repodir/.cache/*")) {
if ($file =~ m,/(\d+)\.(\d+)-([^/]*)$,) {
$cache{"$1.$2"} = $3;
}
@ -80,7 +86,7 @@ sub write_package($$)
if (defined $toignore{$name}) {
return;
}
open(C, $ENV{'HOME'} . "/cache/$mtime.$ino-$name") || die "no cache for $package";
open(C, "$repodir/.cache/$mtime.$ino-$name") || die "no cache for $package";
while ( <C> ) {
print PACKAGES $_;
}
@ -171,7 +177,8 @@ sub write_package($$)
$out .= "-Obs:\n";
if ($ignore == 1) {
open(C, '>', $ENV{'HOME'} . "/cache/$mtime.$ino-$name") || die "no writeable cache for $package";
mkdir("$repodir/.cache");
open(C, '>', "$repodir/.cache/$mtime.$ino-$name") || die "no writeable cache for $package";
print C $out;
close(C);
}
@ -179,7 +186,7 @@ sub write_package($$)
print PACKAGES $out;
}
my @rpms = glob("~/factory-repo/*.rpm");
my @rpms = glob("$repodir/*.rpm");
my $pfile = $ENV{'HOME'} . "/packages";
open(PACKAGES, ">", $pfile) || die 'can not open';
print PACKAGES "=Ver: 2.0\n";