LISTADO 1
Algunos servidores de interés son:
El libro de O'reilly de Perl::DBI "Programming the Perl DBI" de Alligator Descartes y Tim Bunce, los creadores del módulo es una estupenda referencia sobre el tema (ISBN: 1565926994).
PIE LISTADO 1: Más información
LISTADO 2
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0//ES">
<HTML>
<HEAD>
<TITLE>Listado de antiguos alumnos por año de promoción</TITLE>
[-
use DBI;
use POSIX qw/strftime/;
use CGI::Cookie;
%cookies = fetch CGI::Cookie;
$db="alumni2k";
$uslec="lectura";
-]
[-
$dbuser=$uslec;
if (not(defined($dbhlectura))) {
eval {$dbhlectura = DBI->connect("dbi:Pg:dbname=$db", "$dbuser", "")
or die "No puedo abrir la base de datos $dbname con el usuario $dbuser\n"; };
$falloconex = "fallo" if ( ! defined($dbhlectura) );
};
-]
[$ if ($falloconex) $]
[- $udat{errores}="Sin conexión"; -]
<META http-equiv="refresh" content="1;URL=../error/fallo_conexion.epl">
</HEAD>
<BODY>
Ha habido un <A HREF="../error/fallo_conexion.epl">error%lt;/A>
</BODY>
</HTML>
[$ else $]
[- if (exists($cookies{'codigo'}) && $cookies{'codigo'}->value != 0 )
{
$codigo = $cookies{'codigo'}->value;
@arraydatos = $dbhlectura->selectrow_array("SELECT DISTINCT codigo, nombre, apellido, id_persona FROM persona WHERE codigo = \'$codigo\'");
}
if (@arraydatos)
{
$ref = \@arraydatos;
($bogus,$nombreusuario,$apellidousuario,$idpersona)=@$ref;
}
else {$ref=""}
-]
[$ if (not($ref)) $]
[- $udat{errores}="No es miembro o no autentificado"; -]
<META http-equiv="refresh" content="0;URL=../error/no_pertenece.epl">
</HEAD>
<BODY>
<STRONG>
Ha habido algún error en el proceso, si su navegador no se lo muestra
automáticamente pulse <a HREF="../error/no_pertenece.epl">aquí</A>.
</STRONG>
</BODY>
</HTML>
[$ else $]
</HEAD>
<BODY>
<H1>Listado de AAs por año de promoción</H1>
[-
$consulta = "select nombre, apellido, graduacion from persona, datos_academicos where persona.id_persona = datos_academicos.id_persona and autorizacion = 1 order by graduacion";
$sth = $dbhlectura->prepare($consulta);
$sth->execute or die "Lo siento, no puedo realizar la consulta en este momento";
$head = $sth->{NAME};
$data = $sth->fetchall_arrayref ;
$rows = $sth->rows;
-]
[$ if $rows > 0 $]
<table border=0>
<tr><th>[+ $head->[$col] +]</th></tr>
<tr><td>[+ $data -> [$row][$col] +]</td></tr>
</table>
[$ else $]
<P>Lo lamentamos, pero no hay datos en la base de datos en respuesta
a la consulta
</BODY>
</HTML>
[$ endif $]
[$ endif $]
[-
if (defined($dbhlectura)) {
eval{$dbhlectura->disconnect or warn "La desconexión de la base de datos falló: $DBI::errstr\n";}
};
-]
PIE LISTADO 2: Ejemplo de consulta con perl embedido
LISTADO 3
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0//ES"gt;
<HTMLgt;
<HEADgt;
<TITLEgt;Bienvenidos al sitio de la Asociación de Antiguos Alumnos</TITLEgt;
[-
use DBI;
use POSIX qw/strftime/;
use CGI::Cookie;
%cookies = fetch CGI::Cookie;
$db="alumni2k";
$uslec="lectura";
$usesc="escritura";
$uspub="sincompletar";
$usadm="sincompletar";
$passadm="sincompletar";
-]
[-
$dbuser=$uslec;
if (not(defined($dbhlectura))) {
eval {$dbhlectura = DBI-gt;connect("dbi:Pg:dbname=$db", "$dbuser", "") or die "No puedo abrir la base de datos $dbname con el usuario $dbuser\n"; };
if (not(defined($dbhlectura))) {$falloconex="fallo";}
};
-]
[- if (exists($cookies{'codigo'}) && $cookies{'codigo'}-gt;value != 0 )
{
$codigo = $cookies{'codigo'}-gt;value;
@arraydatos = $dbhlectura-gt;selectrow_array("SELECT DISTINCT codigo, nombre, apellido, id_persona FROM persona WHERE codigo = \'$codigo\'");
}
if (@arraydatos)
{
$ref = \@arraydatos;
($bogus,$nombreusuario,$apellidousuario,$idpersona)=@$ref;
}
else {$ref=""}
-]
[-
$dni=$fdat{donaid};
$fecha=$fdat{fecha};
-]
[$ if ($dni && $fecha ) $]
[- sub compruebadate {
use POSIX qw/strftime/;
my $anno = strftime "%Y", localtime;
$_=shift;
if (not(m/(\d\d)-(\d\d)-(\d\d\d\d)/)) {push @erroresdate, "La fecha no cumple el formato, revísela. (DD-MM-AAAA)\n";}
return @erroresdate;
}
-]
[- sub compruebadni {
my $dnip=shift;
$_=$dnip;
if (not(m/^(\d+)$/)) {push @erroresdni, "El dni que ha introducido no es válido, por favor, asegúrese de que no incluye espacios ni caracteres que no sean dígitos.\n";}
return @erroresdni;
}
-]
[-
@edate= compruebadate($fecha);
@edni = compruebadni($dni);
-]
[$ if (not(@edate||@edni)) $]
[-
$autentificable = "SELECT DISTINCT id_persona, nombre, apellido FROM persona WHERE fecha_nacimiento = \'$fecha\' and dni = \'$dni\'";
$sthautentificable = $dbhlectura-gt;prepare($autentificable);
$sthautentificable-gt;execute;
@arrayautent = $sthautentificable-gt;fetchrow_array;
-]
[$ if (not(@arrayautent)) $]
[-
$autentificable = "SELECT DISTINCT id_persona, nombre, apellido FROM persona_sin_verif WHERE fecha_nacimiento = \'$fecha\' and dni = \'$dni\'";
$sthautentificable = $dbhlectura-gt;prepare($autentificable);
$sthautentificable-gt;execute;
@arrayautent = $sthautentificable-gt;fetchrow_array;
-]
[$ if (not(@arrayautent)) $]
[- push @egeneral,('Vd. no ha introducido aún sus datos para solicitar ser miembro de la asociación o ha cometido algun error en sus datos; si tiene algun problema, por favor <A HREF="mailto:alumni-admin@dat.etsit.upm.es"gt;contacte con el administrador</Agt;.'); -]
[$ else $]
[- push @egeneral,('Ya hemos recibido sus datos pero lamentamos decirle que aún no hemos podido verificarlos. No podrá acceder, aún, a las consultas de la base de datos pero sí podra <A HREF="datos/modificadatos.epl"gt;modificar</Agt; sus datos si lo desea. '); -]
[- ($aid,$anom,$aape) = @arrayautent; -]
[-
$sec = strftime "%S", localtime;
$criptado = crypt $anom, "$sec";
$metecodigo="UPDATE persona_sin_verif SET codigo=\'$criptado\' WHERE id_persona=\'$aid\'";
$sthcodigo=$dbhescritura-gt;prepare($metecodigo);
$sthcodigo-gt;execute();
-]
<META HTTP-EQUIV="Set-Cookie" CONTENT="codigo =[+ $criptado +]"gt;
[-
$aumentaacceso="UPDATE accesos SET num_accesos = num_accesos + 1 WHERE persona_sin_verif.id_persona=\'$aid\'";
$aumentaaccesotemp="UPDATE accesos SET num_accesos_parcial = num_accesos_parcial +1 WHERE persona_sin_verif.id_persona=\'$aid\'";
$marcaultimoacceso="UPDATE accesos SET fecha_ultimo_acceso = \'now\' WHERE persona_sin_verif.id_persona=\'$aid\'";
$sthaumenta=$dbhescritura-gt;prepare($aumentaacceso);
$sthaumenta-gt;execute();
$sthaumentatemp=$dbhescritura-gt;prepare($aumentaaccesotemp);
$sthaumentatemp-gt;execute();
$sthmarca=$dbhescritura-gt;prepare($marcaultimoacceso);
$sthmarca-gt;execute();
-]
[$ endif $]
[$ else $]
[- ($aid,$anom,$aape) = @arrayautent; -]
[-
$sec = strftime "%S", localtime;
$criptado = crypt $anom, "$sec";
$metecodigo="UPDATE persona SET codigo=\'$criptado\' WHERE id_persona=\'$aid\'";
$sthcodigo=$dbhescritura-gt;prepare($metecodigo);
$sthcodigo-gt;execute();
-]
<META HTTP-EQUIV="Set-Cookie" CONTENT="codigo =[+ $criptado +]"gt;
[-
$aumentaacceso="UPDATE accesos SET num_accesos = num_accesos + 1 WHERE persona.id_persona=\'$aid\'";
$aumentaaccesotemp="UPDATE accesos SET num_accesos_parcial = num_accesos_parcial +1 WHERE persona.id_persona=\'$aid\'";
$marcaultimoacceso="UPDATE accesos SET fecha_ultimo_acceso = \'now\' WHERE persona.id_persona=\'$aid\'";
$sthaumenta=$dbhescritura-gt;prepare($aumentaacceso);
$sthaumenta-gt;execute();
$sthaumentatemp=$dbhescritura-gt;prepare($aumentaaccesotemp);
$sthaumentatemp-gt;execute();
$sthmarca=$dbhescritura-gt;prepare($marcaultimoacceso);
$sthmarca-gt;execute();
-]
[$ endif $]
[$ endif $]
[$ endif $]
[$ if ($falloconex) $]
[- $udat{errores}="Sin conexión";
-]
<META http-equiv="refresh" content="1;URL=error/fallo_conexion.epl"gt;
</headgt;
<bodygt;
</bodygt;
</htmlgt;
[$ else $]
[$ if ($falloconex) $]
[- $udat{errores}="Sin conexión";
-]
<META http-equiv="refresh" content="1;URL=error/fallo_conexion.epl"gt;
</headgt;
<bodygt;
</bodygt;
</htmlgt;
[$ else $]
</HEADgt;
<BODY BGCOLOR="white"gt;
<H1gt;Bienvenido</H1gt;
<Pgt;Bienvenido al servidor de la Asociación de Antiguos Alumnos.
<table border="0" cellpadding="0" cellspacing="0"gt;
<trgt;
<td width="280" valign="top" align="left"gt;
[$ if not($aid) $]
[$ if (not($ref)) $]
<FORM METHOD="POST" ACTION="index.epl"gt;
D.N.I.:<INPUT TYPE="PASSWORD" NAME="donaid" TABINDEX="1" SIZE="10"gt;
Fecha de Nacimiento:
(DD-MM-AAAA) <INPUT TYPE="TEXT" NAME="fecha" TABINDEX="2" SIZE="10"gt;
<input type="submit" name="autent" value="Autentifícame"gt;
</FORMgt;
[$ endif $]
[$ if ($ref) $]
[+ $nombreusuario +] [+ $apellidousuario +]<brgt;
Conectado al servidor, con los correspondientes permisos de usuario.
[$ endif $]
[$ endif $]
[$ if ($aid) $]
Ud. acaba de ser reconocido como<brgt;
[+ $anom +] [+ $aape +],<brgt;
Bienvenido al servidor.
[$ endif $]
[$ if ($dni) $]
[$ if (@edate||@edni||@egeneral) $]
[$ foreach $msg (@edni) $]
[+ $msg +]<HRgt;
[$ endforeach $]
[$ foreach $msg (@edate) $]
[+ $msg +]<HRgt;
[$ endforeach $]
[$ foreach $msg (@egeneral) $]
[+ $msg +]<HRgt;
[$ endforeach $]
[$ else $]
No olvide que una vez su acceso al servidor ha sido reconocido, ya puede
acceder tanto a las <a href="consultas/"gt;consultas</Agt; como a
la <A HREF="datos/modificadatos.epl"gt;modificación o actualización</Agt; de sus datos guardados aquí.
[$ endif $]
[$ endif $]
[$ if (not($aid)) $]
[$ if (not($ref)) $]
<FORM METHOD="POST" ACTION="datos/nuevosocio.epl"gt;
Nombre: <INPUT TYPE="TEXT" NAME="nombre" TABINDEX="3" SIZE="20"gt;
Apellidos: <INPUT TYPE="TEXT" NAME="apellidos" TABINDEX="4" SIZE="20"gt;
<input type="submit" name="nuevosocio" value="Comenzar"gt;
</FORMgt;
[$ endif $]
[$ endif $]
</BODYgt;
</HTMLgt;
[$ endif $]
[$ endif $]
[- if (defined($dbhescritura)) {
eval{$dbhescritura-gt;disconnect or warn "La desconexión de la base de datos falló: $DBI::errstr\n";}};
-]
[- if (defined($dbhlectura)) {
eval{$dbhlectura-gt;disconnect or warn "La desconexión de la base de datos falló: $DBI::errstr\n";}};
-]
PIE LISTADO 3: Entrada al servidor