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 | |
4932dd97 |
74 | #Stem::Event::Queue::_init_queue() if defined &Stem::Event::Queue::_init_queue ; |
4536f655 |
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 | |
4932dd97 |
319 | our @ISA = qw( Stem::Event ) ; |
4536f655 |
320 | |
321 | =head2 Stem::Event::Plain::new |
322 | |
323 | This class creates an event that will trigger a callback after all |
324 | other pending events have been triggered. |
325 | |
326 | =head2 Example |
327 | |
328 | $plain_event = Stem::Event::Plain->new( 'object' => $self ) ; |
329 | |
330 | =cut |
331 | |
332 | my $attr_spec_plain = [ |
333 | |
334 | { |
335 | 'name' => 'object', |
336 | 'required' => 1, |
337 | 'type' => 'object', |
338 | 'help' => <<HELP, |
339 | This object gets the method callbacks |
340 | HELP |
341 | }, |
342 | { |
343 | 'name' => 'method', |
344 | 'default' => 'triggered', |
345 | 'help' => <<HELP, |
346 | This method is called on the object when the plain event is triggered |
347 | HELP |
348 | }, |
349 | { |
350 | 'name' => 'id', |
351 | 'help' => <<HELP, |
352 | The id is passed to the callback method as its only argument. Use it to |
353 | identify different instances of this object. |
354 | HELP |
355 | |
356 | }, |
357 | ] ; |
358 | |
359 | sub new { |
360 | |
361 | my( $class ) = shift ; |
362 | |
363 | my $self = Stem::Class::parse_args( $attr_spec_plain, @_ ) ; |
364 | return $self unless ref $self ; |
365 | |
4932dd97 |
366 | my $err = $self->_build_core_event( 'plain' ) ; |
4536f655 |
367 | return $err if $err ; |
368 | |
369 | return $self ; |
370 | } |
371 | |
372 | ############################################################################ |
373 | |
374 | package Stem::Event::Signal ; |
375 | |
4932dd97 |
376 | our @ISA = qw( Stem::Event ) ; |
4536f655 |
377 | |
378 | =head2 Stem::Event::Signal::new |
379 | |
380 | This class creates an event that will trigger a callback whenever |
381 | its its signal has been received. |
382 | |
383 | =head2 Example |
384 | |
385 | $signal_event = Stem::Event::Signal->new( 'object' => $self, |
386 | 'signal' => 'INT' ) ; |
387 | |
388 | sub sig_int_handler { die "SIGINT\n" } |
389 | |
390 | =cut |
391 | |
392 | my $attr_spec_signal = [ |
393 | |
394 | { |
395 | 'name' => 'object', |
396 | 'required' => 1, |
397 | 'type' => 'object', |
398 | 'help' => <<HELP, |
399 | This object gets the method callbacks |
400 | HELP |
401 | }, |
402 | { |
403 | 'name' => 'method', |
404 | 'help' => <<HELP, |
405 | This method is called on the object when this event is triggered. The |
406 | default method name for the signal NAME is 'sig_name_handler' (all lower case) |
407 | HELP |
408 | }, |
409 | { |
410 | 'name' => 'signal', |
411 | 'required' => 1, |
412 | 'help' => <<HELP, |
413 | This is the name of the signal to handle. It is used as part of the |
414 | default handler method name. |
415 | HELP |
416 | }, |
417 | { |
418 | 'name' => 'active', |
419 | 'default' => 1, |
420 | 'type' => 'boolean', |
421 | 'help' => <<HELP, |
422 | This flag marks the event as being active. It can be toggled with the |
423 | start/stop methods. |
424 | HELP |
425 | }, |
426 | { |
427 | 'name' => 'id', |
428 | 'help' => <<HELP, |
429 | The id is passed to the callback method as its only argument. Use it to |
430 | identify different instances of this object. |
431 | HELP |
432 | |
433 | }, |
434 | ] ; |
435 | |
436 | sub new { |
437 | |
438 | my( $class ) = shift ; |
439 | |
440 | my $self = Stem::Class::parse_args( $attr_spec_signal, @_ ) ; |
441 | return $self unless ref $self ; |
442 | |
443 | my $signal = uc $self->{'signal'} ; |
444 | |
445 | return "Unknown signal: $signal" unless exists $SIG{ $signal } ; |
446 | |
447 | $self->{'method'} ||= "sig_\L${signal}_handler" ; |
448 | $self->{'signal'} = $signal ; |
449 | |
450 | my $err = $self->_build_core_event( 'signal' ) ; |
451 | return $err if $err ; |
452 | |
453 | #print "SELF SIG $self\nPID $$\n" ; |
454 | |
455 | return $self ; |
456 | } |
457 | |
458 | |
459 | ############################################################################ |
460 | |
461 | package Stem::Event::Timer ; |
462 | |
4932dd97 |
463 | our @ISA = qw( Stem::Event ) ; |
4536f655 |
464 | |
465 | =head2 Stem::Event::Timer::new |
466 | |
467 | This class creates an event that will trigger a callback after a time |
468 | period has elapsed. The initial timer delay is set from the 'delay', |
469 | 'at' or 'interval' attributes in that order. If the 'interval' |
470 | attribute is not set, the timer will cancel itself after its first |
471 | triggering (it is a one-shot). The 'hard' attribute means that the |
472 | next interval delay starts before the callback to the object is |
473 | made. If a soft timer is selected (hard is 0), the delay starts after |
474 | the callback returns. So the hard timer ignores the time taken by the |
475 | callback and so it is a more accurate timer. The accuracy a soft timer |
476 | is affected by how much time the callback takes. |
477 | |
478 | =head2 Example |
479 | |
480 | $timer_event = Stem::Event::Timer->new( 'object' => $self, |
481 | 'delay' => 5, |
482 | 'interval' => 10 ) ; |
483 | |
484 | sub timed_out { print "timer alert\n" } ; |
485 | |
486 | |
487 | =cut |
488 | |
489 | BEGIN { |
490 | |
491 | my $attr_spec_timer = [ |
492 | |
493 | { |
494 | 'name' => 'object', |
495 | 'required' => 1, |
496 | 'type' => 'object', |
497 | 'help' => <<HELP, |
498 | This object gets the method callbacks |
499 | HELP |
500 | }, |
501 | { |
502 | 'name' => 'method', |
503 | 'default' => 'timed_out', |
504 | 'help' => <<HELP, |
505 | This method is called on the object when the timeout is triggered |
506 | HELP |
507 | }, |
508 | { |
509 | 'name' => 'delay', |
510 | 'help' => <<HELP, |
511 | Delay this amount of seconds before triggering the first time. If this |
512 | is not set then the 'at' or 'interval' attributes will be used. |
513 | HELP |
514 | }, |
515 | { |
516 | 'name' => 'interval', |
517 | 'help' => <<HELP, |
518 | Wait this time (in seconds) before any repeated triggers. If not set |
519 | then the timer is a one-shot |
520 | HELP |
521 | }, |
522 | { |
523 | 'name' => 'at', |
524 | 'help' => <<HELP, |
525 | Trigger in the future at this time (in epoch seconds). It will set the intial |
526 | delay to the different between the current time and the 'at' time. |
527 | HELP |
528 | }, |
529 | { |
530 | 'name' => 'hard', |
531 | 'type' => 'boolean', |
532 | 'default' => 0, |
533 | 'help' => <<HELP, |
534 | If this is set, the interval time starts when the event is |
535 | triggered. If it is not set, the interval time starts when the object |
536 | callback has finished. So 'hard' timers repeat closer to equal |
537 | intervals while without 'hard' the repeat time is dependant on how |
538 | long the callback takes. |
539 | HELP |
540 | }, |
541 | { |
542 | 'name' => 'active', |
543 | 'default' => 1, |
544 | 'type' => 'boolean', |
545 | 'help' => <<HELP, |
546 | This flag marks the event as being active. It can be toggled with the |
547 | start/stop methods. |
548 | HELP |
549 | }, |
550 | { |
551 | 'name' => 'id', |
552 | 'help' => <<HELP, |
553 | The id is passed to the callback method as its only argument. Use it to |
554 | identify different instances of this object. |
555 | HELP |
556 | |
557 | }, |
558 | ] ; |
559 | |
560 | sub new { |
561 | |
562 | my( $class ) = shift ; |
563 | |
564 | my $self = Stem::Class::parse_args( $attr_spec_timer, @_ ) ; |
565 | return $self unless ref $self ; |
566 | |
567 | # the delay is either set, or at a future time or the interval |
568 | |
569 | my $delay = exists( $self->{ 'delay' } ) ? |
570 | $self->{ 'delay' } : |
571 | exists( $self->{ 'at' } ) ? |
572 | $self->{ 'at' } - time() : |
573 | $self->{'interval'} ; |
574 | |
575 | #print "INT $self->{'interval'} DELAY $delay\n" ; |
576 | |
577 | # squawk if no delay value |
578 | |
579 | return "No initial delay was specified for timer" |
580 | unless defined $delay ; |
581 | |
582 | $self->{'delay'} = $delay ; |
583 | $self->{'time_left'} = $delay ; |
584 | |
585 | my $err = $self->_build_core_event( 'timer' ) ; |
586 | return $err if $err ; |
587 | |
588 | ########## |
589 | # check on this logic |
590 | ######### |
591 | |
592 | $self->_stop unless $self->{'active'} ; |
593 | |
594 | return $self ; |
595 | } |
596 | |
597 | } |
598 | |
599 | sub reset { |
600 | |
601 | my( $self, $reset_delay ) = @_ ; |
602 | |
603 | return unless $self->{'active'} ; |
604 | |
605 | # if we don't get passed a delay, use the interval or the delay attribute |
606 | |
607 | $reset_delay ||= ($self->{'interval'}) ? |
608 | $self->{'interval'} : $self->{'delay'} ; |
609 | |
610 | # track the new delay and reset the real timer (if we are using one) |
611 | |
612 | $self->{'time_left'} = $reset_delay ; |
613 | |
614 | $self->_reset( $self->{core_event}, $reset_delay ) ; |
615 | |
616 | return ; |
617 | } |
618 | |
619 | sub timer_triggered { |
620 | |
621 | my( $self ) = @_ ; |
622 | |
623 | #print time(), " TIMER TRIG\n" ; |
624 | #use Carp qw( cluck ) ; |
625 | #cluck ; |
626 | |
627 | # check if this is a one-shot timer |
628 | |
629 | $self->cancel() unless $self->{'interval'} ; |
630 | |
631 | # reset the timer count before the trigger code for hard timers |
632 | #(trigger on fixed intervals) |
633 | |
634 | $self->reset( $self->{'interval'} ) if $self->{'hard'}; |
635 | |
636 | $self->trigger() ; |
637 | |
638 | # reset the timer count before the trigger code for soft timers |
639 | #(trigger on at least fixed intervals) |
640 | |
641 | $self->reset( $self->{'interval'} ) unless $self->{'hard'}; |
642 | } |
643 | |
644 | ############################################################################ |
645 | |
646 | #################################################################### |
647 | # common methods for the Read/Write event classes to handle the optional |
648 | # I/O timeouts. |
649 | # these override Stem::Event's methods and then call those via SUPER:: |
650 | |
651 | package Stem::Event::IO ; |
652 | |
4932dd97 |
653 | our @ISA = qw( Stem::Event ) ; |
4536f655 |
654 | |
655 | sub init_io_timeout { |
656 | |
657 | my( $self ) = @_ ; |
658 | |
659 | my $timeout = $self->{'timeout'} ; |
660 | return unless $timeout ; |
661 | |
662 | $self->{'io_timer_event'} = Stem::Event::Timer->new( |
663 | 'object' => $self, |
664 | 'interval' => $timeout, |
665 | ) ; |
666 | |
667 | return ; |
668 | } |
669 | |
670 | sub cancel { |
671 | |
672 | my( $self ) = @_ ; |
673 | |
674 | #print "IO CANCEL $self\n" ; |
675 | |
676 | if ( my $io_timer_event = delete $self->{'io_timer_event'} ) { |
677 | $io_timer_event->cancel() ; |
678 | } |
679 | |
680 | $self->SUPER::cancel() ; |
681 | |
682 | delete $self->{'fh'} ; |
683 | |
684 | return ; |
685 | } |
686 | |
687 | sub start { |
688 | |
689 | my( $self ) = @_ ; |
690 | |
691 | if ( my $io_timer_event = $self->{'io_timer_event'} ) { |
692 | $io_timer_event->start() ; |
693 | } |
694 | |
695 | $self->SUPER::start() ; |
696 | |
697 | return ; |
698 | } |
699 | |
700 | sub stop { |
701 | |
702 | my( $self ) = @_ ; |
703 | |
704 | $self->{'active'} = 0 ; |
705 | |
706 | if ( my $io_timer_event = $self->{'io_timer_event'} ) { |
707 | $io_timer_event->stop() ; |
708 | } |
709 | |
710 | $self->SUPER::stop() ; |
711 | |
712 | return ; |
713 | } |
714 | |
715 | sub timed_out { |
716 | |
717 | my( $self ) = @_ ; |
718 | |
719 | # $self->{log_type} = "$self->{'event_type'}_timeout" ; |
720 | $self->trigger( $self->{'timeout_method'} ) ; |
721 | } |
722 | |
723 | ####################################################### |
724 | |
725 | package Stem::Event::Read ; |
726 | |
4932dd97 |
727 | our @ISA = qw( Stem::Event::IO ) ; |
4536f655 |
728 | |
729 | =head2 Stem::Event::Read::new |
730 | |
731 | This class creates an event that will trigger a callback whenever |
732 | its file descriptor has data to be read. It takes an optional timeout |
733 | value which will trigger a callback to the object if no data has been |
734 | read during that period. |
735 | |
736 | Read events are active when created - a call to the stop method is |
737 | needed to deactivate them. |
738 | |
739 | =cut |
740 | |
741 | BEGIN { |
742 | |
743 | my $attr_spec_read = [ |
744 | |
745 | { |
746 | 'name' => 'object', |
747 | 'required' => 1, |
748 | 'type' => 'object', |
749 | 'help' => <<HELP, |
750 | This object gets the method callbacks |
751 | HELP |
752 | }, |
753 | { |
754 | 'name' => 'fh', |
755 | 'required' => 1, |
756 | 'type' => 'handle', |
757 | 'help' => <<HELP, |
758 | This file handle is checked if it has data to read |
759 | HELP |
760 | }, |
761 | { |
762 | 'name' => 'timeout', |
763 | 'help' => <<HELP, |
764 | How long to wait (in seconds) without being readable before calling |
765 | the timeout method |
766 | HELP |
767 | }, |
768 | { |
769 | 'name' => 'method', |
770 | 'default' => 'readable', |
771 | 'help' => <<HELP, |
772 | This method is called on the object when the file handle has data to read |
773 | HELP |
774 | }, |
775 | { |
776 | 'name' => 'timeout_method', |
777 | 'default' => 'read_timeout', |
778 | 'help' => <<HELP, |
779 | This method is called on the object when the hasn't been readable |
780 | after the timeout period |
781 | HELP |
782 | }, |
783 | { |
784 | 'name' => 'active', |
785 | 'default' => 1, |
786 | 'type' => 'boolean', |
787 | 'help' => <<HELP, |
788 | This flag marks the event as being active. It can be toggled with the |
789 | start/stop methods. |
790 | HELP |
791 | }, |
792 | { |
793 | 'name' => 'id', |
794 | 'help' => <<HELP, |
795 | The id is passed to the callback method as its only argument. Use it to |
796 | identify different instances of this object. |
797 | HELP |
798 | |
799 | }, |
800 | ] ; |
801 | |
802 | sub new { |
803 | |
804 | my( $class ) = shift ; |
805 | |
806 | my $self = Stem::Class::parse_args( $attr_spec_read, @_ ) ; |
807 | return $self unless ref $self ; |
808 | |
809 | # return <<ERR unless defined fileno $self->{fh} ; |
810 | # Stem::Event::Read: $self->{fh} is not an open handle |
811 | # ERR |
812 | |
813 | my $err = $self->_build_core_event( 'read' ) ; |
814 | return $err if $err ; |
815 | |
816 | $self->init_io_timeout() ; |
817 | |
818 | return $self ; |
819 | } |
820 | |
821 | } |
822 | ############################################################################ |
823 | |
824 | package Stem::Event::Write ; |
825 | |
4932dd97 |
826 | our @ISA = qw( Stem::Event::IO ) ; |
4536f655 |
827 | |
828 | =head2 Stem::Event::Write::new |
829 | |
830 | This class creates an event that will trigger a callback whenever |
831 | its file descriptor can be written to. It takes an optional timeout |
832 | value which will trigger a callback to the object if no data has been |
833 | written during that period. |
834 | |
835 | Write events are stopped when created - a call to the start method is |
836 | needed to activate them. |
837 | |
838 | =cut |
839 | |
840 | my $attr_spec_write = [ |
841 | |
842 | { |
843 | 'name' => 'object', |
844 | 'required' => 1, |
845 | 'type' => 'object', |
846 | 'help' => <<HELP, |
847 | This object gets the method callbacks |
848 | HELP |
849 | }, |
850 | { |
851 | 'name' => 'fh', |
852 | 'required' => 1, |
853 | 'type' => 'handle', |
854 | 'help' => <<HELP, |
855 | This file handle is checked if it is writeable |
856 | HELP |
857 | }, |
858 | { |
859 | 'name' => 'timeout', |
860 | 'help' => <<HELP, |
861 | How long to wait (in seconds) without being writeable before calling |
862 | the timeout method |
863 | HELP |
864 | }, |
865 | { |
866 | 'name' => 'method', |
867 | 'default' => 'writeable', |
868 | 'help' => <<HELP, |
869 | This method is called on the object when the file handle is writeable |
870 | HELP |
871 | }, |
872 | { |
873 | 'name' => 'timeout_method', |
874 | 'default' => 'write_timeout', |
875 | 'help' => <<HELP, |
876 | This method is called on the object when the hasn't been writeable |
877 | after the timeout period |
878 | HELP |
879 | }, |
880 | { |
881 | 'name' => 'active', |
882 | 'default' => 0, |
883 | 'type' => 'boolean', |
884 | 'help' => <<HELP, |
885 | This flag marks the event as being active. It can be toggled with the |
886 | start/stop methods. |
887 | NOTE: Write events are not active by default. |
888 | HELP |
889 | }, |
890 | { |
891 | 'name' => 'id', |
892 | 'help' => <<HELP, |
893 | The id is passed to the callback method as its only argument. Use it to |
894 | identify different instances of this object. |
895 | HELP |
896 | |
897 | }, |
898 | ] ; |
899 | |
900 | sub new { |
901 | |
902 | my( $class ) = shift ; |
903 | |
904 | my $self = Stem::Class::parse_args( $attr_spec_write, @_ ) ; |
905 | return $self unless ref $self ; |
906 | |
907 | my $err = $self->_build_core_event( 'write' ) ; |
908 | return $err if $err ; |
909 | |
910 | #print $self->dump_events() ; |
911 | |
912 | $self->init_io_timeout() ; |
913 | |
914 | $self->stop() unless $self->{'active'} ; |
915 | |
916 | #print $self->dump() ; |
917 | |
918 | return $self ; |
919 | } |
920 | |
921 | 1 ; |