AC-DC
view release on metacpan - search on metacpan
view release on metacpan or search on metacpan
This software may be copied and distributed under the terms
found in the Perl "Artistic License".
A copy of the "Artistic License" may be found in the standard
Perl distribution.
MANIFEST
README
lib/AC/SHA1File.pm
lib/AC/DC/IO.pm
lib/AC/DC/Debug.pm
lib/AC/DC/IO/TCP/Server.pm
lib/AC/DC/IO/TCP/Client.pm
lib/AC/DC/IO/UDP/Server.pm
lib/AC/DC/IO/TCP.pm
lib/AC/DC/IO/Forked.pm
lib/AC/DC/IO/UDP.pm
lib/AC/DC/Protocol.pm
lib/AC/DC/Sched.pm
lib/AC/DC/Callback.pm
lib/AC/Import.pm
lib/AC/Misc.pm
lib/AC/DC.pm
lib/AC/Dumper.pm
lib/AC/ISOTime.pm
lib/AC/ConfigFile/Simple.pm
lib/AC/Daemon.pm
LICENSE
Makefile.PL
META.yml Module meta-data (added by MakeMaker)
--- #YAML:1.0
name: AC-DC
version: 1.1
abstract: Asynchronous IO Framework. plus.
author:
- AdCopy <http://www.adcopy.com>
license: perl
distribution_type: module
configure_requires:
ExtUtils::MakeMaker: 0
requires:
Digest::SHA1: 0
MIME::Base64: 0
POSIX: 0
Sys::Hostname: 0
Sys::Syslog: 0
Time::HiRes: 0
Time::Local: 0
Unicode::Normalize: 0
no_index:
directory:
- t
- inc
generated_by: ExtUtils::MakeMaker version 6.48
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
version: 1.4
Makefile.PL view on Meta::CPAN
use ExtUtils::MakeMaker;
WriteMakefile(
NAME => 'AC::DC',
VERSION_FROM => 'lib/AC/DC.pm',
ABSTRACT_FROM => 'lib/AC/DC.pm',
AUTHOR => 'AdCopy <http://www.adcopy.com>',
LICENSE => 'perl',
PREREQ_PM => {
'Sys::Syslog' => 0,
'Sys::Hostname' => 0,
'POSIX' => 0,
'Time::Local' => 0,
'MIME::Base64' => 0,
'Unicode::Normalize' => 0,
'Digest::SHA1' => 0,
'Time::HiRes' => 0,
},
);
lib/AC/ConfigFile/Simple.pm view on Meta::CPAN
# -*- perl -*-
# Copyright (c) 2008 by AdCopy
# Author: Jeff Weisberg
# Created: 2008-Dec-19 10:12 (EST)
# Function: read simple config file
#
# $Id$
# file:
# keyword value
# ...
package AC::ConfigFile::Simple;
use AC::Misc;
use AC::DC::Debug;
use Socket;
use strict;
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};
}
return unless $changed;
verbose("config file changed. reloading");
$me->{_lastconf} = $now;
eval {
$me->_read();
verbose("installed new config file");
if( my $f = $me->{onreload} ){
$f->();
}
};
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;
$l =~ s/\#.*$//;
$l =~ s/^\s*//;
$l =~ s/\s+$//;
next if $l =~ s/^\s*$/; #/;
$line .= $l;
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;
}
1;
lib/AC/DC.pm view on Meta::CPAN
# -*- perl -*-
# Copyright (c) 2010 AdCopy
# Author: Jeff Weisberg
# Created: 2010-May-13 17:06 (EDT)
# Function: documentation
#
# $Id$
package AC::DC;
use strict;
our $VERSION = 1.1;
=head1 NAME
AC::DC - Asynchronous IO Framework. plus.
=head1 SYNOPSIS
use AC::DC::IO;
...
=head1 USAGE
Copy + Paste from the example code into your own code.
=head1 LICENSE
This software may be copied and distributed under the terms
found in the Perl "Artistic License".
A copy of the "Artistic License" may be found in the standard
Perl distribution.
=head1 BUGS
Too many to list here.
=head1 AUTHOR
Jeff Weisberg - http://www.solvemedia.com/
=cut
1;
lib/AC/DC/Callback.pm view on Meta::CPAN
# -*- perl -*-
# Copyright (c) 2009 AdCopy
# Author: Jeff Weisberg
# Created: 2009-Mar-27 10:41 (EDT)
# Function: event callback mixin
#
# $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})");
return $c->{func}->($me, $evt, @{$c->{args}});
}
1;
lib/AC/DC/Debug.pm view on Meta::CPAN
# -*- perl -*-
# Copyright (c) 2009 AdCopy
# Author: Jeff Weisberg
# Created: 2009-Mar-27 11:40 (EDT)
# Function: debugging + log msgs
#
# $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
# -*- perl -*-
# Copyright (c) 2009 AdCopy
# Author: Jeff Weisberg
# Created: 2009-Mar-27 10:36 (EDT)
# Function: async multiplexed io
#
# $Id$
# callbacks:
# readable
# writeable
# write_buffer_empty
# timeout
# error => shut()
# shutdown
package AC::DC::IO;
use AC::DC::Debug 'io';
use AC::DC::IO::TCP;
use AC::DC::IO::UDP;
use AC::DC::IO::Forked;
use AC::DC::Callback;
use AC::DC::Sched;
use Time::HiRes 'time';
use Socket;
use Fcntl;
use POSIX;
use bytes;
use strict;
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);
delete $me->{fd};
close $fd;
$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 );
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',
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;
}
my $i = select($r, $w, undef, $t);
if( $i == -1 ){
return if $! == EINTR;
fatal( "select failed: $!" );
}
my $t1 = time();
$^T = $t1;
# dispatch
for my $n (0 .. $maxfn){
if( vec($r, $n, 1) && vec($rvec, $n, 1) ){
my $x = $fileno[$n];
# debug("fileno $n ($x->{info}) is readable");
$x->_readable();
}
if( vec($w, $n, 1) && vec($wvec, $n, 1) ){
my $x = $fileno[$n];
# debug("fileno $n ($x->{info}) is writeable");
$x->_writable();
}
}
# timeouts
while(@timeout && $timeout[0]{_timeout} <= $^T){
my $x = shift @timeout;
debug("timed out $x->{info}");
delete $x->{_timeout};
$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
# -*- perl -*-
# Copyright (c) 2010 AdCopy
# Author: Jeff Weisberg
# Created: 2010-Jan-12 16:17 (EST)
# Function:
#
# $Id$
package AC::DC::IO::Forked;
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();
if( !defined($pid) ){
problem("cannot fork: $!");
return ;
}elsif( $pid ){
# parent
close $fdb;
}else{
# child
close $fda;
eval { $me->_do_child($fdb) };
_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");
for(1..3){
sleep 1;
my $v = waitpid $me->{pid}, WNOHANG;
last if $v; # error or dead
kill 9, $me->{pid};
}
}
$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', {
cause => 'read',
error => $e,
});
$me->shut();
return ;
}
unless( $i ){
debug("read eof");
$me->run_callback('read_eof', undef);
$me->shut();
return ;
}
debug("forked read $i bytes");
$me->run_callback('read', { data => $buf, size => $i } );
}
1;
lib/AC/DC/IO/TCP.pm view on Meta::CPAN
# -*- perl -*-
# Copyright (c) 2009 AdCopy
# Author: Jeff Weisberg
# Created: 2009-Mar-27 13:41 (EDT)
# Function: tcp
#
# $Id$
# callbacks:
# error => shut()
# read_eof => shut()
# read
package AC::DC::IO::TCP;
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 = $!;
debug("read error - $me->{info}");
$me->run_callback('error', {
cause => 'read',
error => $e,
});
$me->shut();
return ;
}
unless( $i ){
debug("read eof - $me->{info}");
$me->run_callback('read_eof', undef);
$me->shut();
return ;
}
$me->run_callback('read', { data => $buf, size => $i } );
}
1;
lib/AC/DC/IO/TCP/Client.pm view on Meta::CPAN
# -*- perl -*-
# Copyright (c) 2009 AdCopy
# Author: Jeff Weisberg
# Created: 2009-Mar-27 15:11 (EDT)
# Function: tcp client
#
# $Id$
# callbacks:
# connect
# 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'");
return ;
}
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 ;
}
while(1){
my $i = connect($fd, sockaddr_in($me->{tcp_server_port}, $me->{tcp_server_ip}) );
last if $i; # success
next if $! == EINTR; # signal, retry
last if $! == EISCONN || $! == EALREADY || $! == EINPROGRESS;
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" });
$me->shut();
return;
}
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
# -*- perl -*-
# Copyright (c) 2009 AdCopy
# Author: Jeff Weisberg
# Created: 2009-Mar-27 15:01 (EDT)
# Function: tcp server
#
# $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;
my $fd;
socket($fd, PF_INET, SOCK_STREAM, 0);
setsockopt($fd, SOL_SOCKET, SO_REUSEADDR, 1);
my $i = bind($fd, sockaddr_in($port, INADDR_ANY));
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};
$next->new( $newfd, $ip, $me, $me->{nextarg} );
}
1;
lib/AC/DC/IO/UDP.pm view on Meta::CPAN
# -*- perl -*-
# Copyright (c) 2010 by Jeff Weisberg
# Author: Jeff Weisberg <jaw @ tcp4me.com>
# Created: 2010-Nov-22 13:24 (EST)
# Function:
#
# $Id$
package AC::DC::IO::UDP;
use AC::DC::Debug 'udp';
use AC::DC::IO::UDP::Server;
use strict;
our @ISA = 'AC::DC::IO';
1;
lib/AC/DC/IO/UDP/Server.pm view on Meta::CPAN
#!/usr/local/bin/perl
# -*- perl -*-
# Copyright (c) 2010 by Jeff Weisberg
# Author: Jeff Weisberg <jaw @ tcp4me.com>
# Created: 2010-Nov-22 13:21 (EST)
# Function:
#
# $Id$
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;
my $fd;
socket($fd, PF_INET, SOCK_DGRAM, 0);
setsockopt($fd, SOL_SOCKET, SO_REUSEADDR, 1);
my $i = bind($fd, sockaddr_in($port, INADDR_ANY));
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
# -*- perl -*-
# Copyright (c) 2009 AdCopy
# Author: Jeff Weisberg
# Created: 2009-Sep-10 13:37 (EDT)
# Function:
#
# $Id$
package AC::DC::Protocol;
use Carp qw(croak confess);
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' },
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,
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;
$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;
my $apb = $auth ? ACPAuth->encode( $auth ) : '';
my $gpb = $data ? $mt->{$how}->encode( $data ) : '';
if( $proto->{data_encrypted} && $gpb ){
$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;
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
my $fl = fcntl($s, F_GETFL, 0);
fcntl($s, F_SETFL, O_NDELAY);
my $sa = sockaddr_in($port, $ipn);
my $to = $timeo ? $timeo / 2 : 0.25;
# try connecting up to 3 times
for (1..3){
# print STDERR "connecting\n";
my $ok = _try_to_connect($s, $sa, $to);
if( $ok ){
# 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);
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);
my $l = $tlen > $BUFSIZ ? $BUFSIZ : $tlen;
my $i = syswrite($s, $req, $l, $slen);
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);
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
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?
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 {
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
$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/DC/Sched.pm view on Meta::CPAN
# -*- perl -*-
# Copyright (c) 2009 AdCopy
# Author: Jeff Weisberg
# Created: 2009-Mar-27 11:47 (EDT)
# Function: run things periodically
#
# $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});
$p->{time} ||= $p->{freq} + $p->{phi} + $^T if $p->{freq} && !$p->{time};
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
# -*- perl -*-
# Copyright (c) 2008 by AdCopy
# Author: Jeff Weisberg
# Created: 2008-Dec-01 16:02 (EST)
# Function: daemonization + logging
#
# $Id$
package AC::Daemon;
use AC::Import;
use Sys::Syslog;
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
while(1){
$childpid = fork;
die "cannot fork: $!\n" unless defined $childpid;
if( $childpid ){
# parent
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.
=head1 SYNOPSIS
use AC::Daemon;
use strict;
initlog( 'program', 'local5' );
daemonize( 5, 'program', \@ARGV ) unless $opt{foreground};
verbose( 'starting.' );
run_and_watch( $opt{foreground}, \&myfunction );
exit;
=cut
1;
lib/AC/Dumper.pm view on Meta::CPAN
# -*- perl -*-
# Copyright (c) 2008 by Jeff Weisberg
# Author: Jeff Weisberg <jaw @ tcp4me.com>
# 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;
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' ){
return '[]' unless @$val;
my $out = "[\n";
for my $k (@$val){
my $v = _dump($k, $seen);
$v =~ s/^/ /gm;
$out .= $v . "\n";
}
$out .= "]";
return $out;
}
return "<$val>"; # can't dump this
}
1;
lib/AC/ISOTime.pm view on Meta::CPAN
# -*- perl -*-
# Copyright (c) 2009 by dCopy
# Author: Jeff Weisberg
# Created: 2009-Dec-22 11:14 (EST)
# 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';
my($year, $mon, $day) = $date =~ /(\d{4})-?(\d{2})-?(\d{2})?/;
$day ||= 1; # day is optional
($time, my $tz) = $time =~ /([^-+Z]+)(.*)/;
my($hr, $min, $sec) = $time =~ /(\d{2}):?(\d{2}):?(.*)/;
($sec, my $frac) = $sec =~ /(\d+)(\.\d+)?/;
my($tzsign, $tzhr, $tzmin) = $tz =~ /(-?)(\d{2}):?(\d{2})?/;
$tzmin ||= 0;
$tzhr = $tzmin = 0 if $tz eq 'Z';
my $t = timegm($sec,$min,$hr, $day, $mon-1, $year);
$t += $frac;
$t -= (3600 * $tzhr + 60 * $tzmin) * ($tzsign ? -1 : 1);
return $t;
}
1;
lib/AC/Import.pm view on Meta::CPAN
# -*- perl -*-
# Copyright (c) 2008 by AdCopy
# Author: Jeff Weisberg
# Created: 2008-Dec-18 20:26 (EST)
# 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 };
}
}
=head1 NAME
AC::Import - Import/Export functions
=head1 SYNOPSIS
use AC::Import;
use strict;
our @EXPORT = qw(function1 function2);
=head1 SEE ALSO
Exporter
=cut
1;
lib/AC/Misc.pm view on Meta::CPAN
# -*- perl -*-
# Copyright (c) 2008 by AdCopy
# Author: Jeff Weisberg
# Created: 2008-Dec-18 10:37 (EST)
# Function: miscellanea
#
# $Id$
package AC::Misc;
use AC::Import;
use Socket;
use POSIX;
use MIME::Base64;
use Sys::Hostname;
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;
}
1;
lib/AC/SHA1File.pm view on Meta::CPAN
# -*- perl -*-
# Copyright (c) 2010 by AdCopy
# Author: Jeff Weisberg
# Created: 2010-Feb-18 11:05 (EST)
# Function:
#
# $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;
view release on metacpan - search on metacpan
( run in 1.042 second using v1.00-cache-2.02-grep-82fe00e-cpan-1925d2aa809 )