#!/usr/bin/perl -w

$::VERSION	= "1.3";

$::LANG = "eu"; # for format DATE and langage discution ....

use strict;
use POSIX;
use IO;

$::DEBUG	= 00;

$::NAME_BASE	= "dumpdb";
my $c		= undef;
my ($i)		= 0;
my ($toto)	= undef; # J'ai pas d'imagination et alors ? :)
my ($a)		= 0;
my ($length)	= 0;
my ($length2)	= 0;
my ($length_champ)		= 0;
my ($buf)	= undef;
my (@buf)	= undef;
my ($tmp)	= undef;
my (@tmp)	= undef;
    my ($h, $l);
my ($c_old)	= undef;
# nom du champ, le nombre d'octet qui peut contenir, nombre d'octet que peut
# contenir la taille...
my (@champ)	= undef;
my (@data)	= undef;
my ($type)	= undef;	# Type de champ utilise dans *.DB
my ($taille)	= undef;	# La taille de $type, exprimee en Octets.
my ($numero);
my ($dossier);
my ($nom);
my ($prenom);
my ($docteur);

my ($TYPE_CHAMP)	= 120;	# Adresse de depart des tailles et
				# type de champ de la base
my ($NOM_FICHIER)	= "";
my ($TAILLE_NOM_FICHIER)	= 79; # Longeur maximum du nom de fichier.
my ($NB_CHAMP)		= 0;	# Nombre de champ, definie plus bas ...
$::TYPE			= 0;	# Type de champs de la base DB.
$::TAILLE		= 1;
$::C_NOM_CHAMP		= 2;	# Position du nom de fichier dans le tableau.
my ($addr_donnees)	= 2048;	# Adresse physique du lieu ou se trouve les
				# les donnees.
my ($pack)		= 2048;	# Taille des packets...
my ($no_pack)		= 0;	# Indique le nombre de packet ou le dernier No...
my ($markup)		= 0;	# Identifie une base Paradox 7 ou 8...
				# WARNING: no certain.
my ($nb_pack)		= 10;	# Nombre de packet a lire...
my ($ln_pack)		= 0;	# Longueur des packets a parcourrir.
my ($id)		= 0;	# Identite du packet
my ($id2)		= 0;	# Identite du packet
my ($no_champ)		= 0;	# Conteur pour le tableau d'indormation
				# sur l'enetete
$::NOM_CHAMP		= "";	# Contient la liste des noms de champs
$::SEP_DATE		= "/";
$::SEP			= ", ";
$::SILENCE		= 1; # 0 for OFF, 1 for ON

$::OUT			= "s";	# Sortie par defaut en SQL.
$::FORCE		= 0;	# Indique au programme de s'arreter s'il
$::CONVERT_return	= "";	# Permet de confertir les retour chariot (LF/FF)
				# rencontre une erreur identifie par le programmeur.

$::OPEN_ERROR		= "Erreur d'ouverture du fichier";
$::HELP = "

****************************************************************************
 (c) José MANS (dumpdb\@gyptis.frmug.org)
 (c) 1999, 2000
 (c) 2000 11 13
 Version : $::VERSION

 * No commercial use, contact me for commercial.


$0 [OPTIONS] file_base

  file_base		Le fichier au format paradox/Borland.

  [OPTIONS]

  -c 'Separation'	Indique le caractere de separation entre les champs.
  -d eu | us		Determine le format d'affichage de la date US ou EUropeain.
  -f			Force reding *.DB; no exit for error.
  -h			For Help!
  -o s  |  t | sf	Sortie format SQL (default)|  Texte! | Sql File

  			SQL => Work direct sql server.
  			SQL FILE => Out for file -> ';' end line.
  			'Texte' Out text only.

  -r			convert return line (^M and ^J) to space \" \".
  -s 			Ne rempli pas les champs qu'il ne connait pas...


****************************************************************************
";

