SPUG: shell script event loops + wrapping shell utilities

William Julien moonbeam at catmanor.com
Fri Apr 19 18:29:48 CDT 2002


I have done something simular, but I used a client/server approach.
The client sets up a bi-directional socket communication with the
server. The server just waits for commands and runs commands or does
actions on behalf of the client. In this case, it just stats a file
for directory, or tells them who is logged in.  A fun little toy. The
nice thing about this approach, the client and server don't have to
be on the same computer. In the following example, the server does
not fork, so it can only handle one client at a time. This I leave
as an exercise to the reader.

In perl, there is always more than one way to do it.

Here is some sample code:

-->cat biclient.pl
#!/usr/bin/perl -w
#
# biclient - bidirectional forking client

use strict;
use IO::Socket;
my($port, $host, $handle, $line, $kidpid);

$port = "1999";
$host = "localhost";

# create a tcp connection to the specified host and port
$handle = IO::Socket::INET->new(Proto     => "tcp",
                                PeerAddr  => $host,
                                PeerPort  => $port)
       or die "can't connect to port $port on $host: $!";

$handle->autoflush(1);              # so output gets there right away
print "[Connected to $host:$port]\n";

# split the program into two processes, identical twins
die "can't fork: $!" unless defined($kidpid = fork());

if ($kidpid) {
# parent copies the socket to standard output
    while (defined ($line =  <$handle>)) {
        print $line;
    } 
    #kill("TERM" => $kidpid);        # send SIGTERM to child
}
else {
  # child copies standard input to the socket
    while (defined ($line = <>)) {
        print $handle $line;
    }
}

-->cat stat_server.pl
#!/usr/bin/perl -Tw
#
# server to listen on port 1999 and return a stat of a file
#
###

#
# modules
#
use strict;
use IO::Socket;

#
# secure environment
#
$ENV{PATH}="";

#
# declare variables
#
my ($socket,    # client socket connection
    $client,    # client handle
    @stat,      # file stat data
    );

#
# make a socket connection to port 1999
#
$socket = IO::Socket::INET->new(Proto=>"tcp", 
                                LocalPort=>"1999",
                                Listen=>1
                                )
    or die "Cannot create server socket: $!\n";

#
# loop forever for client connections
#
while (1) {
    $client = $socket->accept;
    $client->autoflush(1);

    while (<$client>) {
        chomp;
        s/\r//;
        # client is done
        if ( "$_" eq "." ) {
            close $client;
            last;
        }
        # say hello (we are a friendly server)
        if ( "$_" eq "hello" ) {
            print $client "Hello. Nice to meet you.\n";
            print $client "Please enter a file name.\n";
            next;
        }
        # run a command
        if ( $_ eq "w" ) {
            print $client `/usr/bin/w`;
            next;
        }
        # server kill command
        if ( "$_" eq "kill" ) {
            close $client;
            close $socket;
            exit;
        }
        # stat a file or a directory
        if ( -e "$_" ) {
            @stat = stat("$_");
            print $client "$_: @stat\n";
        } else {
            print $client "File Not Found: $_\n";
        }
        next;
    }
}

Sample Run:

#
# start the server
#
-->stat_server.pl &
[2]     13035

#
# Connect as a client
#
-->biclient.pl
[Connected to localhost:1999]
hello
Hello. Nice to meet you.
Please enter a file name.
/vmlinuz
/vmlinuz: 770 171 33188 1 0 0 0 972211 1015755887 1015755887 1015755887 4096 1910
/home/moonbeam
/home/moonbeam: 779 80481 16877 47 502 100 0 8192 1019216446 1019089720 1019089720 4096 16
w
  4:17pm  up 37 days, 22:22,  6 users,  load average: 0.00, 0.00, 0.00
USER     TTY      FROM              LOGIN@   IDLE   JCPU   PCPU  WHAT
moonbeam pts/2    gamymede.catmano 27Mar02  1:39   2.14s  0.05s  mailx 
moonbeam pts/3    gamymede.catmano  3Apr02 23:15m  0.36s  0.05s  -su 
moonbeam pts/4    gamymede.catmano  2Apr02  0.00s 55.19s  0.19s  /usr/bin/perl -
moonbeam pts/6    gamymede.catmano  6Apr02  5days  0.46s  0.46s  -ksh 
moonbeam pts/7    whitecat.catmano Tue 4pm  2days  0.11s  0.11s  -ksh 
moonbeam pts/8    whitecat.catmano Tue 7pm  2days  0.21s  0.21s  -ksh 
/home/moonbeam/junk
File Not Found: /home/moonbeam/junk
.
 
#
# reconnect as a client and drop the server
#
-->biclient.pl
[Connected to localhost:1999]
hello
Hello. Nice to meet you.
Please enter a file name.
kill
[2] +  Done                    stat_server.pl &

