AC-DC
view release on metacpan or search on metacpan
lib/AC/DC/IO.pm view on Meta::CPAN
$me->write(@_);
$me->set_callback('write_buffer_empty', \&shut);
}
sub _writable {
my $me = shift;
return $me->run_callback('writeable', undef) unless $me->{_wbuffer};
my $len = length($me->{_wbuffer});
my $bs = $me->{wbufsize} || $BUFSIZ;
$len = $bs if $len > $bs;
my $buf = substr($me->{_wbuffer}, 0, $len);
my $i = syswrite( $me->{fd}, $buf );
if( defined $i ){
# debug("wrote $i bytes to $me->{info}");
substr($me->{_wbuffer}, 0, $i) = '';
if( length($me->{_wbuffer}) ){
$me->timeout_rel( $me->{writebuf_timeout} ) if $me->{writebuf_timeout};
}else{
$me->wantwrite(0);
$me->run_callback('write_buffer_empty', undef);
}
}else{
my $e = $!;
debug( "write failed ($e) for $me->{info}");
$me->run_callback('error', {
cause => 'write',
lib/AC/DC/Protocol.pm view on Meta::CPAN
use Digest::SHA1;
use Fcntl;
use POSIX;
use Socket;
use Time::HiRes 'time';
use strict;
# header:
# proto version(32)
# message type(32)
# auth length(32)
# data length(32)
# content length(32)
# msgidno(32)
# flags(32): is-reply(0), want-reply(1), is-error(2), data-encrypted(3), content-encrypted(4)
#
# followed by:
# Auth PB(auth-length)
# Data PB(data-length)
# Content(content-length)
my $VERSION = 0x41433032;
my $BUFSIZ = 65536;
my %MSGTYPE;
my %MSGREV;
# status => { num => 0, reqc => '', resc => 'ACPStdReply' },
lib/AC/DC/Protocol.pm view on Meta::CPAN
$MSGTYPE{$name} = $d;
$MSGREV{$num} = $name;
}
################################################################
sub encode_header {
my $me = shift;
my %p = @_;
# type, auth_length, data_length, content_length, msgidno,
# is_reply, want_reply, is_error
my $mt = $MSGTYPE{ $p{type} };
confess "unknown message type $p{type}\n" unless defined $mt;
my $flags = ( $p{is_reply} ? 1 : 0 )
| ( $p{want_reply} ? 2 : 0 )
| ( $p{is_error} ? 4 : 0 )
| ( $p{data_encrypted} ? 8 : 0 )
| ( $p{content_encrypted} ? 16 : 0 );
return pack( "NNNNNNN",
$VERSION, $mt->{num}, $p{auth_length}, $p{data_length}, $p{content_length}, $p{msgidno}, $flags );
}
sub decode_header {
my $me = shift;
my $headr = shift;
my( $ver, $mt, $al, $dl, $cl, $id, $fl )
= unpack("NNNNNNN", $headr);
my %p = (
auth_length => $al,
data_length => $dl,
content_length => $cl,
msgidno => $id,
type => $MSGREV{$mt},
);
confess "unknown protocol version $ver\n" unless $ver == $VERSION;
confess "unknown protocol message $mt\n" unless $p{type};
$p{is_reply} = ($fl & 1) ? 1 : 0;
$p{want_reply} = ($fl & 2) ? 1 : 0;
$p{is_error} = ($fl & 4) ? 1 : 0;
lib/AC/DC/Protocol.pm view on Meta::CPAN
$gpb = $me->encrypt( $auth, $gpb );
}
my $hdr = $me->encode_header(
type => $proto->{type},
want_reply => $proto->{want_reply},
is_reply => $proto->{is_reply},
msgidno => $proto->{msgidno},
data_encrypted => $proto->{data_encrypted},
content_encrypted => $proto->{content_encrypted},
auth_length => length($apb),
data_length => length($gpb),
content_length => ($cont ? length($$cont) : 0),
);
# caller needs to add content. (to avoid large copy)
return $hdr . $apb . $gpb;
}
sub _decode_common {
my $me = shift;
my $how = shift;
lib/AC/DC/Protocol.pm view on Meta::CPAN
my $req = shift;
my $timeo = shift;
$timeo ||= 1;
# set non-blocking
my $fl = fcntl($s, F_GETFL, 0);
fcntl($s, F_SETFL, O_NDELAY);
my $fn = fileno($s);
my $tlen = length($req);
my $slen = 0;
while($tlen){
my $wfd = "\0\0\0\0";
vec($wfd, $fn, 1) = 1;
my $to = $timeo;
my $si = select(undef, $wfd, undef, $to);
confess "write data failed: $!\n" if $si == -1;
confess "write timeout\n" unless vec($wfd, $fn, 1);
lib/AC/DC/Protocol.pm view on Meta::CPAN
$timeo ||= 1;
# set non-blocking
my $fl = fcntl($s, F_GETFL, 0);
fcntl($s, F_SETFL, O_NDELAY);
my $fn = fileno($s);
my $data;
my $start = time();
while( my $len = $size - length($data) ){
$len = $BUFSIZ if $len > $BUFSIZ;
my $rfd = "\0\0\0\0";
vec($rfd, $fn, 1) = 1;
my $to = $start + $timeo - time();
my $t0 = time();
my $si = select($rfd, undef, undef, $to);
next if $si == -1 && $! == EINTR;
confess "read data failed: $!\n" if $si == -1;
confess "read timeout " . (time() - $t0) . "\n" unless vec($rfd, $fn, 1);
my $i = sysread($s, $data, $len, length($data));
next if !defined($i) && $! == EINTR;
confess "read failed: connection closed (read " . length($data) . " of $len)\n" if $i == 0;
}
fcntl($s, F_SETFL, $fl);
return $data;
}
################################################################
# stream fd to other fd
# return hash
lib/AC/DC/Protocol.pm view on Meta::CPAN
# NB: sendfile(2) only supports file=>socket + file=>file
# not socket=>file, ...
# RSN - elastic buffering?
my $sha1 = Digest::SHA1->new();
while($size){
my $len = $size > $BUFSIZ ? $BUFSIZ : $size;
my $buf = $me->read_data($in, $len, $timeo);
my $i = length $buf;
confess "read failed: $!\n" unless $i > 0;
my $w = $me->write_request($out, $buf, $timeo);
$size -= $i;
$sha1->add($buf);
}
return $sha1->b64digest();
}
sub send_request {
lib/AC/DC/Protocol.pm view on Meta::CPAN
$debug->("sending request");
$me->write_request($s, $req, $timeo);
# get response or timeout
$debug->("reading header");
my $buf = $me->read_data($s, header_size(), $timeo);
my $p = $me->decode_header($buf);
# get auth
if( $p->{auth_length} ){
# read gpb
$debug->("reading auth $p->{auth_length}");
my $data = $me->read_data($s, $p->{auth_length}, $timeo);
$p->{auth} = $data;
}
# get data
if( $p->{data_length} ){
# read gpb
$debug->("reading data $p->{data_length}");
my $data = $me->read_data($s, $p->{data_length}, $timeo);
$p->{data} = $data;
}
# get content
if( $p->{content_length} ){
$debug->("reading content $p->{content_length}");
my $data = $me->read_data($s, $p->{content_length}, $timeo);
$p->{content} = $data;
}
return $p;
}
1;
lib/AC/Dumper.pm view on Meta::CPAN
if( ref($val) && $val =~ 'SCALAR' ){
return '<REF>' . $$val;
}
if( ref($val) && $val =~ 'HASH' ){
return '{}' unless keys %$val;
my $out = "{\n";
# align nicely
my $maxl = 0;
$maxl = (length($_) > $maxl) ? length($_) : $maxl for keys %$val;
for my $k (sort keys %$val){
my $v = _dump($val->{$k}, $seen);
$v =~ s/\n(.)/\n $1/gm; # indent
$out .= sprintf " %-${maxl}s => %s\n", $k, $v;
}
$out .= "}";
return $out;
}
if( ref($val) && $val =~ 'ARRAY' ){
lib/AC/Misc.pm view on Meta::CPAN
use strict;
our @EXPORT = qw(inet_atoi inet_ntoi inet_iton inet_itoa inet_lton inet_ntoa inet_aton
inet_valid inet_normalize
random_text random_bytes unique
url_encode url_decode
encode_base64_safe decode_base64_safe
hex_dump shuffle);
# network length => packed netmask
sub inet_lton {
my $l = shift;
pack 'N', (0xFFFFFFFF << (32-$l));
}
# ascii => integer
sub inet_atoi {
my $a = shift;
return inet_ntoi(inet_aton($a));
lib/AC/Misc.pm view on Meta::CPAN
################################################################
sub hex_dump {
my $s = shift;
my $r;
my $off = 0;
while( my $l = substr($s,0, 16, '') ){
(my $t = $l) =~ s/\W/\./g;
my $h = unpack('H*', $l) . (' ' x (16 - length($l)));
$h =~ s/(..)/$1 /g;
$h =~ s/(.{24})/$1 /;
$r .= sprintf('%04X: ', $off) . "$h $t\n";
$off += 16;
}
$r;
}
lib/AC/Misc.pm view on Meta::CPAN
return $u;
}
sub decode_base64_safe {
my $u = shift;
$u =~ tr%-._%+/=%;
$u =~ tr%\r\n\t %%d; # remove white
# re-add final =s
my $l = length($u) %4;
$u .= '=' x (4-$l) if $l;
return decode_base64($u);
}
################################################################
sub url_encode {
my $txt = shift;
lib/AC/Misc.pm view on Meta::CPAN
$txt =~ s/%(..)/chr(hex $1)/ge;
return $txt;
}
################################################################
my $rndbuf;
sub random_bytes {
my $len = shift;
unless( length($rndbuf) >= $len ){
if( open(RND, "/dev/urandom") ){
my $buf;
my $rl = $len > 512 ? $len : 512;
sysread(RND, $buf, $rl);
$rndbuf .= $buf;
close RND;
}else{
# QQQ - complain?
$rndbuf .= pack('N', rand(0xffffffff)) while(length($rndbuf) < $len);
}
}
return substr($rndbuf, 0, $len, '');
}
sub random_text {
my $len = shift;
return substr( encode_base64_safe( random_bytes( ($len * 3 + 3) >> 2 )),
lib/AC/Misc.pm view on Meta::CPAN
# a unique identifier
sub unique {
my $len = shift;
my $tag = shift;
$unique_n ||= rand(256);
_init_myip();
my $u = encode_base64_safe( pack('Vna4n', time(), $$, $myip, $unique_n++)
^ "\xDE\xAD\xDE\xAD\xD0\x0D\xA5\xC3\xCA\x53\xC3\xA3" );
$u .= random_text($len - length($u)) if $len > length($u);
return $tag . $u;
}
################################################################
sub _init_myip {
$myip ||= gethostbyname( hostname() );
die "cannot determine my IP!\n" unless $myip;
}
( run in 0.548 second using v1.01-cache-2.11-cpan-65fba6d93b7 )