&setup;

    open(IN, $::FILE) || die ("$::OPEN_ERROR : $::FILE");

    read(IN, $buf, 120 ); # h78
    # Je succe le HEADER
    RET1: while( ($c = substr($buf, $length, 1)) ne '' )
    {
       # On prends le No du dernier Packet de $pack octets
       if ( $length == 10 )
       {
          $no_pack = ord( $c ) + ord(substr($buf, $length+1, 1)) * 256 ;
          # On decremente $no_pack car celui_ci contient, reellement,
          # l'indentite du prochain packet non encore cree...
          $no_pack--;
          $length++;
          #$no_pack = ($no_pack * 256) + ord($c) - 1;
          #printf ("Dernier numero de packet = %s\n", $no_pack);
       }
       elsif ( $length == 33 )
       {
          $NB_CHAMP = ord($c);
          #printf("Nombre de Champ = %s\n", $NB_CHAMP);
       }
       elsif ( $length == 62)
       {
          $markup = &dec2asc( substr($buf, $length, 2), 'l' );
          printf("Markup = %s, (hl) = %s\n", $markup, substr($buf, $length, 2)  ) if ($::DEBUG >= 30);
          if ( !$::FORCE && $markup != 7951) #   h1F 0F
          {
             die("No identified file Paradox ... use -f for force read");
          }

          $length++;
       }
       #printf ("%s", $c);
       last RET1 if ($length >= ($TYPE_CHAMP) );
       #last RET1 if ($length >= (2048+6) );
       $length++;
    }


    ##########################################
    # Je decode le type des champs et leurs tailles. #
    ##########################################
    $buf = undef;
    read (IN, $buf, ($NB_CHAMP*2) );
    #printf("len= $length, char=%s\n", substr($buf, 0, 1));
    $length += ( $NB_CHAMP*2);
    for ($tmp = 0; $tmp <= ($NB_CHAMP - 1) *2; $tmp += 2)
    {
        #printf("%s: ", $tmp);
        $type	= ord(substr($buf, $tmp  , 1));
        $taille	= ord(substr($buf, $tmp+1, 1));
        $length_champ	+= $taille;
        printf("%s, %s\n", $type, $taille) if ($::DEBUG >= 10 );
        $champ[$no_champ] = [ $type, $taille ];
        $no_champ++;
    }


    #######################################
    # Ici je cherches les noms des champs #
    #######################################
    read (IN, $buf, ($NB_CHAMP * 4) + 4 );
    printf("len2= $length, char=%s\n", $c ) if ($::DEBUG >= 30);
    printf("len3= $length, char=%s\n", substr($buf, 0, 1)) if ($::DEBUG >= 30);
    printf("buf = %s\n", $buf) if ($::DEBUG >= 30);
    $length += ($NB_CHAMP * 4 + 4);

    my ($resultat)	= undef;
    my ($total)		= undef; # comptabilise l'espace que prends
    				 # les noms de champs... voir plus bas.

    RET1: for ($tmp = 0; $tmp <= $NB_CHAMP * 4; $tmp += 4)
    {
        # tmp =2 sert a ignorer les 2er octect inutiles ici...
        # ATTENTION: ici s'applique la regles des registres ASSEMBLEUR
        # HL, registre 16bits, sera en memoire LH. Octect Fort/faible.
        $l	= substr($buf, $tmp  , 1);
        $h	= substr($buf, $tmp+1  , 1);
        $i = &dec2asc($h);
        $a = &dec2asc($l);
        if ( !($tmp == 0) ) 
        {
        printf("LL: %s=%s,%s*256+%s, ", "RAS", $i, $a, $l ) if ($::DEBUG >= 30);

        # Si l'ancien (toto) est grand que le nouveau ($a)
        if ( $toto > $a)
        {
           $toto = 255 - $toto;
           $resultat = $toto + ($a + 1);
        }
        else
        {
           $resultat = $a - $toto;
        }
           $total += $resultat;
           printf("MM: %s\n", $resultat ) if ($::DEBUG >= 30);
        }

           $toto = $a;
    }

    ###############################
    # Je lis le nom du fichier.DB #
    ###############################
    read (IN, $buf, $TAILLE_NOM_FICHIER);
    $length += $TAILLE_NOM_FICHIER;


    # Je l'affiche. #
    RET1: for ($tmp = 0 ; $tmp < $TAILLE_NOM_FICHIER; $tmp++)
    {
        $c = substr($buf, $tmp, 1);
           $NOM_FICHIER .= $c;
        if ( ord($c) == 0)
        {
           last RET1;
        }
    }
    printf("%s\n", $NOM_FICHIER) if ($::DEBUG >= 30);

    ###############################
    # Je lis les noms des CHAMPS. #
    ###############################
    read (IN, $buf, $total);
    $length += $total;
    $no_champ	= 0;
    $toto	= '';

    RET1: for ($tmp = 0 ; $tmp < $total; $tmp++)
    {
        $c = substr($buf, $tmp, 1);
        if ( ord($c) == 0)
        {
        #$champ[$no_champ] = [ $type, $taille ];
           $champ[$no_champ] -> [$::C_NOM_CHAMP] = $toto;
           $no_champ++;
           $toto	= '';
           #printf("\n") if ($::DEBUG >= 20);
        }
        else
        {
           #printf("%s", $c ) if ($::DEBUG >= 20);
           $toto .= $c;
        }
    }

    my ($q) = '';
    $q = sprintf("CREATE TABLE nom_table (");
    for($tmp = 0; $tmp < ($NB_CHAMP-1); $tmp++)
    {
        #$q .= $champ[$tmp]->[$::C_NOM_CHAMP] . ",";
        $::NOM_CHAMP .= sprintf(q@'%s', @, $champ[$tmp]->[$::C_NOM_CHAMP]?$champ[$tmp]->[$::C_NOM_CHAMP]:'');
        $q .= sprintf(q@%s %s, @, $champ[$tmp]->[$::C_NOM_CHAMP], &return_sql_type_champ( $champ[$tmp]->[$::TYPE]  ) );
        printf("Champ: %s\n", $champ[$tmp]->[$::C_NOM_CHAMP] ) if ($::DEBUG >= 30);
    }

    # j'ajoute le dernie champ sans ",".
    #$::NOM_CHAMP .= sprintf(q@'%s' ) VALUES (@, $champ[$tmp]->[$::C_NOM_CHAMP]);
    $::NOM_CHAMP .= sprintf(q@'%s' @, $champ[$tmp]->[$::C_NOM_CHAMP]);
    $q .= sprintf(q@%s %s ) @, $champ[$tmp]->[$::C_NOM_CHAMP], &return_sql_type_champ( $champ[$tmp]->[$::TYPE]  ) );
    #$q .= $::NOM_CHAMP;
    #$q .= $champ[$tmp]->[$::C_NOM_CHAMP] . ") VALUES (";;
    printf("$q\n") if ($::DEBUG >= 20);





    #########################################
    # Je pointe vers l'adresse des donnees. #
    #########################################
    RET1: while( )
    {
       #printf ("_%-2d", ord($c) )
       last RET1 if ($length >= ($addr_donnees) );
       $c = getc(IN);
       #printf("$c: ");
       $length++;
    }

    #printf("\nDebut des donnees.\n");
    #RET1: for( $i = $nb_pack; $i ; $i-- )

    #ungetc(IN);
    RET1: while()
    {
       last RET1 if ($id2 >= $no_pack );
       $id	= (ord(getc(IN)) + ord(getc(IN)) * 256);
       $id2	= (ord(getc(IN)) + ord(getc(IN)) * 256);
       #printf("%s\n", $id2);
       $ln_pack	= (ord(getc(IN)) + ord(getc(IN)) * 256) ;
       #$ln_pack	= (ord(getc(IN)) + ord(getc(IN)) * 256) + $length_champ;
       for( $a = 0; $a <= ($pack - 7); $a++)
       {
          $c    = getc(IN);
          $tmp     .= $c;
          $buf[$a] = $c;
          #printf("$a, $buf[$a]");
       }
       &suck(@buf);
       $tmp = undef;
    }
    close(IN);
    #printf("Nm = %s\nJOSE", $i);

