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 | |
f4d1dc84 |
67 | INIT{ init_loop() ; } |
4536f655 |
68 | |
69 | |
70 | sub init_loop { |
71 | |
72 | $loop_class->_init_loop() ; |
4536f655 |
73 | } |
74 | |
75 | sub start_loop { |
76 | |
77 | $loop_class->_start_loop() ; |
78 | } |
79 | |
80 | sub stop_loop { |
81 | |
82 | $loop_class->_stop_loop() ; |
83 | } |
84 | |
85 | sub trigger { |
86 | |
87 | my( $self, $method ) = @_ ; |
88 | |
89 | # never trigger inactive events |
90 | |
91 | return unless $self->{active} ; |
92 | |
93 | |
94 | $method ||= $self->{'method'} ; |
95 | #print "METHOD [$method]\n" ; |
96 | |
97 | $self->{'object'}->$method( $self->{'id'} ) ; |
98 | |
99 | Stem::Msg::process_queue() if defined &Stem::Msg::process_queue; |
100 | |
101 | return ; |
102 | } |
103 | |
104 | ################# |
105 | # all the stuff below is a rough cell call trace thing. it needs work |
106 | # it would be put inside the trigger method |
107 | # 'log_type' attribute is set or the event type is used. |
108 | #_init subs need to set event_log_type in the object |
109 | #use Stem::Trace 'log' => 'stem_status', 'sub' => 'TraceStatus' ; |
110 | #use Stem::Trace 'log' => 'stem_error' , 'sub' => 'TraceError' ; |
111 | # $log_type = $self->{'log_type'} || $self->{'event_type'} ; |
112 | # TraceStatus "[$log_type] [$object] [$method]\n" ; |
113 | # $Stem::Event::current_object = $object ; |
114 | # my ( $cell_name, $target ) = Stem::Route::lookup_cell_name( $object ) ; |
115 | # if ( $cell_name ) { |
116 | # # Debug |
117 | # # "EVENT $event to $cell_name:$target [$object] [$method]\n" ; |
118 | # } |
119 | # else { |
120 | # # Debug "EVENT $event to [$object] [$method]\n" ; |
121 | # } |
122 | ################# |
123 | |
124 | |
125 | # get all the event objects for an event type |
126 | # this is a class sub. |
127 | |
128 | sub _get_events { |
129 | |
130 | my( $event_type ) = @_ ; |
131 | |
132 | my $events = $all_events{ $event_type } ; |
133 | |
134 | return unless $events ; |
135 | |
136 | return values %{$events} if wantarray ; |
137 | |
138 | return $events ; |
139 | } |
140 | |
141 | # initialize the subclass object for this event and store generic event |
142 | # info. |
143 | |
144 | sub _build_core_event { |
145 | |
146 | #print "BAZ\n" ; |
147 | |
148 | my( $self, $event_type ) = @_ ; |
149 | |
150 | |
151 | #print "EVT [$self] [$event_type]\n" ; |
152 | |
153 | # call and and check the return of the core event constructor |
154 | |
155 | if ( my $core_event = $self->_build() ) { |
156 | |
157 | # return the error if it was an error string |
158 | |
159 | return $core_event unless ref $core_event ; |
160 | |
161 | # save the core event |
162 | |
163 | $self->{core_event} = $core_event ; |
164 | } |
165 | |
166 | # mark the event type and track it |
167 | |
168 | $self->{event_type} = $event_type ; |
169 | $all_events{ $event_type }{ $self } = $self ; |
170 | |
171 | return ; |
172 | } |
173 | |
174 | # these are the public versions of the support methods. |
175 | # subclasses can provide a _method to override the stub ones in this class. |
176 | |
177 | sub cancel { |
178 | |
179 | my( $self ) = @_ ; |
180 | |
181 | $self->{'active'} = 0 ; |
182 | delete $self->{'object'} ; |
183 | |
184 | # delete the core object |
185 | |
186 | if ( my $core_event = delete $self->{core_event} ) { |
187 | |
188 | # call the core cancel |
189 | |
190 | $self->_cancel( $core_event ) ; |
191 | } |
192 | |
193 | # delete this event from the tracking hash |
194 | |
195 | delete $all_events{ $self->{event_type} }{ $self } ; |
196 | |
197 | return ; |
198 | } |
199 | |
200 | sub start { |
201 | my( $self ) = @_ ; |
202 | |
203 | $self->{'active'} = 1 ; |
204 | $self->_start( $self->{core_event} ) ; |
205 | |
206 | return ; |
207 | } |
208 | |
209 | sub stop { |
210 | my( $self ) = @_ ; |
211 | |
212 | $self->{'active'} = 0 ; |
213 | $self->_stop( $self->{core_event} ) ; |
214 | |
215 | return ; |
216 | } |
217 | |
218 | # stubs for the internal methods that subclasses should override if needed. |
219 | |
220 | sub _init_loop {} |
221 | sub _build {} |
222 | sub _start {} |
223 | sub _stop {} |
224 | sub _reset {} |
225 | sub _cancel {} |
226 | |
227 | use Stem::Debug qw( dump_socket dump_owner dump_data ) ; |
228 | |
229 | sub dump_events { |
230 | |
231 | print dump_data( \%all_events ) ; |
232 | } |
233 | |
234 | sub dump { |
235 | |
236 | my( $self ) = @_ ; |
237 | |
238 | my $event_text = <<TEXT ; |
239 | EV: $self |
240 | ACT: $self->{'active'} |
241 | TEXT |
242 | |
243 | my $obj_dump = dump_owner $self->{'object'} ; |
244 | $event_text .= <<TEXT ; |
245 | OBJ: $obj_dump |
246 | METH: $self->{'method'} |
247 | TEXT |
248 | |
249 | if ( my $fh = $self->{'fh'} ) { |
250 | |
251 | my $fh_text = dump_socket( $self->{'fh'} ) ; |
252 | $event_text .= <<TEXT ; |
253 | FH: $fh_text |
254 | TEXT |
255 | } |
256 | |
257 | if ( $self->{event_type} eq 'timer' ) { |
258 | |
259 | my $delay = $self->{delay} || 'NONE' ; |
260 | my $interval = $self->{interval} || 'NONE' ; |
261 | $event_text .= <<TEXT ; |
262 | DELAY: $delay |
263 | INT: $interval |
264 | TEXT |
265 | } |
266 | |
267 | if ( my $io_timer_event = $self->{'io_timer_event'} ) { |
268 | |
269 | $event_text = "IO TIMER: >>>>>\n" . $io_timer_event->dump() . |
270 | "END\n"; |
271 | } |
272 | |
273 | return <<DUMP ; |
274 | |
275 | >>> |
276 | $event_text<<< |
277 | |
278 | DUMP |
279 | |
280 | } |
281 | |
282 | ############# |
283 | # change this to a cleaner loop style which can handle more event loops and |
284 | # try them in sequence |
285 | ############# |
286 | |
287 | sub _get_loop_class { |
288 | |
289 | my $loop_type = $Stem::Vars::Env{ 'event_loop' } || |
290 | ($^O =~ /win32/i ? 'perl' : 'event' ); |
291 | |
292 | $loop_type = 'perl' unless $loop_to_class{ $loop_type } ; |
293 | my $loop_class = "Stem::Event::$loop_to_class{ $loop_type }" ; |
294 | |
907cbc6d |
295 | #print "LOOP $loop_class\n" ; |
f4d1dc84 |
296 | |
4536f655 |
297 | unless ( eval "require $loop_class" ) { |
298 | die "can't load $loop_class: $@" if $@ && $@ !~ /locate/ ; |
299 | |
f4d1dc84 |
300 | print "not found\n" ; |
301 | |
4536f655 |
302 | $loop_type = 'perl' ; |
303 | eval { require Stem::Event::Perl } ; |
304 | die "can't load event loop Stem::Event::Perl $@" if $@ ; |
305 | } |
306 | |
f4d1dc84 |
307 | |
4536f655 |
308 | # save the event loop that we loaded. |
309 | |
310 | #print "using event loop [$loop_type]\n" ; |
311 | $Stem::Vars::Env{ 'event_loop' } = $loop_type ; |
312 | |
f4d1dc84 |
313 | |
4536f655 |
314 | return $loop_class ; |
315 | } |
316 | |
317 | |
318 | ############################################################################ |
319 | |
320 | package Stem::Event::Plain ; |
4932dd97 |
321 | our @ISA = qw( Stem::Event ) ; |
4536f655 |
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 | |
4932dd97 |
368 | my $err = $self->_build_core_event( 'plain' ) ; |
4536f655 |
369 | return $err if $err ; |
370 | |
371 | return $self ; |
372 | } |
373 | |
374 | ############################################################################ |
375 | |
376 | package Stem::Event::Signal ; |
4932dd97 |
377 | our @ISA = qw( Stem::Event ) ; |
4536f655 |
378 | |
379 | =head2 Stem::Event::Signal::new |
380 | |
381 | This class creates an event that will trigger a callback whenever |
382 | its its signal has been received. |
383 | |
384 | =head2 Example |
385 | |
386 | $signal_event = Stem::Event::Signal->new( 'object' => $self, |
387 | 'signal' => 'INT' ) ; |
388 | |
389 | sub sig_int_handler { die "SIGINT\n" } |
390 | |
391 | =cut |
392 | |
393 | my $attr_spec_signal = [ |
394 | |
395 | { |
396 | 'name' => 'object', |
397 | 'required' => 1, |
398 | 'type' => 'object', |
399 | 'help' => <<HELP, |
400 | This object gets the method callbacks |
401 | HELP |
402 | }, |
403 | { |
404 | 'name' => 'method', |
405 | 'help' => <<HELP, |
406 | This method is called on the object when this event is triggered. The |
407 | default method name for the signal NAME is 'sig_name_handler' (all lower case) |
408 | HELP |
409 | }, |
410 | { |
411 | 'name' => 'signal', |
412 | 'required' => 1, |
413 | 'help' => <<HELP, |
414 | This is the name of the signal to handle. It is used as part of the |
415 | default handler method name. |
416 | HELP |
417 | }, |
418 | { |
419 | 'name' => 'active', |
420 | 'default' => 1, |
421 | 'type' => 'boolean', |
422 | 'help' => <<HELP, |
423 | This flag marks the event as being active. It can be toggled with the |
424 | start/stop methods. |
425 | HELP |
426 | }, |
427 | { |
428 | 'name' => 'id', |
429 | 'help' => <<HELP, |
430 | The id is passed to the callback method as its only argument. Use it to |
431 | identify different instances of this object. |
432 | HELP |
433 | |
434 | }, |
435 | ] ; |
436 | |
437 | sub new { |
438 | |
439 | my( $class ) = shift ; |
440 | |
441 | my $self = Stem::Class::parse_args( $attr_spec_signal, @_ ) ; |
442 | return $self unless ref $self ; |
443 | |
444 | my $signal = uc $self->{'signal'} ; |
445 | |
446 | return "Unknown signal: $signal" unless exists $SIG{ $signal } ; |
447 | |
448 | $self->{'method'} ||= "sig_\L${signal}_handler" ; |
449 | $self->{'signal'} = $signal ; |
450 | |
451 | my $err = $self->_build_core_event( 'signal' ) ; |
452 | return $err if $err ; |
453 | |
454 | #print "SELF SIG $self\nPID $$\n" ; |
455 | |
456 | return $self ; |
457 | } |
458 | |
459 | |
460 | ############################################################################ |
461 | |
462 | package Stem::Event::Timer ; |
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 ; |
4932dd97 |
652 | our @ISA = qw( Stem::Event ) ; |
4536f655 |
653 | |
654 | sub init_io_timeout { |
655 | |
656 | my( $self ) = @_ ; |
657 | |
658 | my $timeout = $self->{'timeout'} ; |
659 | return unless $timeout ; |
660 | |
661 | $self->{'io_timer_event'} = Stem::Event::Timer->new( |
662 | 'object' => $self, |
663 | 'interval' => $timeout, |
664 | ) ; |
665 | |
666 | return ; |
667 | } |
668 | |
669 | sub cancel { |
670 | |
671 | my( $self ) = @_ ; |
672 | |
673 | #print "IO CANCEL $self\n" ; |
674 | |
675 | if ( my $io_timer_event = delete $self->{'io_timer_event'} ) { |
676 | $io_timer_event->cancel() ; |
677 | } |
678 | |
679 | $self->SUPER::cancel() ; |
680 | |
681 | delete $self->{'fh'} ; |
682 | |
683 | return ; |
684 | } |
685 | |
686 | sub start { |
687 | |
688 | my( $self ) = @_ ; |
689 | |
690 | if ( my $io_timer_event = $self->{'io_timer_event'} ) { |
691 | $io_timer_event->start() ; |
692 | } |
693 | |
694 | $self->SUPER::start() ; |
695 | |
696 | return ; |
697 | } |
698 | |
699 | sub stop { |
700 | |
701 | my( $self ) = @_ ; |
702 | |
703 | $self->{'active'} = 0 ; |
704 | |
705 | if ( my $io_timer_event = $self->{'io_timer_event'} ) { |
706 | $io_timer_event->stop() ; |
707 | } |
708 | |
709 | $self->SUPER::stop() ; |
710 | |
711 | return ; |
712 | } |
713 | |
714 | sub timed_out { |
715 | |
716 | my( $self ) = @_ ; |
717 | |
718 | # $self->{log_type} = "$self->{'event_type'}_timeout" ; |
719 | $self->trigger( $self->{'timeout_method'} ) ; |
720 | } |
721 | |
722 | ####################################################### |
723 | |
724 | package Stem::Event::Read ; |
f4d1dc84 |
725 | our @ISA = qw( Stem::Event::IO ) ; |
4536f655 |
726 | |
727 | =head2 Stem::Event::Read::new |
728 | |
729 | This class creates an event that will trigger a callback whenever |
730 | its file descriptor has data to be read. It takes an optional timeout |
731 | value which will trigger a callback to the object if no data has been |
732 | read during that period. |
733 | |
734 | Read events are active when created - a call to the stop method is |
735 | needed to deactivate them. |
736 | |
737 | =cut |
738 | |
739 | BEGIN { |
740 | |
741 | my $attr_spec_read = [ |
742 | |
743 | { |
744 | 'name' => 'object', |
745 | 'required' => 1, |
746 | 'type' => 'object', |
747 | 'help' => <<HELP, |
748 | This object gets the method callbacks |
749 | HELP |
750 | }, |
751 | { |
752 | 'name' => 'fh', |
753 | 'required' => 1, |
754 | 'type' => 'handle', |
755 | 'help' => <<HELP, |
756 | This file handle is checked if it has data to read |
757 | HELP |
758 | }, |
759 | { |
760 | 'name' => 'timeout', |
761 | 'help' => <<HELP, |
762 | How long to wait (in seconds) without being readable before calling |
763 | the timeout method |
764 | HELP |
765 | }, |
766 | { |
767 | 'name' => 'method', |
768 | 'default' => 'readable', |
769 | 'help' => <<HELP, |
770 | This method is called on the object when the file handle has data to read |
771 | HELP |
772 | }, |
773 | { |
774 | 'name' => 'timeout_method', |
775 | 'default' => 'read_timeout', |
776 | 'help' => <<HELP, |
777 | This method is called on the object when the hasn't been readable |
778 | after the timeout period |
779 | HELP |
780 | }, |
781 | { |
782 | 'name' => 'active', |
783 | 'default' => 1, |
784 | 'type' => 'boolean', |
785 | 'help' => <<HELP, |
786 | This flag marks the event as being active. It can be toggled with the |
787 | start/stop methods. |
788 | HELP |
789 | }, |
790 | { |
791 | 'name' => 'id', |
792 | 'help' => <<HELP, |
793 | The id is passed to the callback method as its only argument. Use it to |
794 | identify different instances of this object. |
795 | HELP |
796 | |
797 | }, |
798 | ] ; |
799 | |
800 | sub new { |
801 | |
802 | my( $class ) = shift ; |
803 | |
804 | my $self = Stem::Class::parse_args( $attr_spec_read, @_ ) ; |
805 | return $self unless ref $self ; |
806 | |
f4d1dc84 |
807 | |
4536f655 |
808 | # return <<ERR unless defined fileno $self->{fh} ; |
809 | # Stem::Event::Read: $self->{fh} is not an open handle |
810 | # ERR |
811 | |
812 | my $err = $self->_build_core_event( 'read' ) ; |
813 | return $err if $err ; |
814 | |
815 | $self->init_io_timeout() ; |
816 | |
817 | return $self ; |
818 | } |
819 | |
820 | } |
821 | ############################################################################ |
822 | |
823 | package Stem::Event::Write ; |
4932dd97 |
824 | our @ISA = qw( Stem::Event::IO ) ; |
4536f655 |
825 | |
826 | =head2 Stem::Event::Write::new |
827 | |
828 | This class creates an event that will trigger a callback whenever |
829 | its file descriptor can be written to. It takes an optional timeout |
830 | value which will trigger a callback to the object if no data has been |
831 | written during that period. |
832 | |
833 | Write events are stopped when created - a call to the start method is |
834 | needed to activate them. |
835 | |
836 | =cut |
837 | |
838 | my $attr_spec_write = [ |
839 | |
840 | { |
841 | 'name' => 'object', |
842 | 'required' => 1, |
843 | 'type' => 'object', |
844 | 'help' => <<HELP, |
845 | This object gets the method callbacks |
846 | HELP |
847 | }, |
848 | { |
849 | 'name' => 'fh', |
850 | 'required' => 1, |
851 | 'type' => 'handle', |
852 | 'help' => <<HELP, |
853 | This file handle is checked if it is writeable |
854 | HELP |
855 | }, |
856 | { |
857 | 'name' => 'timeout', |
858 | 'help' => <<HELP, |
859 | How long to wait (in seconds) without being writeable before calling |
860 | the timeout method |
861 | HELP |
862 | }, |
863 | { |
864 | 'name' => 'method', |
865 | 'default' => 'writeable', |
866 | 'help' => <<HELP, |
867 | This method is called on the object when the file handle is writeable |
868 | HELP |
869 | }, |
870 | { |
871 | 'name' => 'timeout_method', |
872 | 'default' => 'write_timeout', |
873 | 'help' => <<HELP, |
874 | This method is called on the object when the hasn't been writeable |
875 | after the timeout period |
876 | HELP |
877 | }, |
878 | { |
879 | 'name' => 'active', |
880 | 'default' => 0, |
881 | 'type' => 'boolean', |
882 | 'help' => <<HELP, |
883 | This flag marks the event as being active. It can be toggled with the |
884 | start/stop methods. |
885 | NOTE: Write events are not active by default. |
886 | HELP |
887 | }, |
888 | { |
889 | 'name' => 'id', |
890 | 'help' => <<HELP, |
891 | The id is passed to the callback method as its only argument. Use it to |
892 | identify different instances of this object. |
893 | HELP |
894 | |
895 | }, |
896 | ] ; |
897 | |
898 | sub new { |
899 | |
900 | my( $class ) = shift ; |
901 | |
902 | my $self = Stem::Class::parse_args( $attr_spec_write, @_ ) ; |
903 | return $self unless ref $self ; |
904 | |
905 | my $err = $self->_build_core_event( 'write' ) ; |
906 | return $err if $err ; |
907 | |
908 | #print $self->dump_events() ; |
909 | |
910 | $self->init_io_timeout() ; |
911 | |
912 | $self->stop() unless $self->{'active'} ; |
913 | |
914 | #print $self->dump() ; |
915 | |
916 | return $self ; |
917 | } |
918 | |
919 | 1 ; |