#!/usr/bin/perl 

# (c) 1999, 2000, 2001.
# v1.0
# Use free, no commercial use!
# mans@gyptis.org


# Please contact me for commercial use!!!



use strict;
use POSIX;
use IO;

my $c		= undef;
my ($i)		= 0;
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 ($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 ($NAME_CHAMP)	= 79;	# Nom des champs.
my ($NB_CHAMP)		= 0;	# Nombre de champ, definie plus bas ...
$::TYPE			= 0;
$::TAILLE		= 1;
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 ($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;
$::SEP			= ", ";
$::HELP = "
****************************************************************************
 (c) José MANS (dumpdb\@gyptis.frmug.org)
 (c) 1999, 2000

 * 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.


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

&setup;

    open(IN, $::FILE);

    # Je succe le HEADER
    RET1: while( ($c = getc(IN)) ne '' )
    {
       # On prends le No du dernier Packet de $pack octets
       if ( $length == 10 )
       {
          $no_pack = ord( $c ) + ord(getc(IN)) * 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);
       }
       #printf ("%s", $c);
       last RET1 if ($length >= ($TYPE_CHAMP) );
       #last RET1 if ($length >= (2048+6) );
       $length++;
    }



    # Je decode les champs et leurs tailles.
    $buf = undef;
    RET1: while()
    {
       $buf .= $c;
       last RET1 if ( $length >= ($TYPE_CHAMP + $NB_CHAMP*2) );
       $c = getc(IN);
       $length++;
    }
    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);
        $champ[$no_champ] = [ $type, $taille ];
        $no_champ++;
    }
    #printf("\nLongueur de la chaine = %s Taille Terminee.\n", $length_champ); # 179





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

    #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;

# 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 (/\-t/)
             {
                $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;
       &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]);

          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] = "DATE";
          $n += $champ[$no_champ] -> [$::TAILLE];
       }
       elsif    ($func == 03)
       {
          $data[$no_champ]  = dec2asc(substr($var, $n, $len) );
          #$data[$no_champ] = "123";
          $n += $champ[$no_champ] -> [$::TAILLE];
       }
       elsif    ($func == 06)
       {
          $data[$no_champ]  = dec2asc(substr($var, $n, $len), "l" );
          #$data[$no_champ] = "12345678";
          $n += $champ[$no_champ] -> [$::TAILLE];
       }
       elsif    ($func == 16)  #10
       {
          #$data[$no_champ]  = substr($var, $n, $champ[$no_champ] -> [$::TAILLE]);
          $data[$no_champ] = "1234567890";
          $n += $champ[$no_champ] -> [$::TAILLE];
       }
       elsif ($func == 22)
       {
          if ($len == 4)
          {
             $data[$no_champ]  = "HLHL";
             $data[$no_champ]  = &dec2asc(substr($var, $n, $len) );
             $n += $champ[$no_champ] -> [$::TAILLE];
          }
       }
       else
       {
          $data[$no_champ] = substr("12345678901234567890234567890", 0, $champ[$no_champ] -> [$::TAILLE]);
          $n += $champ[$no_champ] -> [$::TAILLE];
       }
    }
    foreach (@data)
    {
       printf("%s%s", $_,$::SEP);
    }
    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 == 2)
    {
       &dec2asc_16($var);
    }
    elsif ($len == 4)
    {
       &dec2asc_32($var);
    }
    elsif ($len == 8)
    {
       &dec2asc_64($var);
    }
}

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

    $h = ord(substr($var, $i++, 1));
    if (!$::NO_SIGN)
    {
       if ($h >= 128)
       {
          $h -= 128;
       }
       else
       {
          $h =  127 - $h;
          $sign = -1;
       }
    }
    $l = ord(substr($var, $i++, 1));
    if ($sign == -1)
    {
       return( $sign*($h*256+$l) );
    }
    else
    {
       return( ($h*256+$l) );
    }
} 

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

    $h = ord(substr($var, $i++, 1));
    if (!$::NO_SIGN)
    {
    if ($h >= 128)
    {
       $h -= 128;
    }
    else
    {
       $h =  127 - $h;
       $sign = -1;
    }
    }
    #printf("h:%s\n", $h);

    #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 ($sign == -1)
    {
       return( $sign*(($h*256+$l)*65536+($h2*256+$l2)) );
    }
    else
    {
       return( ($h*256+$l)*65536+($h2*256+$l2)  );
    }
}

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