Net::OpenSSH; rsync_put writes progress into file, scp_put doesn't - perl

rysnc_put and scp_put both show the progress in the terminal.
But when i try to write it into a file i can only see the progress from rysnc_put. The problem remains even if i just print the output from the pty [my edit].
Is this a problem with my pty usage?
It is only mentioned for scp_put, that there is no progress when the STDOUT is not a tty.
Note that scp will not generate progress reports unless its stdout stream is attached to a tty.
#!/usr/bin/perl
use strict;
use warnings;
use Net::OpenSSH;
my $SSH = Net::OpenSSH->new(
'192.168.178.33',
(
user => 'TT',
password => 'TTpassword',
port => '22',
)
);
my $pty = new IO::Pty;
my $slave = $pty->slave;
$SSH->scp_put(
{
quiet => 0,
verbose => 1,
stdout_fh => $pty,
stderr_fh => $pty,
bwlimit => '200',
},
'/opt/TT/CHANGES.md',
'/opt/TT/CHANGES.md',,
);
while (<$pty>) {
print STDOUT "$_";
}

Another solution to your problem is to customize the pure perl implementation of the SCP protocol available from Net::SSH::Any.
I designed the SCP classes from that package to be subclassed so that things like that could be done but never went to actually document that API, so, well, you would be relying on undocumented features (though, I don't plan to change it).
use strict;
use warnings;
package MyPutter {
use parent 'Net::SSH::Any::SCP::Putter::Standard';
use Data::Dumper qw(Dumper);
for my $name (qw(open_dir open_file close_file close_dir)) {
my $method = $name;
my $super = Net::SSH::Any::SCP::Putter::Standard->can($name);
no strict 'refs';
*$name = sub {
my ($putter, $a) = #_;
print STDERR "$method $a->{path} --> $a->{local_path}\n";
$super->(#_);
};
}
sub read_file {
my $putter = shift;
my $a = shift;
my $data = $putter->SUPER::read_file($a, #_);
$a->{bytes_copied} += length($data);
print STDERR "read_file $a->{path} --> $a->{local_path} $a->{bytes_copied}/$a->{size}\n";
return $data;
}
};
use Net::OpenSSH;
my $ssh = Net::OpenSSH->new("localhost");
my $any = $ssh->any;
my $putter = MyPutter->_new($any, {}, "/tmp/out2", "/tmp/passwd3");
$putter->run({})

Even if scp_put and rsync_put are similar methods, they wrap two unrelated programs (scp and rsync) which regarding that matter, do not behave in the same way.
Specifically, scp checks whether its stdio streams are attached to a pty and when not, it suppresses progress messages. AFAIK that feature can not be disabled.
Update: Reading from the PTY in parallel:
This code reads from the PTY and writes the data to a file in parallel:
use strict;
use warnings;
use Net::OpenSSH;
use POSIX ();
use IO::Pty;
my $ssh = Net::OpenSSH->new("localhost"); #, scp_cmd => "/home/salva/t/openssh-8.9p1/scp");
my $pty = new IO::Pty;
my $slave = $pty->slave;
print "slave: $slave, fd: ".fileno($slave)."\n";
my $logger_pid = fork;
unless ($logger_pid) {
defined $logger_pid or die "fork failed: $!";
open my $log, ">", "/tmp/scp.log";
select $log;
$| = 1;
print("Reading from PTY\n");
while (1) {
my $buffer;
sysread($pty, $buffer, 1);
syswrite($log, $buffer, 1);
}
print "PTY closed unexpectedly\n";
POSIX::_exit();
}
my $scp_pid = fork;
unless($scp_pid) {
defined $scp_pid or die "fork failed: $!";
$pty->make_slave_controlling_terminal();
$ssh->scp_put({stdout_fh => $slave,
stderr_fh => $slave,
quiet => 0},
"/etc/passwd", "/tmp/foo.vdi");
}
waitpid($scp_pid, 0);
kill 9, $logger_pid;
waitpid($logger_pid, 0);

Related

Perl: Using IPC::Shareable for pooling Net::Server connections

I am trying to have a pool of shared connections that can be accessed by Net::Server instances. Unfortunately IPC::Shareable does not allow me to store the connections as they are code references. This is a stripped down version of the code:
use IPC::Shareable (':lock');
use parent 'Net::Server::Fork';
use MyConnectClass;
sub login {
return MyConnectClass->new();
};
my %connection;
tie %connection, 'IPC::Shareable', 'CONN', {
'create' => 1,
'exclusive' => 0,
'mode' => 0666,
'destroy' => 'yes',
}
or croak 'Can not tie connection variable';
sub add_connection {
my $id = shift(#_);
my $con = shift(#_);
$connection{$id} = $con;
};
sub get_connection {
my $id = # .. find unused connection
return $connection{$id};
}
sub process_request {
my $self = shift(#_);
eval {
my $connection = get_connection();
my $line = <STDIN>;
# .. use $connection to fetch data for user
};
};
for (my $i=0; $i<10; $i++) {
add_connection($i, &login);
};
main->run(
'host' => '*',
'port' => 7000,
'ipv' => '*',
'max_server' => 3,
};
Unfortunately the program dies after the first login: 'Can't store CODE items at ../../lib/Storable.pm'. This happens even when hiding $connection in an anonymous array. I am looking for an alternative to utilize the pool.
I appreciate your support
I am unable to propose an alternative module, but make a suggestion which may or not be of use. While you cannot store CODE, you can store strings which can be evaluated to run. would it be possible to pass a reference to the string q!&login! which you can dereference call after being assigned to $connection. ?
#!/usr/bin/perl
use warnings;
use strict;
use Storable;
my $codestring = q'sub { q^japh^ };' ;
#my $codestring = q'sub { return MyConnectClass->new(); }';
#
# for (0..9){ add_connection($i, $codestring) }
open my $file, '>', '.\filestore.dat' or die $!;
store \ $codestring, $file;
close $file;
open $file, '<', '.\filestore.dat' or die " 2 $!";
my $stringref = retrieve $file; # my $con = get_connection()
close $file;
print &{ eval $$stringref } ; # &{eval $$con} ;
exit 0; # my $line = <STDIN>; ...

How to check if command executed with IPC::open3 is hung?

I'm using the following script to capture STDIN, STDOUT and STDERR from the command passed as an argument.
#!/usr/bin/perl
use strict;
use warnings;
use IPC::Open3;
local(*CMD_IN, *CMD_OUT, *CMD_ERR);
my $pid = open3(*CMD_IN, *CMD_OUT, *CMD_ERR, $ARGV[0]);
close(CMD_IN);
my #stdout_output = <CMD_OUT>;
my #stderr_output = <CMD_ERR>;
close(CMD_OUT);
close(CMD_ERR);
waitpid ($pid, 0); # reap the exit code
print "OUT:\n", #stdout_output;
print "ERR:\n", #stderr_output;
It all works good with the exception that I'm not sure how to monitor if the command passed is hung. Could you please suggest a way?
I've borrowed this snippet originally from 'Programming Perl'.
You can use select or IO::Select and provide a timeout. If you want to read both from stdout and stderr, you should do that anyway (see the documentation of IPC::Open3).
Here's an example program using IO::Select:
#!/usr/bin/perl
use strict;
use warnings;
use IO::Select;
use IPC::Open3;
use Symbol 'gensym';
my ($cmd_in, $cmd_out, $cmd_err);
$cmd_err = gensym;
my $pid = open3($cmd_in, $cmd_out, $cmd_err, $ARGV[0]);
close($cmd_in);
my $select = IO::Select->new($cmd_out, $cmd_err);
my $stdout_output = '';
my $stderr_output = '';
while (my #ready = $select->can_read(5)) {
foreach my $handle (#ready) {
if (sysread($handle, my $buf, 4096)) {
if ($handle == $cmd_out) {
$stdout_output .= $buf;
}
else {
$stderr_output .= $buf;
}
}
else {
# EOF or error
$select->remove($handle);
}
}
}
if ($select->count) {
print "Timed out\n";
kill('TERM', $pid);
}
close($cmd_out);
close($cmd_err);
waitpid($pid, 0); # reap the exit code
print "OUT:\n", $stdout_output;
print "ERR:\n", $stderr_output;
Notes:
I use lexical vars for file handles. This requires the use of gensym for the stderr handle.
The argument to can_read is the timeout in seconds.
I use sysread for non-buffered IO.
I terminate the child if there's a read timeout.
I came up with the following solution heavily based on this answer.
However using select and avoiding signals as in nwellnhof's example looks much cleaner which is why I accepted it. I'm posting it here if somebody is interested:
my $pid = open3(*CMD_IN, *CMD_OUT, *CMD_ERR, $cmd);
if ($pid > 0){
eval{
local $SIG{ALRM} = sub {kill 9, $pid;};
alarm 6;
waitpid($pid, 0);
alarm 0;
};
}

Creating A Single Threaded Server with AnyEvent (Perl)

I'm working on creating a local service to listen on localhost and provide a basic call and response type interface. What I'd like to start with is a baby server that you can connect to over telnet and echoes what it receives.
I've heard AnyEvent is great for this, but the documentation for AnyEvent::Socket does not give a very good example how to do this. I'd like to build this with AnyEvent, AnyEvent::Socket and AnyEvent::Handle.
Right now the little server code looks like this:
#!/usr/bin/env perl
use AnyEvent;
use AnyEvent::Handle;
use AnyEvent::Socket;
my $cv = AnyEvent->condvar;
my $host = '127.0.0.1';
my $port = 44244;
tcp_server($host, $port, sub {
my($fh) = #_;
my $cv = AnyEvent->condvar;
my $handle;
$handle = AnyEvent::Handle->new(
fh => $fh,
poll => "r",
on_read => sub {
my($self) = #_;
print "Received: " . $self->rbuf . "\n";
$cv->send;
}
);
$cv->recv;
});
print "Listening on $host\n";
$cv->wait;
This doesn't work and also if I telnet to localhost:44244 I get this:
EV: error in callback (ignoring): AnyEvent::CondVar:
recursive blocking wait attempted at server.pl line 29.
I think if I understand how to make a small single threaded server that I can connect to over telnet and prints out whatever its given and then waits for more input, I could take it a lot further from there. Any ideas?
You're blocking inside a callback. That's not allowed. There are a few ways to handle this. My preference is to launch a Coro thread from within the tcp_server callback. But without Coro, something like this might be what you're looking for:
#!/usr/bin/env perl5.16.2
use AnyEvent;
use AnyEvent::Handle;
use AnyEvent::Socket;
my $cv = AE::cv;
my $host = '127.0.0.1';
my $port = 44244;
my %connections;
tcp_server(
$host, $port, sub {
my ($fh) = #_;
print "Connected...\n";
my $handle;
$handle = AnyEvent::Handle->new(
fh => $fh,
poll => 'r',
on_read => sub {
my ($self) = #_;
print "Received: " . $self->rbuf . "\n";
},
on_eof => sub {
my ($hdl) = #_;
$hdl->destroy();
},
);
$connections{$handle} = $handle; # keep it alive.
return;
});
print "Listening on $host\n";
$cv->recv;
Note that I'm only waiting on one condvar. And I'm storing the handles to keep the AnyEvent::Handle objects alive longer. Work to clean up the $self->rbuf is left as an excersise for the reader :-)
Question cross-posted, answer, too :-)
I have heard good things about AnyEvent as well, but have not used it. I wrote a small nonblocking server in the past using IO::Select. There is an example in the documentation for that module (I've added a few lines):
use IO::Select;
use IO::Socket;
$lsn = new IO::Socket::INET(Listen => 1, LocalPort => 8080);
$sel = new IO::Select( $lsn );
while(#ready = $sel->can_read) {
foreach $fh (#ready) {
if($fh == $lsn) {
# Create a new socket
$new = $lsn->accept;
$sel->add($new);
}
else {
# Process socket
my $input = <$fh>;
print $fh "Hello there. You said: $input\n";
# Maybe we have finished with the socket
$sel->remove($fh);
$fh->close;
}
}
}
I'm not sure what your condvar is trying to trigger there. Use it to send state, like:
#!/usr/bin/env perl
use AnyEvent;
use AnyEvent::Handle;
use AnyEvent::Socket;
my $host = '127.0.0.1';
my $port = 44244;
my $exit = AnyEvent->condvar;
tcp_server($host, $port, sub {
my($fh) = #_;
my $handle; $handle = AnyEvent::Handle->new(
fh => $fh,
poll => "r",
on_read => sub {
my($self) = #_;
print "Received: " . $self->rbuf . "\n";
if ($self->rbuf eq 'exit') {
$exit->send;
}
}
);
});
print "Listening on $host\n";
$exit->recv;

Can't read from socket in perl - possible deadlock?

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.

How to keep data marked as UTF-8 after parsing with HTML::Tree?

I wrote a script, where i slurp in UTF-8 encoded HTML-file and then parse it to tree with HTML::Tree. Problem is that after parsing the strings are not marked as UTF-8 anymore.
As _utf8_on() is not recommended way to set flag on, i am looking for proper way.
My simplified code-example:
#!/usr/bin/perl
use strict;
use warnings;
use 5.010;
use utf8::all;
use autodie;
use HTML::Tree;
use Encode qw/is_utf8/;
my $file = shift;
my $tree;
if ($file) {
my $content = slurp_in( 'file' => $file );
$tree = html_tree('content' => $content);
} else {
die "no file";
}
my $title = $tree->look_down(_tag => 'title');
$title = $title->as_HTML('');
if ( is_utf8( $title ) ) {
say "OK: $title";
} else {
say "NOT OK: $title";
}
## SUBS
##
sub slurp_in {
my %v = #_;
open(my $fh, "<:utf8", $v{file}) || die "no $v{file}: $!";
local $/;
my $content = (<$fh>);
close $fh;
if ($content) {
return $content;
} else {
die "no content in $v{file} !";
}
}
sub html_tree {
my %v = #_;
my $tree = HTML::Tree->new();
$tree->utf8_mode(1); ## wrong call here, no such method, but no warnings on it!
$tree->parse( $v{content} );
if ($tree) {
return $tree;
} else {
die "no tree here";
}
}
Your code is overcomplicated, and you employ utf8::all and decode manually and call that strange method all at once. Rhetorically asking, what do you expect to achieve that way? I do not have the patience to find out the details what goes wrong and where, especially since you did not post any input with which your program fails to do the expected, so I drastically reduce it to a much simpler one. This works:
#!/usr/bin/env perl
use 5.010;
use strict;
use warnings FATAL => ':all';
use File::Slurp qw(read_file); # autodies on error
use HTML::Tree qw();
my $file = shift;
die 'no file' unless $file;
my $tree = HTML::Tree->new_from_content(
read_file($file, binmode => ':encoding(UTF-8)')
);
my $title = $tree->look_down(_tag => 'title');
$title->as_HTML(''); # returns a Perl string