---
   William Julien           _,'|            _.-''``-...___..--';
moonbeam at catmanor.com      /, \'.      _..-' ,      ,--...--'''
 vi is my shepherd;       < \   .`--'''      `     /| 
 i shall not font.         `-,;'              ;   ; ;  
                     __...--''     __...--_..'  .;.'  
                    (,__....----'''      (,..--''     
perl -e 'print $i=pack(c5,(41*2),sqrt(7056),(unpack(c,H)-2),oct(115),10);'
perl -e '( $ ,, $ ")=("a".."z")[0,-1]; print "sh", $ ","m\n";;";;"'

>
>So, I wanted to add some minor functionality to a couple of shell 
>programs (telnet and ftp, specifically) and the simplest way seemed 
>to be simply to wrap them in a Perl script, i/e simply make a Perl 
>script that opens the program, and pipes input from the terminal 
>(keystrokes) through to the program, and passes characters output 
>from the program back to the terminal -- occasionally adding some 
>extra keystrokes of its own (the added functionality) but mostly just 
>acting as a "bidirectional pipe" between the program and the terminal.
>
>Here is the main wrapper part of the ftp version of the script 
>(greatly stripped-down for clarity):
>
>____________________________
>#!/usr/bin/perl
>
>use strict;
>use Fcntl;
>use IPC::Open3;
>
>$| = 1;
>
>my $from_term;
>my $from_shell;
>my $pipe_error;
>
>open(TTY, "+</dev/tty") or die "no tty: $!";
>fcntl( TTY, F_SETFL, O_NONBLOCK );
>
>my $pid = open3( \*TO_SHELL, \*FROM_SHELL, \*SHELL_ERR,
>         'ftp -v strangelight.com'
>);
>
>fcntl( FROM_SHELL, F_SETFL, O_NONBLOCK );
>fcntl( SHELL_ERR, F_SETFL, O_NONBLOCK );
>
>my $oldfh = select(FROM_SHELL); $| = 1; select($oldfh);
>$oldfh = select(SHELL_ERR); $| = 1; select($oldfh);
>$oldfh = select(TTY); $| = 1; select($oldfh);
>
>$SIG{PIPE} = sub { ++$pipe_error; };
>
>while ( not $pipe_error ) {
>                 while( defined( $from_term = getc(TTY) ) ) {
>                         print TO_SHELL $from_term;
>                 }
>                 while( defined( $from_shell = getc(FROM_SHELL) ) ) {
>                         print $from_shell;
>                 }
>                 while( defined( $from_shell = getc(SHELL_ERR) ) ) {
>                         print $from_shell;
>                 }
>}
>
>__END__
>
>Now, I have two questions.
>
>My first question is, admittedly, one of those "I could probably 
>figure it out on my own but I'm lazy so I'll ask the folks on SPUG 
>instead" questions:
>
>While my script works fairly well as-is, it's a real processor hog, 
>as you can probably guess.  All of those getc() calls are 
>non-blocking, so even when there's no input or output to process, the 
>main while() loop still keeps executing over and over again, doing 
>absolutely nothing as fast as it possibly can.  What's the 
>best/simplest way to tell Perl to "go to sleep, but wake up as soon 
>as something interesting happens"?
>
>My second question is one I've banged my head on for a while and 
>haven't been able to figure out at all:
>
>Even with setting $|=1 on all the open pipes, I still don't always 
>get my I/O flushed promptly -- in particular, the responses I read 
>back from FROM_SHELL seem often to be one or two lines behind what I 
>should be getting. (My work-around has been to send a no-op command 
>like 'pwd', the response to which usually forces the lines that I 
>want to see out of the buffer.)  What else can I do to get my pipes 
>"piping hot" (as the perldocs say)?
>
>-jason
>
> - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
>     POST TO: spug-list at pm.org       PROBLEMS: owner-spug-list at pm.org
>      Subscriptions; Email to majordomo at pm.org:  ACTION  LIST  EMAIL
>  Replace ACTION by subscribe or unsubscribe, EMAIL by your Email-address
> For daily traffic, use spug-list for LIST ;  for weekly, spug-list-digest
>     Seattle Perl Users Group (SPUG) Home Page: http://seattleperl.org
>

 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
     POST TO: spug-list at pm.org       PROBLEMS: owner-spug-list at pm.org
      Subscriptions; Email to majordomo at pm.org:  ACTION  LIST  EMAIL
  Replace ACTION by subscribe or unsubscribe, EMAIL by your Email-address
 For daily traffic, use spug-list for LIST ;  for weekly, spug-list-digest
     Seattle Perl Users Group (SPUG) Home Page: http://seattleperl.org




More information about the spug-list mailing list