¿Cómo puedo leer el resultado de comandos externos en tiempo real en Perl?
https://stackoverflow.com/questions/1236089
italiano
english
français
española
中国
日本の
العربية
Deutsch
한국어
Português
RussianPregunta
Tengo algunos scripts de bash que ejecuto, pero pueden tardar varias horas en finalizar, tiempo durante el cual arrojan velocidades de descarga, ETA e información similar.Necesito capturar esta información en Perl, pero tengo un problema: no puedo leer el resultado línea por línea (a menos que me falte algo).
¿Alguna ayuda para resolver esto?
EDITAR:Para explicar esto un poco mejor, estoy ejecutando varios scripts bash uno al lado del otro, deseo usar gtk con perl para producir barras de progreso útiles.Actualmente estoy ejecutando 2 subprocesos por cada script bash que deseo ejecutar, un subproceso maestro para actualizar la información gráfica.Se parece a esto (reduzca tanto como pueda):
my $command1 = threads->create(\&runCmd, './bash1', \@out1);
my $controll1 = threads->create(\&monitor, $command1, \@out1);
my $command1 = threads->create(\&runCmd, 'bash2', \@out2);
my $controll2 = threads->create(\&monitor, $command2, \@out2);
sub runCmd{
my $cmd = shift;
my @bso = shift;
@bso = `$cmd`
}
sub monitor{
my $thrd = shift;
my @bso = shift;
my $line;
while($thrd->is_running()){
while($line = shift(@bso)){
## I check the line and do things with it here
}
## update anything the script doesn't tell me here.
sleep 1;# don't cripple the system polling data.
}
## thread quit, so we remove the status bar and check if another script is in the queue, I'm omitting this here.
}
Solución
En lugar de hilos, y ``, use:
open my $fh, '-|', 'some_program --with-options';
De esta forma, abra varios manejadores de archivos (tantos programas que necesite ejecutar) y luego use IO::Select para sondear datos de ellos.
Ejemplo simplista.
Supongamos que tengo un script de shell que se ve así:
=> cat test.sh
#!/bin/bash
for i in $( seq 1 5 )
do
sleep 1
echo "from $$ : $( date )"
done
su salida podría verse así:
=> ./test.sh from 26513 : Fri Aug 7 08:48:06 CEST 2009 from 26513 : Fri Aug 7 08:48:07 CEST 2009 from 26513 : Fri Aug 7 08:48:08 CEST 2009 from 26513 : Fri Aug 7 08:48:09 CEST 2009 from 26513 : Fri Aug 7 08:48:10 CEST 2009
Ahora, escribamos un multi-test.pl:
#!/usr/bin/perl -w
use strict;
use IO::Select;
my $s = IO::Select->new();
for (1..2) {
open my $fh, '-|', './test.sh';
$s->add($fh);
}
while (my @readers = $s->can_read()) {
for my $fh (@readers) {
if (eof $fh) {
$s->remove($fh);
next;
}
my $l = <$fh>;
print $l;
}
}
Como puede ver, no hay horquillas ni hilos. Y así es como funciona:
=> time ./multi-test.pl from 28596 : Fri Aug 7 09:05:54 CEST 2009 from 28599 : Fri Aug 7 09:05:54 CEST 2009 from 28596 : Fri Aug 7 09:05:55 CEST 2009 from 28599 : Fri Aug 7 09:05:55 CEST 2009 from 28596 : Fri Aug 7 09:05:56 CEST 2009 from 28599 : Fri Aug 7 09:05:56 CEST 2009 from 28596 : Fri Aug 7 09:05:57 CEST 2009 from 28599 : Fri Aug 7 09:05:57 CEST 2009 from 28596 : Fri Aug 7 09:05:58 CEST 2009 from 28599 : Fri Aug 7 09:05:58 CEST 2009 real 0m5.128s user 0m0.060s sys 0m0.076s
Otros consejos
Los backticks y el operador qx // se bloquean hasta que finaliza el subproceso. Debe abrir los scripts de bash en una tubería. Si necesita que no se bloqueen, ábralos como identificadores de archivo, utilizando open2 o open3 si es necesario, luego coloque los identificadores en select () y espere a que sean legibles.
Acabo de encontrarme con un problema similar: tuve un proceso muy largo (un servicio que podría ejecutarse durante semanas) que abrí con un qx //. El problema era que la salida de este programa eventualmente excedió los límites de memoria (alrededor de 2.5G en mi arquitectura). Lo resolví abriendo el subcomando en una tubería y luego solo guardando las últimas 1000 líneas de salida. Al hacerlo, noté que el formulario qx // solo imprime el resultado una vez que se completó el comando, pero el formulario de tubería pudo imprimir el resultado tal como sucedió.
No tengo el código a mano, pero si puedes esperar hasta mañana, publicaré lo que hice.
Consulte el perlipc (comunicación entre procesos) para conocer varias cosas que puede hacer. Se abren los canales e IPC :: Open3 son útiles.
sí, puedes.
while (<STDIN>) { print "Line: $_"; }
El problema es que algunas aplicaciones no arrojan información línea por línea, sino que actualizan una línea hasta que finalizan. ¿Es tu caso?
Aquí está con el código GTK2 para mostrar las barras de progreso.
#!/usr/bin/perl
use strict;
use warnings;
use Glib qw/TRUE FALSE/;
use Gtk2 '-init';
my $window = Gtk2::Window->new('toplevel');
$window->set_resizable(TRUE);
$window->set_title("command runner");
my $vbox = Gtk2::VBox->new(FALSE, 5);
$vbox->set_border_width(10);
$window->add($vbox);
$vbox->show;
# Create a centering alignment object;
my $align = Gtk2::Alignment->new(0.5, 0.5, 0, 0);
$vbox->pack_start($align, FALSE, FALSE, 5);
$align->show;
# Create the Gtk2::ProgressBar and attach it to the window reference.
my $pbar = Gtk2::ProgressBar->new;
$window->{pbar} = $pbar;
$align->add($pbar);
$pbar->show;
# Add a button to exit the program.
my $runbutton = Gtk2::Button->new("Run");
$runbutton->signal_connect_swapped(clicked => \&runCommands, $window);
$vbox->pack_start($runbutton, FALSE, FALSE, 0);
# This makes it so the button is the default.
$runbutton->can_default(TRUE);
# This grabs this button to be the default button. Simply hitting the "Enter"
# key will cause this button to activate.
$runbutton->grab_default;
$runbutton->show;
# Add a button to exit the program.
my $closebutton = Gtk2::Button->new("Close");
$closebutton->signal_connect_swapped(clicked => sub { $_[0]->destroy;Gtk2->main_quit; }, $window);
$vbox->pack_start($closebutton, FALSE, FALSE, 0);
$closebutton->show;
$window->show;
Gtk2->main;
sub pbar_increment {
my ($pbar, $amount) = @_;
# Calculate the value of the progress bar using the
# value range set in the adjustment object
my $new_val = $pbar->get_fraction() + $amount;
$new_val = 0.0 if $new_val > 1.0;
# Set the new value
$pbar->set_fraction($new_val);
}
sub runCommands {
use IO::Select;
my $s = IO::Select->new();
for (1..2) {
open my $fh, '-|', './test.sh';
$s->add($fh);
}
while (my @readers = $s->can_read()) {
for my $fh (@readers) {
if (eof $fh) {
$s->remove($fh);
next;
}
my $l = <$fh>;
print $l;
pbar_increment($pbar, .25) if $l =~ /output/;
}
}
}
vea los documentos de GTK2 perl para más información
Utilizo esta subrutina y este método para registrar mis comandos externos. Se llama así:
open($logFileHandle, "mylogfile.log");
logProcess($logFileHandle, "ls -lsaF", 1, 0); #any system command works
close($logFileHandle);
y aquí están las subrutinas:
#******************************************************************************
# Sub-routine: logProcess()
# Author: Ron Savage
# Date: 10/31/2006
#
# Description:
# This sub-routine runs the command sent to it and writes all the output from
# the process to the log.
#******************************************************************************
sub logProcess
{
my $results;
my ( $logFileHandle, $cmd, $print_flag, $no_time_flag ) = @_;
my $logMsg;
my $debug = 0;
if ( $debug ) { logMsg($logFileHandle,"Opening command: [$cmd]", $print_flag, $no_time_flag); }
if ( open( $results, "$cmd |") )
{
while (<$results>)
{
chomp;
if ( $debug ) { logMsg($logFileHandle,"Reading from command: [$_]", $print_flag, $no_time_flag); }
logMsg($logFileHandle, $_, $print_flag, $no_time_flag);
}
if ( $debug ) { logMsg($logFileHandle,"closing command.", $print_flag, $no_time_flag); }
close($results);
}
else
{
logMsg($logFileHandle, "Couldn't open command: [$cmd].")
}
}
#******************************************************************************
# Sub-routine: logMsg()
# Author: Ron Savage
# Date: 10/31/2006
#
# Description:
# This sub-routine prints the msg and logs it to the log file during the
# install process.
#******************************************************************************
sub logMsg
{
my ( $logFileHandle, $msg, $print_flag, $time_flag ) = @_;
if ( !defined($print_flag) ) { $print_flag = 1; }
if ( !defined($time_flag) ) { $time_flag = 1; }
my $logMsg;
if ( $time_flag )
{ $logMsg = "[" . timeStamp() . "] $msg\n"; }
else
{ $logMsg = "$msg\n"; }
if ( defined($logFileHandle)) { print $logFileHandle $logMsg; }
if ( $print_flag ) { print $logMsg; }
}
La forma más sencilla de ejecutar un proceso hijo con control total sobre su entrada y salida es IPC::Open2 módulo (o IPC::Open3 si también desea capturar STDERR), pero el problema si desea tratar con varios a la vez, o especialmente si desea hacerlo en una GUI, es el bloqueo.Si solo haces un <$fh> escriba read, se bloqueará hasta que tenga una entrada, lo que podría bloquear toda su interfaz de usuario.Si el proceso hijo es interactivo, es aún peor porque se puede bloquear fácilmente, con el hijo y el padre esperando la entrada del otro.Puedes escribir el tuyo propio select bucle y realizar E/S sin bloqueo, pero realmente no vale la pena.Mi sugerencia sería utilizar POE, POE::Wheel::Run para interactuar con los procesos secundarios, y POE::Loop::Gtk para incluir POE en el bucle de ejecución GTK.
