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