Commit | Line | Data |
4536f655 |
1 | # File: Stem/Event.pm |
2 | |
3 | # This file is part of Stem. |
4 | # Copyright (C) 1999, 2000, 2001 Stem Systems, Inc. |
5 | |
6 | # Stem is free software; you can redistribute it and/or modify |
7 | # it under the terms of the GNU General Public License as published by |
8 | # the Free Software Foundation; either version 2 of the License, or |
9 | # (at your option) any later version. |
10 | |
11 | # Stem is distributed in the hope that it will be useful, |
12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of |
13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
14 | # GNU General Public License for more details. |
15 | |
16 | # You should have received a copy of the GNU General Public License |
17 | # along with Stem; if not, write to the Free Software |
18 | # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA |
19 | |
20 | # For a license to use the Stem under conditions other than those |
21 | # described here, to purchase support for this software, or to purchase a |
22 | # commercial warranty contract, please contact Stem Systems at: |
23 | |
24 | # Stem Systems, Inc. 781-643-7504 |
25 | # 79 Everett St. info@stemsystems.com |
26 | # Arlington, MA 02474 |
27 | # USA |
28 | |
29 | # this is the base class for all of the other event classes. it |
30 | # provides common services and also stubs for the internal _methods so |
31 | # the other classes don't need to declare them if they don't use them. |
32 | |
33 | package Stem::Event ; |
34 | |
35 | use Stem::Class ; |
36 | |
37 | use strict ; |
38 | |
39 | # this will hold the hashes of events for each event type. |
40 | |
41 | my %all_events = ( |
42 | |
43 | plain => {}, |
44 | signal => {}, |
45 | timer => {}, |
46 | read => {}, |
47 | write => {}, |
48 | ) ; |
49 | |
50 | # table of loop types to the Stem::Event::* class name |
51 | |
52 | my %loop_to_class = ( |
53 | |
54 | event => 'EventPM', |
55 | perl => 'Perl', |
56 | tk => 'Tk', |
57 | wx => 'Wx', |
58 | # gtk => 'Gtk', |
59 | # qt => 'Qt', |
60 | ) ; |
61 | |
62 | # use the requested event loop and default to perl on windows and |
63 | # event.pm elsewhere. |
64 | |
65 | my $loop_class = _get_loop_class() ; |
66 | |
67 | init_loop() ; |
68 | |
69 | |
70 | sub init_loop { |
71 | |
72 | $loop_class->_init_loop() ; |
73 | |
74 | Stem::Event::Queue::_init_queue() if defined &Stem::Event::Queue::_init_queue ; |
75 | |
76 | } |
77 | |
78 | sub start_loop { |
79 | |
80 | $loop_class->_start_loop() ; |
81 | } |
82 | |
83 | sub stop_loop { |
84 | |
85 | $loop_class->_stop_loop() ; |
86 | } |
87 | |
88 | sub trigger { |
89 | |
90 | my( $self, $method ) = @_ ; |
91 | |
92 | # never trigger inactive events |
93 | |
94 | return unless $self->{active} ; |
95 | |
96 | |
97 | $method ||= $self->{'method'} ; |
98 | #print "METHOD [$method]\n" ; |
99 | |
100 | $self->{'object'}->$method( $self->{'id'} ) ; |
101 | |
102 | Stem::Msg::process_queue() if defined &Stem::Msg::process_queue; |
103 | |
104 | return ; |
105 | } |
106 | |
107 | ################# |
108 | # all the stuff below is a rough cell call trace thing. it needs work |
109 | # it would be put inside the trigger method |
110 | # 'log_type' attribute is set or the event type is used. |
111 | #_init subs need to set event_log_type in the object |
112 | #use Stem::Trace 'log' => 'stem_status', 'sub' => 'TraceStatus' ; |
113 | #use Stem::Trace 'log' => 'stem_error' , 'sub' => 'TraceError' ; |
114 | # $log_type = $self->{'log_type'} || $self->{'event_type'} ; |
115 | # TraceStatus "[$log_type] [$object] [$method]\n" ; |
116 | # $Stem::Event::current_object = $object ; |
117 | # my ( $cell_name, $target ) = Stem::Route::lookup_cell_name( $object ) ; |
118 | # if ( $cell_name ) { |
119 | # # Debug |
120 | # # "EVENT $event to $cell_name:$target [$object] [$method]\n" ; |
121 | # } |
122 | # else { |
123 | # # Debug "EVENT $event to [$object] [$method]\n" ; |
124 | # } |
125 | ################# |
126 | |
127 | |
128 | # get all the event objects for an event type |
129 | # this is a class sub. |
130 | |
131 | sub _get_events { |
132 | |
133 | my( $event_type ) = @_ ; |
134 | |
135 | my $events = $all_events{ $event_type } ; |
136 | |
137 | return unless $events ; |
138 | |
139 | return values %{$events} if wantarray ; |
140 | |
141 | return $events ; |
142 | } |
143 | |
144 | # initialize the subclass object for this event and store generic event |
145 | # info. |
146 | |
147 | sub _build_core_event { |
148 | |
149 | #print "BAZ\n" ; |
150 | |
151 | my( $self, $event_type ) = @_ ; |
152 | |
153 | |
154 | #print "EVT [$self] [$event_type]\n" ; |
155 | |
156 | # call and and check the return of the core event constructor |
157 | |
158 | if ( my $core_event = $self->_build() ) { |
159 | |
160 | # return the error if it was an error string |
161 | |
162 | return $core_event unless ref $core_event ; |
163 | |
164 | # save the core event |
165 | |
166 | $self->{core_event} = $core_event ; |
167 | } |
168 | |
169 | # mark the event type and track it |
170 | |
171 | $self->{event_type} = $event_type ; |
172 | $all_events{ $event_type }{ $self } = $self ; |
173 | |
174 | return ; |
175 | } |
176 | |
177 | # these are the public versions of the support methods. |
178 | # subclasses can provide a _method to override the stub ones in this class. |
179 | |
180 | sub cancel { |
181 | |
182 | my( $self ) = @_ ; |
183 | |
184 | $self->{'active'} = 0 ; |
185 | delete $self->{'object'} ; |
186 | |
187 | # delete the core object |
188 | |
189 | if ( my $core_event = delete $self->{core_event} ) { |
190 | |
191 | # call the core cancel |
192 | |
193 | $self->_cancel( $core_event ) ; |
194 | } |
195 | |
196 | # delete this event from the tracking hash |
197 | |
198 | delete $all_events{ $self->{event_type} }{ $self } ; |
199 | |
200 | return ; |
201 | } |
202 | |
203 | sub start { |
204 | my( $self ) = @_ ; |
205 | |
206 | $self->{'active'} = 1 ; |
207 | $self->_start( $self->{core_event} ) ; |
208 | |
209 | return ; |
210 | } |
211 | |
212 | sub stop { |
213 | my( $self ) = @_ ; |
214 | |
215 | $self->{'active'} = 0 ; |
216 | $self->_stop( $self->{core_event} ) ; |
217 | |
218 | return ; |
219 | } |
220 | |
221 | # stubs for the internal methods that subclasses should override if needed. |
222 | |
223 | sub _init_loop {} |
224 | sub _build {} |
225 | sub _start {} |
226 | sub _stop {} |
227 | sub _reset {} |
228 | sub _cancel {} |
229 | |
230 | use Stem::Debug qw( dump_socket dump_owner dump_data ) ; |
231 | |
232 | sub dump_events { |
233 | |
234 | print dump_data( \%all_events ) ; |
235 | } |
236 | |
237 | sub dump { |
238 | |
239 | my( $self ) = @_ ; |
240 | |
241 | my $event_text = <<TEXT ; |
242 | EV: $self |
243 | ACT: $self->{'active'} |
244 | TEXT |
245 | |
246 | my $obj_dump = dump_owner $self->{'object'} ; |
247 | $event_text .= <<TEXT ; |
248 | OBJ: $obj_dump |
249 | METH: $self->{'method'} |
250 | TEXT |
251 | |
252 | if ( my $fh = $self->{'fh'} ) { |
253 | |
254 | my $fh_text = dump_socket( $self->{'fh'} ) ; |
255 | $event_text .= <<TEXT ; |
256 | FH: $fh_text |
257 | TEXT |
258 | } |
259 | |
260 | if ( $self->{event_type} eq 'timer' ) { |
261 | |
262 | my $delay = $self->{delay} || 'NONE' ; |
263 | my $interval = $self->{interval} || 'NONE' ; |
264 | $event_text .= <<TEXT ; |
265 | DELAY: $delay |
266 | INT: $interval |
267 | TEXT |
268 | } |
269 | |
270 | if ( my $io_timer_event = $self->{'io_timer_event'} ) { |
271 | |
272 | $event_text = "IO TIMER: >>>>>\n" . $io_timer_event->dump() . |
273 | "END\n"; |
274 | } |
275 | |
276 | return <<DUMP ; |
277 | |
278 | >>> |
279 | $event_text<<< |
280 | |
281 | DUMP |
282 | |
283 | } |
284 | |
285 | ############# |
286 | # change this to a cleaner loop style which can handle more event loops and |
287 | # try them in sequence |
288 | ############# |
289 | |
290 | sub _get_loop_class { |
291 | |
292 | my $loop_type = $Stem::Vars::Env{ 'event_loop' } || |
293 | ($^O =~ /win32/i ? 'perl' : 'event' ); |
294 | |
295 | $loop_type = 'perl' unless $loop_to_class{ $loop_type } ; |
296 | my $loop_class = "Stem::Event::$loop_to_class{ $loop_type }" ; |
297 | |
298 | unless ( eval "require $loop_class" ) { |
299 | die "can't load $loop_class: $@" if $@ && $@ !~ /locate/ ; |
300 | |
301 | $loop_type = 'perl' ; |
302 | eval { require Stem::Event::Perl } ; |
303 | die "can't load event loop Stem::Event::Perl $@" if $@ ; |
304 | } |
305 | |
306 | # save the event loop that we loaded. |
307 | |
308 | #print "using event loop [$loop_type]\n" ; |
309 | $Stem::Vars::Env{ 'event_loop' } = $loop_type ; |
310 | |
311 | return $loop_class ; |
312 | } |
313 | |
314 | |
315 | ############################################################################ |
316 | |
317 | package Stem::Event::Plain ; |
318 | |
319 | BEGIN { |
320 | @Stem::Event::Plain::ISA = qw( Stem::Event ) ; |
321 | } |
322 | |
323 | =head2 Stem::Event::Plain::new |
324 | |
325 | This class creates an event that will trigger a callback after all |
326 | other pending events have been triggered. |
327 | |
328 | =head2 Example |
329 | |
330 | $plain_event = Stem::Event::Plain->new( 'object' => $self ) ; |
331 | |
332 | =cut |
333 | |
334 | my $attr_spec_plain = [ |
335 | |
336 | { |
337 | 'name' => 'object', |
338 | 'required' => 1, |
339 | 'type' => 'object', |
340 | 'help' => <<HELP, |
341 | This object gets the method callbacks |
342 | HELP |
343 | }, |
344 | { |
345 | 'name' => 'method', |
346 | 'default' => 'triggered', |
347 | 'help' => <<HELP, |
348 | This method is called on the object when the plain event is triggered |
349 | HELP |
350 | }, |
351 | { |
352 | 'name' => 'id', |
353 | 'help' => <<HELP, |
354 | The id is passed to the callback method as its only argument. Use it to |
355 | identify different instances of this object. |
356 | HELP |
357 | |
358 | }, |
359 | ] ; |
360 | |
361 | sub new { |
362 | |
363 | my( $class ) = shift ; |
364 | |
365 | my $self = Stem::Class::parse_args( $attr_spec_plain, @_ ) ; |
366 | return $self unless ref $self ; |
367 | |
368 | my $err = $self->_core_event_build( 'plain' ) ; |
369 | return $err if $err ; |
370 | |
371 | return $self ; |
372 | } |
373 | |
374 | ############################################################################ |
375 | |
376 | package Stem::Event::Signal ; |
377 | |
378 | BEGIN { our @ISA = qw( Stem::Event ) } ; |
379 | |
380 | =head2 Stem::Event::Signal::new |
381 | |
382 | This class creates an event that will trigger a callback whenever |
383 | its its signal has been received. |
384 | |
385 | =head2 Example |
386 | |
387 | $signal_event = Stem::Event::Signal->new( 'object' => $self, |
388 | 'signal' => 'INT' ) ; |
389 | |
390 | sub sig_int_handler { die "SIGINT\n" } |
391 | |
392 | =cut |
393 | |
394 | my $attr_spec_signal = [ |
395 | |
396 | { |
397 | 'name' => 'object', |
398 | 'required' => 1, |
399 | 'type' => 'object', |
400 | 'help' => <<HELP, |
401 | This object gets the method callbacks |
402 | HELP |
403 | }, |
404 | { |
405 | 'name' => 'method', |
406 | 'help' => <<HELP, |
407 | This method is called on the object when this event is triggered. The |
408 | default method name for the signal NAME is 'sig_name_handler' (all lower case) |
409 | HELP |
410 | }, |
411 | { |
412 | 'name' => 'signal', |
413 | 'required' => 1, |
414 | 'help' => <<HELP, |
415 | This is the name of the signal to handle. It is used as part of the |
416 | default handler method name. |
417 | HELP |
418 | }, |
419 | { |
420 | 'name' => 'active', |
421 | 'default' => 1, |
422 | 'type' => 'boolean', |
423 | 'help' => <<HELP, |
424 | This flag marks the event as being active. It can be toggled with the |
425 | start/stop methods. |
426 | HELP |
427 | }, |
428 | { |
429 | 'name' => 'id', |
430 | 'help' => <<HELP, |
431 | The id is passed to the callback method as its only argument. Use it to |
432 | identify different instances of this object. |
433 | HELP |
434 | |
435 | }, |
436 | ] ; |
437 | |
438 | sub new { |
439 | |
440 | my( $class ) = shift ; |
441 | |
442 | my $self = Stem::Class::parse_args( $attr_spec_signal, @_ ) ; |
443 | return $self unless ref $self ; |
444 | |
445 | my $signal = uc $self->{'signal'} ; |
446 | |
447 | return "Unknown signal: $signal" unless exists $SIG{ $signal } ; |
448 | |
449 | $self->{'method'} ||= "sig_\L${signal}_handler" ; |
450 | $self->{'signal'} = $signal ; |
451 | |
452 | my $err = $self->_build_core_event( 'signal' ) ; |
453 | return $err if $err ; |
454 | |
455 | #print "SELF SIG $self\nPID $$\n" ; |
456 | |
457 | return $self ; |
458 | } |
459 | |
460 | |
461 | ############################################################################ |
462 | |
463 | package Stem::Event::Timer ; |
464 | |
465 | BEGIN { our @ISA = qw( Stem::Event ) } ; |
466 | |
467 | =head2 Stem::Event::Timer::new |
468 | |
469 | This class creates an event that will trigger a callback after a time |
470 | period has elapsed. The initial timer delay is set from the 'delay', |
471 | 'at' or 'interval' attributes in that order. If the 'interval' |
472 | attribute is not set, the timer will cancel itself after its first |
473 | triggering (it is a one-shot). The 'hard' attribute means that the |
474 | next interval delay starts before the callback to the object is |
475 | made. If a soft timer is selected (hard is 0), the delay starts after |
476 | the callback returns. So the hard timer ignores the time taken by the |
477 | callback and so it is a more accurate timer. The accuracy a soft timer |
478 | is affected by how much time the callback takes. |
479 | |
480 | =head2 Example |
481 | |
482 | $timer_event = Stem::Event::Timer->new( 'object' => $self, |
483 | 'delay' => 5, |
484 | 'interval' => 10 ) ; |
485 | |
486 | sub timed_out { print "timer alert\n" } ; |
487 | |
488 | |
489 | =cut |
490 | |
491 | BEGIN { |
492 | |
493 | my $attr_spec_timer = [ |
494 | |
495 | { |
496 | 'name' => 'object', |
497 | 'required' => 1, |
498 | 'type' => 'object', |
499 | 'help' => <<HELP, |
500 | This object gets the method callbacks |
501 | HELP |
502 | }, |
503 | { |
504 | 'name' => 'method', |
505 | 'default' => 'timed_out', |
506 | 'help' => <<HELP, |
507 | This method is called on the object when the timeout is triggered |
508 | HELP |
509 | }, |
510 | { |
511 | 'name' => 'delay', |
512 | 'help' => <<HELP, |
513 | Delay this amount of seconds before triggering the first time. If this |
514 | is not set then the 'at' or 'interval' attributes will be used. |
515 | HELP |
516 | }, |
517 | { |
518 | 'name' => 'interval', |
519 | 'help' => <<HELP, |
520 | Wait this time (in seconds) before any repeated triggers. If not set |
521 | then the timer is a one-shot |
522 | HELP |
523 | }, |
524 | { |
525 | 'name' => 'at', |
526 | 'help' => <<HELP, |
527 | Trigger in the future at this time (in epoch seconds). It will set the intial |
528 | delay to the different between the current time and the 'at' time. |
529 | HELP |
530 | }, |
531 | { |
532 | 'name' => 'hard', |
533 | 'type' => 'boolean', |
534 | 'default' => 0, |
535 | 'help' => <<HELP, |
536 | If this is set, the interval time starts when the event is |
537 | triggered. If it is not set, the interval time starts when the object |
538 | callback has finished. So 'hard' timers repeat closer to equal |
539 | intervals while without 'hard' the repeat time is dependant on how |
540 | long the callback takes. |
541 | HELP |
542 | }, |
543 | { |
544 | 'name' => 'active', |
545 | 'default' => 1, |
546 | 'type' => 'boolean', |
547 | 'help' => <<HELP, |
548 | This flag marks the event as being active. It can be toggled with the |
549 | start/stop methods. |
550 | HELP |
551 | }, |
552 | { |
553 | 'name' => 'id', |
554 | 'help' => <<HELP, |
555 | The id is passed to the callback method as its only argument. Use it to |
556 | identify different instances of this object. |
557 | HELP |
558 | |
559 | }, |
560 | ] ; |
561 | |
562 | sub new { |
563 | |
564 | my( $class ) = shift ; |
565 | |
566 | my $self = Stem::Class::parse_args( $attr_spec_timer, @_ ) ; |
567 | return $self unless ref $self ; |
568 | |
569 | # the delay is either set, or at a future time or the interval |
570 | |
571 | my $delay = exists( $self->{ 'delay' } ) ? |
572 | $self->{ 'delay' } : |
573 | exists( $self->{ 'at' } ) ? |
574 | $self->{ 'at' } - time() : |
575 | $self->{'interval'} ; |
576 | |
577 | #print "INT $self->{'interval'} DELAY $delay\n" ; |
578 | |
579 | # squawk if no delay value |
580 | |
581 | return "No initial delay was specified for timer" |
582 | unless defined $delay ; |
583 | |
584 | $self->{'delay'} = $delay ; |
585 | $self->{'time_left'} = $delay ; |
586 | |
587 | my $err = $self->_build_core_event( 'timer' ) ; |
588 | return $err if $err ; |
589 | |
590 | ########## |
591 | # check on this logic |
592 | ######### |
593 | |
594 | $self->_stop unless $self->{'active'} ; |
595 | |
596 | return $self ; |
597 | } |
598 | |
599 | } |
600 | |
601 | sub reset { |
602 | |
603 | my( $self, $reset_delay ) = @_ ; |
604 | |
605 | return unless $self->{'active'} ; |
606 | |
607 | # if we don't get passed a delay, use the interval or the delay attribute |
608 | |
609 | $reset_delay ||= ($self->{'interval'}) ? |
610 | $self->{'interval'} : $self->{'delay'} ; |
611 | |
612 | # track the new delay and reset the real timer (if we are using one) |
613 | |
614 | $self->{'time_left'} = $reset_delay ; |
615 | |
616 | $self->_reset( $self->{core_event}, $reset_delay ) ; |
617 | |
618 | return ; |
619 | } |
620 | |
621 | sub timer_triggered { |
622 | |
623 | my( $self ) = @_ ; |
624 | |
625 | #print time(), " TIMER TRIG\n" ; |
626 | #use Carp qw( cluck ) ; |
627 | #cluck ; |
628 | |
629 | # check if this is a one-shot timer |
630 | |
631 | $self->cancel() unless $self->{'interval'} ; |
632 | |
633 | # reset the timer count before the trigger code for hard timers |
634 | #(trigger on fixed intervals) |
635 | |
636 | $self->reset( $self->{'interval'} ) if $self->{'hard'}; |
637 | |
638 | $self->trigger() ; |
639 | |
640 | # reset the timer count before the trigger code for soft timers |
641 | #(trigger on at least fixed intervals) |
642 | |
643 | $self->reset( $self->{'interval'} ) unless $self->{'hard'}; |
644 | } |
645 | |
646 | ############################################################################ |
647 | |
648 | #################################################################### |
649 | # common methods for the Read/Write event classes to handle the optional |
650 | # I/O timeouts. |
651 | # these override Stem::Event's methods and then call those via SUPER:: |
652 | |
653 | package Stem::Event::IO ; |
654 | |
655 | BEGIN { our @ISA = qw( Stem::Event ) } ; |
656 | |
657 | sub init_io_timeout { |
658 | |
659 | my( $self ) = @_ ; |
660 | |
661 | my $timeout = $self->{'timeout'} ; |
662 | return unless $timeout ; |
663 | |
664 | $self->{'io_timer_event'} = Stem::Event::Timer->new( |
665 | 'object' => $self, |
666 | 'interval' => $timeout, |
667 | ) ; |
668 | |
669 | return ; |
670 | } |
671 | |
672 | sub cancel { |
673 | |
674 | my( $self ) = @_ ; |
675 | |
676 | #print "IO CANCEL $self\n" ; |
677 | |
678 | if ( my $io_timer_event = delete $self->{'io_timer_event'} ) { |
679 | $io_timer_event->cancel() ; |
680 | } |
681 | |
682 | $self->SUPER::cancel() ; |
683 | |
684 | delete $self->{'fh'} ; |
685 | |
686 | return ; |
687 | } |
688 | |
689 | sub start { |
690 | |
691 | my( $self ) = @_ ; |
692 | |
693 | if ( my $io_timer_event = $self->{'io_timer_event'} ) { |
694 | $io_timer_event->start() ; |
695 | } |
696 | |
697 | $self->SUPER::start() ; |
698 | |
699 | return ; |
700 | } |
701 | |
702 | sub stop { |
703 | |
704 | my( $self ) = @_ ; |
705 | |
706 | $self->{'active'} = 0 ; |
707 | |
708 | if ( my $io_timer_event = $self->{'io_timer_event'} ) { |
709 | $io_timer_event->stop() ; |
710 | } |
711 | |
712 | $self->SUPER::stop() ; |
713 | |
714 | return ; |
715 | } |
716 | |
717 | sub timed_out { |
718 | |
719 | my( $self ) = @_ ; |
720 | |
721 | # $self->{log_type} = "$self->{'event_type'}_timeout" ; |
722 | $self->trigger( $self->{'timeout_method'} ) ; |
723 | } |
724 | |
725 | ####################################################### |
726 | |
727 | package Stem::Event::Read ; |
728 | |
729 | BEGIN { our @ISA = qw( Stem::Event::IO ) } |
730 | |
731 | =head2 Stem::Event::Read::new |
732 | |
733 | This class creates an event that will trigger a callback whenever |
734 | its file descriptor has data to be read. It takes an optional timeout |
735 | value which will trigger a callback to the object if no data has been |
736 | read during that period. |
737 | |
738 | Read events are active when created - a call to the stop method is |
739 | needed to deactivate them. |
740 | |
741 | =cut |
742 | |
743 | BEGIN { |
744 | |
745 | my $attr_spec_read = [ |
746 | |
747 | { |
748 | 'name' => 'object', |
749 | 'required' => 1, |
750 | 'type' => 'object', |
751 | 'help' => <<HELP, |
752 | This object gets the method callbacks |
753 | HELP |
754 | }, |
755 | { |
756 | 'name' => 'fh', |
757 | 'required' => 1, |
758 | 'type' => 'handle', |
759 | 'help' => <<HELP, |
760 | This file handle is checked if it has data to read |
761 | HELP |
762 | }, |
763 | { |
764 | 'name' => 'timeout', |
765 | 'help' => <<HELP, |
766 | How long to wait (in seconds) without being readable before calling |
767 | the timeout method |
768 | HELP |
769 | }, |
770 | { |
771 | 'name' => 'method', |
772 | 'default' => 'readable', |
773 | 'help' => <<HELP, |
774 | This method is called on the object when the file handle has data to read |
775 | HELP |
776 | }, |
777 | { |
778 | 'name' => 'timeout_method', |
779 | 'default' => 'read_timeout', |
780 | 'help' => <<HELP, |
781 | This method is called on the object when the hasn't been readable |
782 | after the timeout period |
783 | HELP |
784 | }, |
785 | { |
786 | 'name' => 'active', |
787 | 'default' => 1, |
788 | 'type' => 'boolean', |
789 | 'help' => <<HELP, |
790 | This flag marks the event as being active. It can be toggled with the |
791 | start/stop methods. |
792 | HELP |
793 | }, |
794 | { |
795 | 'name' => 'id', |
796 | 'help' => <<HELP, |
797 | The id is passed to the callback method as its only argument. Use it to |
798 | identify different instances of this object. |
799 | HELP |
800 | |
801 | }, |
802 | ] ; |
803 | |
804 | sub new { |
805 | |
806 | my( $class ) = shift ; |
807 | |
808 | my $self = Stem::Class::parse_args( $attr_spec_read, @_ ) ; |
809 | return $self unless ref $self ; |
810 | |
811 | # return <<ERR unless defined fileno $self->{fh} ; |
812 | # Stem::Event::Read: $self->{fh} is not an open handle |
813 | # ERR |
814 | |
815 | my $err = $self->_build_core_event( 'read' ) ; |
816 | return $err if $err ; |
817 | |
818 | $self->init_io_timeout() ; |
819 | |
820 | return $self ; |
821 | } |
822 | |
823 | } |
824 | ############################################################################ |
825 | |
826 | package Stem::Event::Write ; |
827 | |
828 | BEGIN { our @ISA = qw( Stem::Event::IO ) } ; |
829 | |
830 | =head2 Stem::Event::Write::new |
831 | |
832 | This class creates an event that will trigger a callback whenever |
833 | its file descriptor can be written to. It takes an optional timeout |
834 | value which will trigger a callback to the object if no data has been |
835 | written during that period. |
836 | |
837 | Write events are stopped when created - a call to the start method is |
838 | needed to activate them. |
839 | |
840 | =cut |
841 | |
842 | my $attr_spec_write = [ |
843 | |
844 | { |
845 | 'name' => 'object', |
846 | 'required' => 1, |
847 | 'type' => 'object', |
848 | 'help' => <<HELP, |
849 | This object gets the method callbacks |
850 | HELP |
851 | }, |
852 | { |
853 | 'name' => 'fh', |
854 | 'required' => 1, |
855 | 'type' => 'handle', |
856 | 'help' => <<HELP, |
857 | This file handle is checked if it is writeable |
858 | HELP |
859 | }, |
860 | { |
861 | 'name' => 'timeout', |
862 | 'help' => <<HELP, |
863 | How long to wait (in seconds) without being writeable before calling |
864 | the timeout method |
865 | HELP |
866 | }, |
867 | { |
868 | 'name' => 'method', |
869 | 'default' => 'writeable', |
870 | 'help' => <<HELP, |
871 | This method is called on the object when the file handle is writeable |
872 | HELP |
873 | }, |
874 | { |
875 | 'name' => 'timeout_method', |
876 | 'default' => 'write_timeout', |
877 | 'help' => <<HELP, |
878 | This method is called on the object when the hasn't been writeable |
879 | after the timeout period |
880 | HELP |
881 | }, |
882 | { |
883 | 'name' => 'active', |
884 | 'default' => 0, |
885 | 'type' => 'boolean', |
886 | 'help' => <<HELP, |
887 | This flag marks the event as being active. It can be toggled with the |
888 | start/stop methods. |
889 | NOTE: Write events are not active by default. |
890 | HELP |
891 | }, |
892 | { |
893 | 'name' => 'id', |
894 | 'help' => <<HELP, |
895 | The id is passed to the callback method as its only argument. Use it to |
896 | identify different instances of this object. |
897 | HELP |
898 | |
899 | }, |
900 | ] ; |
901 | |
902 | sub new { |
903 | |
904 | my( $class ) = shift ; |
905 | |
906 | my $self = Stem::Class::parse_args( $attr_spec_write, @_ ) ; |
907 | return $self unless ref $self ; |
908 | |
909 | my $err = $self->_build_core_event( 'write' ) ; |
910 | return $err if $err ; |
911 | |
912 | #print $self->dump_events() ; |
913 | |
914 | $self->init_io_timeout() ; |
915 | |
916 | $self->stop() unless $self->{'active'} ; |
917 | |
918 | #print $self->dump() ; |
919 | |
920 | return $self ; |
921 | } |
922 | |
923 | 1 ; |