How can I test STDIN without blocking in Perl? - perl

I'm writing my first Perl app -- an AOL Instant Messenger bot that talks to an Arduino microcontroller, which in turn controls a servo that will push the power button on our sysadmin's server, which freezes randomly every 28 hours or so.
I've gotten all the hard stuff done, I'm just trying to add one last bit of code to break the main loop and log out of AIM when the user types 'quit'.
The problem is, if I try to read from STDIN in the main program loop, it blocks the process until input is entered, essentially rendering the bot inactive. I've tried testing for EOF before reading, but no dice... EOF just always returns false.
Here's below is some sample code I'm working with:
while(1) {
$oscar->do_one_loop();
# Poll to see if any arduino data is coming in over serial port
my $char = $port->lookfor();
# If we get data from arduino, then print it
if ($char) {
print "" . $char ;
}
# reading STDIN blocks until input is received... AAARG!
my $a = <STDIN>;
print $a;
if($a eq "exit" || $a eq "quit" || $a eq 'c' || $a eq 'q') {last;}
}
print "Signing off... ";
$oscar->signoff();
print "Done\n";
print "Closing serial port... ";
$port->close() || warn "close failed";
print "Done\n";

The Perl built-in is select(), which is a pass-through to the select() system call, but for sane people I recommend IO::Select.
Code sample:
#!/usr/bin/perl
use IO::Select;
$s = IO::Select->new();
$s->add(\*STDIN);
while (++$i) {
print "Hiya $i!\n";
sleep(5);
if ($s->can_read(.5)) {
chomp($foo = <STDIN>);
print "Got '$foo' from STDIN\n";
}
}

I found that IO::Select works fine as long as STDOUT gets closed, such as when the upstream process in the pipeline exits, or input is from a file. However, if output is ongoing (such as from "tail -f") then any partial data buffered by <STDIN> will not be displayed. Instead, use the unbuffered sysread:
#!/usr/bin/perl
use IO::Select;
$s = IO::Select->new(\*STDIN);
while (++$i) {
if ($s->can_read(2)) {
last unless defined($foo=get_unbuf_line());
print "Got '$foo'\n";
}
}
sub get_unbuf_line {
my $line="";
while (sysread(STDIN, my $nextbyte, 1)) {
return $line if $nextbyte eq "\n";
$line .= $nextbyte;
}
return(undef);
}

Related

How to flush pipe handle obtained from open?

