1# This file was automatically generated by SWIG (http://www.swig.org). 2# Version 3.0.7 3# 4# Do not make changes to this file unless you know what you are doing--modify 5# the SWIG interface file instead. 6 7package Amanda::MainLoop; 8use base qw(Exporter); 9use base qw(DynaLoader); 10package Amanda::MainLoopc; 11bootstrap Amanda::MainLoop; 12package Amanda::MainLoop; 13@EXPORT = qw(); 14 15# ---------- BASE METHODS ------------- 16 17package Amanda::MainLoop; 18 19sub TIEHASH { 20 my ($classname,$obj) = @_; 21 return bless $obj, $classname; 22} 23 24sub CLEAR { } 25 26sub FIRSTKEY { } 27 28sub NEXTKEY { } 29 30sub FETCH { 31 my ($self,$field) = @_; 32 my $member_func = "swig_${field}_get"; 33 $self->$member_func(); 34} 35 36sub STORE { 37 my ($self,$field,$newval) = @_; 38 my $member_func = "swig_${field}_set"; 39 $self->$member_func($newval); 40} 41 42sub this { 43 my $ptr = shift; 44 return tied(%$ptr); 45} 46 47 48# ------- FUNCTION WRAPPERS -------- 49 50package Amanda::MainLoop; 51 52*run_c = *Amanda::MainLoopc::run_c; 53*run_until_empty_c = *Amanda::MainLoopc::run_until_empty_c; 54*quit = *Amanda::MainLoopc::quit; 55*timeout_source = *Amanda::MainLoopc::timeout_source; 56*idle_source = *Amanda::MainLoopc::idle_source; 57*child_watch_source = *Amanda::MainLoopc::child_watch_source; 58*fd_source = *Amanda::MainLoopc::fd_source; 59 60############# Class : Amanda::MainLoop::Source ############## 61 62package Amanda::MainLoop::Source; 63use vars qw(@ISA %OWNER %ITERATORS %BLESSEDMEMBERS); 64@ISA = qw( Amanda::MainLoop ); 65%OWNER = (); 66%ITERATORS = (); 67sub new { 68 my $pkg = shift; 69 my $self = Amanda::MainLoopc::new_Source(@_); 70 bless $self, $pkg if defined($self); 71} 72 73sub DESTROY { 74 return unless $_[0]->isa('HASH'); 75 my $self = tied(%{$_[0]}); 76 return unless defined $self; 77 delete $ITERATORS{$self}; 78 if (exists $OWNER{$self}) { 79 Amanda::MainLoopc::delete_Source($self); 80 delete $OWNER{$self}; 81 } 82} 83 84*set_callback = *Amanda::MainLoopc::Source_set_callback; 85*remove = *Amanda::MainLoopc::Source_remove; 86sub DISOWN { 87 my $self = shift; 88 my $ptr = tied(%$self); 89 delete $OWNER{$ptr}; 90} 91 92sub ACQUIRE { 93 my $self = shift; 94 my $ptr = tied(%$self); 95 $OWNER{$ptr} = 1; 96} 97 98 99# ------- VARIABLE STUBS -------- 100 101package Amanda::MainLoop; 102 103*G_IO_IN = *Amanda::MainLoopc::G_IO_IN; 104*G_IO_OUT = *Amanda::MainLoopc::G_IO_OUT; 105*G_IO_PRI = *Amanda::MainLoopc::G_IO_PRI; 106*G_IO_ERR = *Amanda::MainLoopc::G_IO_ERR; 107*G_IO_HUP = *Amanda::MainLoopc::G_IO_HUP; 108*G_IO_NVAL = *Amanda::MainLoopc::G_IO_NVAL; 109 110@EXPORT_OK = (); 111%EXPORT_TAGS = (); 112 113 114=head1 NAME 115 116Amanda::MainLoop - Perl interface to the Glib MainLoop 117 118=head1 SYNOPSIS 119 120 use Amanda::MainLoop; 121 122 my $to = Amanda::MainLoop::timeout_source(2000); 123 $to->set_callback(sub { 124 print "Time's Up!\n"; 125 $to->remove(); # dont' re-queue this timeout 126 Amanda::MainLoop::quit(); # return from Amanda::MainLoop::run 127 }); 128 129 Amanda::MainLoop::run(); 130 131Note that all functions in this module are individually available for 132export, e.g., 133 134 use Amanda::MainLoop qw(run quit); 135 136=head1 OVERVIEW 137 138The main event loop of an application is a tight loop which waits for 139events, and calls functions to respond to those events. This design 140allows an IO-bound application to multitask within a single thread, by 141responding to IO events as they occur instead of blocking on 142particular IO operations. 143 144The Amanda security API, transfer API, and other components rely on 145the event loop to allow them to respond to their own events in a 146timely fashion. 147 148The overall structure of an application, then, is to initialize its 149state, register callbacks for some events, and begin looping. In each 150iteration, the loop waits for interesting events to occur (data 151available for reading or writing, timeouts, etc.), and then calls 152functions to handle those interesting things. Thus, the application 153spends most of its time waiting. When some application-defined state 154is reached, the loop is terminated and the application cleans up and 155exits. 156 157The Glib main loop takes place within a call to 158C<Amanda::MainLoop::run()>. This function executes until a call to 159C<Amanda::MainLoop::quit()> occurs, at which point C<run()> returns. 160You can check whether the loop is running with 161C<Amanda::MainLoop::is_running()>. 162 163=head1 HIGH-LEVEL INTERFACE 164 165The functions in this section are intended to make asynchronous 166programming as simple as possible. They are implemented on top of the 167interfaces described in the LOW-LEVEL INTERFACE section. 168 169=head3 call_later 170 171In most cases, a callback does not need to be invoked immediately. In 172fact, because Perl does not do tail-call optimization, a long chain of 173callbacks may cause the perl stack to grow unnecessarily. 174 175The solution is to queue the callback for execution on the next 176iteration of the main loop, and C<call_later($cb, @args)> does exactly 177this. 178 179 sub might_delay { 180 my ($cb) = @_; 181 if (can_do_it_now()) { 182 my $result = do_it(); 183 Amanda::MainLoop::call_later($cb, $result) 184 } else { 185 # .. 186 } 187 } 188 189When starting the main loop, an application usually has a sub that 190should run after the loop has started. C<call_later> works in this 191situation, too. 192 193 my $main = sub { 194 # .. 195 Amanda::MainLoop::quit(); 196 }; 197 Amanda::MainLoop::call_later($main); 198 # .. 199 Amanda::MainLoop::run(); 200 201=head3 make_cb 202 203As an optimization, C<make_cb> wraps a sub with a call to call_later 204while also naming the sub (using C<Sub::Name>, if available): 205 206 my $fetched_cb = make_cb(fetched_cb => sub { 207 # .. callback body 208 } 209 210In general, C<make_cb> should be used whenever a callback is passed to 211some other library. For example, the Changer API (see 212L<Amanda::Changer>) might be invoked like this: 213 214 my $reset_finished_cb = make_cb(reset_finished_cb => sub { 215 my ($err) = @_; 216 die "while resetting: $err" if $err; 217 # .. 218 }); 219 220Be careful I<not> to use C<make_cb> in cases where some action must 221take place before the next iteration of the main loop. In practice, 222this means C<make_cb> should be avoided with file-descriptor 223callbacks, which will trigger repeatedly until the descriptors' needs 224are addressed. 225 226C<make_cb> is exported automatically. 227 228=head3 call_after 229 230Sometimes you need the MainLoop equivalent of C<sleep()>. That comes 231in the form of C<call_later($delay, $cb, @args)>, which takes a delay 232(in milliseconds), a sub, and an arbitrary number of arguments. The 233sub is called with the arguments after the delay has elapsed. 234 235 sub countdown { 236 my $counter; 237 $counter = sub { 238 print "$i..\n"; 239 if ($i) { 240 Amanda::MainLoop::call_after(1000, $counter, $i-1); 241 } 242 } 243 $counter->(10); 244 } 245 246The function returns the underlying event source (see below), enabling 247the caller to cancel the pending call: 248 249 my $tosrc = Amanda::MainLoop::call_after(15000, $timeout_cb): 250 # ...data arrives before timeout... 251 $tosrc->remove(); 252 253=head3 call_on_child_termination 254 255To monitor a child process for termination, give its pid to 256C<call_on_child_termination($pid, $cb, @args)>. When the child exits 257for any reason, this will collect its exit status (via C<waitpid>) and 258call C<$cb> as 259 260 $cb->($exitstatus, @args); 261 262Like C<call_after>, this function returns the event source to allow 263early cancellation if desired. 264 265=head3 async_read 266 267 async_read( 268 fd => $fd, 269 size => $size, # optional, default 0 270 async_read_cb => $async_read_cb, 271 args => [ .. ]); # optional 272 273This function will read C<$size> bytes when they are available from 274file descriptor C<$fd>, and invoke the callback with the results: 275 276 $async_read_cb->($err, $buf, @args); 277 278If C<$size> is zero, then the callback will get whatever data is 279available as soon as it is available, up to an arbitrary buffer size. 280If C<$size> is nonzero, then a short read may still occur if C<$size> 281bytes do not become available simultaneously. On EOF, C<$buf> will be 282the empty string. It is the caller's responsibility to set C<$fd> to 283non-blocking mode. Note that not all operating sytems generate errors 284that might be reported here. For example, on Solaris an invalid file 285descriptor will be silently ignored. 286 287The return value is an event source, and calling its C<remove> method 288will cancel the read. It is an error to have more than one 289C<async_read> operation on a single file descriptor at any time, and 290will lead to unpredictable results. 291 292This function adds a new FdSource every time it is invoked, so it is 293not well-suited to processing large amounts of data. For that 294purpose, consider using the low-level interface or, better, the 295transfer architecture (see L<Amanda::Xfer>). 296 297=head3 async_write 298 299 async_write( 300 fd => $fd, 301 data => $data, 302 async_write_cb => $async_write_cb, 303 args => [ .. ]); # optional 304 305This function will write C<$data> to file descriptor C<$fd> and invoke 306the callback with the number of bytes written: 307 308 $cb->($err, $bytes_written, @args); 309 310If C<$bytes_written> is less than then length of <$data>, then an 311error occurred, and is given in C<$err>. As for C<async_read>, the 312caller should set C<$fd> to non-blocking mode. Multiple parallel 313invocations of this function for the same file descriptor are allowed 314and will be serialized in the order the calls were made: 315 316 async_write($fd, "HELLO!\n", 317 async_write_cb => make_cb(wrote_hello => sub { 318 print "wrote 'HELLO!'\n"; 319 })); 320 async_write($fd, "GOODBYE!\n", 321 async_write_cb => make_cb(wrote_goodbye => sub { 322 print "wrote 'GOODBYE!'\n"; 323 })); 324 325In this case, the two strings are guaranteed to be written in the same 326order, and the callbacks will be called in the correct order. 327 328Like async_read, this function may add a new FdSource every time it is 329invoked, so it is not well-suited to processing large amounts of data. 330 331=head3 synchronized 332 333Java has the notion of a "synchronized" method, which can only execute in one 334thread at any time. This is a particular application of a lock, in which the 335lock is acquired when the method begins, and released when it finishes. 336 337With C<Amanda::MainLoop>, this functionality is generally not needed because 338there is no unexpected preemeption. However, if you break up a long-running 339operation (that doesn't allow concurrency) into several callbacks, you'll need 340to ensure that at most one of those operations is going on at a time. The 341C<synchronized> function manages that for you. 342 343The function takes a C<$lock> argument, which should be initialized to an empty 344arrayref (C<[]>). It is used like this: 345 346 use Amanda::MainLoop 'synchronized'; 347 # .. 348 sub dump_data { 349 my $self = shift; 350 my ($arg1, $arg2, $dump_cb) = @_; 351 352 synchronized($self->{'lock'}, $dump_cb, sub { 353 my ($dump_cb) = @_; # IMPORTANT! See below 354 $self->do_dump_data($arg1, $arg2, $dump_cb); 355 }; 356 } 357 358Here, C<do_dump_data> may take a long time to complete (perhaps it starts 359a long-running data transfer) but only one such operation is allowed at any 360time and other C<Amanda::MainLoop> callbacks may occur (e.g. a timeout). 361When the critical operation is complete, it calls C<$dump_cb> which will 362release the lock before transferring control to the caller. 363 364Note that the C<$dump_cb> in the inner C<sub> shadows that in 365C<dump_data> -- this is intentional, the a call to the the inner 366C<$dump_cb> is how C<synchronized> knows that the operation has completed. 367 368Several methods may be synchronized with one another by simply sharing the same 369lock. 370 371=head1 ASYNCHRONOUS STYLE 372 373When writing asynchronous code, it's easy to write code that is *very* 374difficult to read or debug. The suggestions in this section will help 375write code that is more readable, and also ensure that all asynchronous 376code in Amanda uses similar, common idioms. 377 378=head2 USING CALLBACKS 379 380Most often, callbacks are short, and can be specified as anonymous 381subs. They should be specified with make_cb, like this: 382 383 some_async_function(make_cb(foo_cb => sub { 384 my ($x, $y) = @_; 385 # ... 386 })); 387 388If a callback is more than about two lines, specify it in a named 389variable, rather than directly in the function call: 390 391 my $foo_cb = make_cb(foo_cb => sub { 392 my ($src) = @_; 393 # . 394 # . long function 395 # . 396 }); 397 some_async_function($foo_cb); 398 399When using callbacks from an object-oriented package, it is often 400useful to treat a method as a callback. This requires an anonymous 401sub "wrapper", which can be written on one line: 402 403 some_async_function(sub { $self->foo_cb(@_) }); 404 405=head2 LINEARITY 406 407The single most important factor in readability is linearity. If a function 408that performs operations A, B, and C in that order, then the code for A, B, and 409C should appear in that order in the source file. This seems obvious, but it's 410all too easy to write 411 412 sub three_ops { 413 my $do_c = sub { .. }; 414 my $do_b = sub { .. $do_c->() .. }; 415 my $do_a = sub { .. $do_b->() .. }; 416 $do_a->(); 417 } 418 419Which isn't very readable. Be readable. 420 421=head2 SINGLE ENTRY AND EXIT 422 423Amanda's use of callbacks emulates continuation-passing style. As such, when a 424function finishes -- whether successfully or with an error -- it should call a 425single callback. This ensures that the function has a simple control 426interface: perform the operation and call the callback. 427 428=head2 MULTIPLE STEPS 429 430Some operations require a long squence of asynchronous operations. For 431example, often the results of one operation are required to initiate 432another. The I<step> syntax is useful to make this much more readable, and 433also eliminate some nasty reference-counting bugs. The idea is that each "step" 434in the process gets its own sub, and then each step calls the next step. The 435first step defined will be called automatically. 436 437 sub send_file { 438 my ($hostname, $port, $data, $sendfile_cb) = @_; 439 my ($addr, $socket); # shared lexical variables 440 my $steps = define_steps 441 cb_ref => \$sendfile_cb; 442 step lookup_addr => sub { 443 return async_gethostbyname(hostname => $hostname, 444 ghbn_cb => $steps->{'got_addr'}); 445 }; 446 step ghbn_cb => sub { 447 my ($err, $hostinfo) = @_; 448 die $err if $err; 449 $addr = $hostinfo->{'ipaddr'}; 450 return $steps->{'connect'}->(); 451 }; 452 step connect => sub { 453 return async_connect( 454 ipaddr => $addr, 455 port => $port, 456 connect_cb => $steps->{'connect_cb'}, 457 ); 458 }; 459 step connect_cb => sub { 460 my ($err, $conn_sock) = @_; 461 die $err if $err; 462 $socket = $conn_sock; 463 return $steps->{'write_block'}->(); 464 }; 465 # ... 466 } 467 468The C<define_steps> function sets the stage. It is given a reference to the 469callback for this function (recall there is only one exit point!), and 470"patches" that reference to free C<$steps>, which otherwise forms a reference 471loop, on exit. 472 473WARNING: if the function or method needs to do any kind of setup before its 474first step, that setup should be done either in a C<setup> step or I<before> 475the C<define_steps> invocation. Do not write any statements other than step 476declarations after the C<define_steps> call. 477 478Note that there are more steps in this example than are strictly necessary: the 479body of C<connect> could be appended to C<ghbn_cb>. The extra steps make the 480overall operation more readable by adding "punctuation" to separate the task of 481handling a callback (C<ghbn_cb>) from starting the next operation (C<connect>). 482 483Also note that the enclosing scope contains some lexical (C<my>) 484variables which are shared by several of the callbacks. 485 486All of the steps are wrapped by C<make_cb>, so each step will be executed on a 487separate iteration of the MainLoop. This generally has the effect of making 488asynchronous functions share CPU time more fairly. Sometimes, especially when 489using the low-level interface, a callback must be called immediately. To 490achieve this for all callbacks, add C<< immediate => 1 >> to the C<define_steps> 491invocation: 492 493 my $steps = define_steps 494 cb_ref => \$finished_cb, 495 immediate => 1; 496 497To do the same for a single step, add the same keyword to the C<step> invocation: 498 499 step immediate => 1, 500 connect => sub { .. }; 501 502In some case, you want to execute some code when the step finish, it can 503be done by defining a finalize code in define_steps: 504 505 my $steps = define_steps 506 cb_ref => \$finished_cb, 507 finalize => sub { .. }; 508 509=head2 JOINING ASYNCHRONOUS "THREADS" 510 511With slow operations, it is often useful to perform multiple operations 512simultaneously. As an example, the following code might run two system 513commands simultaneously and capture their output: 514 515 sub run_two_commands { 516 my ($finished_cb) = @_; 517 my $running_commands = 0; 518 my ($result1, $result2); 519 my $steps = define_steps 520 cb_ref => \$finished_cb; 521 step start => sub { 522 $running_commands++; 523 run_command($command1, 524 run_cb => $steps->{'command1_done'}); 525 $running_commands++; 526 run_command($command2, 527 run_cb => $steps->{'command2_done'}); 528 }; 529 step command1_done => sub { 530 $result1 = $_[0]; 531 $steps->{'maybe_done'}->(); 532 }; 533 step command2_done => sub { 534 $result2 = $_[0]; 535 $steps->{'maybe_done'}->(); 536 }; 537 step maybe_done => sub { 538 return if --$running_commands; # not done yet 539 $finished_cb->($result1, $result2); 540 }; 541 } 542 543It is tempting to optimize out the C<$running_commands> with something like: 544 545 step maybe_done { ## BAD! 546 return unless defined $result1 and defined $result2; 547 $finished_cb->($result1, $result2); 548 } 549 550However this can lead to trouble. Remember that define_steps automatically 551applies C<make_cb> to each step, so a C<maybe_done> is not invoked immediately 552by C<command1_done> and C<command2_done> - instead, C<maybe_done> is scheduled 553for invocation in the next loop of the mainloop (via C<call_later>). If both 554commands finish before C<maybe_done> is invoked, C<call_later> will be called 555I<twice>, with both C<$result1> and C<$result2> defined both times. The result 556is that C<$finished_cb> is called twice, and mayhem ensues. 557 558This is a complex case, but worth understanding if you want to be able to debug 559difficult MainLoop bugs. 560 561=head2 WRITING ASYNCHRONOUS INTERFACES 562 563When designing a library or interface that will accept and invoke 564callbacks, follow these guidelines so that users of the interface will 565not need to remember special rules. 566 567Each callback signature within a package should always have the same 568name, ending with C<_cb>. For example, a hypothetical 569C<Amanda::Estimate> module might provide its estimates through a 570callback with four parameters. This callback should be referred to as 571C<estimate_cb> throughout the package, and its parameters should be 572clearly defined in the package's documentation. It should take 573positional parameters only. If error conditions must also be 574communicated via the callback, then the first parameter should be an 575C<$error> parameter, which is undefined when no error has occurred. 576The Changer API's C<res_cb> is typical of such a callback signature. 577 578A caller can only know that an operation is complete by the invocation 579of the callback, so it is important that a callback be invoked 580I<exactly once> in all circumstances. Even in an error condition, the 581caller needs to know that the operation has failed. Also beware of 582bugs that might cause a callback to be invoked twice. 583 584Functions or methods taking callbacks as arguments should either take 585only a callback (like C<call_later>), or take hash-key parameters, 586where the callback's key is the signature name. For example, the 587C<Amanda::Estimate> package might define a function like 588C<perform_estimate>, invoked something like this: 589 590 my $estimate_cb = make_cb(estimate_cb => sub { 591 my ($err, $size, $level) = @_; 592 die $err if $err; 593 # ... 594 }); 595 Amanda::Estimate::perform_estimate( 596 host => $host, 597 disk => $disk, 598 estimate_cb => $estimate_cb, 599 ); 600 601When invoking a user-supplied callback within the library, there is no 602need to wrap it in a C<call_later> invocation, as the user already 603supplied that wrapper via C<make_cb>, or is not interested in using 604such a wrapper. 605 606Callbacks are a form of continuation 607(L<http://en.wikipedia.org/wiki/Continuations>), and as such should 608only be called at the I<end> of a function. Do not do anything after 609invoking a callback, as you cannot know what processing has gone on in 610the callback. 611 612 sub estimate_done { 613 # ... 614 $self->{'estimate_cb'}->(undef, $size, $level); 615 $self->{'estimate_in_progress'} = 0; # BUG!! 616 } 617 618In this case, the C<estimate_cb> invocation may have called 619C<perform_estimate> again, setting C<estimate_in_progress> back to 1. 620A technique to avoid this pitfall is to always C<return> a callback's 621result, even though that result is not important. This makes the bug 622much more apparent: 623 624 sub estimate_done { 625 # ... 626 return $self->{'estimate_cb'}->(undef, $size, $level); 627 $self->{'estimate_in_progress'} = 0; # BUG (this just looks silly) 628 } 629 630=head1 LOW-LEVEL INTERFACE 631 632MainLoop events are generated by event sources. A source may produce 633multiple events over its lifetime. The higher-level methods in the 634previous section provide a more Perlish abstraction of event sources, 635but for efficiency it is sometimes necessary to use event sources 636directly. 637 638The method C<< $src->set_callback(\&cb) >> sets the function that will 639be called for a given source, and "attaches" the source to the main 640loop so that it will begin generating events. The arguments to the 641callback depend on the event source, but the first argument is always 642the source itself. Unless specified, no other arguments are provided. 643 644Event sources persist until they are removed with 645C<< $src->remove() >>, even if the source itself is no longer accessible from Perl. 646Although Glib supports it, there is no provision for "automatically" 647removing an event source. Also, calling C<< $src->remove() >> more than 648once is a potentially-fatal error. As an example: 649 650 sub start_timer { 651 my ($loops) = @_; 652 Amanda::MainLoop::timeout_source(200)->set_callback(sub { 653 my ($src) = @_; 654 print "timer\n"; 655 if (--$loops <= 0) { 656 $src->remove(); 657 Amanda::MainLoop::quit(); 658 } 659 }); 660 } 661 start_timer(10); 662 Amanda::MainLoop::run(); 663 664There is no means in place to specify extra arguments to be provided 665to a source callback when it is set. If the callback needs access to 666other data, it should use a Perl closure in the form of lexically 667scoped variables and an anonymous sub. In fact, this is exactly what 668the higher-level functions (described above) do. 669 670=head2 Timeout 671 672 my $src = Amanda::MainLoop::timeout_source(10000); 673 674A timeout source will create events at the specified interval, 675specified in milliseconds (thousandths of a second). The events will 676continue until the source is destroyed. 677 678=head2 Idle 679 680 my $src = Amanda::MainLoop::idle_source(2); 681 682An idle source will create events continuously except when a 683higher-priority source is emitting events. Priorities are generally 684small positive integers, with larger integers denoting lower 685priorities. The events will continue until the source is destroyed. 686 687=head2 Child Watch 688 689 my $src = Amanda::MainLoop::child_watch_source($pid); 690 691A child watch source will issue an event when the process with the 692given PID dies. To avoid race conditions, it will issue an event even 693if the process dies before the source is created. The callback is 694called with three arguments: the event source, the PID, and the 695child's exit status. 696 697Note that this source is totally incompatible with any thing that 698would cause perl to change the SIGCHLD handler. If SIGCHLD is 699changed, under some circumstances the module will recognize this 700circumstance, add a warning to the debug log, and continue operating. 701However, it is impossible to catch all possible situations. 702 703=head2 File Descriptor 704 705 my $src = Amanda::MainLoop::fd_source($fd, $G_IO_IN); 706 707This source will issue an event whenever one of the given conditions 708is true for the given file (a file handle or integer file descriptor). 709The conditions are from Glib's GIOCondition, and are C<$G_IO_IN>, 710C<G_IO_OUT>, C<$G_IO_PRI>, C<$G_IO_ERR>, C<$G_IO_HUP>, and 711C<$G_IO_NVAL>. These constants are available with the import tag 712C<:GIOCondition>. 713 714Generally, when reading from a file descriptor, use 715C<$G_IO_IN|$G_IO_HUP|$G_IO_ERR> to ensure that an EOF triggers an 716event as well. Writing to a file descriptor can simply use 717C<$G_IO_OUT|$G_IO_ERR>. 718 719The callback attached to an FdSource should read from or write to the 720underlying file descriptor before returning, or it will be called 721again in the next iteration of the main loop, which can lead to 722unexpected results. Do I<not> use C<make_cb> here! 723 724=head2 Combining Event Sources 725 726Event sources are often set up in groups, e.g., a long-term operation 727and a timeout. When this is the case, be careful that all sources are 728removed when the operation is complete. The easiest way to accomplish 729this is to include all sources in a lexical scope and remove them at 730the appropriate times: 731 732 { 733 my $op_src = long_operation_src(); 734 my $timeout_src = Amanda::MainLoop::timeout_source($timeout); 735 736 sub finish { 737 $op_src->remove(); 738 $timeout_src->remove(); 739 } 740 741 $op_src->set_callback(sub { 742 print "Operation complete\n"; 743 finish(); 744 }); 745 746 $timeout_src->set_callback(sub { 747 print "Operation timed out\n"; 748 finish(); 749 }); 750 } 751 752=head2 Relationship to Glib 753 754Glib's main event loop is described in the Glib manual: 755L<http://library.gnome.org/devel/glib/stable/glib-The-Main-Event-Loop.html>. 756Note that Amanda depends only on the functionality available in 757Glib-2.2.0, so many functions described in that document are not 758available in Amanda. This module provides a much-simplified interface 759to the glib library, and is not intended as a generic wrapper for it: 760Amanda's perl-accessible main loop only runs a single C<GMainContext>, 761and always runs in the main thread; and (aside from idle sources), 762event priorities are not accessible from Perl. 763 764=cut 765 766 767 768 769use POSIX; 770use Carp; 771 772## basic functions 773 774BEGIN { 775 my $have_sub_name = eval "use Sub::Name; 1"; 776 if (!$have_sub_name) { 777 eval <<'EOF' 778 sub subname { 779 my ($name, $sub) = @_; 780 $sub; 781 } 782EOF 783 } 784} 785 786# glib's g_is_main_loop_running() seems inaccurate, so we just 787# track that information locally.. 788my $mainloop_running = 0; 789sub run { 790 $mainloop_running = 1; 791 run_c(); 792 $mainloop_running = 0; 793} 794push @EXPORT_OK, "run"; 795 796sub is_running { 797 return $mainloop_running; 798} 799push @EXPORT_OK, "is_running"; 800 801# quit is a direct call to C 802push @EXPORT_OK, "quit"; 803 804## utility functions 805 806my @waiting_to_call_later; 807sub call_later { 808 my ($sub, @args) = @_; 809 810 confess "undefined sub" unless ($sub); 811 812 # add the callback if nothing is waiting right now 813 if (!@waiting_to_call_later) { 814 timeout_source(0)->set_callback(sub { 815 my ($src) = @_; 816 $src->remove(); 817 818 while (@waiting_to_call_later) { 819 my ($sub, @args) = @{shift @waiting_to_call_later}; 820 $sub->(@args) if $sub; 821 } 822 }); 823 } 824 825 push @waiting_to_call_later, [ $sub, @args ]; 826} 827push @EXPORT_OK, "call_later"; 828 829sub make_cb { 830 my ($name, $sub) = @_; 831 832 if ($sub) { 833 my ($pkg, $filename, $line) = caller; 834 my $newname = sprintf('$%s::%s@l%s', $pkg, $name, $line); 835 $sub = subname($newname => $sub); 836 } else { 837 $sub = $name; # no name => sub is actually in first parameter 838 } 839 840 sub { 841 Amanda::MainLoop::call_later($sub, @_); 842 }; 843} 844push @EXPORT, 'make_cb'; 845 846sub call_after { 847 my ($delay_ms, $sub, @args) = @_; 848 849 confess "undefined sub" unless ($sub); 850 851 my $src = timeout_source($delay_ms); 852 $src->set_callback(sub { 853 $src->remove(); 854 $sub->(@args); 855 }); 856 857 return $src; 858} 859push @EXPORT_OK, "call_after"; 860 861sub call_on_child_termination { 862 my ($pid, $cb, @args) = @_; 863 864 confess "undefined sub" unless ($cb); 865 866 my $src = child_watch_source($pid); 867 $src->set_callback(sub { 868 my ($src, $pid, $exitstatus) = @_; 869 $src->remove(); 870 return $cb->($exitstatus); 871 }); 872} 873push @EXPORT_OK, "call_on_child_termination"; 874 875sub async_read { 876 my %params = @_; 877 my $fd = $params{'fd'}; 878 my $size = $params{'size'} || 0; 879 my $cb = $params{'async_read_cb'}; 880 my @args; 881 @args = @{$params{'args'}} if exists $params{'args'}; 882 883 my $fd_cb = sub { 884 my ($src) = @_; 885 $src->remove(); 886 887 my $buf; 888 my $res = POSIX::read($fd, $buf, $size || 32768); 889 if (!defined $res) { 890 return $cb->($!, undef, @args); 891 } else { 892 return $cb->(undef, $buf, @args); 893 } 894 }; 895 my $src = fd_source($fd, $G_IO_IN|$G_IO_HUP|$G_IO_ERR); 896 $src->set_callback($fd_cb); 897 return $src; 898} 899push @EXPORT_OK, "async_read"; 900 901my %outstanding_writes; 902sub async_write { 903 my %params = @_; 904 my $fd = $params{'fd'}; 905 my $data = $params{'data'}; 906 my $cb = $params{'async_write_cb'}; 907 my @args; 908 @args = @{$params{'args'}} if exists $params{'args'}; 909 910 # more often than not, writes will not block, so just try it. 911 if (!exists $outstanding_writes{$fd}) { 912 my $res = POSIX::write($fd, $data, length($data)); 913 if (!defined $res) { 914 if ($! != POSIX::EAGAIN) { 915 return $cb->($!, 0, @args); 916 } 917 } elsif ($res eq length($data)) { 918 return $cb->(undef, $res, @args); 919 } else { 920 # chop off whatever data was written 921 $data = substr($data, $res); 922 } 923 } 924 925 if (!exists $outstanding_writes{$fd}) { 926 my $fd_writes = $outstanding_writes{$fd} = []; 927 my $src = fd_source($fd, $G_IO_OUT|$G_IO_HUP|$G_IO_ERR); 928 929 # (note that this does not coalesce consecutive outstanding writes 930 # into a single POSIX::write call) 931 my $fd_cb = sub { 932 my $ow = $fd_writes->[0]; 933 my ($buf, $nwritten, $len, $cb, $args) = @$ow; 934 935 my $res = POSIX::write($fd, $buf, $len-$nwritten); 936 if (!defined $res) { 937 shift @$fd_writes; 938 $cb->($!, $nwritten, @$args); 939 } else { 940 $ow->[1] = $nwritten = $nwritten + $res; 941 if ($nwritten == $len) { 942 shift @$fd_writes; 943 $cb->(undef, $nwritten, @$args); 944 } else { 945 $ow->[0] = substr($buf, $res); 946 } 947 } 948 949 # (the following is *intentionally* done after calling $cb, allowing 950 # $cb to add a new message to $fd_writes if desired, and thus avoid 951 # removing and re-adding the source) 952 if (@$fd_writes == 0) { 953 $src->remove(); 954 delete $outstanding_writes{$fd}; 955 } 956 }; 957 958 $src->set_callback($fd_cb); 959 } 960 961 push @{$outstanding_writes{$fd}}, [ $data, 0, length($data), $cb, \@args ]; 962} 963push @EXPORT_OK, "async_write"; 964 965sub synchronized { 966 my ($lock, $orig_cb, $sub) = @_; 967 my $continuation_cb; 968 969 $continuation_cb = sub { 970 my @args = @_; 971 972 # shift this invocation off the queue 973 my ($last_sub, $last_orig_cb) = @{ shift @$lock }; 974 975 # start the next invocation, if the queue isn't empty 976 if (@$lock) { 977 Amanda::MainLoop::call_later($lock->[0][0], $continuation_cb); 978 } 979 980 # call through to the original callback for the last invocation 981 return $last_orig_cb->(@args); 982 }; 983 984 # push this sub onto the lock queue 985 if ((push @$lock, [ $sub, $orig_cb ]) == 1) { 986 # if this is the first addition to the queue, start it 987 $sub->($continuation_cb); 988 } 989} 990push @EXPORT_OK, "synchronized"; 991 992{ # privat variables to track the "current" step definition 993 my $current_steps; 994 my $immediate; 995 my $first_step; 996 997 sub define_steps (@) { 998 my (%params) = @_; 999 my $cb_ref = $params{'cb_ref'}; 1000 my $finalize = $params{'finalize'}; 1001 my %steps; 1002 1003 croak "cb_ref is undefined" unless defined $cb_ref; 1004 croak "cb_ref is not a reference" unless ref($cb_ref) eq 'REF'; 1005 croak "cb_ref is not a code double-reference" unless ref($$cb_ref) eq 'CODE'; 1006 1007 # arrange to clear out $steps when $exit_cb is called; this eliminates 1008 # reference loops (values in %steps are closures which point to %steps). 1009 # This also clears $current_steps, which is likely holding a reference to 1010 # the steps hash. 1011 my $orig_cb = $$cb_ref; 1012 $$cb_ref = sub { 1013 %steps = (); 1014 $current_steps = undef; 1015 $finalize->() if defined($finalize); 1016 goto $orig_cb; 1017 }; 1018 1019 # set up state 1020 $current_steps = \%steps; 1021 $immediate = $params{'immediate'}; 1022 $first_step = 1; 1023 1024 return $current_steps; 1025 } 1026 push @EXPORT, "define_steps"; 1027 1028 sub step (@) { 1029 my (%params) = @_; 1030 my $step_immediate = $immediate || $params{'immediate'}; 1031 delete $params{'immediate'} if $step_immediate; 1032 1033 my ($name) = keys %params; 1034 my $cb = $params{$name}; 1035 1036 croak "expected a sub at key $name" unless ref($cb) eq 'CODE'; 1037 1038 # make the sub delayed 1039 unless ($step_immediate) { 1040 my $orig_cb = $cb; 1041 $cb = sub { Amanda::MainLoop::call_later($orig_cb, @_); } 1042 } 1043 1044 # patch up the callback 1045 my ($pkg, $filename, $line) = caller; 1046 my $newname = sprintf('$%s::%s@l%s', $pkg, $name, $line); 1047 $cb = subname($newname => $cb); 1048 1049 # store the step for later 1050 $current_steps->{$name} = $cb; 1051 1052 # and invoke it, if it's the first step given 1053 if ($first_step) { 1054 if ($step_immediate) { 1055 call_later($cb); 1056 } else { 1057 $cb->(); 1058 } 1059 } 1060 $first_step = 0; 1061 } 1062 push @EXPORT, "step"; 1063} 1064 1065push @EXPORT_OK, qw(GIOCondition_to_strings); 1066push @{$EXPORT_TAGS{"GIOCondition"}}, qw(GIOCondition_to_strings); 1067 1068my %_GIOCondition_VALUES; 1069#Convert a flag value to a list of names for flags that are set. 1070sub GIOCondition_to_strings { 1071 my ($flags) = @_; 1072 my @result = (); 1073 1074 for my $k (keys %_GIOCondition_VALUES) { 1075 my $v = $_GIOCondition_VALUES{$k}; 1076 1077 #is this a matching flag? 1078 if (($v == 0 && $flags == 0) || ($v != 0 && ($flags & $v) == $v)) { 1079 push @result, $k; 1080 } 1081 } 1082 1083#by default, just return the number as a 1-element list 1084 if (!@result) { 1085 return ($flags); 1086 } 1087 1088 return @result; 1089} 1090 1091push @EXPORT_OK, qw($G_IO_IN); 1092push @{$EXPORT_TAGS{"GIOCondition"}}, qw($G_IO_IN); 1093 1094$_GIOCondition_VALUES{"G_IO_IN"} = $G_IO_IN; 1095 1096push @EXPORT_OK, qw($G_IO_OUT); 1097push @{$EXPORT_TAGS{"GIOCondition"}}, qw($G_IO_OUT); 1098 1099$_GIOCondition_VALUES{"G_IO_OUT"} = $G_IO_OUT; 1100 1101push @EXPORT_OK, qw($G_IO_PRI); 1102push @{$EXPORT_TAGS{"GIOCondition"}}, qw($G_IO_PRI); 1103 1104$_GIOCondition_VALUES{"G_IO_PRI"} = $G_IO_PRI; 1105 1106push @EXPORT_OK, qw($G_IO_ERR); 1107push @{$EXPORT_TAGS{"GIOCondition"}}, qw($G_IO_ERR); 1108 1109$_GIOCondition_VALUES{"G_IO_ERR"} = $G_IO_ERR; 1110 1111push @EXPORT_OK, qw($G_IO_HUP); 1112push @{$EXPORT_TAGS{"GIOCondition"}}, qw($G_IO_HUP); 1113 1114$_GIOCondition_VALUES{"G_IO_HUP"} = $G_IO_HUP; 1115 1116push @EXPORT_OK, qw($G_IO_NVAL); 1117push @{$EXPORT_TAGS{"GIOCondition"}}, qw($G_IO_NVAL); 1118 1119$_GIOCondition_VALUES{"G_IO_NVAL"} = $G_IO_NVAL; 1120 1121#copy symbols in GIOCondition to constants 1122push @{$EXPORT_TAGS{"constants"}}, @{$EXPORT_TAGS{"GIOCondition"}}; 11231; 1124