debug results from the CPAN

debug

AC-DC

view release on metacpan or search on metacpan

lib/AC/ConfigFile/Simple.pm view on Meta::CPAN

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 {

lib/AC/ConfigFile/Simple.pm view on Meta::CPAN

    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};
}

lib/AC/DC/Callback.pm view on Meta::CPAN

}

# 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


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};

lib/AC/DC/IO.pm view on Meta::CPAN


    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);

lib/AC/DC/IO.pm view on Meta::CPAN

        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();

lib/AC/DC/IO/Forked.pm view on Meta::CPAN

    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: $!");

lib/AC/DC/IO/Forked.pm view on Meta::CPAN

    $| = 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} = $?;

lib/AC/DC/IO/Forked.pm view on Meta::CPAN


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


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


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;

lib/AC/DC/IO/TCP/Client.pm view on Meta::CPAN

        $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;

lib/AC/DC/IO/TCP/Server.pm view on Meta::CPAN

}

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/Server.pm view on Meta::CPAN

    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

    }

    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

        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} );
}

lib/AC/DC/Sched.pm view on Meta::CPAN

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 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;

lib/AC/Daemon.pm view on Meta::CPAN

    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;
}

( run in 1.651 second using v1.01-cache-2.11-cpan-49f99fa48dc )