Term::ReadKey, non-blocking read in raw mode: Detect EOF? - perl

When I pipe stuff into my program, it does not seem to get any character like 0x4 to indicate EOF.
$ echo "abc" | map 'cat'
saw a: \x61
saw b: \x62
saw c: \x63
saw
: \x0A
zzzbc
^C
I have to press Ctrl+C to quit, but I'm not really sure what the Ctrl+C is acting on. It's probably having the shell send a SIGINT to the pipeline? I don't know how pipelines work on that level.
Here is my program map:
#!/usr/bin/env perl
use strict;
use warnings;
use IO::Pty::Easy;
use Term::ReadKey;
use Encode;
$#ARGV % 2 and die "Odd number of args required.\n";
if ($#ARGV == -1) {
warn ("No args provided. A command must be specified.\n");
exit 1;
}
# be sure to enter the command as a string
my %mapping = #ARGV[-#ARGV..-2];
my $interactive = -t STDIN;
# my %mapping = #ARGV;
# my #mapkeys = keys %mapping;
# warn #mapkeys;
if ($interactive) {
print "Spawning command in pty: #ARGV\n"
# print "\nContinue? (y/n)";
# my $y_n;
# while (($y_n = <STDIN>) !~ /^(y|n)$/) {
# print '(y/n)';
# }
# exit if $y_n eq "n\n";
}
my $pty = IO::Pty::Easy->new();
my $spawnret = $pty->spawn("#ARGV")."\n";
print STDERR "Spawning has failed: #ARGV\n" if !$spawnret;
ReadMode 4;
END {
ReadMode 0; # Reset tty mode before exiting
}
my $i = undef;
my $j = 0;
{
local $| = 1;
while (1) {
myread();
# responsive to key input, and pty output may be behind by 50ms
my $key = ReadKey(0.05);
# last if !defined($key) || !$key;
if (defined($key)) {
my $code = ord($key); # this byte is...
if ($interactive and $code == 4) {
# User types Ctrl+D
print STDERR "Saw ^D from term, embarking on filicide with TERM signal\n";
$pty->kill("TERM", 0); # blocks till death of child
myread();
$pty->close();
last;
}
printf("saw %s: \\x%02X\n", $key, $code);
# echo translated input to pty
if ($key eq "a") {
$pty->write("zzz"); # print 'Saw "a", wrote "zzz" to pty';
} else {
$pty->write($key); # print "Wrote to pty: $key";
}
}
}
}
sub myread {
# read out pty's activity to echo to stdout
my $from_pty = $pty->read(0);
if (defined($from_pty)) {
if ($from_pty) {
# print "read from pty -->$from_pty<--\n";
print $from_pty;
} else {
if ($from_pty eq '') {
# empty means EOF means pty has exited, so I exit because my fate is sealed
print STDERR "Got back from pty EOF, quitting\n" if $interactive;
$pty->close();
last;
}
}
}
}
That would explain why it produced "zzzbc".
Now my question is how can I get map to be able to know about echo "abc" having reached the end of input? cf. echo "abc" | cat completes on its own. ReadKey does not seem to provide API for determining this situation.
Similarly I am not sure how to do the same to pass along the EOF to the child in the pty. I am thinking this might cause issues when a command is to write to a file or something, because EOF vs sending a kill signal is the difference between writing the file correctly and not exiting cleanly.

Try reading from STDIN and not that $pty object. The pipe you create via the shell passes the data to your STDIN file descriptor 0, which in perl is your handle .
The $pty, I assume that's your terminal. That's why the script just hangs (I guess).

Related

Reading and Concat'ing lines until specific value found in Perl

