AC-DC
view release on metacpan or search on metacpan
lib/AC/ConfigFile/Simple.pm view on Meta::CPAN
my $MINSTAT = 15;
my %CONFIG = (
include => \&include_file,
debug => \&parse_debug,
allow => \&parse_allow,
_default => \&parse_keyvalue,
);
sub new {
my $class = shift;
my $file = shift;
my $me = bless {
_laststat => $^T,
_lastconf => $^T,
_configfile => $file,
_files => [ ],
@_,
}, $class;
$me->_read();
return $me;
}
sub check {
my $me = shift;
my $now = $^T;
return if $now - $me->{_laststat} < $MINSTAT;
$me->{_laststat} = $now;
my $changed;
for my $file ( @{$me->{_files}} ){
my $mtime = (stat($file))[9];
$changed = 1 if $mtime > $me->{_lastconf};
lib/AC/ConfigFile/Simple.pm view on Meta::CPAN
}
};
if(my $e = $@){
problem("error reading new config file: $e");
return;
}
return 1;
}
sub _read {
my $me = shift;
delete $me->{_pending};
$me->_readfile($me->{_configfile});
$me->{config} = $me->{_pending};
delete $me->{_pending};
}
sub _readfile {
my $me = shift;
my $file = shift;
my $fd;
open($fd, $file) || die "cannot open file '$file': $!";
$me->{fd} = $fd;
push @{$me->{_files}}, $file;
while( defined(my $l = $me->_nextline()) ){
my($key, $rest) = split /\s+/, $l, 2;
$me->handle_config( $key, $rest ) || die "invalid config '$key'\n";
}
close $fd;
}
sub handle_config {
my $me = shift;
my $key = shift;
my $rest = shift;
my $fnc = $CONFIG{$key} || $CONFIG{_default};
return unless $fnc;
$fnc->($me, $key, $rest);
return 1;
}
sub _nextline {
my $me = shift;
my $line;
while(1){
my $fd = $me->{fd};
my $l = <$fd>;
return $line unless defined $l;
chomp $l;
lib/AC/ConfigFile/Simple.pm view on Meta::CPAN
if( $line =~ /\\$/ ){
chop $line;
next;
}
return $line;
}
}
################################################################
sub include_file {
my $me = shift;
my $key = shift;
my $file = shift;
$file =~ s/^"(.*)"$/$1/;
if( $file !~ m|^/| ){
# add path from main config file
my($path) = $me->{_configfile} =~ m|(.*)/[^/]+$|;
$file = "$path/$file" if $path;
}
my $fd = $me->{fd};
$me->_readfile($file);
$me->{fd} = $fd;
}
sub parse_keyvalue {
my $me = shift;
my $key = shift;
my $value = shift;
problem("parameter '$key' redefined") if $me->{_pending}{$key};
$me->{_pending}{$key} = $value;
}
sub parse_keyarray {
my $me = shift;
my $key = shift;
my $value = shift;
push @{$me->{_pending}{$key}}, $value;
}
sub parse_allow {
my $me = shift;
my $key = shift;
my $acl = shift;
my($host, $len) = split m|/|, $acl;
$host ||= $acl;
$len ||= 32;
push @{$me->{_pending}{acl}}, [ inet_aton($host), inet_lton($len) ];
}
sub parse_debug {
my $me = shift;
my $key = shift;
my $value = shift;
$me->{_pending}{debug}{$value} = 1;
}
################################################################
sub config {
my $me = shift;
return $me->{config};
}
sub get {
my $me = shift;
my $k = shift;
return $me->{config}{$k};
}
sub check_acl {
my $me = shift;
my $ip = shift; # ascii
my $ipn = inet_aton($ip);
for my $acl ( @{$me->{config}{acl}} ){
my($net, $mask) = @$acl;
return 1 if ($ipn & $mask) eq $net;
}
return 0;
lib/AC/DC/Callback.pm view on Meta::CPAN
# $Id$
package AC::DC::Callback;
use AC::DC::Debug 'callback';
use AC::Import;
use strict;
our @EXPORT = qw(set_callback clear_callback run_callback);
sub set_callback {
my $me = shift;
my $cb = shift;
my $fnc = shift;
$me->{_callback}{$cb} = { func => $fnc, args => [@_] };
}
sub clear_callback {
my $me = shift;
my $cb = shift;
delete $me->{_callback}{$cb};
}
# call the specified callback function
sub run_callback {
my $me = shift;
my $cb = shift;
my $evt = shift;
my $c = $me->{_callback}{$cb};
unless( $c ){
debug("no callback for $cb ($me->{info})");
return;
}
debug("running callback $cb ($me->{info})");
lib/AC/DC/Debug.pm view on Meta::CPAN
#
# $Id$
package AC::DC::Debug;
use AC::Daemon;
use strict;
my $config;
my $debugall;
sub init {
shift;
$debugall = shift;
$config = shift;
}
sub _tagged_debug {
my $tag = shift;
my $msg = shift;
if( $config && $config->{config} ){
return unless $config->{config}{debug}{$tag} || $config->{config}{debug}{all} || $debugall;
}else{
return unless $debugall;
}
debugmsg( "$tag - $msg" );
}
sub import {
my $class = shift;
my $tag = shift; # use AC::DC::Debug 'tag';
my $caller = caller;
no strict;
if( $tag ){
# export a curried debug (with the specified tag) to the caller
*{$caller . '::debug'} = sub { _tagged_debug($tag, @_) };
}
for my $f qw(verbose problem fatal){
no strict;
*{$caller . '::' . $f} = $class->can($f);
}
}
1;
lib/AC/DC/IO.pm view on Meta::CPAN
my $BUFSIZ = 8192;
my $maxfn = 0;
my $rvec = "\0\0\0\0";
my $wvec = "\0\0\0\0";
my @fileno;
my @timeout;
my $exitrequested = 0;
sub import {
my $pkg = shift;
my $param = shift;
# import a stats monitor?
if( $param && $param->{monitor} ){
*add_idle = \&{ $param->{monitor} .'::add_idle' };
}
}
sub underway {
return $maxfn;
}
sub closeall {
for my $x (@fileno){
close($x->{fd}) if $x && $x->{fd};
}
}
sub _cleanup {
for my $f (@fileno){
next unless $f;
$f->shut();
}
@fileno = ();
@timeout = ();
}
sub report {
my $txt;
for my $x (@fileno){
$txt .= fileno($x->{fd}) . "\t$x->{info}\n";
}
return $txt;
}
sub request_exit { $exitrequested = 1 }
sub init {
my $me = shift;
my $fd = shift;
$me->{fd} = $fd;
$me->_setnbio();
my $n = fileno($fd);
$fileno[ $n ] = $me;
$maxfn = $n if $n > $maxfn;
debug("init io fileno $n (/$maxfn) - $me->{info}");
}
sub shut {
my $me = shift;
$me->clear_timeout();
my $fd = $me->{fd};
return unless $fd;
my $n = fileno($fd);
debug("shutting down fileno $n $me->{info}");
$me->wantread(0);
$me->wantwrite(0);
lib/AC/DC/IO.pm view on Meta::CPAN
$fileno[$n] = undef;
$me->run_callback('shutdown', undef);
delete $me->{_callback};
if( $n >= $maxfn ){
while( $maxfn && !$fileno[$maxfn] ){ $maxfn -- }
}
}
sub wantread {
my $me = shift;
my $v = shift;
return unless defined $me->{fd};
$me->{_wantread} = $v;
my $n = fileno($me->{fd});
vec($rvec,$n,1) = $v ? 1 : 0;
return ;
}
sub wantwrite {
my $me = shift;
my $v = shift;
return unless defined $me->{fd};
$me->{_wantwrite} = $v;
my $n = fileno($me->{fd});
vec($wvec,$n,1) = $v ? 1 : 0;
return ;
}
sub timeout_abs {
my $me = shift;
my $t = shift;
$me->clear_timeout() if $me->{_timeout};
return unless $t;
$me->{_timeout} = $t;
my $i = 0;
foreach my $x (@timeout){
last if $x && $x->{_timeout} > $t;
$i++;
}
splice @timeout, $i, 0, $me;
return ;
}
sub timeout_rel {
my $me = shift;
my $to = shift;
$to += $^T if $to;
$me->timeout_abs( $to );
}
sub clear_timeout {
my $me = shift;
delete $me->{_timeout};
@timeout = grep { $_ != $me } @timeout;
return ;
}
################################################################
# buffered writing
sub write {
my $me = shift;
my $data = shift;
$me->{_wbuffer} .= $data;
$me->wantwrite(1);
}
sub write_and_shut {
my $me = shift;
$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 );
lib/AC/DC/IO.pm view on Meta::CPAN
$me->run_callback('error', {
cause => 'write',
error => $e,
});
$me->shut();
}
}
################################################################
sub _readable {
my $me = shift;
$me->run_callback('readable', undef);
}
sub _timeout {
my $me = shift;
debug("io - timeout $me->{info}");
$me->run_callback('timeout', undef);
}
################################################################
sub _setnbio {
my $me = shift;
my $fd = $me->{fd};
fcntl($fd, F_SETFL, O_NDELAY);
}
################################################################
sub _oneloop {
my $t0 = time();
$^T = $t0;
my $r = $rvec;
my $w = $wvec;
my $t;
if( @timeout ){
$t = $timeout[0]{_timeout} - $^T;
$t = 0 if $t < 0;
lib/AC/DC/IO.pm view on Meta::CPAN
$x->_timeout();
}
my $t2 = time();
# track idle/busy time
# debug("add idle? $t0, $t1, $t2 " . (defined &add_idle ? 'f' : '!'));
add_idle( $t1 - $t0, $t2 - $t0 ) if defined &add_idle;
}
sub mainloop {
while(1){
_oneloop();
last if $exitrequested;
}
_cleanup();
}
1;
lib/AC/DC/IO/Forked.pm view on Meta::CPAN
use AC::DC::Debug 'forked';
use Socket;
use POSIX;
use strict;
our @ISA = 'AC::DC::IO';
my $BUFSIZ = 8192;
sub new {
my $class = shift;
my $func = shift;
my $args = shift;
my $me = bless {
func => $func,
args => $args,
@_
}, $class;
debug("new forked");
return $me;
}
sub start {
my $me = shift;
debug("starting forked");
my($fda, $fdb);
unless( socketpair($fda, $fdb, AF_UNIX, SOCK_STREAM, PF_UNSPEC) ){
problem("socketpair failed: $!");
return ;
}
my $pid = fork();
lib/AC/DC/IO/Forked.pm view on Meta::CPAN
_exit( $@ ? 1 : 0 );
}
$me->{pid} = $pid;
$me->init($fda);
$me->wantread(1);
return $me;
}
sub _do_child {
my $me = shift;
my $fd = shift;
close STDIN; open( STDIN, "<&", $fd );
close STDOUT; open( STDOUT, ">&", $fd );
close $fd;
AC::DC::IO->closeall();
$| = 1;
$SIG{INT} = $SIG{TERM} = $SIG{QUIT} = $SIG{ALRM} = 'DEFAULT';
alarm($me->{child_timeout});
$me->{func}->( @{$me->{args}} );
}
sub shut {
my $me = shift;
debug("forked wait");
if( $me->{pid} ){
kill 15, $me->{pid};
my $v = waitpid $me->{pid}, WNOHANG;
if( $v == 0 ){
# but I'm not dead yet
debug("not dead yet");
lib/AC/DC/IO/Forked.pm view on Meta::CPAN
}
}
$me->{exitval} = $?;
delete $me->{pid};
}
$me->SUPER::shut();
}
sub _readable {
my $me = shift;
my $buf;
my $bs = $me->{rbufsize} || $BUFSIZ;
my $i = sysread($me->{fd}, $buf, $bs);
unless( defined $i ){
my $e = $!;
debug("read error");
$me->run_callback('error', {
lib/AC/DC/IO/TCP.pm view on Meta::CPAN
use AC::DC::Debug 'tcp';
use AC::DC::IO::TCP::Server;
use AC::DC::IO::TCP::Client;
use strict;
our @ISA = 'AC::DC::IO';
my $BUFSIZ = 8192;
sub new {
my $class = shift;
my $me = bless {
@_
}, $class;
debug("new tcp");
return $me;
}
sub start {
my $me = shift;
my $fd = shift;
$me->init($fd);
$me->wantread(1);
return $me;
}
sub _readable {
my $me = shift;
my $buf;
my $bs = $me->{rbufsize} || $BUFSIZ;
my $i = sysread($me->{fd}, $buf, $bs);
# debug("tcp read $i bytes");
unless( defined $i ){
my $e = $!;
lib/AC/DC/IO/TCP/Client.pm view on Meta::CPAN
# error => shut()
package AC::DC::IO::TCP::Client;
use AC::DC::Debug 'tcp_client';
use Socket;
use POSIX;
use strict;
our @ISA = 'AC::DC::IO::TCP';
sub new {
my $class = shift;
my $addr = shift;
my $port = shift;
($addr, $port) = $class->use_addr_port( $addr, $port );
debug("starting new tcp client: $addr:$port");
my $ip = inet_aton($addr);
unless($ip){
verbose("tcp client cannot resolve '$addr'");
lib/AC/DC/IO/TCP/Client.pm view on Meta::CPAN
my $me = $class->SUPER::new( @_ );
$me->{tcp_server_ip} = $ip;
$me->{tcp_server_addr} = $addr;
$me->{tcp_server_port} = $port;
return $me;
}
sub start {
my $me = shift;
my $fd;
my $i = socket($fd, PF_INET, SOCK_STREAM, 0);
$me->SUPER::start($fd);
unless( $i ){
verbose("tcp client socket failed: $! ($me->{info})");
$me->run_callback('error', { cause => 'socket', error => "socket failed: $!" });
$me->shut();
return ;
lib/AC/DC/IO/TCP/Client.pm view on Meta::CPAN
debug("tcp client connect failed: $! ($me->{info})");
$me->run_callback('error', { cause => 'connect', error => "connect failed: $!" });
$me->shut();
return ;
}
$me->wantwrite(1);
return $me;
}
sub _writable {
my $me = shift;
# socket will elect as writable once the connect completes
unless( $me->{_connected} ){
my $fd = $me->{fd};
my $i = unpack('L', getsockopt($fd, SOL_SOCKET, SO_ERROR));
if( $i ){
my $e = $! = $i;
debug("tcp client connect failed: $! ($me->{info})");
$me->run_callback('error', { cause => 'connect', error => "connect failed: $e" });
lib/AC/DC/IO/TCP/Client.pm view on Meta::CPAN
}
debug("tcp client connected $me->{info}");
$me->{_connected} = 1;
$me->run_callback('connect', undef);
}
$me->SUPER::_writable(@_);
}
sub use_addr_port {
my $class = shift;
return @_;
}
1;
lib/AC/DC/IO/TCP/Server.pm view on Meta::CPAN
#
# $Id$
package AC::DC::IO::TCP::Server;
use AC::DC::Debug 'tcp';
use Socket;
use strict;
our @ISA = 'AC::DC::IO::TCP';
sub new {
my $class = shift;
my $port = shift; # 0 => system picks
my $nextc = shift;
my $arg = shift;
my $me = bless {
info => "server tcp/$port",
nextclass => $nextc,
nextarg => $arg,
}, $class;
lib/AC/DC/IO/TCP/Server.pm view on Meta::CPAN
fatal( "cannot bind to tcp/$port: $!" ) unless $i;
listen( $fd, 128 );
$me->init($fd);
$me->wantread(1);
return $me;
}
sub port {
my $me = shift;
my $fd = $me->{fd};
my $s = getsockname($fd);
my($port, $addr) = sockaddr_in($s);
return $port;
}
sub _readable {
my $me = shift;
my $newfd;
my $i = accept( $newfd, $me->{fd} );
return verbose("tcp accept failed: $!" ) unless $i;
my $ip = inet_ntoa( (sockaddr_in(getpeername($newfd)))[1] );
debug( "new tcp connection from $ip" );
my $next = $me->{nextclass};
lib/AC/DC/IO/UDP/Server.pm view on Meta::CPAN
package AC::DC::IO::UDP::Server;
use AC::DC::Debug 'udp';
use Socket;
use strict;
our @ISA = 'AC::DC::IO::UDP';
my $BUFSIZ = 65536;
sub new {
my $class = shift;
my $port = shift;
my $nextc = shift;
my $arg = shift;
my $me = bless {
info => "server udp/$port",
nextclass => $nextc,
nextarg => $arg,
}, $class;
lib/AC/DC/IO/UDP/Server.pm view on Meta::CPAN
fatal( "cannot bind to udp/$port: $!" ) unless $i;
listen( $fd, 128 );
$me->init($fd);
$me->wantread(1);
return $me;
}
sub _readable {
my $me = shift;
debug( "new udp connection" );
my $next = $me->{nextclass};
$next->new( $me, $me->{nextarg} );
}
1;
lib/AC/DC/Protocol.pm view on Meta::CPAN
my $VERSION = 0x41433032;
my $BUFSIZ = 65536;
my %MSGTYPE;
my %MSGREV;
# status => { num => 0, reqc => '', resc => 'ACPStdReply' },
sub header_size { return 28 }
sub new {
my $class = shift;
return bless { @_ }, $class;
}
sub add_msg {
my $class = shift;
my $name = shift;
my $num = shift;
my $reqc = shift;
my $resc = shift;
my $d = {
name => $name,
num => $num,
reqc => $reqc,
resc => $resc,
};
$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,
lib/AC/DC/Protocol.pm view on Meta::CPAN
$p{is_reply} = ($fl & 1) ? 1 : 0;
$p{want_reply} = ($fl & 2) ? 1 : 0;
$p{is_error} = ($fl & 4) ? 1 : 0;
$p{data_encrypted} = ($fl & 8) ? 1 : 0;
$p{content_encrypted} = ($fl & 16) ? 1 : 0;
return \%p;
}
sub encrypt {
my $me = shift;
# NYI - placeholder
}
sub decrypt {
my $me = shift;
my $auth = shift;
my $buf = shift;
# NYI - placeholder
}
sub _encode_common {
my $me = shift;
my $how = shift;
my $proto = shift;
my $data = shift;
my $cont = shift; # reference
my $auth = shift; # NYI
my $mt = $MSGTYPE{ $proto->{type} };
confess "unknown message type $proto->{type}\n" unless defined $mt;
lib/AC/DC/Protocol.pm view on Meta::CPAN
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;
my $reply = shift;
my $data = shift;
my $mt = $MSGTYPE{ $reply->{type} };
confess "unknown message type $reply->{type}\n" unless defined $mt;
return unless $data || $reply->{data};
my $res = $mt->{$how}->decode( $data || $reply->{data} || '' );
return $res;
}
sub encode_request {
my $me = shift;
return $me->_encode_common( 'reqc', @_ );
}
sub encode_reply {
my $me = shift;
return $me->_encode_common( 'resc', @_ );
}
sub decode_request {
my $me = shift;
return $me->_decode_common( 'reqc', @_ );
}
sub decode_reply {
my $me = shift;
return $me->_decode_common( 'resc', @_ );
}
################################################################
sub _try_to_connect {
my $s = shift;
my $sa = shift;
my $to = shift;
my $fn = fileno($s);
my $wfd = "\0\0\0\0";
vec($wfd, $fn, 1) = 1;
my $i = connect($s, $sa);
return 1 if $i; # connected
return unless $! == EISCONN || $! == EALREADY || $! == EINPROGRESS;
# wait until connected or timeout
my $is = select(undef, $wfd, undef, $to);
return if $is == -1;
return 1 if vec($wfd, $fn, 1);
return;
}
sub connect_to_server {
my $me = shift;
my $ipn = shift;
my $port = shift;
my $timeo = shift;
my $s;
socket($s, PF_INET, SOCK_STREAM, 6) || confess "cannot create socket: $!\n";
setsockopt($s, Socket::IPPROTO_TCP(), Socket::TCP_NODELAY(), 1);
# set non-blocking
lib/AC/DC/Protocol.pm view on Meta::CPAN
# reset non-blocking
fcntl($s, F_SETFL, $fl);
return $s;
}
}
my $ipa = inet_ntoa($ipn);
confess "connect failed to $ipa:$port\n";
}
sub write_request {
my $me = shift;
my $s = shift;
my $req = shift;
my $timeo = shift;
$timeo ||= 1;
# set non-blocking
my $fl = fcntl($s, F_GETFL, 0);
fcntl($s, F_SETFL, O_NDELAY);
lib/AC/DC/Protocol.pm view on Meta::CPAN
confess "write failed $!\n" unless $i >= 1;
$tlen -= $i;
$slen += $i;
}
fcntl($s, F_SETFL, $fl);
return $slen;
}
sub read_data {
my $me = shift;
my $s = shift;
my $size = shift;
my $timeo = shift;
$timeo ||= 1;
# set non-blocking
my $fl = fcntl($s, F_GETFL, 0);
fcntl($s, F_SETFL, O_NDELAY);
lib/AC/DC/Protocol.pm view on Meta::CPAN
}
fcntl($s, F_SETFL, $fl);
return $data;
}
################################################################
# stream fd to other fd
# return hash
sub sendfile {
my $me = shift;
my $out = shift;
my $in = shift;
my $size = shift;
my $timeo = shift;
# NB: sendfile(2) only supports file=>socket + file=>file
# not socket=>file, ...
# RSN - elastic buffering?
lib/AC/DC/Protocol.pm view on Meta::CPAN
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 {
my $me = shift;
my $ipn = shift;
my $port = shift;
my $req = shift;
my $debug = shift;
my $timeo = shift;
$debug ||= sub {};
$timeo ||= 0.5;
local $SIG{ALRM} = sub{ $debug->("timeout") };
my $s = $me->connect_to_server($ipn, $port, $timeo);
# send request
$debug->("sending request");
$me->write_request($s, $req, $timeo);
# get response or timeout
lib/AC/DC/Sched.pm view on Meta::CPAN
#
# $Id$
package AC::DC::Sched;
use AC::DC::Debug 'sched';
use Carp 'carp';
use strict;
our @ISA = qw(AC::DC::IO);
sub new {
my $class = shift;
my $p = { @_ };
# { info, time, freq, phi, func, args }
my $me = bless {
sched => $p,
}, $class;
$p->{info} ||= 'scheduled function';
$p->{phi} = rand($p->{freq}) if $p->{freq} && !defined($p->{phi});
lib/AC/DC/Sched.pm view on Meta::CPAN
carp "cannot schedule, no time, no freq.\n" unless $p->{time};
$me->{info} = $p->{info};
debug("installing scheduled func ($me->{info})");
$me->_sched();
return $me;
}
sub _sched {
my $me = shift;
$me->timeout_abs( $me->{sched}{time} );
}
sub _resched {
my $me = shift;
while( $me->{sched}{time} < $^T ){ $me->{sched}{time} += $me->{sched}{freq} }
$me->_sched();
}
sub _timeout {
my $me = shift;
# run specified func
debug("running scheduled func ($me->{info})");
$me->{sched}{func}->($me->{sched}{args});
$me->_resched() if $me->{sched}{freq};
}
1;
lib/AC/Daemon.pm view on Meta::CPAN
use Time::HiRes;
use POSIX;
use strict;
BEGIN {
# use it if we've got it
eval {
require AC::Error; AC::Error->import();
};
if($@){
*daemon_error = sub {};
*stack_trace = sub {};
}
}
our @EXPORT = qw(daemonize run_and_watch initlog debugmsg verbose problem fatal);
my $childpid;
my $verbose = 1;
my $nomail = 0;
my $syslog;
my @maybe_argv = @ARGV; # save for restart (might not be available)
sub daemonize {
my $tout = shift;
my $name = shift;
my $argv = shift;
fork && exit; # background ourself
$verbose = 0;
my @argv = $argv ? @$argv : @maybe_argv;
close STDIN; open( STDIN, "/dev/null" );
close STDOUT; open( STDOUT, "> /dev/null" );
close STDERR; open( STDERR, "> /dev/null" );
setsid();
$SIG{QUIT} = $SIG{INT} = $SIG{TERM} = sub { _signal($name, @_) };
if( $name ){
# save pid file
open(PID, "> /var/run/$name.pid");
print PID "$$\n";
print PID "# @argv\n";
close PID;
}
# run as 2 processes
lib/AC/Daemon.pm view on Meta::CPAN
wait;
$childpid = undef;
sleep $tout;
}else{
# child
return;
}
}
}
sub _signal {
my $name = shift;
verbose( "caught signal SIG$_[0] - exiting" );
if( $childpid > 1 ){
# kill child process + wait for it to exit
unlink "/var/run/$name.pid" if $name;
kill "TERM", $childpid;
wait;
}
exit;
}
sub initlog {
my $name = shift;
my $facil = shift;
my $quiet = shift;
my $verb = shift;
unless( $syslog ){
openlog( $name, 'ndelay, pid', $facil );
$syslog = 1;
}
$nomail = $quiet;
$verbose = $verb if defined $verb;
}
sub run_and_watch {
my $optf = shift;
my $func = shift;
$SIG{USR2} = \&_send_trace;
eval {
$func->();
};
if( my $e = $@ ){
if( $optf ){
$e .= "\n\n" . stack_trace();
verbose( "UNCAUGHT ERROR: $e" );
}else{
fatal( "UNCAUGHT ERROR: $e" );
}
}
}
sub debugmsg {
my $msg = shift;
syslog( 'debug', '%s', $msg ) if $syslog;
_to_stderr( $msg ) if $verbose;
}
sub verbose {
my $msg = shift;
syslog( 'info', '%s', $msg ) if $syslog;
_to_stderr( $msg ) if $verbose;
}
sub problem {
my $msg = shift;
daemon_error( $msg ) unless $nomail;
syslog( 'err', '%s', $msg ) if $syslog;
_to_stderr( $msg );
}
sub fatal {
my $msg = shift;
daemon_error( $msg ) unless $nomail;
syslog( 'err', '%s', $msg ) if $syslog;
_to_stderr( $msg );
exit -1;
}
sub _to_stderr {
my $msg = shift;
my $tx = Time::HiRes::time();
my $f = $tx - int($tx);
$f = sprintf('%.6f', $f);
$f =~ s/^0\.//;
my $t = strftime '%H:%M:%S', localtime($tx);
print STDERR "[$$ $t.$f] $msg\n";
}
sub _send_trace {
# email a stack trace to developer
problem("sigusr2");
}
=head1 NAME
AC::Daemon - daemon program utility functions.
lib/AC/Dumper.pm view on Meta::CPAN
# Created: 2008-Dec-11 23:20 (EST)
# Function: dump data all pretty-like
#
# $Id$
package AC::Dumper;
use AC::Import;
our @EXPORT = 'dumper';
sub dumper {
my $val = shift;
return _dump( $val, {} );
}
sub _dump {
my $val = shift;
my $seen = shift;
return '<NULL>' unless defined $val;
return $val unless ref($val);
# detect infinite loop
return '<LOOP>' if $seen->{$val};
$seen->{$val} = 1 if ref $val;
lib/AC/ISOTime.pm view on Meta::CPAN
# Function: time_t <=> iso8601
package AC::ISOTime;
use AC::Import;
use Time::Local;
use POSIX;
use strict;
our @EXPORT = qw(isotime timeiso);
# convert time_t => iso8601
sub isotime {
my $t = shift;
my $precision = shift;
return unless $t;
$precision ||= 6;
my $f = sprintf("%.${precision}f", $t - int($t));
$f =~ s/^0//;
$f = '' if $f =~ /\.0+$/;
return strftime( '%Y%m%dT%H%M%S', gmtime($t)) . $f . 'Z';
}
# convert iso8601 => time_t
sub timeiso {
my $iso = shift;
return unless $iso;
$iso =~ s/^\s+//g; # Ensure no leading spaces can throw off the split
my($date, $time) = split /T|\s/, $iso, 2;
$time =~ s/\s//g;
$time ||= '00:00:00Z';
lib/AC/Import.pm view on Meta::CPAN
# Function: import/export
#
# $Id$
package AC::Import;
use strict;
our @EXPORT = 'import';
sub import {
my $class = shift;
my $caller = caller;
no strict;
no warnings;
for my $f ( @{$class . '::EXPORT'} ){
*{$caller . '::' . $f} = \&{ $class . '::' . $f };
}
}
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));
}
# packed => integer
sub inet_ntoi {
my $n = shift;
return unpack('N', $n);
}
# integer => packed
sub inet_iton {
my $i = shift;
return pack('N', $i);
}
# integer => ascii
sub inet_itoa {
my $i = shift;
return inet_ntoa(inet_iton($i));
}
sub inet_valid {
my $ip = shift;
return 1 if $ip =~ /^\d+\.\d+\.\d+\.\d+$/;
return 1 if $ip =~ /^[0-9a-f]*:[0-9a-f:.]+$/i;
return ;
}
sub inet_normalize {
my $ip = shift;
# ipv4
return $ip if $ip =~ /^\d+\.\d+\.\d+\.\d+$/;
# ipv6: expand ::
my($l, $r) = split /::/, lc($ip);
my @ln = split /:/, $l;
my @rn = split /:/, $r;
my @mn = ('0') x (8 - @ln - @rn);
return join(':', @ln, @mn, @rn);
}
################################################################
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;
}
################################################################
sub encode_base64_safe {
my $t = shift;
my $u = encode_base64( $t );
$u =~ tr/\r\n//d;
$u =~ s/=*$//;
$u =~ tr%+/=%-._%;
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;
$txt =~ s/([^a-z0-9_\.\-])/sprintf('%%%02x',ord($1))/gei;
return $txt;
}
sub url_decode {
my $txt = shift;
$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 )),
0, $len);
}
################################################################
my $unique_n;
my $myip;
# 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;
}
# fisher yates - cut+paste from perl-faq-4
sub shuffle {
my $deck = shift;
return unless $deck;
my $i = @$deck;
while (--$i > 0) {
my $j = int rand ($i+1);
@$deck[$i,$j] = @$deck[$j,$i];
}
return $deck;
}
lib/AC/SHA1File.pm view on Meta::CPAN
#
# $Id$
package AC::SHA1File;
use AC::Import;
use Digest::SHA1;
use strict;
our @EXPORT = qw(sha1_file);
sub sha1_file {
my $file = shift;
open(my $f, $file) || return ;
my $sh = Digest::SHA1->new();
$sh->addfile($f);
return $sh->b64digest();
}
1;
( run in 0.395 second using v1.01-cache-2.11-cpan-a5abf4f5562 )