Redirecciones de url en script perl

Es muy común que en lugar de devolver una página web, un script tenga que redirigir hacia otro lugar. Veamos cómo hacer una redirección de url (url redirection) en un script Perl

Imprimir directamente la cabecera Location

Para ciertas cosas Perl resulta mágico: sólo con una línea de código puede resolver el problema

#!/usr/bin/perl
print "Location: http://example.com/\n\n"; #Status code 302

Importante: la redirección tiene que ser lo primero que se envíe, dado que corresponde a las cabeceras HTTP de la respuesta. En el momento en que se imprimen los 2 saltos de línea (\n\n) explícitamente se indica la terminación de esas cabeceras. Todo lo que venga después será tratado como contenido y presentado por el navegador.

 

Usar el módulo CGI

Mediante la función redirect del módulo CGI se puede hacer la redirección también de una manera muy sencilla:

#!/usr/bin/perl
use CGI qw(:standard);
print redirect('http://example.com'); #Status code 302

De manera análoga, se puede crear una instancia de CGI y sobre la misma invocar el método redirect.

#!/usr/bin/perl
use CGI qw(:standard);
my $q = new CGI;
print $q->redirect('http://example.com'); #Status code 302

En ninguno de los casos, tal como en el ejemplo anterior, se debe imprimir otras cabeceras previamente.

Adicionamente, se soportan parámetros nombrados en la invocación:

print $q->redirect(
 -url => 'http://example.com',
 -status => '301 Moved Permanently'
);

Es a través del parámetro -status que se puede establecer el estado de la redirección. El estado por defecto en perl, si no es especificado, es 302.

 

Estados posibles para la redirección

HTTP define los siguientes códigos de estado para la redirección

  • 301 Moved Permanently
    • Esta petición y todas las siguientes se deben repetir con la url indicada
  • 302 Found
    • La petición debe repetirse con otra url. Futuras peticiones deben seguir utilizando la url original.
    • Este estado ha sido reemplazado por 303 y 307:
      • HTTP/1.0 requería que el cliente realizara una redirección temporal (la frase original de la descripción era “Moved Temporarily”) sin cambiar el método utilizado en la petición original. Pero muchos navegadores implementaron este código forzando el método de la nueva petición a GET, sin importar el utilizado en la petición original. Es un ejemplo de cuando la práctica de la industria termina contradiciendo el estándar.
      • HTTP/1.1 agregó nuevos códigos de estado a fin de distinguir ambos comportamientos: 303 para cambiar el método a GET y 307 para preservar el método originalmente usado.
      • Muchos frameworks y aplicaciones web lo siguen soportando para mantener la compatibilidad hacia atrás.
  • 303 See Other (desde HTTP/1.1)
    • La petición debe repetirse con otra url usando el método GET.
    • Cuando se recibe en respuesta a POST (o PUT/DELETE), el cliente debe asumir que el servidor ha recibido los datos y debe solicitar una petición GET a la url indicada
  • 307 Temporary Redirect (desde HTTP/1.1)
    • Esta petición debe repetirse con otra url. Futuras peticiones deben seguir utilizando la url original.
    • A diferencia de 302, no permite que cambie el método cuando se vuelve a realizar la petición.
  • 308 Permanent Redirect
    • Esta petición y todas las siguientes se deben repetir con la url indicada
    • A diferencia de 301, no permite que cambie el método cuando se vuelve a realizar la petición.

Si bien es posible utilizar cualquier código de estado diferente a los especificados, probablemente se rompa la redirección. Notar también que la frase a continuación del código se espera también como parte del mismo.

OBS: los códigos 304, 305 y 306 existen pero no se utilizan para la redirección.

Anuncios

Acceder a página protegida con htaccess mediante Perl (LWP)

Ya vimos como acceder a una página que se encuentra protegida por htaccess desde un script PHP (con curl y con file_get_contents). Ahora vamos a hacer lo mismo con LWP en Perl. Las principales diferencias con los métodos vistos para PHP son que en este caso se debe indicar junto a las credenciales:

  • el dominio con el puerto
  • el “realm” (ámbito), que representa el valor del AuthName definido en el archivo htaccess.
    • Importante: Deben coincidir perfectamente

