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;