Foro - Perl en Español

[creating021]

Le falta trabajo, y el contador tiene problemas debido al fork(), pero con un poco de trabajo se logra:

Sintáxis: [ Descargar ] [ Ocultar ]

Sintáxis: [ Descargar ] [ Mostrar ]

Using perl Syntax Highlighting

#!/usr/bin/env perl
use strict;

package MyServer;
use strict;
use Socket;
use POSIX;

our $MaxClients = 50;
our $Clientes   = 0; # Clientes en linea...
our $eol        = "\015\012";

$SIG{CHLD} = \&ExitChild;

sub ExitChild {
    my $pid;
    while ( ( $pid = waitpid( -1, WNOHANG ) ) > 0 ) {
        $Clientes--;
    }
    $SIG{CHLD} = \&ExitChild;
}

sub new {
    my ( $pkg, $tarea ) = @_;
    my $self = {};
    socket( my $server, AF_INET, SOCK_STREAM, getprotobyname('tcp') )
        or die "Socket error: $!\n";
    setsockopt( $server, SOL_SOCKET, SO_REUSEADDR, 1 )
        or die "setsockopt error: $!\n";

    bind( $server, sockaddr_in( 80, INADDR_ANY ) ) or die "bind: $!\n";
    listen( $server, ( SOMAXCONN ) ) or die "listen: $!\n";

    $self->{Socket} = $server;
    $self->{Tarea}  = $tarea;
    bless $self, $pkg;
    return $self;
}

sub run {
    my $self = shift;
    while ( accept(CLIENT, $self->{Socket}) ) {
        $Clientes += 1;
        if ( $Clientes == $MaxClients ) { # Si exede los 50 usuarios...
            print CLIENT ( "HTTP/1.1 509 Bandwidth Limit Exceeded" . $eol );
            print CLIENT ( "DATE: " . scalar( gmtime() ) . " GMT$eol" );
            print CLIENT ( "Connection: close" . $eol );
            print CLIENT $eol;
            print CLIENT "Bandwidth limit exceeded";
            shutdown( CLIENT, 2 ); # no acepta al cliente.
        }

        my $pid = fork(); # Si, decidi hacerlo con fork...
        if ( not $pid ) {
            #Timeout
            POSIX::sigaction( SIGALRM,
            POSIX::SigAction->new( sub { shutdown( CLIENT, 2 ); exit; } ) )
                or die "Error setting SIGALRM: $!\n";
            alarm( 20 );

            select( ( select(CLIENT), $| = 1 )[0] );

            while ( my $cl = <CLIENT> ){print $cl; last if $cl eq $eol;}
            alarm 120; # timeout 2 min.
            print CLIENT ( "HTTP/1.1 200 OK" . $eol );
            print CLIENT ( "DATE: " . scalar( gmtime() ) . "GMT$eol" );
            print CLIENT ( "Content-Type: text/html" . $eol );
            print CLIENT ( "Content-Length: 25" . $eol );
            print CLIENT ( "Connection: Keep-Alive" . "$eol$eol" ); # Para saber si interesado.
            print CLIENT ( "Hello Dave, I am HAL 9000" . $eol );
            $self->{Tarea}() or print "$@\n";
        }
    }
}

package main;
sub Tarea {
    print "Usuarios conectados: $MyServer::Clientes\n";
}
my $servidor = MyServer->new( \&Tarea );
$servidor->run();

Coloreado en 0.006 segundos, usando GeSHi 1.0.8.4

EDITO:
Hay otro problema, con éste y cualquier otro servidor... resulta que todos los browsers hacen dos peticiones, el index y el favicon.ico.
Croe que lo más facil va a ser usar un servidor como lighttp o OpenAngle y un CGI.