Entonces, el bloque de código modelo para implementar LWP es el siguiente:

 #!/usr/bin/perl
 use strict;
 use LWP;
 
 my $url = 'http://www.destino.com/secure/index.cgi';
 
 my $domain = 'www.destino.com';
 my $port = 80;
 my $username = 'ht_user';
 my $password = 'ht_pass';
 my $realm = 'Secured directory';
 
 my $ua = LWP::UserAgent->new();
 
 //Credenciales htaccess 
 $ua->credentials( "$domain:$port", $realm ,$username => $password);

 my $response = $ua->get($url);

 print "Content-type:text/html\n\n";
 my $data = $response->content;

En este ejemplo, obtendremos dentro la variable $data el contenido de la página index.cgi, para poder utilizarlo en el resto del script.

Se puede utilizar este medio para invocar otros scripts que devuelvan urls, json, etc. como si fuera un API a la aplicación.

 

Si desconocemos el “realm” podemos obtenerlo haciendo un get inicial de la url sin credenciales y leyendo el header WWW-Authenticate de la respuesta. El resultado para el ejemplo presentado devolvería:

Basic realm="Secured directory"

Información sobre módulos core de Perl

Es importante conocer si un módulo pertenece o no al core de Perl y a partir de qué versión.

Como primer alternativa tenemos Perldoc, donde debemos:

  1. elegir la versión deseada de Perl, en el combo de la izquierda
  2. seleccionar la primer letra del módulo que buscamos en el apartado Modules

si el módulo aparece en el listado, entonces pertenece al core, en la versión elegida.

Pero si necesitamos más información esta forma es bastante limitada y poco productiva. Teniendo instalado Perl, accedemos al directorio bin desde la línea de comandos y ejecutamos corelist con alguno de sus parámetros.

Este comando utiliza internamente el módulo Module::CoreList para generar la salida. También podríamos invocarlo desde un script que desarrollemos si necesitamos realizar alguna tarea más específica.

Listar versiones de perl de las cuales se tiene información

corelist -v

Module::CoreList has info on the following perl versions:
 5
 5.000
 5.001
 5.002
 5.00307
 5.004
 5.00405
 5.005
 ...
 v.5.17.8

La última será la versión de perl que tenemos instalada.

Listar versiones de perl y su fecha de lanzamiento

corelist -r [<PERL_VERSION>]

Ejemplo:

corelist r

Module::CoreList has release info for the following perl versions:
 5           1994-10-17
 5.000       1994-10-17
 5.001       1995-03-14
 5.002       1996-02-29
 5.00307     1996-10-10
 5.004       1997-05-15
 5.00405     1999-04-29
 5.005       1998-07-22
 .....

Listar módulos core y su versión, para cierta versión de perl

corelist -v <PERL_VERSION>

Ejemplo:

corelist -v 5.14.0

The following modules were in perl 5.14.0 CORE
 AnyDBM_File                                      1.00
 App::Cpan                                        1.5701
 App::Prove                                       3.23
 App::Prove::State                                3.23
 App::Prove::State::Result                        3.23
 App::Prove::State::Result::Test                  3.23
 Archive::Extract                                 0.48
 Archive::Tar                                     1.76
 Archive::Tar::Constant                           1.76
 Archive::Tar::File                               1.76
 ....

Listar las versiones de un módulo

corelist -a <MODULO>

Ejemplo:

corelist -a Archive::Zip

Data for 2013-01-20
Archive::Zip was not in CORE (or so I think)

corelist -a Archive::Tar

Data for 2013-01-20
Archive::Tar was first released with perl v5.9.3
  v5.9.3     1.26_01
  v5.9.4     1.30_01
  v5.9.5     1.32
  v5.10.0    1.38
  v5.10.1    1.52
  v5.11.0    1.54
  v5.11.1    1.54
  v5.11.2    1.54
  v5.11.3    1.54
  .....

Ver las diferencias entre 2 versiones de perl

corelist --diff <PERL_VERSION> <PERL_VERSION>

Ejemplo:

corelist --diff 5.10.1 5.12.5