Morning SO,
I'm working on redesigning a Perl script designed by an external software vendor. It uses Perl, which I've never written in before. Basically all it does is read a line in, and then send a syslog packet to the a destination host containing that line. I need to modify it so Perl will keep reading and concat'ing until it reaches "". The problem is, it loops on the first line of a given file, and therefore never reaches the send stage. Any guidance on this? I went back and read the original script again, and it doesn't look to have a mechanism for iterating through each line.
Edit: OK - so apparently I've gone stupid and can't understand basic iterative logic. Fixed the looping problem, now to fix the syslog sending problem. It reads the data in correctly, but never executes the syslog send request, which implies it's not getting into the if statements.
Program should eventually enter here: if($lineRead eq $check){//do something;}
#!/usr/bin/perl -w
use strict;
use warnings;
use lib qw(.);
use lib qw(<removed>);
use Syslog;
use Time::HiRes qw( time sleep usleep );
use Getopt::Std;
# create log entries at a fixed rate (n per sec)
# Option defautls
my $me = $0;
$me =~ s|.*/||;
my %options = (
d => "127.0.0.1", # host
p => 514, # port
f => "readme.syslog", # filename
b => 0, # burst
v => 0, # verbose
t => 0, # tcp vs. udp
l => 0, # loop option
# u => "127.0.0.2", # new IP to send
);
my $theProto='tcp';
# Help
sub HELP_MESSAGE {
print <<EOF;
$me [-d <host>] [-p <port>] [-f filename] [-u <IP>] [-l] [-t] [-b] [-n NAME] [-v] <messages per second>
Options:
-d : destination syslog host (default 127.0.0.1)
-p : destination port (default 514)
-f : filename to read (default readme.syslog)
-b : burst the same message for 20% of the delay time
-t : use TCP instead of UDP for sending syslogs
-v : verbose, display lines read in from file
-n : use NAME for object name in syslog header
-l : loop indefinately
-u : use this IP as spoofed sender (default is NOT to send IP header)
EOF
}
getopts('vbtlu:d:p:n:f:', \%options);
unless (#ARGV) {
print STDERR "Need an event rate.\n";
HELP_MESSAGE;
exit 1;
}
my $nmsg = shift #ARGV;
if (!($nmsg =~ /^\d+$/)) {
print "Invalid number of messages per second.\n";
HELP_MESSAGE;
exit 1;
}
if ($options{t}) { $theProto='tcp'; }
my $syslog = new Syslog(
name => $options{n}, # prog name for syslog header
facility => 'local6',
priority => 'info',
loghost => $options{d},
port => $options{p},
proto => $theProto,
);
sub doitall() { # for purpose of infinate looping
open(F,$options{f}) or die("Unable to open file: $options{f}\n");
print STDERR "generating $nmsg messages per second to $options{d}:$options{p}\n";
print STDERR "Ctrl-c to stop\n";
# delay in milliseconds
my $delay = 1.0/$nmsg;
my $resolution = 0.2;
my $burst = $nmsg * $resolution;
my $check = "</Event>";
my $lineRead;
my $payload="a";
if ($options{b}) {
print "Sending $burst messages every ", int ($delay * 1000), "ms\n";
}
while (<F>) {
#print $lineRead;
if ($options{v}) {
print "Read in: $_\n";
}
$lineRead=$_;
if($lineRead eq $check){
$payload = join $payload, $lineRead;
if ($options{b}) {
for (my $i = 0 ; $i < $burst; $i++) {
if ($options{u}) { print $payload; $syslog->send($payload, host=> $options{u}); }
else { print $payload; $syslog->send($payload); }
}
} else {
if ($options{u}) { print $payload; $syslog->send($payload, host=> $options{u}); }
else { print $payload; $syslog->send($payload); }
}
if ($delay > 0) {
if ($options{v}) {
print "waiting for ", int($delay * 1000), "ms ...\n";
}
usleep (1000000*$delay);
}
$lineRead = "a";
$payload = "a";
}
else{
$payload = join $payload, $lineRead;
}
}
close(F);
} # end of the subroutine
if ($options{l}) {
while (1) { doitall(); }
} else { doitall(); }
exit 0;

Perl : CRTL C ignored when calling subroutine instead of exiting

So the script is something like this:
use strict;
use warnings;
use Term::ReadLine;
$SIG{'INT'} = 'INT_handler';
sub INT_handler {
print "[+] Abording\n";
home();
}
my $term = Term::ReadLine->new('Simple Perl calc');
sub home {
my $prompt = "\$> ";
my $OUT = $term->OUT || \*STDOUT;
while ( defined ($_ = $term->readline($prompt)) ) {
my $com = $_;
print $com."\n";
if ($com eq 'exit') {
exit;
}
option(); # another subroutine when the input is transferred to
}
}
home();
what I get:
$>
[+] Abording
$> # I pushed CRTL C but nothing shows
$> # same here
What I want to achieve is to be able to go to home() without exiting, and keep the $SIG{'INT'} working.
I have tried some other methods ( labels, using if statement ), but it will take too long cause the input is used in long processes
You should not call home() in your signal handler.
Just set a flag that you check in your input loop. When $term->readline() returns, because it was interrupted by CTRL-C, check that the flag was set, reset it and continue to loop.
Here is your updated code:
#!/usr/bin/perl
use strict;
use warnings;
use Term::ReadLine;
$SIG{'INT'} = 'INT_handler';
my $interrupted;
sub INT_handler {
$interrupted++;
}
my $term = Term::ReadLine->new('Simple Perl calc');
sub home {
my $prompt = "\$> ";
my $OUT = $term->OUT || \*STDOUT;
while ( defined ($_ = $term->readline($prompt)) || $interrupted ) {
if ($interrupted) {
$interrupted = 0;
print "\n[+] Aborting\n";
next;
}
my $com = $_;
print $com."\n";
if ($com eq 'exit') {
exit;
}
}
}
home();
exit 0;
Test output:
$ perl dummy.pl
$> test
test
$> ^C
[+] Aborting
$> ^C
[+] Aborting
$> sdasd^C
[+] Aborting
$> exit
exit
NOTE: there seems to be one issue still: you need to press return to get the prompt back. Probably something to do with how Term::Readline works.

Reading from Perl pipe child process hanging on last element of handle array

When running the following code, the last server is not printed - the script 'hangs' after the second-last array element.
my %readers;
my $command = "pgrep -f weblogic.Name";
foreach my $server(#servers) {
pipe($readers{$server},WRITER);
unless(my $pid = fork()) {
my $response = qx(ssh -q oracle\#$server "$command");
print WRITER $response;
exit();
}
}
foreach my $server (#servers) {
my $fh = $readers{$server};
my #procs = <$fh>;
chomp(#procs);
for my $proc (#procs) {
printf "%s\t%s\n", substr($server,8), $proc;
}
}
print "end\n";
The output is as follows:
$ ./get_stuck.pl
92 18196
93 27420
94 17635
95 10258
96 10831
There should be a server '97' output after '96', yet there is not, and the script just hangs/stops at that point.
If I change the reader section to use a string instead of an array as follows:
foreach my $server (#servers) {
my $fh = $readers{$server};
my $procs = <$fh>;
printf "%s\n", $server;
}
...then the script prints all servers including '97', however, if there are multiple results from the command, this will only print the first result (seems to break on newline). In other words, if the command returns 3 process ids for a given server, only the first process id is printed.
Any suggestions on why using an array causes the script to hang on the last element? Or perhaps (less desirable) how I might use a string, but retrieve all results?
I haven't actually tried it, but:
This code looks like you're deadlocking yourself.
< > in list context slurps the whole file, i.e. it reads until it reaches end-of-file (EOF).
The file handle in question refers to a pipe.
The read end of a pipe reaches EOF when all open handles to the write end are closed.
You never close WRITER in the parent (the child implicitly closes it on exit).
Thus the parent is stuck reading from the pipe while holding the write end open.
The reason this only happens for the last array element is because you're using a bareword filehandle (WRITER), which is effectively a global variable. Re-opening the same handle implicitly closes it first; i.e. the (n+1)th iteration of the loop closes the nth pipe. Only the last WRITER is left open.
If I'm right, then the fix is:
foreach my $server(#servers) {
pipe($readers{$server},WRITER);
unless(my $pid = fork()) {
my $response = qx(ssh -q oracle\#$server "$command");
print WRITER $response;
exit();
}
close WRITER; # always close WRITER in the parent
}
But I would also recommend changing the code to this:
foreach my $server (#servers) {
pipe($readers{$server}, my $WRITER);
defined(my $pid = fork()) or die "$0: fork: $!\n";
unless($pid) {
my $response = qx(ssh -q oracle\#$server "$command");
print $WRITER $response;
exit();
}
close $WRITER;
}
I.e. check fork for errors and use a lexical variable instead of a bareword filehandle. In this case the close is actually optional because $WRITER is implicitly closed at the end of its scope (the current loop iteration) because there are no other references to it.
You could simplify it a bit more by using pipe open:
foreach my $server (#servers) {
open $readers{$server}, '-|', 'ssh', '-q', "oracle\#$server", $command
or die "$0: ssh: $!\n";
}
Finally,
my $fh = $readers{$server};
my #procs = <$fh>;
could be reduced to
my #proces = readline $readers{$server};
(I don't like the < > operator. In my opinion always writing either readline or glob explicitly makes it more readable.)

Perl script is not kill tcl process

I have a perl script. It's not killing my tcl process. Here is what my process looks like:
UID 14439 10897 0 13:55:44 pts/26 0:00 /prod/bin/wish /prod/bin/q
Here is my perl script:
#!/usr/bin/env perl
#
# Simple kill script that allows users to kill specific processes
# using sudo
use BPub::Platform qw(solaris);
# Assume a taint mode type environment
$ENV{PATH} = '/opt/csw/bin:/usr/bin:/bin';
use strict;
use Getopt::Long;
if (!#ARGV) {
print "Usage: bkill [-9] pid <pid...>\n";
exit 1;
}
my $dashnine;
GetOptions('9' => \$dashnine);
# If the process name isn't in this hash, then you don't get to kill
# it
my %allowed_process_names = (
'dtsession' => 1,
'wish' => 1,
'compose' => 1,
);
# True if the given process name is one that we can kill
sub allowed_to_kill {
return $allowed_process_names{$_[0]};
}
# Takes a pid and returns the process name
sub process_name {
my ($pid) = #_;
my $out = `/usr/ucb/ps -c $pid | /bin/grep $pid | /bin/cut -b 25-1000`;
if ($?) {
print "Error running ps command: $!\n";
exit 2;
}
chomp($out);
return $out;
}
foreach my $pid (#ARGV) {
# tainted, remember?
if ($pid =~ /^(\d+)$/) {
my $safe_pid = $1;
my $name = process_name($safe_pid);
if (allowed_to_kill($name)) {
my #cmd = "/usr/bin/kill";
push (#cmd, '-9') if $dashnine;
push #cmd, $pid;
print "#cmd\n";
print "Killing $name ($pid)\n";
system(#cmd);
} else {
print "Not allowed to kill $safe_pid: $name.\n";
}
} else {
print "Invalid pid: must be a number: $pid\n";
}
}
When I run the script using sudo bkill PID. I get an error message saying:
bpub-xserver7-prod^UID118-> sudo bkill 14439
Password:
Not allowed to kill 14439: wish8.0.
Is there somethings that i can better in this script? How can i fix this problem that i am having getting rid of tcl process.
The program name your error message is emitting is wish8.0. So the simplest fix (and most strict) is to add 'wish8.0' => 1 to %allowed_process_names.
Or you could make your search less strict by doing something like:
my #allowed_process_names = qw(dtsession wish compose)
sub allowed_to_kill {
return scalar grep { index($_[0], $_) == 0 } #allowed_process_names
}
Which will find any string that starts with any of the allowed process names. (change to >= 0 or != -1 to allow it to match anywhere)
You could also use a regular expression instead. The following ones will match any program that starts with the provided program names. If you remove the leading caret, it would instead match them anywhere in the string.
my $allowed_process_names = qr/^(?:dtsession|wish|compose)/;
sub allowed_to_kill {
return $_[0] =~ /$allowed_process_names/;
}
or if you want to build up the regular expression programmatically:
my #allowed_process_names = qw(dtsession wish compose)
my $allowed_process_names = join('|', map quotemeta, #allowed_process_names);
$allowed_process_names = qr/^(?:$allowed_process_names)/;
# If the process name isn't in this hash, then you don't get to kill
# it
my %allowed_process_names = (
'dtsession' => 1,
'wish' => 1,
'compose' => 1,
);
...
my $out = `/usr/ucb/ps -c $pid | /bin/grep $pid | /bin/cut -b 25-1000`;
...
Not allowed to kill 14439: wish8.0.
Your ps pipeline is identifying the process as wish8.0 instead of wish or /prod/bin/wish. You will need to add an entry for "wish8.0" to this %allowed_process_names hash in order to use this perl script to kill this process.
If you were to look at /prod/bin/wish, you might find that it's a symbolic link to a file named wish8.0.

Show bash script output in live on perl - curses script

I'm a newb' on Perl, and try to do a simple script's launcher in Perl with Curses (Curses::UI)
On Stackoverflow I found a solution to print (in Perl) in real time the output of a Bash script.
But I can't do this with my Curses script, to write this output in a TextEditor field.
For example, the Perl script :
#!/usr/bin/perl -w
use strict;
use Curses::UI;
use Curses::Widgets;
use IO::Select;
my $cui = new Curses::UI( -color_support => 1 );
[...]
my $process_tracking = $container_middle_right->add(
"text", "TextEditor",
-readonly => 1,
-text => "",
);
sub launch_and_read()
{
my $s = IO::Select->new();
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>;
$process_tracking->text( $l );
my $actual_text = $process_tracking->text() . "\n";
my $new_text = $actual_text . $l;
$process_tracking->text( $new_text );
$process_tracking->cursor_to_end();
}
}
}
[...]
$cui->mainloop();
This script contains a button to launch launch_and_read().
And the test.sh :
#!/bin/bash
for i in $( seq 1 5 )
do
sleep 1
echo "from $$ : $( date )"
done
The result is my application freeze while the bash script is executed, and the final output is wrote on my TextEditor field at the end.
Is there a solution to show in real time what's happened in the Shell script, without blocking the Perl script ?
Many thanks, and sorry if this question seems to be stupid :x
You can't block. Curses's loop needs to run to process events. So you must poll. select with a timeout of zero can be used to poll.
my $sel;
sub launch_child {
$sel = IO::Select->new();
open my $fh, '-|', './test.sh';
$sel->add($fh);
}
sub read_from_child {
if (my #readers = $sel->can_read(0)) {
for my $fh (#readers) {
my $rv = sysread($fh, my $buf, 64*1024);
if (!$rv) {
$sel->remove($fh);
close($fh);
next;
}
... add contents of $buf to the ui here ...
}
}
}
launch_child();
$cui->set_timer(read_from_child => \&read_from_child, 1);
$cui->mainloop();
Untested.
Note that I switched from readline (<>) to sysread since the former blocks until a newline is received. Using blocking calls like read or readline defies the point of using select. Furthermore, using buffering calls like read or readline can cause select to say nothing is waiting when there actually is. Never use read and readline with select.