libdanga-socket-perl 1.61-1 / usr / share / doc / libdanga-socket-perl / examples / example.pl

#!/usr/bin/perl

use strict;
use warnings;

use IO::Handle;
use Socket;

# CHANGE THIS!
my $PROGRAM = "/home/hachi/test.pl";

# Using IO::Handle::INET (or whatever that module is) actually blocks during
# connect even if you set the 'blocking' option to 0.

socket( my $server_sock, PF_INET, SOCK_STREAM, getprotobyname( 'tcp' ) )
    or die( "socket failed: $!\n" );
    
setsockopt( $server_sock, SOL_SOCKET, SO_REUSEADDR, pack( "l", 1 ) )
    or die( "setsockopt failed: $!\n" );
    
bind( $server_sock, sockaddr_in( 2345, INADDR_ANY ) )
    or die( "bind failed: $!\n" );

listen( $server_sock, SOMAXCONN )
    or die( "listen failed: $!\n" );

IO::Handle::blocking( $server_sock, 0 );

Danga::Socket->AddOtherFds( fileno( $server_sock ), sub {
    my $paddr = accept( my $client, $server_sock );
    Client->new( $client );
} );

$SIG{CHLD} = 'IGNORE';

Danga::Socket->EventLoop;

warn "Clean Exit!\n";
exit 0;

package Client;

use strict;
use warnings;

use Data::Dumper;

use base 'Danga::Socket';

use fields qw(exec);

sub new {
    my Client $self = shift;
    my $sock = shift;
    
    $self = fields::new( $self ) unless ref $self;
    $self->SUPER::new( $sock );

    my $exec = Exec->new(
        read  => sub {
            my $exec = shift;
            my $input = $exec->read( 1024 );
            if ($input) {
                print "Exec for $exec->{pid} read: $$input\n";
                $self->write( $input );
            }
            else {
                $exec->watch_read( 0 );
            }
        },
        program => $PROGRAM,
    );

    $exec->watch_read( 1 );

    $self->{exec} = $exec;

    return $self;
}

sub event_err {
    my Client $self = shift;
    $self->{exec}->kill;
}

sub event_hup {
    my Client $self = shift;
    $self->{exec}->kill( "INT" );
}

package Exec;

use strict;
use warnings;

use Socket;
use IO::Handle;

use base 'Danga::Socket';

use fields qw(pid read write err hup);

sub new {
    my Exec $self = shift;
    my %opts = @_;

    $self = fields::new( $self ) unless ref $self;

    $self->{read} = delete( $opts{read} );
    $self->{write} = delete( $opts{write} );
    $self->{err} = delete( $opts{err} );
    $self->{hup} = delete( $opts{hup} );

    my $program = delete( $opts{program} )
        or die( "Must supply a program argument" );
    my $args = delete( $opts{args} ) || [];

    die( "Unknown arguments" ) if keys( %opts );

    socketpair( my $one, my $two, AF_UNIX, SOCK_STREAM, PF_UNSPEC )
        or die( "Sockpair failed" );
    IO::Handle::blocking( $one, 0 );
    IO::Handle::blocking( $two, 0 );

    # Try turning off autoflush on these, so stdio calls don't buffer
    select((select( $one ), $|++)[0]);
    select((select( $two ), $|++)[0]);

    my $pid = fork();

    die( "Fork failed: $!" ) unless defined( $pid );

    if ($pid) {
        # Parent process
        $self->{pid} = $pid;
        close $two;
        $self->SUPER::new( $one );
        return $self;
    }
    else {
        # Child process
        close $one;
        close STDIN;
        close STDOUT;

        # DUP our $two handle into the 0 and 1 fd slots
        open( STDIN, "<&" . fileno( $two ) )
            or die( "Couldn't dup to STDIN in pid $$: $!" );
        open( STDOUT, ">&" . fileno( $two ) )
            or die( "Couldn't dup to STDOUT in pid $$: $!" );

        exec( $program, @$args );
        
        die( "Exec failed: $!" );
    }
}

sub event_read {
    my Exec $self = shift;
    if (my $code = $self->{read}) {
        $code->( $self );
    }
}

sub event_write {
    my Exec $self = shift;
    if (my $code = $self->{write}) {
        $code->( $self );
    }
}

sub event_err {
    my Exec $self = shift;
    if (my $code = $self->{err}) {
        $code->( $self );
    }
}

sub event_hup {
    my Exec $self = shift;
    if (my $code = $self->{hup}) {
        $code->( $self );
    }
}

sub kill {
    my Exec $self = shift;
    my $signal = shift or return;
    kill $signal, $self->{pid};
}