App::Cpan                             (absent)     1.5701
 Archive::Extract                          0.34       0.38
 Archive::Tar                              1.52       1.54
 Attribute::Handlers                       0.85       0.87
 AutoLoader                                5.68       5.70
 B                                         1.22       1.23
 B::Concise                                0.76    0.78_01
 B::Debug                                  1.11       1.12
 B::Deparse                                0.89     0.9701
 B::Lint                                   1.11    1.11_01
 B::Lint::Debug                         (undef)       0.01
 CGI                                       3.43       3.49
 CGI::Apache                               1.00       1.01
 CGI::Carp                              1.30_01       3.45
 .........

Controlar el tiempo de validez de un mensaje entre aplicaciones

Supongamos que tenemos 2 aplicaciones, cada una en su propio servidor, la cuales necesitan comunicarse ciertos mensajes. El mensaje que se origina en una aplicación contiene información de la fecha y hora en la que se generó. Cuando se envía a la aplicación receptora, ésta verifica la fecha y hora de generación contra la actual y determina si se excedió o no el tiempo de validez del mensaje. Si ese fuera el caso, lo descartaría.

Ahora bien, puede suceder que ambos servidores no estén sincronizados y entonces la verificación no se realice de manera adecuada.

Para solucionarlo podemos hacer uso de un servidor ntp que nos brinde un timestamp y utilizarlo en cada una de las aplicaciones, en lugar de la hora del servidor al que pertenece. En el caso de Argentina, podemos obtener la dirección de un servidor ntp desde http://www.pool.ntp.org/es/zone/ar.  Es posible que deban aplicar algunas cuestiones adicionales de seguridad y que además existan muchas otras soluciones.

A continuación les dejo un ejemplo de un script perl que recibe como parámetro la dirección de un servidor ntp y devuelve la información obtenida de la comunicación:

#!/usr/bin/perl -w
#
# sntp.pl
#
my $PgmName = "SNTP - Get time from an NTP time server";
my $VERSION = "0.2b, 2004-12-10";
#

