← Back to branch summary

~ubuntu-branches/ubuntu/trusty/horae/trusty

« back to all changes in this revision

Viewing changes to 0CPAN/Tk-Splashscreen-1.0/waitVariableX.pm

  • Committer: Bazaar Package Importer
  • Author(s): Carlo Segre
  • Date: 2008-02-23 23:13:02 UTC
  • mfrom: (2.1.2 hardy)
  • Revision ID: james.westby@ubuntu.com-20080223231302-mnyyxs3icvrus4ke
Tags: 066-3
Apply patch to athena_parts/misc.pl for compatibility with 
perl-tk 804.28.

Show diffs side-by-side

added added

removed removed

Lines of Context:
0CPAN/Tk-Splashscreen-1.0/waitVariableX.pm
1
 
$Tk::waitVariableX::VERSION = '1.0';
2
 
 
3
 
package Tk::waitVariableX;
4
 
 
5
 
use Carp;
6
 
use Exporter;
7
 
 
8
 
use base qw/Exporter/;
9
 
@EXPORT = qw/waitVariableX/;
10
 
use strict;
11
 
 
12
 
sub waitVariableX {
13
 
 
14
 
    use Tie::Watch;
15
 
 
16
 
    my ($parent, $millis) = (shift, shift); # @_ has list of var refs
17
 
 
18
 
    croak "waitVariableX:  no milliseconds." unless defined $millis;
19
 
    my ($callback, $st, $tid, @watch, $why);
20
 
 
21
 
    if (ref $millis eq 'ARRAY') {
22
 
        $callback = Tk::Callback->new($millis->[1]);
23
 
        $millis = $millis->[0];
24
 
    }
25
 
 
26
 
    $st = sub {my $argv = $_[0]->Args('-store'); $why = $argv->[0]};
27
 
    foreach my $vref (@_) {
28
 
        push @watch,
29
 
            Tie::Watch->new(-variable => $vref, -store => [$st, $vref]);
30
 
    }
31
 
    $tid = $parent->after($millis => sub {$why = 0}) unless $millis == 0;
32
 
 
33
 
    $parent->waitVariable(\$why); # wait for timer or watchpoint(s)
34
 
 
35
 
    $_->Unwatch foreach @watch;
36
 
    $parent->afterCancel($tid);
37
 
    $callback->Call($why) if defined $callback;
38
 
 
39
 
    return $why;                # why we stopped waiting: 0 or $vref
40
 
 
41
 
} # end waitVariableX
42
 
 
43
 
1;
44
 
__END__
45
 
 
46
 
=head1 NAME
47
 
 
48
 
Tk::waitVariableX - a waitVariable with extensions.
49
 
 
50
 
=head1 SYNOPSIS
51
 
 
52
 
 use Tk::waitVariableX;
53
 
 
54
 
 $splash->waitVariableX( [$millis, $destroy_splashscreen], \$v1, \$v2} );
55
 
 
56
 
=head1 DESCRIPTION
57
 
 
58
 
This subroutine waits for a list of variables, with a timeout - the
59
 
subroutine returns when one of the variables changes value or the timeout
60
 
expires, whichever occurs first. 
61
 
 
62
 
Although the millisecond parameter is required, it may be zero, which
63
 
effects no timeout. The milliscond paramter may also be an array of
64
 
two elements, the first the millisecond value, and the second a 
65
 
normal Per/Tk callback. The callback is invoked just before 
66
 
waitVariableX returns.
67
 
 
68
 
Callback format is patterned after the Perl/Tk scheme: supply either a
69
 
code reference, or, supply an array reference and pass the callback
70
 
code reference in the first element of the array, followed by callback
71
 
arguments.
72
 
 
73
 
=head1 COPYRIGHT
74
 
 
75
 
Copyright (C) 2000 - 2002 Stephen O. Lidie. All rights reserved.
76
 
 
77
 
This program is free software; you can redistribute it and/or modify it under
78
 
the same terms as Perl itself.
79
 
 
80
 
=cut