Reescribiremos ahora el servidor con preforking adaptativo introducido en la sección 14.2. Para configurar la conducta del servidor hay que heredar de la clase Net::Server::PreFork. La estructura del programa principal es exactamente la misma que en los ejemplos anteriores:
1 #!/usr/bin/perl 2 use strict; 3 use warnings; 4 use base qw(Net::Server::PreFork); 5 use MIME::Types; 6 use HTTP::Status; 7 use HTTP::Request; 8 9 ### run the server 10 __PACKAGE__->run; 11 exit;
En este caso el servicio proveído es la descarga de
páginas estáticas solicitadas mediante el protocolo
HTTP. El método process_request
es el encargado de
hacerlo. Es similar a la subrutina handle_connection
del servidor presentado en la sección
14.2.
52 sub process_request { 53 my $self = shift; 54 55 local $/ = "$CRLF$CRLF"; 56 my $request = <STDIN>; # read the request header 57 # warn "header:\n$request\n"; 58 59 my $r = HTTP::Request->parse( $request ); 60 my $method = $r->method; # GET | HEAD | ... 61 my $url = $r->uri; 62 63 warn join(" ", time, $method, "$url")."\n"; 64 65 ### do we support the type 66 if ($method !~ /GET|HEAD/) { 67 return $self->error(RC_BAD_REQUEST(), "Unsupported Method"); 68 } 69 70 ### clean up uri 71 my $path = URI::Escape::uri_unescape($url); 72 $path =~ s/\?.*$//; # ignore query 73 $path =~ s/\#.*$//; # get rid of fragment 74 75 ### at this point the path should be ready to use 76 $path = "$self->{document_root}$path"; 77 78 ### see if there's an index page 79 if (-d $path) { 80 foreach (@{ $self->{default_index} }){ 81 if (-e "$path/$_") { 82 return redirect("$url/$_"); 83 } 84 } 85 } 86 87 ### error 404 88 return $self->error(RC_NOT_FOUND(), "file not found") unless -e $path; 89 90 ### spit it out 91 open(my $fh, "<$path") || return $self->error(RC_INTERNAL_SERVER_ERROR(), "Can't open file [$!]"); 92 my $length = (stat($fh))[7]; # file size 93 94 my $mimeobj = MIME::Types->new->mimeTypeOf($path); 95 my $type = $mimeobj->type if defined($mimeobj); 96 97 # print the header 98 print STDOUT "HTTP/1.0 ".RC_OK." OK$CRLF"; 99 print STDOUT "Content-length: $length$CRLF"; 100 print STDOUT "Content-type: $type; charset=utf-8"; 101 print STDOUT "$CRLF$CRLF"; 102 103 return unless $method eq 'GET'; 104 105 # print the content 106 my $buffer; 107 while ( read($fh,$buffer,1024) ) { 108 print STDOUT $buffer; 109 } 110 close $fh; 111 }
Casiano Rodríguez León