"Fossies" - the Fresh Open Source Software Archive

Member "Tk-804.036/t/async.t" (20 Oct 2019, 943 Bytes) of package /linux/misc/Tk-804.036.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

    1 #!/usr/bin/perl -w
    2 # -*- perl -*-
    3 
    4 #
    5 # $Id: $
    6 # Author: Slaven Rezic
    7 #
    8 
    9 use strict;
   10 
   11 use Config qw(%Config);
   12 
   13 BEGIN {
   14     if (!eval q{
   15     use Test::More;
   16     1;
   17     }) {
   18     print "1..0 # skip no Test::More module\n";
   19     exit;
   20     }
   21 }
   22 
   23 BEGIN {
   24     if (!defined $Config{sig_name}) {
   25     print "1..0 # skip No signals on this system?\n";
   26     exit;
   27     }
   28     if ($Config{sig_name} !~ m{\bUSR2\b}) {
   29     print "1..0 # skip signal USR2 is not available on this system\n";
   30     exit;
   31     }
   32 }
   33 
   34 use Tk;
   35 
   36 plan tests => 1;
   37 
   38 my $caught_USR2 = 0;
   39 $SIG{USR2} = sub { $caught_USR2++ };
   40 
   41 my $mw = tkinit;
   42 $mw->geometry("+0+0");
   43 $mw->Label(-text => "Waiting for USR2 signals...")->pack;
   44 $mw->idletasks;
   45 
   46 my $ppid = $$;
   47 if (fork == 0) {
   48     kill USR2 => $ppid;
   49     select undef,undef,undef,0.2;
   50     kill USR2 => $ppid;
   51     require POSIX;
   52     POSIX::_exit(0);
   53 }
   54 
   55 $mw->after(500, sub { $mw->destroy });
   56 
   57 MainLoop;
   58 
   59 is($caught_USR2, 2, "Caught USR2 signal exactly two times");
   60 
   61 __END__