I am trying to flush a pipe handle obtained from open using either autoflush() and flush() methods from the IO::Handle module, but I think it is not working. Here is an example:
host.pl:
use feature qw(say);
use strict;
use warnings;
my $client_pid = open ( my $fh, '|-', 'client.pl' )
or die "Could not open client: $!";
#$fh->autoflush(1); # adding this line does not help
sleep 2;
say "Host: sent message";
print $fh "Hello";
#print $fh "Hello\n"; # adding a newline works fine
$fh->flush() or warn "$!"; # this does not work
sleep 2;
say "Host exits.";
close $fh;
client.pl:
use feature qw(say);
use strict;
use warnings;
say "Client running..";
chomp (my $line = <STDIN>);
say "Client got line: '$line'";
sleep 1;
say "Client exits..";
The output of running host.pl is:
Client running..
Host: sent message
Host exits.
Client got line: 'Hello'
Client exits..
Expected output would be:
Client running..
Host: sent message
Client got line: 'Hello'
Client exits..
Host exits.
I know I can fix this by adding a newline at the end of string to be printed:
print $fh "Hello\n";
but I am curious why $fh->flush() is not working here?
The data is being sent to the client immediately, but the client waits for a newline to arrive.
readline (for which <> is a shortcut in your program) reads until a newline is encountered before returning (although changing $/ can change that behaviour. If you want a call that returns as soon as data is available, use sysread.
use BLOCK_SIZE => 64*1024;
say "Client running..";
while (1) {
my $rv = sysread(\*STDIN, my $buf, BLOCK_SIZE);
die($!) if !defined($rv);
last if !$rv;
say "Got: $buf";
}
Note a single print can result in data being received in multiple chunks. In practice, especially with a socket instead of a pipe, you'd need some way of framing your messages in order to reliably identify them. For example, the following client expects sentinel-terminated messages (the sentinel being a newline):
use BLOCK_SIZE => 64*1024;
say "Client running..";
my $buf = '';
while (1) {
my $rv = sysread(\*STDIN, $buf, BLOCK_SIZE, length($buf));
die($!) if !defined($rv);
last if !$rv;
while ($buf =~ s/^([^\n]*)\n//) {
my $msg = $1;
say "Got: $msg";
}
say "Got a partial message" if length($buf);
}
die("Premature EOF\n") if length($buf);
Try sending:
$fh->autoflush();
print($fh "abc");
sleep(1);
print($fh "def\n");
sleep(1);
print($fh "ghi\njkl\nmno");
sleep(1);
print($fh "pqr\n");
This can be adapted to handle length-prefixed messages or any other message format.

Debug a Perl script

I already did some research on Perl script debugging but couldn't find what I was looking for.
Let me explain my problem here.
I have a Perl script which is not entering into last while loop it seems cos it is not printing anything inside as instructed.
So, I want to know is there any easier method available to see all lines one by one like we can see in shell script using
set -x
Here is my Perl script code
#!/usr/bin/perl -w
my $ZONEADM = "/usr/sbin/zoneadm list -c";
use strict;
use diagnostics;
use warnings;
system("clear");
print "Enter the app\n";
chomp(my $INS = <>);
print "\nEnter the Symmitrix ID\n";
chomp(my $SYMM = <>);
print "\nEnter the Server\n";
chomp(my $SRV = <>);
print "\nEnter the devices\n";
while (<>) {
if($_ !~ m/(q|quit)/) {
chomp($_);
my $TEMP_FILE = "/export/home/ptiwari/scripts/LOG.11";
open (my $FH, '>>', $TEMP_FILE);
my #arr = split(/:/, $_);
if($arr[3]) {
print $FH "/".$INS."db/".$arr[0]." ".$SYMM." ".$arr[1]." ".$arr[2]." ".$arr[3]."\n";
}
else {
print $FH "/".$INS."db/".$arr[0]." ".$SYMM." ".$arr[1]." ".$arr[2]."\n";
}
undef #arr;
close $FH;
}
else {
exit;
}
}
my $IS_ZONE = qx($ZONEADM|grep -i $SRV|grep -v global);
if($IS_ZONE) {
$IS_ZONE = "yes";
}
else {
$IS_ZONE = "no";
}
open(my $FLH, '<', "/export/home/ptiwari/scripts/LOG.11");
my #lines;
while(<$FLH>) {
my ($GLOBAL_MTPT, $SYM, $SYM_DEV, $SIZE, $NEWFS) = split;
print $GLOBAL_MTPT." ".$SYM." ".$SYM_DEV;
print "\n";
}
I already tried perl -d but it didn't show me anything which can help me to troubleshoot why it didn't enter the while loop.
Your while(<>) loop doesn't have sensible termination conditions. The /q|quit/ regex is buggy.
You exit the whole script if any line contains q or quit. You will also exit, if the device descriptions contains things like quill or acquisition. The effect of typing an accidental q is similar to a CtrlC.
The only way to finish the loop and go on with the script is to send an EOF. This requires the user to punch CtrlD into the keyboard, or a file to simply end. Then your script will continue.
There are some other things wrong/weird with this script.
Main criticism: (a) all-uppercase variables are informally reserved for Perl and pragmatic modules. Lowercase or mixed case variables work too. (b) Your script contains quite some redundant code. Either refactor it into subs, or rewrite your logic
Here is an example rewrite that may be easier to debug / may not contain some of the bugs.
#!/usr/bin/perl
use strict;
use warnings;
use diagnostics;
use constant DEBUG_FLAG => 1; # set to false value for release
my $zoneadm_command = "/usr/sbin/zoneadm list -c";
my $temp_file_name = "/export/home/ptiwari/scripts/LOG.11";
sub prompt { print "\n", $_[0], "\n"; my $answer = <>; chomp $answer; return $answer }
sub DEBUG { print STDERR "DEBUG> ", #_, "\n" if DEBUG_FLAG }
system("clear");
my $app_name = prompt("Enter the app");
my $symm_id = prompt("Enter the Symmitrix ID");
my $server = prompt("Enter the server name");
print "Enter the devices.\n";
print qq(\tTo terminate the script, type "q" or "quit".\n);
print qq(\tTo finish the list of devices, type Ctrl+D.\n);
open my $temp_file, ">>", $temp_file_name
or die "Can't open log file: $!";
while (<>) {
chomp; # remove trailing newline
exit if /^q(?:uit)?$/; # terminate the script if the input line *is* `q` or `quit`.
my #field = split /:/;
# grep: select all true values
#field = grep {$_} ("/${app_name}db/$field[0]", $symm_id, #field[1 .. 3]);
print $temp_file join(" ", #field), "\n";
}
close $temp_file;
DEBUG("finished the reading loop");
# get the zones with only *one* extra process
my #zones =
grep {not /global/}
grep {/\Q$server\E/i}
map {chomp; $_}
qx($zoneadm_command);
my $is_zone = #zones ? "yes" : "no";
DEBUG("Am I in the zone? $is_zone");
open my $device_file, "<", $temp_file_name or die "Can't open $temp_file_name: $!";
while (<$device_file>) {
chomp;
my ($global_mtpt, $sym, $sym_dev) = split;
print join(" ", $global_mtpt, $sym, $sym_dev), "\n";
# or short: print join(" ", (split)[0 .. 2]), "\n";
}
You need something like this for stepping into the script:
http://www.devshed.com/c/a/Perl/Using-The-Perl-Debugger/
You can really use the debugger: http://perldoc.perl.org/perldebug.html
But if your preference is to trace like bash -x, take a look at this discussion:
http://www.perlmonks.org/?node_id=419653
The Devel::Trace Perl module is designed to mimic sh -x tracing for shell programs.
Try to remove the "my $" from the last open statement and the "$" from there in the last while statement. Or better yet, try this:
open(my FLH, '<', "/export/home/ptiwari/scripts/LOG.11");
my #lines = <FLH>;
foreach (#lines) {
my ($GLOBAL_MTPT, $SYM, $SYM_DEV, $SIZE, $NEWFS) = split;
print $GLOBAL_MTPT." ".$SYM." ".$SYM_DEV;
print "\n";
}
Let me know about the results.

Perl cron job stays running

I'm currently using a cron job to have a perl script that tells my arduino to cycle my aquaponics system and all is well, except the perl script doesn't die as intended.
Here is my cron job:
*/15 * * * * /home/dburke/scripts/hal/bin/main.pl cycle
And below is my perl script:
#!/usr/bin/perl -w
# Sample Perl script to transmit number
# to Arduino then listen for the Arduino
# to echo it back
use strict;
use Device::SerialPort;
use Switch;
use Time::HiRes qw ( alarm );
$|++;
# Set up the serial port
# 19200, 81N on the USB ftdi driver
my $device = '/dev/arduino0';
# Tomoc has to use a different tty for testing
#$device = '/dev/ttyS0';
my $port = new Device::SerialPort ($device)
or die('Unable to open connection to device');;
$port->databits(8);
$port->baudrate(19200);
$port->parity("none");
$port->stopbits(1);
my $lastChoice = ' ';
my $signalOut;
my $args = shift(#ARGV);
# Parent must wait for child to exit before exiting itself on CTRL+C
if ($args eq "cycle") {
open (LOG, '>>log.txt');
print LOG "Cycle started.\n";
my $stop = 0;
sleep(2);
$SIG{ALRM} = sub {
print "Expecting plant bed to be full; please check.\n";
$signalOut = $port->write('2'); # Signal to set pin 3 low
print "Sent cmd: 2\n";
$stop = 1;
};
$signalOut = $port->write('1'); # Signal to arduino to set pin 3 High
print "Sent cmd: 1\n";
print "Waiting for plant bed to fill...\n";
print LOG "Alarm is being set.\n";
alarm (420);
print LOG "Alarm is set.\n";
while ($stop == 0) {
print LOG "In while-sleep loop.\n";
sleep(2);
}
print LOG "The loop has been escaped.\n";
die "Done.";
print LOG "No one should ever see this.";
}
else {
my $pid = fork();
$SIG{'INT'} = sub {
waitpid($pid,0) if $pid != 0; exit(0);
};
# What child process should do
if($pid == 0) {
# Poll to see if any data is coming in
print "\nListening...\n\n";
while (1) {
my $incmsg = $port->lookfor(9);
# If we get data, then print it
if ($incmsg) {
print "\nFrom arduino: " . $incmsg . "\n\n";
}
}
}
# What parent process should do
else {
sleep(1);
my $choice = ' ';
print "Please pick an option you'd like to use:\n";
while(1) {
print " [1] Cycle [2] Relay OFF [3] Relay ON [4] Config [$lastChoice]: ";
chomp($choice = <STDIN>);
switch ($choice) {
case /1/ {
$SIG{ALRM} = sub {
print "Expecting plant bed to be full; please check.\n";
$signalOut = $port->write('2'); # Signal to set pin 3 low
print "Sent cmd: 2\n";
};
$signalOut = $port->write('1'); # Signal to arduino to set pin 3 High
print "Sent cmd: 1\n";
print "Waiting for plant bed to fill...\n";
alarm (420);
$lastChoice = $choice;
}
case /2/ {
$signalOut = $port->write('2'); # Signal to set pin 3 low
print "Sent cmd: 2";
$lastChoice = $choice;
}
case /3/ {
$signalOut = $port->write('1'); # Signal to arduino to set pin 3 High
print "Sent cmd: 1";
$lastChoice = $choice;
}
case /4/ {
print "There is no configuration available yet. Please stab the developer.";
}
else { print "Please select a valid option.\n\n";}
}
}
}
}
When I run ps -ef I find the following output:
dburke 15294 15293 0 14:30 ? 00:00:00 /bin/sh -c /home/dburke/scripts/hal/bin/main.pl cycle
dburke 15295 15294 0 14:30 ? 00:00:00 /usr/bin/perl -w /home/dburke/scripts/hal/bin/main.pl cycle
Shouldn't there only be one process? Is it forking even though it received the cycle argument and the fork is outside of the cycle argument's if block?
Any idea why it wouldn't die from the statement die "Done.";? It runs fine from the command line and interprets the 'cycle' argument fine. When it runs in cron it runs fine, however, the process never dies and while each process doesn't continue to cycle the system it does seem to be looping in some way due to the fact that it ups my system load very quickly.
If you'd like more information, just ask. Thanks guys!
It looks as thought the issue was that my script originally encapsulated the cycle block inside of the fork which for some reason, unknown to me, was leaving a process open (possibly the child?). Taking the cycle block out of the fork has corrected the issue. Now it runs at the specified time and correctly dies after the cycle is complete leaving my cpu load for something more useful. :)
Thank you everyone who commented on my question. You suggestions helped me work through the issue.

Flushing Perl STDIN buffer

Is there any way to clear the STDIN buffer in Perl? A part of my program has lengthy output (enough time for someone to enter a few characters) and after that output I ask for input, but if characters were entered during the output, they are "tacked on" to whatever is entered at the input part. Here is an example of my problem:
for(my $n = 0; $n < 70000; $n++){
print $n . "\n";
}
chomp(my $input = <STDIN>);
print $input . "\n";
The output would include any characters entered during the output from that for loop. How could I either disable STDIN or flush the STDIN buffer (or any other way to not allow extra characters to be inserted into STDIN before calling it)?
It looks like you can accomplish this with the Term::ReadKey module:
#!perl
use strict;
use warnings;
use 5.010;
use Term::ReadKey;
say "I'm starting to sleep...";
ReadMode 2;
sleep(10);
ReadMode 3;
my $key;
while( defined( $key = ReadKey(-1) ) ) {}
ReadMode 0;
say "Enter something:";
chomp( my $input = <STDIN> );
say "You entered '$input'";
Here's what happens:
ReadMode 2 means "put the input mode into regular mode but turn off echo". This means that any keyboard banging that the user does while you're in your computationally-expensive code won't get echoed to the screen. It still gets entered into STDIN's buffer though, so...
ReadMode 3 turns STDIN into cbreak mode, meaning STDIN kind of gets flushed after every keypress. That's why...
while(defined($key = ReadKey(-1))) {} happens. This is flushing out the characters that the user entered during the computationally-expensive code. Then...
ReadMode 0 resets STDIN, and you can read from STDIN as if the user hadn't banged on the keyboard.
When I run this code and bang on the keyboard during the sleep(10), then enter some other text after the prompt, it only prints out the text I typed after the prompt appeared.
Strictly speaking the ReadMode 2 isn't needed, but I put it there so the screen doesn't get cluttered up with text when the user bangs on the keyboard.
I had the same problem and solved it by just discarding anything in STDIN after the processing like this:
for(my $n = 0; $n < 70000; $n++){
print $n . "\n";
}
my $foo=<STDIN>;
print "would you like to continue [y/n]: ";
chomp(my $input = <STDIN>);
print $input . "\n";
{ local $/; <STDIN> }
This temporarily - limited to scope of the block - sets $/, the input record seperator, to be undef, which tells perl to just read everything instead of reading a line at a time. Then reads everything available on STDIN and doesn't do anything with it, thus flushing the buffer.
After that, you can read STDIN as normal.

Perl: avoid greedy reading from stdin?

Consider the following perl script (read.pl):
my $line = <STDIN>;
print "Perl read: $line";
print "And here's what cat gets: ", `cat -`;
If this script is executed from the command line, it will get the first line of input, while cat gets everything else until the end of input (^D is pressed).
However, things are different when the input is piped from another process or read from a file:
$ echo "foo\nbar" | ./read.pl
Perl read: foo
And here's what cat gets:
Perl seems to greadily buffer the entire input somewhere, and processes called using backticks or system do no see any of the input.
The problem is that I'd like to unit test a script that mixes <STDIN> and calls to other processes. What would be the best way to do this? Can I turn off input buffering in perl? Or can I spool the data in a way that will "mimic" a terminal?
This is not a Perl problem. It is a UNIX/shell problem. When you run a command without pipes you are in line buffering mode, but when you redirect with pipes, you are in block buffering mode. You can see this by saying:
cat /usr/share/dict/words | ./read.pl | head
This C program has the same problem:
#include <stdio.h>
int main(int argc, char** argv) {
char line[4096];
FILE* cat;
fgets(line, 4096, stdin);
printf("C got: %s\ncat got:\n", line);
cat = popen("cat", "r");
while (fgets(line, 4096, cat)) {
printf("%s", line);
}
pclose(cat);
return 0;
}
I have good news and bad news.
The good news is a simple modification of read.pl allows you to give it fake input:
#! /usr/bin/perl
use warnings;
use strict;
binmode STDIN, "unix" or die "$0: binmode: $!";
my $line = <STDIN>;
print "Perl read: $line";
print "And here's what cat gets: ", `cat -`;
Sample run:
$ printf "A\nB\nC\nD\n" | ./read.pl
Perl read: A
And here's what cat gets: B
C
D
The bad news is you get a single switchover: if you try to repeat the read-then-cat, the first cat will starve all subsequent reads. To see this, consider
#! /usr/bin/perl
use warnings;
use strict;
binmode STDIN, "unix" or die "$0: binmode: $!";
my $line = <STDIN>;
print "1: Perl read: $line";
print "1: And here's what cat gets: ", `cat -`;
$line = <STDIN>;
$line = "<undefined>\n" unless defined $line;
print "2: Perl read: $line";
print "2: And here's what cat gets: ", `cat -`;
and then a sample run that produces
$ printf "A\nB\nC\nD\n" | ./read.pl
1: Perl read: A
1: And here's what cat gets: B
C
D
2: Perl read: <undefined>
2: And here's what cat gets:
Today I think I've found what I needed: Perl has a module called Expect which is perfect for such situations:
#!/usr/bin/perl
use strict;
use warnings;
use Expect;
my $exp = Expect->spawn('./read.pl');
$exp->send("First Line\n");
$exp->send("Second Line\n");
$exp->send("Third Line\n");
$exp->soft_close();
Works like a charm ;)
Here's a sub-optimal way that I've found:
use IPC::Run;
my $input = "First Line\n";
my $output;
my $process = IPC::Run::start(['./read.pl'], \$input, \$output);
$process->pump() until $output =~ /Perl read:/;
$input .= "Second Line\n";
$process->finish();
print $output;
It's sub-optimal in the sense that one needs to know the "prompt" that the program will emit before waiting for more input.
Another sub-optimal solution is the following:
use IPC::Run;
my $input = "First Line\n";
my $output;
my $process = IPC::Run::start(['./read.pl'], \$input, my $timer = IPC::Run::timer(1));
$process->pump() until $timer->is_expired();
$timer->start(1);
$input .= "Second Line\n";
$process->finish();
It does not require knowledge of any prompt, but is slow because it waits at least two seconds. Also, I don't understand why the second timer is needed (finish won't return otherwise).
Does anybody know better solutions?
Finally I ended up with the following solution. Still far from optimal, but it works. Even in situations like the one described by gbacon.
use Carp qw( confess );
use IPC::Run;
use Scalar::Util;
use Time::HiRes;
# Invokes the given program with the given input and argv, and returns stdout/stderr.
#
# The first argument provided is the input for the program. It is an arrayref
# containing one or more of the following:
#
# * A scalar is simply passed to the program as stdin
#
# * An arrayref in the form [ "prompt", "input" ] causes the function to wait
# until the program prints "prompt", then spools "input" to its stdin
#
# * An arrayref in the form [ 0.3, "input" ] waits 0.3 seconds, then spools
# "input" to the program's stdin
sub capture_with_input {
my ($program, $inputs, #argv) = #_;
my ($stdout, $stderr);
my $stdin = '';
my $process = IPC::Run::start( [$program, #argv], \$stdin, \$stdout, \$stderr );
foreach my $input (#$inputs) {
if (ref($input) eq '') {
$stdin .= $input;
}
elsif (ref($input) eq 'ARRAY') {
(scalar #$input == 2) or
confess "Input to capture_with_input must be of the form ['prompt', 'input'] or [timeout, 'input']!";
my ($prompt_or_timeout, $text) = #$input;
if (Scalar::Util::looks_like_number($prompt_or_timeout)) {
my $start_time = [ Time::HiRes::gettimeofday ];
$process->pump_nb() while (Time::HiRes::tv_interval($start_time) < $prompt_or_timeout);
}
else {
$prompt_or_timeout = quotemeta $prompt_or_timeout;
$process->pump until $stdout =~ m/$prompt_or_timeout/gc;
}
$stdin .= $text;
}
else {
confess "Unknown input type passed to capture_with_input!";
}
}
$process->finish();
return ($stdout, $stderr);
}
my $input = [
"First Line\n",
["Perl read:", "Second Line\n"],
[0.5, "Third Line\n"],
];
print "Executing process...\n";
my ($stdout, $stderr) = capture_with_input('./read.pl', $input);
print "done.\n";
print "STDOUT:\n", $stdout;
print "STDERR:\n", $stderr;
Usage example (with a slightly modified read.pl to test gbacon's case):
$ time ./spool_read4.pl
Executing process...
done.
STDOUT:
Perl read: First Line
And here's what head -n1 gets: Second Line
Perl read again: Third Line
STDERR:
./spool_read4.pl 0.54s user 0.02s system 102% cpu 0.547 total
Still, I'm open to better solutions...