MMAgic/Log/Pipe.pl

Go to the documentation of this file.

#!perl -I C:\MMAperl
#
# MMAgic/Log/Pipe.pl
#
#   Utility program for reading from a named pipe and printing it.
#

use     IO::Socket::INET;
use     IO::Pipe;
use     IO::Select;
use     Win32::Pipe;

$name = $ARGV[0] || 'trace';
$port = 10382;

###########################################################################
sub indent      # $code
#
    {
    my  $code = shift || ' ';
    my ($sec, $min, $hour, $mday, $mon, $year) = localtime(time);
    
    return sprintf "<%s> %04d/%02d/%02d %02d:%02d:%02d ",
                   $code, $year, $mon, $mday, $hour, $min, $sec;
    }

###########################################################################
sub pipeError   # $pip, $intro
#
    {
    my  $pip = shift;
    my ($err, $msg) = $pip->Error;
    
    return $err ? "[$err]  $msg" : '{no pipe error registered}';
    }

###########################################################################
sub play        # $i
#
    {
    my  $i = shift; # child number
    
    my  $socket = new IO::Socket::INET
            (PeerAddr => 'localhost',
             PeerPort => $port,
             Proto    => 'tcp',
             Type     => SOCK_STREAM);
    
    print $socket indent('I'), "Child $i started\n";
    $socket->flush;

    while (1)
        {
        my  $namePipe = new Win32::Pipe($name);
        
        $namePipe->ResizeBuffer(1024);
        
        unless (ref($namePipe) eq 'Win32::Pipe')
            {
            print $socket 
                  indent('E'), "Unable to allocate named pipe:\n",
                  indent('E'), "  $!";
            $socket->flush;
            return;
            }
        
        while (1)
            {
            unless ($namePipe->Connect())
                {
#               print $socket
#                     indent('E'), "Unable to connect named pipe:\n",
#                     indent('E'), '  ', pipeError($namePipe),  "\n",
#                     indent('E'), "  $!";
                $socket->flush;
                last;
                }
            
            print $socket indent('+'), "Connected\n";
            $socket->flush;
            
            while (1)
                {
                my  $data = $namePipe->Read();
                
                unless (defined($data))
                    {
#                   print $socket
#                         indent('E'), "Error reading from named pipe:\n",
#                         indent('E'), '  ', pipeError($namePipe),    "\n",
#                         indent('E'), "  $!\n";
                    $socket->flush;
                    last;
                    }
                
                # Whoa!!!  Time to print some data...
                print $socket $data;
                $socket->flush;
                }
            
            $namePipe->Disconnect();
            
            print $socket indent('-'), "Disconnected\n";
            $socket->flush;
            }
        
        $namePipe->Close();
        $namePipe = undef;
        }
    
    $socket->close;
    }

###########################################################################
###########################################################################
#
# Main program:
#

# Start a bunch of child processes for named pipe:
for (my $i = 0; $i < 5; $i++)
    {
    my  $pid = fork;
    
    if (! defined($pid))
        {
        print indent('C'), "Unable to fork child process:\n",
              indent('C'), "  $!\n";
        exit;
        }
    
    if (! $pid)
        {
        # Child fork:
        play($i);
        exit;
        }
    
    # Parent fork:
    }

# Capture socket data and prints it:
$server = new IO::Socket::INET
    (LocalPort => $port,
     Type      => SOCK_STREAM,
     Reuse     =>  1,
     Listen    => 10);

unless ($server)
    {
    print indent('C'), "Unable to create server socket:\n",
          indent('C'), "  $!\n";
    exit;
    }

$switch = new IO::Select($server);

unless ($switch)
    {
    print indent('C'), "Unable to create select object:\n",
          indent('C'), "  $!\n";
    exit;
    }

print indent('I'), "Server started on port $port\n";

while (1)
    {
#   print indent('T'), "Check for ", $switch->count(), " handles\n";
    
    my  @handles = $switch->can_read;
    
    for my $handle (@handles)
        {
        if ($handle == $server)
            {
            # Accept and create another connection:
            my  $connection = $server->accept;
            
            $switch->add($connection);  # now wait for this one too.
            
#           print indent('T'), "Accepted connection\n";
            }
        
        else
            {
            my  $data = undef;
            my  $done = $handle->recv($data, 1024);
            
            if (defined($done))
                {
                print $data if $data;
                next;
                }
            
            # An error, connection probably dead:
            $switch->remove($handle);
            $handle->close();
            }
        }
    }