File Coverage

blib/lib/Event/Watcher.pm

Criterion	Covered	Total	%
statement	77	88	87.5
branch	25	34	73.5
condition	4	5	80.0
subroutine	14	16	87.5
pod	0	7	0.0
total	120	150	80.0

use strict;
package Event::Watcher;
use base 'Exporter';
use Carp;
use vars qw(@EXPORT_OK @ATTRIBUTE);
@EXPORT_OK = qw(ACTIVE SUSPEND R W E T);
@ATTRIBUTE = qw(cb cbtime desc debug prio reentrant repeat max_cb_tm);

sub register {
    no strict 'refs';
    my $package = caller;

    my $name = $package;
    $name =~ s/^.*:://;

    my $sub = \&{"$package\::new"};
    die "can't find $package\::new"
	if !$sub;
    *{"Event::".$name} = sub {
	shift;
	$sub->("Event::".$name, @_);
    };

    &Event::add_hooks if @_;
}

my $warn_noise = 10;
sub init {
    croak "Event::Watcher::init wants 2 args" if @_ != 2;
    my ($o, $arg) = @_;

    for my $k (keys %$arg) {
	if ($k =~ s/^e_//) {
	    Carp::cluck "'e_$k' is renamed to '$k'"
		if --$warn_noise >= 0;
	    $arg->{$k} = delete $arg->{"e_$k"};
	}
    }

    if (!exists $arg->{desc}) {
	# try to find caller but cope with optimized-away frames & etc
	for my $up (1..4) {
	    my @fr = caller $up;
	    next if !@fr || $fr[0] =~ m/^Event\b/;
	    my ($file,$line) = @fr[1,2];
	    $file =~ s,^.*/,,;
	    $o->desc("?? $file:$line");
	    last;
	}
    }

    # set up prio
    {
	no strict 'refs';
	$o->prio($ { ref($o)."::DefaultPriority" } || Event::PRIO_NORMAL());
	if (exists $arg->{nice}) {
	    $o->prio($o->prio + delete $arg->{nice});
	}
    }
    $o->prio(-1)
	if delete $arg->{async};
    $o->prio(delete $arg->{prio})
	if exists $arg->{prio};

    # is parked?
    my $parked = delete $arg->{parked};

    for my $k (keys %$arg) {
	my $m = $k;
	if ($o->can($m)) {
	    $o->$m($arg->{$k});
	    next;
	}
    }

    Carp::cluck "creating ".ref($o)." desc='".$o->desc."'\n"
	if $Event::DebugLevel >= 3;

    $o->start unless $parked;
    $o;
}

sub attributes {
    no strict 'refs';
    my ($o) = @_;
    my $pk = ref $o? ref $o : $o;
    @{"$ {pk}::ATTRIBUTE"}, map { attributes($_) } @{"$ {pk}::ISA"};
}

sub configure {
    my $o = shift;
    if (! @_) {
	map { $_, $o->$_() } $o->attributes;
    } else {
	while (my ($k,$v)= splice @_, -2) { $o->$k($v)}
	1 # whatever
    }
}

sub private {  # assumes $self is a HASH ref
    my $self = shift;
    my $pkg = caller;
    if (@_) {
	$self->{$pkg} = shift
    } else {
	$self->{$pkg};
    }
}

sub data {  # assumes $self is a HASH ref
    my $self = shift;
    if (@_) {
	$self->{_user_data_} = shift
    } else {
	$self->{_user_data_};
    }
}

sub clump {
    require Carp;
    Carp::cluck "clump is deprecated";
}

package Event::Watcher::Tied;
use vars qw(@ISA @ATTRIBUTE);
@ISA = 'Event::Watcher';
@ATTRIBUTE = qw(hard at flags);

1;