=head1 SNTP - Get time from an NTP time server

 This program has been written just for fun to take a short look on the NTP stuff
 and to learn about the NTP/SNTP data :
 get time information from an NTP time server using SNTP (Simple Network Time
 Protocol, RFC-2030), analyze the protocol information, and display what we've got.
 Finally optionally set the local unix system clock, if you wish.

 For real time synchronization, please use a more professional client software.

 (c) 2001, Ralf D. Kloth <ralf at kloth.net | ralf at qrq.de>, QRQ.software.
 All rights reserved.
 This program is free software; you can redistribute it and/or modify it
 under the same terms as Perl itself 
    (Perl Artistic License, http://dev.perl.org/licenses/artistic.html).
 THIS PRGOGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESSED OR IMPLIED
 WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
 MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
 You are using this program at own risk.

 Written and tested under Perl V 5.6.0 on Linux 2.4.

 Revision history: 
   V0.1,  2000-09-30, first version
   V0.2,  2001-03-31, published version
   V0.2b, 2004-12-10, minor patch by Tim Braun

 usage: perl sntp.pl [-u (update the unix clock)] <timeserver>

 Attention: Year-2036 problem:
 This program will not work after the NTP timestamp rollover on 2036-02-07.

 Finally, RFC-2030 recommends the following on stratum usage:
 As the load on the hosts supporting NTP primary (stratum 1) time service is heavy
 and always increasing, clients should avoid using the primary servers whenever
 possible. In most cases the accuracy of the NTP secondary (stratum 2) servers is
 only slightly degraded relative to the primary servers and, as a group, the
 secondary servers may be just as reliable.
 List of stratum 2 servers: http://www.eecis.udel.edu/~mills/ntp/clock2.htm

=cut 

use strict;
use IO::Socket;
use Time::HiRes qw(time);
use Getopt::Std;
  
sub usage { # print a short 'usage` message and exit
  print "usage: perl $0 <timeserver>\n";
  print "                      [-u (update the unix clock)]\n";
  exit;
}

use vars qw($opt_h $opt_u); # command line options

  print "$0, $PgmName, V $VERSION \n";
  # handle the commandline options
  getopts('hu');            # look for -h and -u
  $opt_h && usage;          # -h print usage message and exit
  (!$ARGV[0]) && usage;     # no server: print usage message and exit

  my $server = $ARGV[0];
  my $serverIPv4 ="";
  if (gethostbyname($server)) {
    $serverIPv4 = sprintf("%d.%d.%d.%d",unpack("C4",gethostbyname($server)));
  }

  my $timeout = 2;

  sub bin2frac { # convert a binary string to fraction
    my @bin = split '', shift;
    my $frac = 0;
    while (@bin) {
      $frac = ($frac + pop @bin)/2;
    }
    $frac;
  } # end sub bin2frac

  sub frac2bin { # convert a fraction to binary string (B32)
    my $frac = shift;
    my $bin ="";
    while (length($bin) < 32) {
      $bin = $bin . int($frac*2);
      $frac = $frac*2 - int($frac*2);
    }
    $bin;
  } # end sub frac2bin

  my ($LocalTime0, $LocalTime0F, $LocalTime0H, $LocalTime0FH, $LocalTime0FB);
  my ($LocalTime1, $LocalTime2);
  my ($LocalTime, $LocalTimeF, $LocalTimeT);
  my ($NetTime, $NetTime2, $Netfraction);
  my ($netround, $netdelay, $off);
  
  my ($Byte1, $Stratum, $Poll, $Precision,
      $RootDelay, $RootDelayFB, $RootDisp, $RootDispFB, $ReferenceIdent,
      $ReferenceTime, $ReferenceTimeFB, $OriginateTime, $OriginateTimeFB,
      $ReceiveTime, $ReceiveTimeFB, $TransmitTime, $TransmitTimeFB);
  my ($dummy, $RootDelayH, $RootDelayFH, $RootDispH, $RootDispFH, $ReferenceIdentT,
      $ReferenceTimeH, $ReferenceTimeFH, $OriginateTimeH, $OriginateTimeFH,
      $ReceiveTimeH, $ReceiveTimeFH, $TransmitTimeH, $TransmitTimeFH);
  my ($LI, $VN, $Mode, $sc, $PollT, $PrecisionV, $ReferenceT, $ReferenceIPv4);
  
  my $ntp_msg;  # NTP message according to NTP/SNTP protocol specification

  sub get_ntp_time {
  # open the connection to the ntp server,
  # prepare the ntp request packet
  # send and receive
  # take local timestamps before and after

    my ($remote);
    my ($rin, $rout, $eout) ="";
    my $ntp_msg;

    # open the connection to the ntp server
    $remote = IO::Socket::INET -> new(Proto => "udp", PeerAddr => $server,
                                      PeerPort => 123,
                                      Timeout => $timeout)
                                  or die "Can't connect to \"$server\"\n";

    # measure local time BEFORE timeserver query
    $LocalTime1 = time();
    # convert fm unix epoch time to NTP timestamp
    $LocalTime0 = $LocalTime1 + 2208988800;

    # prepare local timestamp for transmission in our request packet
    $LocalTime0F = $LocalTime0 - int($LocalTime0);
    $LocalTime0FB = frac2bin($LocalTime0F);
    $LocalTime0H = unpack("H8",(pack("N", int($LocalTime0))));
    $LocalTime0FH = unpack("H8",(pack("B32", $LocalTime0FB)));

    $ntp_msg = pack("B8 C3 N10 B32", '00011011', (0)x12, int($LocalTime0), $LocalTime0FB);
                   # LI=0, VN=3, Mode=3 (client), remainder msg is 12 nulls
                   # and the local TxTimestamp derived from $LocalTime1

    # send the ntp-request to the server
    $remote -> send($ntp_msg) or return undef;
    vec($rin, fileno($remote), 1) = 1;
    select($rout=$rin, undef, $eout=$rin, $timeout)
      or do {print "No answer from $server\n"; exit};

    # receive the ntp-message from the server
    $remote -> recv($ntp_msg, length($ntp_msg))
               or do {print "Receive error from $server ($!)\n"; exit};

    # measure local time AFTER timeserver query
    $LocalTime2 = time();

    $ntp_msg;

  } # end sub get_ntp_time 

  sub interpret_ntp_data {
  # do some interpretations of the data

    my $ntp_msg = shift;

    # unpack the received ntp-message into long integer and binary values
    ( $Byte1, $Stratum, $Poll, $Precision,
      $RootDelay, $RootDelayFB, $RootDisp, $RootDispFB, $ReferenceIdent,
      $ReferenceTime, $ReferenceTimeFB, $OriginateTime, $OriginateTimeFB,
      $ReceiveTime, $ReceiveTimeFB, $TransmitTime, $TransmitTimeFB) =
      unpack ("a C3   n B16 n B16 H8   N B32 N B32   N B32 N B32", $ntp_msg);

    # again unpack the received ntp-message into hex and ASCII values
    ( $dummy, $dummy, $dummy, $dummy,
      $RootDelayH, $RootDelayFH, $RootDispH, $RootDispFH, $ReferenceIdentT,
      $ReferenceTimeH, $ReferenceTimeFH, $OriginateTimeH, $OriginateTimeFH,
      $ReceiveTimeH, $ReceiveTimeFH, $TransmitTimeH, $TransmitTimeFH) =
      unpack ("a C3   H4 H4 H4 H4 a4   H8 H8 H8 H8   H8 H8 H8 H8", $ntp_msg);

    $LI = unpack("C", $Byte1 & "\xC0") >> 6;
    $VN = unpack("C", $Byte1 & "\x38") >> 3;
    $Mode = unpack("C", $Byte1 & "\x07");
    if ($Stratum < 2) {$sc = $Stratum;}
    else {
      if ($Stratum > 1) {
        if ($Stratum < 16) {$sc = 2;} else {$sc = 16;}
      }
    }
    $PollT = 2**($Poll);
    if ($Precision > 127) {$Precision = $Precision - 255;}
    $PrecisionV = sprintf("%1.4e",2**$Precision);
    $RootDelay += bin2frac($RootDelayFB);
    $RootDelay = sprintf("%.4f", $RootDelay);
    $RootDisp += bin2frac($RootDispFB);
    $RootDisp = sprintf("%.4f", $RootDisp);
    $ReferenceT = "";
    if ($Stratum eq 1) {$ReferenceT = "[$ReferenceIdentT]";}
    else {
      if ($Stratum eq 2) {
        if ($VN eq 3) {
          $ReferenceIPv4 = sprintf("%d.%d.%d.%d",unpack("C4",$ReferenceIdentT));
          $ReferenceT = "[32bit IPv4 address $ReferenceIPv4 of the ref src]";
        }
        else {
          if ($VN eq 4) {$ReferenceT = "[low 32bits of latest TX timestamp of reference src]";}
        }
      }
    }

    $ReferenceTime += bin2frac($ReferenceTimeFB);
    $OriginateTime += bin2frac($OriginateTimeFB);
    $ReceiveTime += bin2frac($ReceiveTimeFB);
    $TransmitTime += bin2frac($TransmitTimeFB);

  } # end sub interpret_ntp_data 

  sub calculate_time_data {
  # convert time stamps to unix epoch and do some calculations on the time data

    my ($sec, $min, $hr, $dy, $mo, $yr);

    $ReferenceTime -= 2208988800; # convert to unix epoch time stamp
    $OriginateTime -= 2208988800; 
    $ReceiveTime -= 2208988800; 
    $TransmitTime -= 2208988800; 

    $NetTime = scalar(gmtime $TransmitTime);
    $Netfraction = sprintf("%03.f",1000*sprintf("%.3f", $TransmitTime - int($TransmitTime)));
    ($sec, $min, $hr, $dy, $mo, $yr) = gmtime($TransmitTime);
    $NetTime2 = sprintf("%04d-%02d-%02d %02d:%02d:%02d", $yr+1900, $mo+1, $dy, $hr, $min, $sec);

    # calculate delay and difference
    $netround = sprintf("%+.4f",($LocalTime1 - $LocalTime2));
    $netdelay = sprintf("%+.4f",(($LocalTime1 - $LocalTime2)/2) - ($TransmitTime - $ReceiveTime));
    $off = sprintf("%+.4f",(($ReceiveTime - $LocalTime1) + ($TransmitTime - $LocalTime2))/2);

    $LocalTime = ($LocalTime1 + $LocalTime2) /2;
    $LocalTimeF = sprintf("%03.f",1000*sprintf("%.3f", $LocalTime - int($LocalTime)));
    ($sec, $min, $hr, $dy, $mo, $yr) = gmtime($LocalTime);
    $LocalTimeT = sprintf("%04d-%02d-%02d %02d:%02d:%02d", $yr+1900, $mo+1, $dy, $hr, $min, $sec);

  } # end sub calculate_time_data

  sub output_ntp_data { # raw data from $ntp_msg
  # output the information we have

    my %LItext = (  "0" => "no warning",
                    "1" => "last minute of current day has 61 sec",
                    "2" => "last minute of current day has 59 sec",
                    "3" => "alarm condition (clock not synchronized)",
                 );
    my %Modetext = ("0" => "reserved",
                    "1" => "symmetric active",
                    "2" => "symmetric passive",
                    "3" => "client",
                    "4" => "server",
                    "5" => "broadcast",
                    "6" => "reserved for NTP control message",
                    "7" => "reserved for private use",
                   );

    my %Stratumtext = (
                    "0" => "unspecified or unavailable",
                    "1" => "primary reference (e.g. radio clock)",
                    "2" => "2...15: secondary reference (via NTP or SNTP)",
                    "16" => "16...255: reserved",
                       );

    print "Local Transmit Timestp : " . $LocalTime0 . "\n";
    print "The ntp server [$server $serverIPv4] sent the following data:\n";
    print "Byte1                  : " . ord($Byte1) . "\n";
    print "  Leap Indicator (LI)  : $LI [" . $LItext{$LI} . "]\n";
    print "  Version number (VN)  : $VN [NTP/SNTP version number]\n";
    print "  Mode                 : $Mode [" . $Modetext{$Mode} . "]\n";
    print "Stratum                : $Stratum [" . $Stratumtext{$sc} . "]\n";
    print "Poll Interval          : $Poll [2**$Poll = $PollT sec max interval between successive msgs]\n";
    print "Clock Precision        : $Precision [2**$Precision = $PrecisionV]\n";
    print "Root Delay             : $RootDelayH$RootDelayFH [$RootDelay sec]\n";
    print "Root Dispersion        : $RootDispH$RootDispFH [$RootDisp sec]\n";
    print "Reference Identifier   : $ReferenceIdent $ReferenceT \n";
    print "Reference Timestamp    : $ReferenceTimeH.$ReferenceTimeFH [" .
                                    sprintf("%10.5f",$ReferenceTime) . "]\n";
    print "Originate Timestamp    : $OriginateTimeH.$OriginateTimeFH [" .
                                    sprintf("%10.5f",$OriginateTime) . "]\n";
    print "Receive Timestamp      : $ReceiveTimeH.$ReceiveTimeFH [" .
                                    sprintf("%10.5f",$ReceiveTime) . "]\n";
    print "Transmit Timestamp     : $TransmitTimeH.$TransmitTimeFH [" .
                                    sprintf("%10.5f",$TransmitTime) . "]\n";
    print "\n";

  } # end sub output_ntp_date

  sub output_ntp_data2 { # interpreted time data
  # output the information we have

    print "Interpreted results, converted to unix epoch (sec since 1970-01-01 00:00:00):\n";
    print "Reference Timestamp    : " . sprintf("%10.5f",$ReferenceTime) .
          " [last sync of server clock with ref]\n";
    print "Originate Timestamp    : " . sprintf("%10.5f",$OriginateTime) .
          " [returned Local Transmit Timestamp]\n";

    print "Receive Timestamp      : " . sprintf("%10.5f",$ReceiveTime) .
          " [request packet arrived at server]\n";
    print "Transmit Timestamp     : " . sprintf("%10.5f",$TransmitTime) .
          " [this reply departed the server]\n";

    print "Net time UTC           : $NetTime +$Netfraction ms\n";
    print "                         $NetTime2.$Netfraction\n";

    # delay and difference
    print "Network roundtrip time : $netround sec";
    if (abs($netround) > 1) {print " <-- high roundtrip time, try another server closer to you";}
    print "\n";
    print "Network delay          : $netdelay sec";
    if (abs($netdelay) > 1) {print " <-- high delay time, try another server closer to you";}
    print "\n";

    print "Local Timestamp        : $LocalTime \n";
    print "Local time UTC         : $LocalTimeT.$LocalTimeF\n";

  } # end sub output_ntp_data2

  sub correct_localclock {
  # set the unix clock to the nearest second
    my $off = shift;
    $off = sprintf("%.f", $off);
    print "\nSet local system clock: ";
    system("date --set=\'$off seconds\'");
  } # end sub correct_localclock

  # main *********************************************************************

  print "Connecting to $server\n";

  $ntp_msg = get_ntp_time;

  interpret_ntp_data($ntp_msg);

  # Check if the received packet is the correct reply to our request:
  # it is correct, if our original transmit time we sent in the Transmit Time field
  # of our request packet shows up in the Originate Time field of the received reply.
  if (($LocalTime0H . $LocalTime0FH) ne ($OriginateTimeH . $OriginateTimeFH)) {
    print "*** The received reply seems to be faulty and NOT the reply to our request packet:\n";
    print "*** The OriginateTime stamp $OriginateTimeH.$OriginateTimeFH of the received packet does not \n";
    print "***  show our Transmit Time $LocalTime0H.$LocalTime0FH.\n";
    exit;
  }

  # comment this one out, if you don't want to see these data
  output_ntp_data;    # raw data from $ntp_msg

  calculate_time_data;

  # comment this one out, if you don't want to see these data
  output_ntp_data2;   # interpreted and calculated time data

  # the final result: the difference report
  print "Clock Difference       : $off sec off between $server and local";
  if (abs($off) > 11000) {print " <-- check this !";}
  print "\n";

  # if this program is executed with system privileges under unix,
  # the unix clock may now be set to the nearest second
  $opt_u && correct_localclock($off);
  
__END__

 

Basado en:

http://www.kloth.net/software/sntp.php

Solucionar error de child process al ejecutar scripts CGI con código Perl desde Apache

Es posible que cuando intentemos acceder mediante un navegador a un script CGI con código Perl servido por Apache, obtengamos un Internal Server Error (500) y al ver el log de errores correspondiente veamos las siguientes líneas:

[Mon Sep 01 19:26:36 2014] [error] [client 127.0.0.1] (OS 2)El sistema no puede encontrar el archivo especificado.  : couldn't create child process: 720002: script.cgi, referer: http://localhost
[Mon Sep 01 19:26:36 2014] [error] [client 127.0.0.1] (OS 2)El sistema no puede encontrar el archivo especificado.  : couldn't spawn child process: C:/www/script.cgi, referer: http://localhost

En inglés el mensaje es parecido:

[Mon Sep 01 19:26:36 2014] [error] [client 127.0.0.1] (OS 2)The system cannot find the file specified.  : couldn't create child process: 720002: script.cgi, referer: http://localhost
[Mon Sep 01 19:26:36 2014] [error] [client 127.0.0.1] (OS 2)The system cannot find the file specified.  : couldn't spawn child process: C:/www/script.cgi, referer: http://localhost

Para solucionarlo simplemente debemos:

  1. Abrir el script.cgi con un editor de textos
  2. Ver la ruta hacia perl en la primer línea (shebang)
  3. Verificar que el ejecutable de perl esté en esa ruta

Si no hay coincidencia, tenemos 2 alternativas:

  1. Copiar el ejecutable de perl a la ruta donde lo busca el script
    • Lo recomiendo cuando son muchos los scripts que apuntan a esa ruta en el shebang o cuando es la ruta más común “usr/bin/perl
  2. Cambiar la ruta en el script para que apunte al directorio donde está instalado perl
    • Lo recomiendo cuando sea un único script o cuando tenemos perl en el directorio más común “usr/bin

Tratamiento de los errores del módulo DBI de Perl

Cuando utilizamos el módulo DBI para conectarnos a una base de datos en Perl, existen algunos atributos que definen cómo tratar las alertas y errores que sucedan:

PrintWarn

Valor por defecto: Si los warnings de Perl están activados, es 1. De lo contrario, 0.

Controla la impresión de los warnings que determina el driver. Utiliza la función warn.

Como los drivers lo utilizan poco, considero que se puede dejar en el valor por defecto (sea cual fuere)

PrintError

Valor por defecto: 1

Además de devolver los errores de la forma normal, fuerza warnings. Utiliza la función warn.

Considero que es correcto generar los warnings adicionales, manteniendo el valor por defecto, para que se alerten todos los errores.

RaiseError

Valor por defecto: 0

En lugar de devolver los errores de la forma normal, fuerza una excepción. Utiliza la función die. Si está activado, por lo general se desactiva PrintError. Pero si ambos estuvieran activados, se procesa primero PrintError (warning) y luego RaiseError (excepción). En el momento de la conexión, curiosamente, se procesan al revés!

Considero que debe activarse cuando el uso de la base de datos sea esencial para la aplicación (lo más común), de lo contrario la ejecución continúa aún cuando el módulo DBI detecte un error.

 

Los valores por defecto de estos atributos se establecen cuando se realiza la conexión:

my $dbh = DBI->connect("<DBI:CONNECTION>", "<DB_USER>", "<DB_PASS>");

En este caso: PrintWarn depende de si los warnings están activados, PrintError será 1 y RaiseError tendrá el valor 0.

 

Los atributos se pueden redefinir en el momento de la conexión:

my $dbh = DBI->connect("<DBI:CONNECTION>", "<DB_USER>", "<DB_PASS>",{RaiseError => <BOOL>, PrintError => <BOOL>, PrintWarn => <BOOL>});

Ejemplo:

my $dbh = DBI->connect("dbi:mysql:test:localhost:3306", "test", "secure",{RaiseError => 1, PrintError => 0});

En este caso determinamos el forzar una excepción ante un error, desactivando el warning que su hubiera generado en su lugar.

 

También se pueden modificar en cualquier momento posterior para realizar alguna acción en particular:

Ejemplo:

$dbh->{RaiseError} = 0;

 

Se puede agregar código Perl para manejar los warnings y las excepciones generadas en cada caso.

 

Basado en:

http://search.cpan.org/~timb/DBI-1.631/DBI.pm

http://oreilly.com/catalog/perldbi/chapter/ch04.html

Manejar warnings y excepciones en Perl

Cuando el código de nuestro script Perl genera warnings o excepciones ambos se envían al STDERR (una de los flujos estándares de datos). Adicionalmente podemos “atraparlos” (catch) y “manejarlos” (handle) con ciertos bloques de código.

Los warnings se pueden atrapar de la siguiente manera:

local $SIG{__WARN__} = sub {
  my $message = shift;
  #CODIGO DE TRATAMIENTO DE WARNING
};

Ejemplo:

sub db_connect {
  ...
  local $SIG{__WARN__} = sub {
    my $message = shift;
    return 'DB_CONN_ERROR';
  };
  ...
  my $dbh = DBI->connect("dbi:mysql:test:localhost:3306", "test", "secure",{PrintError => 1});

Así, cuando falle la conexión a la base de datos la función devolverá el código de error correspondiente para que la aplicación responda a esa situación.

Las excepciones se pueden atrapar de manera análoga a los warnings:

local $SIG{__DIE__} = sub {
  my $message = shift;
  #CODIGO DE TRATAMIENTO DE EXCEPCION
};

En este caso, también existe una forma alternativa:

eval {
  #CODIGO QUE PUEDE GENERAR EXCEPCION
};
if( $@ ){
  #CODIGO DE TRATAMIENTO DE EXCEPCION
}

Ejemplo:

eval {
  mkpath($ubicacion);
}
if( $@ ){
  $path = $ubicacion;
}

Así, cuando falle la la creación del path indicado en la variable $ubicacion porque el mismo ya existe, se asigna a la variable $path.