ViewVC Help
View File | Revision Log | Show Annotations | Root Listing
root/yamap/ExecuteCommand.pm
Revision: 1.1.1.1 (vendor branch)
Committed: Thu Sep 7 15:35:20 2006 UTC (9 years, 7 months ago) by knirirr
Branch: MAIN, cehox
CVS Tags: start, HEAD
Changes since 1.1: +0 -0 lines
Log Message:
Imported sources

Line File contents
1 $Tk::ExecuteCommand::VERSION = '1.6';
2
3 package Tk::ExecuteCommand;
4
5 use IO::Handle;
6 use Proc::Killfam;
7 use Tk::widgets qw/LabEntry ROText/;
8 use base qw/Tk::Frame/;
9 use strict;
10
11 Construct Tk::Widget 'ExecuteCommand';
12
13 sub Populate {
14
15 my($self, $args) = @_;
16
17 $self->SUPER::Populate($args);
18
19 my $f1 = $self->Frame->pack;
20 my $c = $f1->LabEntry->pack(qw/-side left/);
21 $self->Advertise('command' => $c);
22
23 my $doit = $f1->Button->pack(qw/-side left/);
24 $self->Advertise('doit' => $doit);
25 $self->_reset_doit_button;
26
27 $c->bind('<Return>' => [$doit => 'invoke']);
28
29 my $s = $self->Frame->pack(qw/-pady 10/);
30 $self->Advertise('spacer' => $s);
31 my $l = $self->Label(-text => 'Command\'s stdout and stderr')->pack;
32 $self->Advertise('label' => $l);
33
34 my $text = $self->Scrolled('ROText');
35 $text->pack(qw/-expand 1 -fill both/);
36 $self->Advertise('text' => $text);
37 $self->OnDestroy( sub { killfam 'TERM', $self->{-pid} if defined $self->{-pid} } );
38
39 $self->{-finish} = 0;
40 $self->{-tid} = undef;
41 $self->{doit_text} = 'Do It!';
42
43 $self->ConfigSpecs(
44 -command => [qw/METHOD command Command/, 'sleep 5; pwd' ],
45 -entryWidth => [{-width => $c}, qw/entryWidth EntryWidth 10/ ],
46 -height => [$text, qw/height Height 24/ ],
47 -label => [$c, qw/label Label/, 'Command to Execute' ],
48 -labelPack => [$c, qw/labelPack LabelPack/, [-side=>'left'] ],
49 -scrollbars => [$text, qw/scrollbar Scrollbar sw/ ],
50 -text => [qw/METHOD text Text/, $self->{doit_text} ],
51 -textvariable => [$c,qw/textvariable Textvariable/,\$self->{-command}],
52 -width => [$text, qw/width Width 80/ ],
53 -wrap => [$text, qw/wrap Wrap/, 'none' ],
54 );
55
56 } # end Populate
57
58 sub command {
59
60 my($self, $command) = @_;
61 $self->{-command} = $command;
62
63 } # end command
64
65 sub _flash_doit {
66
67 # Flash "Do It" by alternating its background color.
68
69 my($self, $option, $val1, $val2, $interval) = @_;
70
71 if ($self->{-finish} == 0) {
72 $self->Subwidget('doit')->configure($option => $val1);
73 $self->idletasks;
74 $self->{-tid} = $self->after($interval,
75 [\&_flash_doit, $self, $option, $val2, $val1, $interval]);
76 }
77
78 } # end _flash_doit
79
80 sub _read_stdout {
81
82 # Called when input is available for the output window. Also checks
83 # to see if the user has clicked Cancel.
84
85 my($self) = @_;
86
87 if ($self->{-finish}) {
88 $self->kill_command;
89 } else {
90 my $h = $self->{-handle};
91 die "ExecuteCommand handle is udefined!\n" unless defined $h;
92 my $stat;
93 if ( $stat = sysread $h, $_, 4096 ) {
94 my $t = $self->Subwidget('text');
95 $t->insert('end', $_);
96 $t->yview('end');
97 } elsif ( $stat == 0 ) {
98 $self->{-finish} = 1;
99 } else {
100 die "ExecuteCommand sysread error: $!";
101 }
102 }
103
104 } # end _read_stdout
105
106 sub _reset_doit_button {
107
108 # Establish normal "Do It" button parameters.
109
110 my($self) = @_;
111
112 my $doit = $self->Subwidget('doit');
113 my $doit_bg = ($doit->configure(-background))[3];
114 $doit->configure(
115 -text => $self->{doit_text},
116 -relief => 'raised',
117 -background => $doit_bg,
118 -state => 'normal',
119 -command => [sub {
120 my($self) = @_;
121 $self->Subwidget('doit')->configure(
122 -text => 'Working ...',
123 -relief => 'sunken',
124 -state => 'disabled'
125 );
126 $self->{-finish} = 0;
127 $self->execute_command;
128 }, $self],
129 );
130
131 $self->{-finish} = 0;
132
133 } # end _reset_doit_button
134
135 sub text {
136
137 my($self, $text) = @_;
138 $self->{doit_text} = $text;
139 $self->Subwidget('doit')->configure(-text => $text);
140
141 } # end text
142
143 # Public methods.
144
145 sub execute_command {
146
147 # Execute the command and capture stdout/stderr.
148
149 my($self) = @_;
150
151 $self->{-finish} = 0;
152 $self->{-handle} = undef;
153 $self->{-pid} = undef;
154 $self->{-tid} = undef;
155
156 my $h = IO::Handle->new;
157 die "IO::Handle->new failed." unless defined $h;
158 $self->{-handle} = $h;
159
160 $self->{-pid} = open $h, $self->{-command} . ' 2>&1 |';
161 if (not defined $self->{-pid}) {
162 $self->Subwidget('text')->insert('end',
163 "'" . $self->{-command} . "' : $!\n");
164 $self->kill_command;
165 return;
166 }
167 $h->autoflush(1);
168 $self->fileevent($h, 'readable' => [\&_read_stdout, $self]);
169
170 my $doit = $self->Subwidget('doit');
171 $doit->configure(
172 -text => 'Cancel',
173 -relief => 'raised',
174 -state => 'normal',
175 -command => [\&kill_command, $self],
176 );
177
178 my $doit_bg = ($doit->configure(-background))[3];
179 $self->_flash_doit(-background => $doit_bg, qw/cyan 500/);
180
181 $self->waitVariable(\$self->{-finish});
182 $self->kill_command;
183
184 } # end execute_command
185
186 sub get_status {
187
188 # Return a 2 element array of $? and $! from last command execution.
189
190 my($self) = @_;
191
192 my $stat = $self->{-status};
193 return (defined $stat ? @$stat : undef);
194
195 } # end get_status
196
197 sub kill_command {
198
199 # A click on the blinking Cancel button resumes normal operations.
200
201 my($self) = @_;
202
203 $self->{-finish} = 1;
204 $self->afterCancel($self->{-tid}) if defined $self->{-tid};
205 my $h = $self->{-handle};
206 if( defined $h ) {
207 $self->fileevent($h, 'readable' => '');
208 killfam 'TERM', $self->{-pid} if defined $self->{-pid};
209 close $h;
210 $self->{-status} = [$?, $!];
211 }
212 $self->_reset_doit_button;
213
214 } # end kill_command
215
216 sub terse_gui {
217
218 # Remove all but ROText widget. Currently, cannot be reversed.
219
220 my ($self) =@_;
221
222 my $n = 0;
223 foreach ($self->children) {
224 if (ref($_) eq 'Tk::Frame') {
225 $n++;
226 $_->packForget if $n <= 2;
227 } elsif (ref($_) eq 'Tk::Label') {
228 $_->packForget;
229 }
230 }
231
232 } # end terse_gui
233
234 1;
235
236 __END__
237
238 =head1 NAME
239
240 Tk::ExecuteCommand - execute a command asynchronously (non-blocking).
241
242 =for pm Tk/ExecuteCommand.pm
243
244 =for category Widgets
245
246 =head1 SYNOPSIS
247
248 $exec = $parent->ExecuteCommand;
249
250 =head1 DESCRIPTION
251
252 Tk::ExecuteCommand runs a command yet still allows Tk events to flow. All
253 command output and errors are displayed in a window.
254
255 This ExecuteCommand mega widget is composed of an LabEntry widget for
256 command entry, a "Do It" Button that initiates command execution, and
257 a ROText widget that collects command execution output.
258
259 While the command is executing, the "Do It" Button changes to a "Cancel"
260 Button that can prematurely kill the executing command. The B<kill_command>
261 method does the same thing programmatically.
262
263 The primary benefit of this widget is the ability to execute system commands
264 asynchronously without blocking Tk's event loop. The widget doesn't even
265 have to be managed (pack/grid), see the EXAMPLES section.
266
267 =head1 OPTIONS
268
269 =over 4
270
271 =item B<-command>
272
273 The command to execute asynchronously.
274
275 =item B<-entryWidth>
276
277 Character width of command Entry widget.
278
279 =item B<-height>
280
281 Character height of the ROText widget.
282
283 =item B<-label>
284
285 Label text for command Entry widget.
286
287 =item B<-text>
288
289 Label text for "Do It!" Button.
290
291 =item B<-width>
292
293 Character width of the ROText widget.
294
295 =back
296
297 =head1 METHODS
298
299 =over 4
300
301 =item $exec->execute_command;
302
303 Initiates command execution.
304
305 =item $exec->get_status;
306
307 Returns a 2 element array of $? and $! from last command execution.
308
309 =item $exec->kill_command;
310
311 Terminates the command. This subroutine is called automatically via an
312 OnDestroy handler when the ExecuteCommand widget goes away.
313
314 =item $exec->terse_gui;
315
316 packForgets all but the minimal ROText widget. Currently, this action
317 cannot be rescinded.
318
319 =back
320
321 =head1 ADVERISED SUBWIDGETS
322
323 Component subwidgets can be accessed via the B<Subwidget> method.
324 Valid subwidget names are listed below.
325
326 =over 4
327
328 =item Name: command, Class: LabEntry
329
330 Refers to the command LabEntry widget.
331
332 =item Name: doit, Class: Button
333
334 Refers to the command execution Button.
335
336 =item Name: spacer, Class: Frame
337
338 Refers to the spacer Frame separating the Entry and ROText widgets.
339
340 =item Name: label, Class: Label
341
342 Refers to the Label across the top of the ROText widget.
343
344 =item Name: text, Class: ROText
345
346 Refers to the ROText widget that collects command execution output.
347
348 =back
349
350 =head1 EXAMPLES
351
352 $ec = $mw->ExecuteCommand(
353 -command => '',
354 -entryWidth => 50,
355 -height => 10,
356 -label => '',
357 -text => 'Execute',
358 )->pack;
359 $ec->configure(-command => 'mtx -f /dev/sch0 load 1 0');
360 $ec->execute_command;
361 $ec->bell;
362 $ec->update;
363
364 =================================================================
365
366 # More complicated example to read AC temps via snmpget. The target
367 # air conditioner IPs have been changed to protect them ;)
368
369 #!/usr/local/bin/perl
370 use Tk;
371 use Tk::ExecuteCommand;
372 use subs qw/ init main read_acs sys /;
373 use strict;
374 use warnings;
375
376 # Globals.
377
378 my $ec; # ExecuteCommand widget
379 my @gauges; # list of AC NGauge widgets
380 my $interval; # interval between SNMP scans, seconds
381 my $mw; # MainWindow
382 my $snmp_liebert_temperature_actual; # temperature, actual reading
383 my $snmp_liebert_temperature_tolerance; # temperature, desired tolerance
384 my $snmp_liebert_temperature_setting; # temperature, desired setting
385 my $snmp_root; # snmpget/snmpset dirname
386 my $temp_tolerance_factor; # tolerance value * factor = degrees
387
388 init;
389 main;
390
391 sub init {
392
393 $mw = MainWindow->new;
394 $ec = $mw->ExecuteCommand;
395
396 $interval = 2;
397
398 $snmp_root = '/usr/bin';
399 $snmp_liebert_temperature_setting = '.1.3.6.1.4.1.476.1.42.3.4.1.2.1.0';
400 $snmp_liebert_temperature_tolerance = '.1.3.6.1.4.1.476.1.42.3.4.1.2.2.0';
401 $snmp_liebert_temperature_actual = '.1.3.6.1.4.1.476.1.42.3.4.1.2.3.1.3.1';
402
403 $gauges[0] = {-ac => 'some-ip-1'};
404 $gauges[1] = {-ac => 'some-ip-2'};
405
406 } # end init
407
408 sub main {
409
410 read_acs;
411 MainLoop;
412
413 } # end main
414
415 sub read_acs {
416
417 my( $stat, @temperature, @humidity );
418
419 foreach my $g ( @gauges ) {
420 my $ac_ip = $g->{ -ac } . '.some.domain.name';
421
422 ( $stat, @temperature ) = sys "$snmp_root/snmpget $ac_ip communityname $snmp_liebert_temperature_setting $snmp_liebert_temperature_tolerance $snmp_liebert_temperature_actual";
423 die "Cannot get temperature data for AC '$ac_ip': $stat." if $stat or $#temperature != 2;
424 print "stat=$stat, data=@temperature.\n";
425
426 } # forend all air conditioners
427
428 $mw->after( $interval * 1000 => \&read_acs );
429
430 } # end read_acs
431
432 sub sys {
433
434 # Execute a command asynchronously and return its status and output.
435
436 my $cmd = shift;
437
438 $ec->configure( -command => $cmd );
439 my $t = $ec->Subwidget( 'text' ); # ROText widget
440 $t->delete( '1.0' => 'end' );
441 $ec->execute_command;
442 return ($ec->get_status)[0], split /\n/, $t->get( '1.0' => 'end -1 chars' );
443
444 } # end sys
445
446 =head1 KEYWORDS
447
448 exec, command, fork, asynchronous, non-blocking, widget
449
450 =head1 COPYRIGHT
451
452 Copyright (C) 1999 - 2004 Stephen O. Lidie. All rights reserved.
453
454 This program is free software; you can redistribute it and/or modify it under
455 the same terms as Perl itself.
456
457 =cut