add mls' script to mirror repos from build service
This commit is contained in:
Stephan Kulow
parent
1465f7ee02
commit
7b090def1a
401
bs_copy/BSHTTP.pm
Normal file
401
bs_copy/BSHTTP.pm
Normal 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
354
bs_copy/BSRPC.pm
Normal 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
140
bs_copy/BSSSL.pm
Normal 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
593
bs_copy/BSUtil.pm
Normal 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
1671
bs_copy/BSXML.pm
Normal file
File diff suppressed because it is too large
Load Diff
532
bs_copy/XML/Structured.pm
Normal file
532
bs_copy/XML/Structured.pm
Normal 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/&/&/sg;
|
||||||
|
$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})."</$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
75
bs_mirrorfull
Executable 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";
|
||||||
Loading…
x
Reference in New Issue
Block a user