1 - | |
2 - | use local::lib; |
3 - | use IO::Select; |
4 - | use Expect; |
5 - | |
6 - | $debug = 0; |
7 - | |
8 - | |
9 - | |
10 - | |
11 - | $xvfb_pid = 0; |
12 - | $authority = ''; |
13 - | |
14 - | |
15 - | END { |
16 - | if ( $xvfb_pid ) { |
17 - | kill 9, $xvfb_pid; |
18 - | } |
19 - | if ( $authority ) { |
20 - | unlink($authority); |
21 - | } |
22 - | } |
23 - | |
24 - | |
25 - | |
26 - | sub create_authority { |
27 - | my $display_num = shift; |
28 - | my $file = shift; |
29 - | my $cookie = ''; |
30 - | my $seed = 0; |
31 - | for (1..10) { |
32 - | srand(time+$$+$seed); |
33 - | $cookie .= sprintf("%4.5x", ($seed = int(rand(65536)))); |
34 - | } |
35 - | $cookie = substr $cookie, 0, 32; |
36 - | open( XAUTH, "xauth -f $file add :$display_num . $cookie 2>&1 |" ); |
37 - | print "creating xauthority file $file for display :$display_num...\n" if $debug; |
38 - | while ( <XAUTH> ) { |
39 - | print " $_" if $debug; |
40 - | } |
41 - | close(XAUTH); |
42 - | } |
43 - | |
44 - | sub launch_xvfb { |
45 - | my $authority = shift; |
46 - | my $display=4; |
47 - | my $failed = 1; |
48 - | while ( $failed ) { |
49 - | $failed = 0; |
50 - | pipe my $read, my $write or die "could not create pipe"; |
51 - | |
52 - | |
53 - | |
54 - | select((select($write), $| = 1)[0]); |
55 - | if ( my $pid = fork( ) ) { |
56 - | |
57 - | |
58 - | |
59 - | $xvfb_pid = $pid; |
60 - | close $write; |
61 - | print "trying to start xvfb on display :$display...\n" if $debug; |
62 - | my $readable = IO::Select->new($read); |
63 - | |
64 - | while ( my @ready = $readable->can_read(5) ) { |
65 - | foreach $fh ( @ready ) { |
66 - | my $buf = <$fh>; |
67 - | if ( $buf ) { |
68 - | |
69 - | print " $buf" if $debug; |
70 - | if ( $buf =~ m|server.*already active|i ) { |
71 - | $readable->remove($fh); |
72 - | close($fh); |
73 - | $failed = 1; |
74 - | $display += 1; |
75 - | } |
76 - | } else { |
77 - | |
78 - | $readable->remove($fh); |
79 - | close($fh); |
80 - | $failed = 1; |
81 - | $display += 1; |
82 - | } |
83 - | } |
84 - | } |
85 - | } else { |
86 - | |
87 - | |
88 - | |
89 - | close $read; |
90 - | open(STDERR, ">&=" . fileno($write)) or die "cannot dup to stderr"; |
91 - | open(STDOUT, ">&=" . fileno($write)) or die "cannot dup to stdout"; |
92 - | my @args = ( 'Xvfb', ":$display", "-screen", "0", "2048x2048x24+32", "-auth", $authority ); |
93 - | exec { $args[0] } @args; |
94 - | die "exec failed..."; |
95 - | } |
96 - | } |
97 - | return $display; |
98 - | } |
99 - | |
100 - | |
101 - | |
102 - | |
103 - | select((select(STDOUT), $| = 1)[0]); |
104 - | select((select(STDERR), $| = 1)[0]); |
105 - | |
106 - | if ( scalar(@ARGV) == 1 ) { |
107 - | my $e = @ARGV[0]; |
108 - | die "initialization file ($e) does not exist, or is not a file" unless -f $e; |
109 - | open(F,"< $e") or die "cannot read $e"; |
110 - | my @x = <F>; |
111 - | close(F); |
112 - | eval join('',@x); |
113 - | } elsif ( scalar(@ARGV) > 1 ) { |
114 - | die "casapy-version takes at most one argument (an initialization file)..."; |
115 - | } |
116 - | |
117 - | $authority = "/tmp/.xauth-$$"; |
118 - | open( XAUTH, "> $authority" ) or die "cannot create xauth file..."; |
119 - | close( XAUTH ); |
120 - | |
121 - | $display = launch_xvfb( $authority ); |
122 - | create_authority( $display, $authority ); |
123 - | |
124 - | $ENV{'DISPLAY'} = "localhost:$display.0"; |
125 - | $ENV{'XAUTHORITY'} = $authority; |
126 - | |
127 - | unless ( $casa_pid = fork( ) ) { |
128 - | |
129 - | |
130 - | setpgrp(0,0); |
131 - | |
132 - | my @args = ( "--nologger", "--log2term", "--colors=NoColor" ); |
133 - | $expect = new Expect( "casapy", @args ); |
134 - | $expect->log_stdout(0); |
135 - | |
136 - | my $timeout = 30; |
137 - | $expect->expect( $timeout, [ qr/CASA\s+<\S*?>/ => sub { |
138 - | sleep(10); $expect->send("exit\n"); exp_continue; } ], |
139 - | [ qr/leaving casapy.../ => sub { my $exp = shift; sleep(5); } ], |
140 - | [ qr/CASA Version\s+(\S+)\s+\(r(\d+)\)/ => sub { my @m = $expect->matchlist( ); print "VERSION> $m[0] $m[1]\n"; |
141 - | my $exp = shift; exp_continue; } ], |
142 - | [ timeout => sub { $timeout_occurred = 1; } ], |
143 - | [ eof => sub { $eof_occurred = 1; } ] ); |
144 - | |
145 - | exit $expect->exitstatus( ); |
146 - | } |
147 - | |
148 - | waitpid( $casa_pid, 0 ); |
149 - | exit(0); |