Bueno, ha sido un ejercicio divertido adaptar el código a Perl. Aquí está mi primera aproximación:
Código:
#! /usr/bin/perl -w
use strict;
use vars qw($cadena $contador $nombre $p);
### Prototipos de funciones ###
sub Identifica_variable ($$);
sub Recibe_parametros ();
sub Transforma_ASCII ($);
### Definicion de valores constantes ###
sub ARCHIVO_SALIDA () { '../httpdocs/inscriptos.xls' }
sub ARCHIVO_SALIDA2 () { '../httpdocs/inscrip_copia.xls' }
sub ARCHIVO_CANT () { '../httpdocs/contador.txt' }
### Codigo principal ###
$cadena = Recibe_parametros ();
open (DA, '>>' . ARCHIVO_SALIDA) or die $!;
open (DA2, '>>' . ARCHIVO_SALIDA2) or die $!;
print DA "\n";
print DA2 "\n";
$p = 0;
while ($nombre = Identifica_variable ($cadena, \$p)) {
print DA "$nombre\t";
print DA2 "$nombre\t";
}
close (DA2) or die $!;
close (DA) or die $!;
$contador = 0;
if (! -f ARCHIVO_CANT)
{ open (CANT, '>' . ARCHIVO_CANT) or die $! }
else
{ open (CANT, '+<' . ARCHIVO_CANT) or die $! }
read (CANT, $contador, -s ARCHIVO_CANT);
$contador++;
seek (CANT, 0, 0); # va al comienzo del archivo
print CANT $contador;
close (CANT) or die $!;
# Imprime cabecera HTTP para cumplir con un requisito de la interfaz
# CGI
print <<FIN_SALIDA;
Content-Type: text/html
<html>
<head>
<title>Gracias por anotarse en Baradero 2003</title>
</head>
<body bgcolor="#000000" text="#FFFFFF">
<div align=center>
<p> </p>
<p>
<b><font face=Arial, Helvetica, sans-serif size=4>
<u>SU NUMERO DE INSCRIPCION ES: ${contador}</u></font></b>
</p>
</div>
</body>
</html>
FIN_SALIDA
exit (0);
### Declaracion de funciones ###
# Recibe la cadena donde buscara los datos pasados desde el formulario
# y una referencia a la posicion actual de procesamiento en la
# cadena. Devuelve el siguiente valor disponible, o 0 si no hay mas.
sub Identifica_variable ($$)
{
my $cadena = shift;
my $ref_pos = shift;
my $param = substr ($cadena, $$ref_pos);
return 0 if (! $param or $param eq '');
# Ignorar el nombre de la variable, ir directo al valor
while ($param !~ /^=/ and $param ne '') {
$param =~ s/^.//s;
$$ref_pos++;
}
if ($param =~ /^=/) {
$param =~ s/^.//s;
$$ref_pos++;
my $vble = '';
my $cont = 0;
while ($param !~ /^&/ and $param ne '')
{
$cont = 1 if ! $cont;
for ($param) {
/^%/ && do {
$vble .= Transforma_ASCII ($param);
$param = substr ($param, 2);
$$ref_pos += 2;
last;
};
/^\+/ && do { $vble .= ' '; last; };
$vble .= substr ($param, 0, 1);
last;
}
$param =~ s/^.//s;
$$ref_pos++;
}
# Si no hay datos en la variable (ej: ape=&nom=pepe)
$vble .= ' ' if ($param =~ /^&/ and ! $cont);
return $vble;
} else
{ return 0 }
}
# Devuelve toda la informacion del formulario (enviado con el metodo
# POST)
sub Recibe_parametros ()
{
if ($ENV{'CONTENT_LENGTH'} and
(! $ENV{'CONTENT_TYPE'} or
$ENV{'CONTENT_TYPE'} eq 'application/x-www-form-urlencoded')) {
read (STDIN, my $bufer, $ENV{'CONTENT_LENGTH'});
return $bufer;
}
return '';
}
# Transforma una secuencia hexadecimal `%xx' por el caracter
# correspondiente segun su valor ASCII.
sub Transforma_ASCII ($)
{
my $cadena = shift;
# Devolver un signo de interrogacion si no se recibe una secuencia
# valida
return ($cadena =~ /^%/) ? pack ('c', hex (substr ($cadena, 1, 2))) : '?';
}
Hay algunas cosas que han resultado más bien curiosas debido a que traté en lo posible traducir fielmente la misma lógica del código original. Algunas otras cosas si resultan evidentemente distintas, ya que han tenido que escribirse en "estilo Perl", lo cual no es decir mucho, ya que como bien es sabido, el estilo Perl consiste precisamente en que "hay más de una forma de hacerlo".
Espero que no tengas problema montando la aplicación final en tu servidor. En caso de dudas, discute con la gente encargada del servidor sobre los permisos apropiados que deben otorgarse al archivo del script y al directorio en donde deben ir los archivos de datos.
Saludos.