I recently tried to make a game server controller in Perl, I would like to start, stop and view the text that has been outputted by the game server, this is what I have so far:
#!/usr/bin/perl -w
use IO::Socket;
use Net::hostent; # for OO version of gethostbyaddr
$PORT = 9050; # pick something not in use
$server = IO::Socket::INET->new( Proto => 'tcp',
LocalPort => $PORT,
Listen => SOMAXCONN,
Reuse => 1);
die "can't setup server" unless $server;
print "[Server $0 accepting clients]\n";
while ($client = $server->accept()) {
$client->autoflush(1);
print $client "Welcome to $0; type help for command list.\n";
$hostinfo = gethostbyaddr($client->peeraddr);
printf "[Connect from %s]\n", $hostinfo->name || $client->peerhost;
print $client "Command? ";
while ( <$client>) {
next unless /\S/; # blank line
if (/quit|exit/i) {
last; }
elsif (/some|thing/i) {
printf $client "%s\n", scalar localtime; }
elsif (/start/i ) {
open RSPS, '|java -jar JARFILE.jar' or die "ERROR STARTING: $!\n";
print $client "I think it started...\n Say status for output\n"; }
elsif (/stop/i ) {
print RSPS "stop";
close(RSPS);
print $client "Should be closed.\n"; }
elsif (/status/i ) {
$output = <RSPS>;
print $client $output; }
else {
print $client "Hmmmm\n";
}
} continue {
print $client "Command? ";
}
close $client;
}
I am having trouble reading from the pipe, any ideas?
Thanks!
You are trying to do both reading and writing on the RSPS filehandle, though you have only opened it for writing (open RSPS, '|java -jar JARFILE.jar' means start the java process and use the RSPS filehandle to write to the standard input of the java process).
To read the output of the process, you will either need to write the process output to a file and open a separate filehandle to that file
open RSPS, '| java -jar JARFILE.jar > jarfile.out';
open PROC_OUTPUT, '<', 'jarfile.out';
or check out a module like IPC::Open3, which was made for applications like this.
use IPC::Open3;
# write to RSPS and read from PROC_OUTPUT and PROC_ERROR
open3(\*RSPS, \*PROC_OUTPUT, \*PROC_ERROR,
'java -jar JARFILE.jar');
Related
How can I find out the $code and $mess in HTTP::Daemon module? In cpan the usage is as
$c->send_status_line( $code, $mess, $proto )
but I dont know where/how to get $code, $mess from.
Like, send_error($code) is used as send_error(RC_FORBIDDEN) which I found from someone's code online, where did he get RC_FORBIDDEN from?
Have been playing with the following code. Sorry for the formatting and many thanks to #choroba for formatting it for me.
use warnings;
use strict;
use HTTP::Daemon;
use HTTP::Status;
use LWP;
my $daemon = HTTP::Daemon->new or die;
my $d = HTTP::Daemon->new(
LocalAddr => '0.0.0.0',
LocalPort => '5000',
);
printf ("\n\n URL of webserver is %s, show this script with %stest\n",
$d->url, $d->url);
while (my $client_connection = $d->accept)
{
new_connection($client_connection);
}
sub new_connection
{
my $client_connection = shift;
printf "new connection\n";
while (my $request = $client_connection->get_request)
{
if (my $pid = fork)
{
print "Child created : $pid\n";
}
elsif (!defined $pid)
{
die "Cannot fork $!\n";
}
else
{
my $address_of_client = $client_connection->peerhost();
my $port_of_client = $client_connection->peerport();
print "Connection from client $address_of_client on port
$port_of_client\n";
print " request\n";
if ($request->method eq 'GET' and $request->uri->path
eq "/test")
{
$client_connection->send_file_response(RC_OK);
#$client_connection->send_status_line(200);
#print "OK ";
#$client_connection->send_file_response($0);
}
else
{
$client_connection->send_error(RC_NOT_FOUND);
}
}
$client_connection->close;
}
}
The documentation also states
If $code is omitted 200 is assumed. If $mess is omitted, then a message corresponding to $code is inserted. If $proto is missing the content of the $HTTP::Daemon::PROTO variable is used.
So, you don't have to specify the arguments at all. Otherwise, just use any of the possible HTTP status codes for $code, and either don't specify the $mess to get the default message for the code, or use any message you like.
RC_FORBIDEN is exported from HTTP::Status.
I would like to execute external command rtmpdump and read it's STDOUT and STDERR separately, but not to wait till such command ends, but read its partial outputs in bulks, when available...
What is a safe way to do it in Perl?
This is a code I have that works "per-line" basis:
#!/usr/bin/perl
use warnings;
use strict;
use Symbol;
use IPC::Open3;
use IO::Select;
sub execute {
my($cmd) = #_;
print "[COMMAND]: $cmd\n";
my $pid = open3(my $in, my $out, my $err = gensym(), $cmd);
print "[PID]: $pid\n";
my $sel = new IO::Select;
$sel->add($out, $err);
while(my #fhs = $sel->can_read) {
foreach my $fh (#fhs) {
my $line = <$fh>;
unless(defined $line) {
$sel->remove($fh);
next;
}
if($fh == $out) {
print "[OUTPUT]: $line";
} elsif($fh == $err) {
print "[ERROR] : $line";
} else {
die "[ERROR]: This should never execute!";
}
}
}
waitpid($pid, 0);
}
But the above code works in text mode only, I believe. To use rtmpdump as a command, I need to collect partial outputs in binary mode, so do not read STDOUT line-by-line as it is in the above code.
Binary output of STDOUT should be stored in variable, not printed.
Using blocking functions (e.g. readline aka <>, read, etc) inside a select loop defies the use of select.
$sel->add($out, $err);
my %bufs;
while ($sel->count) {
for my $fh ($sel->can_read) {
my $rv = sysread($fh, $bufs{$fh}, 128*1024, length($bufs{$fh}));
if (!defined($rv)) {
# Error
die $! ;
}
if (!$rv) {
# Eof
$sel->remove($fh);
next;
}
if ($fh == $err) {
while ($bufs{$err} =~ s/^(.*\n)//) {
print "[ERROR] $1";
}
}
}
}
print "[ERROR] $bufs{$err}\n" if length($bufs{$err});
waitpid($pid, 0);
... do something with $bufs{$out} ...
But it would be much simpler to use IPC::Run.
use IPC::Run qw( run );
my ($out_buf, $err_buf);
run [ 'sh', '-c', $cmd ],
'>', \$out_buf,
'2>', sub {
$err_buf .= $_[0];
while ($err_buf =~ s/^(.*\n)//) {
print "[ERROR] $1";
}
};
print "[ERROR] $err_buf\n" if length($err_buf);
... do something with $out_buf ...
If you're on a POSIX system, try using Expect.pm. This is exactly the sort of problem it is designed to solve, and it also simplifies the task of sending keystrokes to the spawned process.
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.
Im trying to emulate a TCP Server on the same PC where the app is running.
I dont know if it can be done in Perl because im not very experienced.
With the code bellow the first reply is working but i dont know how to implement the second.
#!/usr/bin/perl -w
use IO::Socket::INET;
use strict;
my $socket = IO::Socket::INET->new('LocalPort' => '3000',
'Proto' => 'tcp',
'Listen' => SOMAXCONN)
or die "Can't create socket ($!)\n";
print "Server listening\n";
while (my $client = $socket->accept) {
my $name = gethostbyaddr($client->peeraddr, AF_INET);
my $port = $client->peerport;
while (<$client>) {
print "$_";
print $client "RESPONSE1";
}
close $client
or die "Can't close ($!)\n";
}
die "Can't accept socket ($!)\n";
EDIT: Thank you guys for the imput, i ended up with php done it and its working, yay!
Use Net::Server for the connection, and a variable in the sub to keep the current state ($state in this code); something like this:
package MyServer;
use base qw/Net::Server/;
use strict;
use warnings;
sub process_request {
my $self = shift;
my $state = 0;
while (<STDIN>) {
s/\r?\n$//; # like chomp but for crlf too
if ($state == 0 and $_ eq 'data1') {
print "> okay1\n";
$state++;
} elsif ($state == 1 and $_ eq 'data2') {
print "> okay2\n";
$state++;
} else {
last if $state == 2;
$state = 0;
}
}
}
my $port = shift || 3000;
MyServer->run( port => $port );
The example in the Net::Server POD suggests using an alarm to timeout connections, which might be appropriate here. The code above does the following:
$ nc localhost 3000
data1
> okay1
data2
> okay2
data3
$
And if you need to move to a forking / preforking / non-blocking / co-routine driven system, there's a Net::Server personality for that.
"ready to go" code:
package MyServer;
use base qw/Net::Server/;
use strict;
use warnings;
sub process_request {
my $self = shift;
my $state = 0;
$| = 1;
binmode *STDIN;
while (read(*STDIN, local $_, 3 )) {
if ($state == 0 and $_ eq "\x{de}\x{c0}\x{ad}") {
print "\x{c4}\x{1a}\x{20}\x{de}";
$state++;
} elsif ($state == 1 and $_ eq "\x{18}\x{c0}\x{0a}") {
print "\x{11}\x{01}\x{73}\x{93}";
$state++;
last;
}
}
}
my $port = shift || 3000;
MyServer->run( port => $port );
It seems to me process_request sub doesn't work correctly when a low port is set (in my situation, port 23). In particular only with low port, while parsing data input, the first request contains additional chars (but it's all ok with subsequent requests).
Have you a tips? Thank you
My OS is Archlinux with perl 5.14.2. I am just trying to write a little program to accomplish a remote comlile. The program just passes a C source file to the server. The server will call gcc to compile the C code and pass the compiler's message. The client can't receive the compiler's message. I have the message in the server.
There is the code:
#!/usr/bin/perl -w
# oj.pl --- alpha
use warnings;
use strict;
use IO::File;
use IO::Socket;
use constant MY_TRAN_PORT => 138000;
$| = 1;
my $tmpFileToBeCompiled = IO::File->new ("> tmpFile09090989.c") or die "Can't creat this file";
#if (defined $tmpFileToBeCompiled) {
# print $tmpFileToBeCompiled "argh"; # just for test!
#}
# $fihi->close;
my $port = shift || MY_TRAN_PORT;
my $sock_server = IO::Socket::INET->new (Listen => 20,
LocalPort => $port,
Timeout => 60,
Reuse => 1)
or die "Can't create listening socket: $!\n";
my $tmp = 1;
while ($tmp) {
next unless my $session = $sock_server->accept;
my $peer = gethostbyaddr ($session->peeraddr, AF_INET)
|| $session->peerhost;
warn "Connection from [$peer, $port]\n";
while (<$session>) {
print $tmpFileToBeCompiled $_; # if it works, the filehandle should be changed into tmpFile. just fixed.
print $session "test!";
}
my #lines = `gcc tmpFile09090989.c 2>&1`;
foreach ( #lines) {
print $session $_ . "test!!!\n";
# $session->print;
}
print "OK!";
$tmpFileToBeCompiled->close;
warn "Connecting finished!\n";
$session->close;
$tmp --;
}
$sock_server->close;
----------------------------------------end--------------------------------------------------------
-------------------------------------client.pl--------------------------------------------------------
use warnings;
use strict;
use IO::Socket qw(:DEFAULT);
use File::Copy;
use constant MY_TRAN_PORT => 138000;
use IO::File;
my $host = shift || '127.0.0.1';
my $port = shift || MY_TRAN_PORT;
my $socket = IO::Socket::INET->new("$host:$port") or die $#;
my $fh = IO::File->new("a.c", "r");
my $child = fork();
die "Can't fork: $!\n" unless defined $child;
# if (!$child) {
# $SIG{CHLD} = sub { exit 0 };
# userToHost();
# print "Run userToHost done!\n";
# $socket->shutdown(1);
# sleep;
# } else {
# hostToUser();
# print "Run hostToUser done! \n";
# warn "Connection closed by foreign host\n";
# }
userToHost();
unless ($child) {
hostToUser();
print "Run hostToUser done! \n";
warn "Connection closed by foreign host\n";
$socket->close;
}
sub userToHost {
while (<$fh>) {
# print $_; # for debug
print $socket $_;
}
}
sub hostToUser {
while (<$socket >) {
print $_;
}
}
# copy ("a.c", $socket) or die "Copy failed: $!";
print "Done!";
You don't need to fork in client. At all. Just like themel said
You have error in client code: <$socket > should be <$socket>
You need to notify server that you have written all data and server can start compilation. Otherwise server will stuck at while (<$session>) forever.
To achieve this you could call shutdown($socket, 1) which means you finished writing. See perldoc -f shutdown
Final prototype (very rough) could look like this: https://gist.github.com/19b589b8fc8072e3cfff
yko nailed it, but let me just suggest that your task will be solved in a much easier and more maintainable way by a shell script running from inetd.