exit;

sub warning
{
    my ($warn) = @_;
    printf STDERR "%s\n", @_;
}

# arg = le numero de fonction. $taille = taille en octet de la fonction.
sub return_sql_type_champ
{
    my ($ret)	= '';
    my ($arg, $taille);
    # On verifie qu'il y bien le nombre de parametre desire.
    # Pour eviter des warning avec l'option -w de perl.
    if ($#_ == 1) { ($arg, $taille)	= @_; }
    else { ($arg)	= @_; $taille = 0; }

    if ($taille > 8)
    {
       &warning( sprintf("Warning: function numeric > 8 octets ; function number = %d", $arg)  );
       $ret = "text";
    }
    elsif ($arg == 1)
    {
       $ret = "text";
    }
    elsif ($arg == 2 )
    {
       $ret = "date";
    }
    elsif ($arg == 3 )
    {
       $ret = "int2";
    }
    elsif ($arg == 6 )
    {
       $ret = "";
    }
    elsif ($arg == 16 )
    {
       $ret = "";
    }
    elsif ($arg == 22)
    {
       $ret = "int4";
    }
    else
    {
       $ret = "text";
    }
    return ($ret);
}

# J'analizeur syntaxique!

sub setup
{
    my ($arg_o) = 0;

    if ( $#ARGV < 0) { printf("%s", $::HELP); exit(1) }

    RET1: for ($i = 0; $ARGV [$i]; $i++)
    {
       $_ = $ARGV[$i];
       if ($_)
       {
          if (/^\-/)
          {
             if (/\-d/)
             {
                $i++;
                $_ = $ARGV[$i];
                if (/us/ || /US/ ) { $::LANG = "us"; }
                else { die"Preciser language '-d eu' ou '-d us'"; }
                next RET1;
             }
             elsif (/\-f/)
             {
                $::FORCE = 1;
             }
             elsif (/\-h/)
             {
                printf("%s", $::HELP);
                exit;
             }
             elsif (/\-o/)
             {
                $i++;
                $_ = $ARGV[$i];
                if (/t/) { $::OUT = "t"; }
                elsif (/sf/) { $::OUT = "sf"; }
                else { die"Preciser le type de sortie '-o sf' ou '-o t'"; }
                next RET1;
             }
             elsif (/\-r/)
             {
                $::CONVERT_return = 1;
             }
             elsif (/\-s/)
             {
                $::SILENCE = 0;
             }
             elsif (/\-c/)
             {
                $i++;
                $_ = $ARGV[$i];
                if (/\\t/ || /t/ ) { $::SEP = "	"; }
                else { $::SEP = $ARGV[$i]; }
                next RET1;
             }
          }
          else
          {          
             if ($arg_o == 0)
             {
                $::FILE = $ARGV[$i];
             }
             $arg_o ++;
          }
       }
    }
}


sub suck
{
    my (@buf)	= @_;
    my ($o)	= 0;
    my ($var)	= undef;
    # Je suce les donnees!
    $length2 = 0;

#for ($o = 0; $o <= 100 ; $o++) { printf("%s", $buf[$o]); }
#die;
if (0)
{
    printf("
Longueur de Packets = $ln_pack
Nombre de Packets = $no_pack
Longueur de la fiche = $length_champ
Id: = $id
Id2 = $id2
");
}
    RET1: for( $length2 = 0; $length2 <= ($ln_pack) ; $length2 += $length_champ)
    {
       #printf("%s, ", $length2);
       for( $o = 0; $o <= $length_champ ; $o++)
       {
          $c = $buf[ $length2 + $o ];
          $var .= $c;
          #printf("$c");
       }
       #$ln_pack = $ln_pack - $length_champ;
       #printf("VAR: %s\n", length($var)  );
       &decoup($var);
       $var = undef;
    }
    #printf("\n\n%d\n", $c);
}

sub decoup
{
    my ($var) = @_;
    my ($n) = 0;
    my ($len) = 0;
    my ($l) = 0;
    my ($func) = 0;
    my ($vir) = undef;
    #$var =~ s/\0/_/g;
    #printf "\n";
    #$var  = substr($var, 2, length($var) );
    for ($no_champ = 0; $no_champ != $NB_CHAMP; $no_champ++)
    {
       #printf("taille: %s", $champ[$no_champ] -> [1]);
       $func = $champ[$no_champ] -> [$::TYPE];
       $len  = $champ[$no_champ] -> [$::TAILLE];
       if    ($func == 01)
       {
          #$data[$no_champ]  = substr($var, $n, $champ[$no_champ] -> [$::TAILLE]);

          # Je controle qu'il n'y ai pas de 0 dans la chaine de caractere.
          # Ensuite, si oui ou non, j'envois le nombres de caracteres dans
          # $l. Si je trouve 0 avant la fin de la chaine de caracteres
          # $l contiendra le nombre decaractere de la nouvelle chaine.

          # Cela sert a ne pas copier bettement la suite de caractere.
          # On analyse sa taille, sur celle declare par la fonction 01
          # Et on prends juste ce qu'il faut...
          RET1: for ($l=0; $l < $len; $l++)
          {
             if ( substr($var, $n + $l, 1) eq "\000")
             {
                #printf("l: %s \n", $l);
                last RET1;
             }
          }
          $data[$no_champ]  = substr($var, $n, $l);
          $n += $champ[$no_champ] -> [$::TAILLE];
       }
       elsif    ($func == 02)
       {
          #$data[$no_champ]  = substr($var, $n, $champ[$no_champ] -> [$::TAILLE]);
          #$data[$no_champ] = ctime ( 962386097  + 730202 );# +   dec2asc(substr($var, $n, $len), "l") );
          #use Time::gmtime;
          #use File::stat;

          $toto = &date (dec2asc(substr($var, $n, $len)) );
          #$data[$no_champ] = "DATE" if ($::SILENCE);
          $data[$no_champ] = $toto;
          $n += $champ[$no_champ] -> [$::TAILLE];
          #die " \n\n $data[$no_champ]  \n\n";
       }
       elsif    ($func == 03)
       {
          $data[$no_champ]  = dec2asc(substr($var, $n, $len) );
          $n += $champ[$no_champ] -> [$::TAILLE];
       }
       elsif    ($func == 06)
       {
          $data[$no_champ]  = dec2asc(substr($var, $n, $len), "l" );
          $data[$no_champ]  = substr($var, $n, $len);
          #$data[$no_champ] = "12345678";
          $n += $champ[$no_champ] -> [$::TAILLE];
       }
       elsif    ($func == 12)  #0C
       {
          # Je prossede pareil que pour la fontion 01
          RET1: for ($l=0; $l < $len; $l++)
          {
             if ( substr($var, $n + $l, 1) eq "\000")
             {
                #printf("l: %s \n", $l);
                last RET1;
             }
          }
          $data[$no_champ]  = substr($var, $n, $l);
          $n += $champ[$no_champ] -> [$::TAILLE];
       }
       elsif    ($func == 16)  #10
       {
          #$data[$no_champ]  = substr($var, $n, $champ[$no_champ] -> [$::TAILLE]);
          $data[$no_champ] = "1234567890" if ($::SILENCE);
          $n += $champ[$no_champ] -> [$::TAILLE];
       }
       elsif ($func == 22)
       {
          if ($len == 4)
          {
             # Status 'l' sert a calculer norlement, sans bit fort/faible...
             $data[$no_champ]  = &dec2asc(substr($var, $n, $len) );
             $n += $champ[$no_champ] -> [$::TAILLE];
          }
       }
       else
       {
          $data[$no_champ] = substr("12345678901234567890234567890*", 0, $champ[$no_champ] -> [$::TAILLE]) if ($::SILENCE);
          $n += $champ[$no_champ] -> [$::TAILLE];
       }
    }

    if ($::OUT eq "s" || $::OUT eq "sf")
    {
       $q = sprintf("INSERT INTO %s (%s) VALUES (", $::NAME_BASE, $::NOM_CHAMP);
       foreach (@data)
       {
          $q .= sprintf("'%s', ", $_?$_:'');
       }
       chop($q); chop($q); # Je vire le dernier , et l'esapce ' '

       if ($::OUT eq 'sf')
       {
          printf("$q);\n");
       }
       else
       {
          printf("$q)\n");
       }
    }
    else
    {
       $toto = $#data;
       $i = 0;
       foreach $tmp (@data)
       {
          if ($tmp)
          {
             if ($::CONVERT_return)
             {
                $tmp =~ s/\
/\ /g;
                $tmp =~ s/\
/\ /g;
             }
             printf("%s", $tmp);
          }
          else
          {
             printf("%s", '');
          }
          if ($i < $toto)
          {
             printf("%s", $::SEP);
          }
          $i++;
       }
    }
    printf("\n");
    return(@data);
    $dossier 	= substr($var, 2, 10);
    $nom 	= substr($var, 12, 50);
    $prenom	= substr($var, 62, 50);
    #printf("No: %s %s %s, %s\n", $vor, $dossier, $nom, $prenom);
    #printf "$var\n";
}


# Code un registre 32bits en ascii.
sub dec2asc
{
# Je Bidouille!!!
    my ($var);
    ($var, $::NO_SIGN) = @_;
    # $::NO_SIGN signie sans nombre negatif!

    my ($len) = length($var);

    if ($len == 1)
    {
       $var = ord($var);
    }
    elsif ($len == 2)
    {
       $var = &dec2asc_16($var);
    }
    elsif ($len == 4 || $len == 3)
    {
       if ($len == 3)
       {
          $var = &dec2asc_32($var);
       }
       else
       {
          $var = &dec2asc_32($var);
       }
    }
    elsif ($len == 8)
    {
       $var = &dec2asc_64($var);
    }
    return ($var);
}

sub dec2asc_16
{
    my ($var) = @_;
    my ($i)   = 0;
    my ($l); my ($h);

    # si $var = 0 return 0;
    $h = ord(substr($var, $i, 1));
    $l = ord(substr($var, $i+1, 1));

    if (!$h && !$l) {return ("0"); }

    $var =  ($h*256+$l) ;

    if ($::NO_SIGN) { return $var;}
    if ($h >= 128)
    {
       $var = $var - 32768;
    }
    else
    {
       $var = -(32768 - $var);
    }

    return($var);
} 

sub dec2asc_32
{
    my ($var) = @_;
    my ($i)	= 0;
    my ($l); my ($h); my ($l2); my ($h2);

    $h = ord(substr($var, $i++, 1));
    #die"D: $h\n";
    $l = ord(substr($var, $i++, 1));
    #printf("l:%s, %s\n", $l,$i);
    $h2 = ord(substr($var, $i++, 1));
    #printf("%s\n", $h2);
    $l2 = ord(substr($var, $i++, 1));
    #printf("%s\n", $l2);

    if (!$h && !$l && !$h2 && !$l2) {return ("0"); }

    $var = ( ($h*256+$l)*65536+($h2*256+$l2)  );

    if ($::NO_SIGN) { return $var;}
    if ($h >= 128)
    {
       $var = $var - 2147483648;
    }
    else
    {
       $var = -(2147483648 - $var);
       #$h =  127 - $h;
       #$sign = -1;
    }
    #printf("h:%s\n", $h);


    return ($var);
}

sub dec2asc_64
{
    my ($var) = @_;
    my ($l); my ($h); my ($l2); my ($h2);

    $h = &dec2asc_32( substr($var, 0, 4) );
    $l = &dec2asc_32( substr($var, 4, 4) );
    return($h * 18446744073709551616 + $l);
}

# 16: H * 256 + l
# 32: (H * 256 + l ) * 65536 + (H2 * 256 + l2)
#
# 2^8   =                                                 256
# 2^16  =                                              65 536
# 2^24  =                                          16 777 216
# 2^32  =                                       4 294 967 296
# 2^64  =                          18 446 744 073 709 551 616
# 2^128 = 340 282 366 920 938 463 463 374 607 431 768 211 456

sub date
{
    my ($jours, $mois, $annee) = Julian2Date(@_);
    if ($::LANG eq "eu" )
    {
       return ($jours . "$::SEP_DATE" . $mois . "$::SEP_DATE" . $annee );
    }
    elsif ($::LANG eq "us" )
    {
       return ($mois . "$::SEP_DATE" . $jours . "$::SEP_DATE" . $annee );
    }
}

sub Julian2Date
{
    my ($lJul) = @_;
    my $pnYear;
    my $pnDay;
    my $pnMonth;

    #my $lJul	= undef;

$::CYCLE_4	= (4 * 365 + 1);
$::CYCLE_400	= (100 * $::CYCLE_4 - 3);

 $lJul += 365;

 #// Cycle de 400 ans (de [400 * n] <85> [400 * n + 399])
 $pnYear = ($lJul / $::CYCLE_400) * 400;
 $lJul %= $::CYCLE_400;

 #// Supprime correction gr<E9>gorienne
 if ($lJul > 59) { $lJul += ($lJul - 59) / 36524; }

 #// Cycle de 4 ann<E9>es (de [4 * n] <E0> [4 * n + 3]) ; 
 #// la 1re est bissextile

 $pnYear += 4 * ($lJul / $::CYCLE_4);
 $lJul %= $::CYCLE_4;

 #// 29 f<E9>vrier ?
 if ($lJul == 59)
  {
   $pnDay = 29;
   $pnMonth = 2;
   return;
  }

 #// Supprime 29 f<E9>vrier de 1re ann<E9>e
 if ($lJul > 59) { $lJul--; }

 #// Calcule ann<E9>e
 $pnYear += $lJul / 365;


 #// Cycle annuel (ann<E9>e commune)
 $lJul %= 365;

 #// Corrige irr<E9>gularit<E9> des mois
 if ($lJul >= 59) { $lJul += 3;}
 if ($lJul >= 123) { $lJul++; }
 if ($lJul >= 185) { $lJul++; }
 if ($lJul >= 278) { $lJul++; }
 if ($lJul >= 340) { $lJul++; }

 #// Calcule mois et jour
 $pnDay = $lJul % 31 + 1;
 $pnMonth = $lJul / 31 + 1;


 # On enleve les virgules :) en C je sais pas comment faire!
 $pnYear =~ s/(.*)\.(.*)/$1/;
 $pnDay =~ s/(.*)\.(.*)/$1/;
 $pnMonth =~ s/(.*)\.(.*)/$1/;
 $pnYear = substr($pnYear, (length($pnYear)) - 2, 2);

    return($pnDay, $pnMonth, $pnYear);
}