package access;
require 5.000;
require Exporter;

@ISA = qw(Exporter);
# Vyexportované funkce se nemusí volat s prefixem "access::", ale já spíš chci, aby se tak volaly.
#@EXPORT = qw(prevest_desetinnou_carku win2iso iso2lascii dekodovat_zaznam_access cist_zaznam_access);

use Encode;

##############################################################################
# Poskytuje funkce pro přenos dat mezi databázemi Microsoft Access a Perlem.
# S Accessem spolupracuje prostřednictvím textových souborů, které Access umí
# exportovat i importovat. Modul také poskytuje funkce pro překódování
# češtiny.
##############################################################################



#-----------------------------------------------------------------------------
# Přečte tabulku vyexportovanou z MS Access.
# Přečte ji z již otevřeného souboru, na nějž dostane handle.
# Názvy polí si zjistí z prvního řádku souboru. Pokud dostane seznam názvů od
# volajícího, načtené názvy ignoruje. Pokud od volajícího dostane odkaz na
# prázdný seznam, vyplní do něj načtené názvy a umožní tak volajícímu později
# uložit tabulku se stejným pořadím sloupců.
#-----------------------------------------------------------------------------
sub cist_otevreno
{
    my $soubor = shift; # handle otevřeného souboru předaný jako typeglob (*STDIN)
    my $konverze = shift; $konverze = "utf-8" if($konverze eq "");
    my $nazvy = shift; # odkaz na pole
    my $filtr = shift; # odkaz na proceduru, která vrací -1, pokud se má záznam přeskočit, a +1, pokud se má skončit
    # Nedodal-li volající seznam názvů polí, očekávat je na prvním řádku.
    if($nazvy eq "")
    {
        my @nactene_nazvy = cist_zaznam_access($soubor, $konverze);
        $nazvy = \@nactene_nazvy;
    }
    # Dodal-li volající prázdné pole na názvy polí, vyplnit mu do něj názvy, které jsme našli.
    elsif($#{$nazvy}<0)
    {
        @{$nazvy} = cist_zaznam_access($soubor, $konverze);
    }
    # Projít soubor a číst jednotlivé záznamy.
    my @tabulka;
    while(!eof($soubor))
    {
        my @zaznam = cist_zaznam_access($soubor, $konverze);
        # Přiřadit hodnotám názvy.
        my %zaznam;
        for(my $i = 0; $i<=$#zaznam; $i++)
        {
            $zaznam{$nazvy->[$i]} = $zaznam[$i];
        }
        my $f = eval{$filtr->(\%zaznam)};
        next if($f==-1);
        last if($f==+1);
        push(@tabulka, \%zaznam);
    }
    return \@tabulka;
}



#-----------------------------------------------------------------------------
# Přečte tabulku vyexportovanou z MS Access.
# Přečte ji ze souboru, jehož jméno dostane a který si sám otevře a zavře.
#-----------------------------------------------------------------------------
sub cist_tabulku_access
{
    my $soubor = shift; # jméno souboru
    open(TABULKA, $soubor); # při neúspěchu neumírat, protože nevíme, jestli to volající chce
    my $handle = "TABULKA";
    my $tabulka = cist_otevreno($handle, @_);
    close(TABULKA);
    return $tabulka;
}



#-----------------------------------------------------------------------------
# Rozebere záznam vyexportovaný z MS Access. Pole jsou oddělena středníky,
# některá mohou být v uvozovkách, potom mohou obsahovat i středník. Mají-li
# obsahovat uvozovky, uvozovky se zdvojí. Provede se též automatická konverze
# z kódování Windows 1250 do ISO 8859-2, ale nepřevádí se desetinná čárka na
# desetinnou tečku, protože se neví, která pole obsahují desetinná čísla.
# Od funkce dekodovat_zaznam_access() se liší tím, že si záznam i sám přečte
# ze souboru. Díky tomu může načíst i další řádky, když zjistí, že záznam na
# prvním řádku neskončil.
#-----------------------------------------------------------------------------
sub cist_zaznam_access
{
    my $soubor = $_[0]; # file handle
    my $konverze = $_[1]; # windows-1250 | utf-8 | nic
    $konverze = "windows-1250" if($konverze eq "");
    my $stav = "zacatek";
    my @znaky_vsechny_radky;
    do
    {
        # Až do odladění kašlat na parametr $konverze a požadovat, aby vstup byl v UTF8.
        my $radek = decode("utf8", <$soubor>);
        # Zahodit případný konec řádku a zbytek rozsekat na znaky.
        # chomp($radek); nefunguje na linuxu pro windowsovy vstup
        $radek =~ s/[\r\n]+$//;
        my @znaky = split(//, $radek);
        my $i;
        # Oddělující uvozovky zahodit, neoddělující nechat.
        # Oddělující středníky převést na tabulátory, neoddělující nechat.
        # Dosavadní tabulátory převést na &tab;, dosavadní ampersandy na &amp;.
        for($i = 0; $i<=$#znaky; $i++)
        {
            # Zakódovat znaky, které dosud neměly zvláštní funkci, ale teď ji budou
            # mít.
            if($znaky[$i] eq "&")
            {
                $znaky[$i] = "&amp;";
            }
            elsif($znaky[$i] eq "\t")
            {
                $znaky[$i] = "&tab;";
            }
            # Podle toho, v jakém jsme stavu, naložit s uvozovkami a středníky.
            if($stav eq "zacatek")
            {
                if($znaky[$i] eq "\"")
                {
                    $znaky[$i] = "";
                    $stav = "text";
                }
                elsif($znaky[$i] eq ";")
                {
                    $znaky[$i] = "\t";
                    $stav = "zacatek";
                }
                else
                {
                    $stav = "hodnota";
                }
            }
            elsif($stav eq "text")
            {
                if($znaky[$i] eq "\"")
                {
                    if($znaky[$i+1] eq "\"")
                    {
                        # Dvě po sobě jdoucí uvozovky zastupují jednu skutečnou.
                        $znaky[$i+1] = "";
                    }
                    else
                    {
                        # Jedna uvozovka ukončuje stav text.
                        $znaky[$i] = "";
                        $stav = "hodnota";
                    }
                }
            }
            elsif($stav eq "hodnota")
            {
                if($znaky[$i] eq ";")
                {
                    $znaky[$i] = "\t";
                    $stav = "zacatek";
                }
            }
        }
        # Přidat znaky z tohoto řádku na konec pole všech znaků.
        splice(@znaky_vsechny_radky, $#znaky_vsechny_radky+1, 0, @znaky);
        # Pokud řádek skončil a jsme ve stavu text, máme problém. Data zřejmě obsahovala zalomení řádku.
        # Musíme přečíst nejméně jeden další řádek, obsahující pokračování dat.
        if($stav eq "text")
        {
            push(@znaky_vsechny_radky, "\n");
        }
    } while($stav eq "text");
    # Upravený řetězec slepit a pak rozsekat podle tabulátorů.
    # Pozor, split() má tendenci vynechat prázdné prvky na konci pole, ale my chceme vědět, kolik prvků pole má!
    # Poznáme to podle počtu tabulátorů a pole pak uměle natáhneme.
    my $znaky = join("", @znaky_vsechny_radky);
    $znaky =~ s/[^\t]//g;
    my $pocet_tabulatoru = length($znaky);
    my @pole = split(/\t/, join("", @znaky_vsechny_radky));
    $#pole = $pocet_tabulatoru if($#pole<$pocet_tabulatoru);
    # V jednotlivých prvcích pole vrátit do původního stavu skutečné tabulátory
    # a ampersandy. Současně také převést z Windows 1250 do ISO 8859-2.
    for($i = 0; $i<=$#pole; $i++)
    {
        $pole[$i] =~ s/&tab;/\t/g;
        $pole[$i] =~ s/&amp;/&/g;
        if($konverze eq "windows-1250")
        {
            $pole[$i] = win2iso($pole[$i]);
        }
        # Převést také konce řádků, které byly zakódovány už při exportu z Accessu.
        $pole[$i] =~ s/\\n/\n/g;
    }
    return @pole;
}



#-----------------------------------------------------------------------------
# Rozebere záznam vyexportovaný z MS Access. Pole jsou oddělena středníky,
# některá mohou být v uvozovkách, potom mohou obsahovat i středník. Mají-li
# obsahovat uvozovky, uvozovky se zdvojí. Provede se též automatická konverze
# z kódování Windows 1250 do ISO 8859-2, ale nepřevádí se desetinná čárka na
# desetinnou tečku, protože se neví, která pole obsahují desetinná čísla.
#-----------------------------------------------------------------------------
sub dekodovat_zaznam_access
{
    # Zahodit případný konec řádku a zbytek rozsekat na znaky.
#    chomp($_[0]); # to nefunguje na linuxu pro windowsovy vstup
    $_[0] =~ s/[\r\n]+$//;
    my @znaky = split(//, $_[0]);
    my $i;
    # Oddělující uvozovky zahodit, neoddělující nechat.
    # Oddělující středníky převést na tabulátory, neoddělující nechat.
    # Dosavadní tabulátory převést na &tab;, dosavadní ampersandy na &amp;.
    my $stav = "zacatek";
    for($i = 0; $i<=$#znaky; $i++)
    {
        # Zakódovat znaky, které dosud neměly zvláštní funkci, ale teď ji budou
        # mít.
        if($znaky[$i] eq "&")
        {
            $znaky[$i] = "&amp;";
        }
        elsif($znaky[$i] eq "\t")
        {
            $znaky[$i] = "&tab;";
        }
        # Podle toho, v jakém jsme stavu, naložit s uvozovkami a středníky.
        if($stav eq "zacatek")
        {
            if($znaky[$i] eq "\"")
            {
                $znaky[$i] = "";
                $stav = "text";
            }
            elsif($znaky[$i] eq ";")
            {
                $znaky[$i] = "\t";
                $stav = "zacatek";
            }
            else
            {
                $stav = "hodnota";
            }
        }
        elsif($stav eq "text")
        {
            if($znaky[$i] eq "\"")
            {
                if($znaky[$i+1] eq "\"")
                {
                    # Dvě po sobě jdoucí uvozovky zastupují jednu skutečnou.
                    $znaky[$i+1] = "";
                }
                else
                {
                    # Jedna uvozovka ukončuje stav text.
                    $znaky[$i] = "";
                    $stav = "hodnota";
                }
            }
        }
        elsif($stav eq "hodnota")
        {
            if($znaky[$i] eq ";")
            {
                $znaky[$i] = "\t";
                $stav = "zacatek";
            }
        }
    }
    # Upravený řetězec slepit a pak rozsekat podle tabulátorů.
    # Pozor, split() má tendenci vynechat prázdné prvky na konci pole, ale my chceme vědět, kolik prvků pole má!
    # Poznáme to podle počtu tabulátorů a pole pak uměle natáhneme.
    my $znaky = join("", @znaky);
    $znaky =~ s/[^\t]//g;
    my $pocet_tabulatoru = length($znaky);
    my @pole = split(/\t/, join("", @znaky));
    $#pole = $pocet_tabulatoru if($#pole<$pocet_tabulatoru);
    # V jednotlivých prvcích pole vrátit do původního stavu skutečné tabulátory
    # a ampersandy. Současně také převést z Windows 1250 do ISO 8859-2.
    for($i = 0; $i<=$#pole; $i++)
    {
        $pole[$i] =~ s/&tab;/\t/g;
        $pole[$i] =~ s/&amp;/&/g;
        $pole[$i] = win2iso($pole[$i]);
    }
    return @pole;
}



#------------------------------------------------------------------------------
# Převezme pole skalárů a vypíše je jako řádek hodnot oddělených středníky.
# Pokud některý z nich obsahoval středník nebo uvozovky, obalí ho nejdřív
# uvozovkami. Pokud obsahoval uvozovky, tak je zdvojí.
#------------------------------------------------------------------------------
sub sestavit_zaznam_access
{
    my $zaznam;
    for(my $i = 0; $i<=$#_; $i++)
    {
        $zaznam .= ";" if($i>0);
        if($_[$i] =~ m/[;\"]/)
        {
            # Zneškodnit uvozovky.
            $_[$i] =~ s/\"/\"\"/g;
            # Zneškodnit středníky a všechno ostatní.
            $_[$i] = "\"$_[$i]\"";
        }
        $zaznam .= $_[$i];
    }
    $zaznam .= "\n";
    return $zaznam;
}



#------------------------------------------------------------------------------
# Vypíše tabulku do souboru. Tabulku přebírá jako pole hashů, volitelně se může
# omezit jen na některé řádky a na některé sloupce. Na výstupu je textový (CSV)
# soubor v UTF-8 s hodnotami oddělenými středníkem a v případě potřeby obalený-
# mi uvozovkami. První řádek souboru obsahuje názvy sloupců (polí). Takto ulo-
# ženou tabulku lze znovu načíst funkcí cist_tabulku_access().
#
# Poznámka: tato funkce by se mohla jmenovat psat_tabulku_access(). Výhledově
# chci ale spíše skončit u dvou funkcí, access::cist() a access::psat().
#------------------------------------------------------------------------------
sub psat_otevreno
{
    my $soubor = shift; # handle souboru otevřeného pro zápis (předává se jako *STDOUT)
    my $tabulka = shift; # odkaz na pole hashů
    my $od = shift; # index prvního hashe, který se má vypsat
    my $do = shift; # index posledního hashe, který se má vypsat
    my $nazvy = shift; # odkaz na pole názvů, ovlivní výběr a pořadí sloupců
    binmode($soubor, ":utf8");
    $od = 0 if($od<0 || $od eq "");
    $do = $#{$tabulka} if($do>$#{$tabulka} || $do eq "");
    my @klice = $nazvy ne "" ? @{$nazvy} : keys(%{$tabulka->[$od]});
    my $zaznam = sestavit_zaznam_access(@klice);
    print $soubor ($zaznam);
    for(my $i = $od; $i<=$do; $i++)
    {
        $zaznam = sestavit_zaznam_access(map{$tabulka->[$i]{$_}}(@klice));
        print $soubor ($zaznam);
    }
}



#------------------------------------------------------------------------------
# Vypíše tabulku do souboru. Obálka na funkci psat_otevreno(). Na rozdíl od ní
# nepřebírá handle otevřeného souboru, ale jméno souboru, který si sama otevře.
#------------------------------------------------------------------------------
sub psat
{
    my $soubor = shift; # jméno souboru
    # Při neúspěchu neházet výjimku, protože nevíme, zda to tak volající chce.
    # (V režimu CGI skončí výjimka neurčitým hlášením Internal server error;
    # kromě toho není jasné, jaké kódování by měla používat naše výjimka.)
    open(SOUBOR, ">$soubor");
    psat_otevreno(*SOUBOR, @_);
    close(SOUBOR);
}



#-----------------------------------------------------------------------------
# Převede desetinnou čárku na desetinnou tečku.
#-----------------------------------------------------------------------------
sub prevest_desetinnou_carku
{
    $_[0] =~ s/^(\d+),(\d+)$/$1.$2/;
    return $_[0];
}



#-----------------------------------------------------------------------------
# Převede řetězec z kódování Windows 1250 do kódování ISO 8859-2.
#-----------------------------------------------------------------------------
sub win2iso
{
    my $text = $_[0];
    # Převést z kódové stránky Windows do ISO 8859-2.
    #188 -> #165 Ľ
    #138 -> #169 Š
    #141 -> #171 Ť
    #142 -> #174 Ž
    #190 -> #181 ľ
    #154 -> #185 š
    #157 -> #187 ť
    #158 -> #190 ž
    #151 -> "-"  dlouhá pomlčka

# ŁódŸ
    #191 -> #188 Ÿ

    #138 (x8A) Š (S háček)  -> #169 xA9 (ve Windows vypadá jako copyright)
    #140 (x8C) Œ (S čárka)  -> #166 xA6 (ve Windows vypadá jako svislítko)
    #141 (x8D) Ť (T háček)  -> #171 xAB (ve Windows vypadá jako dvojité menšítko)
    #142 (x8E) Ž (Z háček)  -> #174 xAE (ve Windows vypadá jako registrovaná ochranná známka)
    #143 (x8F)  (Z čárka)  -> #172 xAC (ve Windows vypadá jako klika otočená doleva)
    #154 (x9A) š (s háček)  -> #185 xB9 (ve Windows vypadá jako a ogonek)
    #156 (x9C) œ (s čárka)  -> #182 xB6 (ve Windows vypadá jako znak konce odstavce)
    #157 (x9D) ť (t háček)  -> #187 xBB (ve Windows vypadá jako dvojité většítko)
    #158 (x9E) ž (z háček)  -> #190 xBE (ve Windows vypadá jako l háček)
    #159 (x9F) Ÿ (z čárka)  -> #188 xBC (ve Windows vypadá jako L háček)
    #163 (xA3) Ł (L škrt)   -> #163 xA3 (stejný kód Windows i ISO!)
    #165 (xA5) Ľ (A ogonek) -> #161 xA1 (ve Windows vypadá jako háček)
    #170 (xAA) Ş (S ocásek) -> #170 xAA (stejný kód Windows i ISO!)
    #175 (xAF) Ż (Z tečka)  -> #175 xAF (stejný kód Windows i ISO!)
    #179 (xB3) ł (l škrt)   -> #179 xB3 (stejný kód Windows i ISO!)
    #185 (xB9) š (a ogonek) -> #177 xB1 (ve Windows vypadá jako plus-mínus)
    #186 (xBA) ş (s ocásek) -> #186 xBA (stejný kód Windows i ISO!)
    #188 (xBC) Ľ (L háček)  -> #165 xA5 (ve Windows vypadá jako A ogonek)
    #190 (xBE) ľ (l háček)  -> #181 xB5 (ve Windows vypadá jako řecké mí)
    #191 (xBF) ż (z tečka)  -> #191 xBF (stejný kód Windows i ISO!)
    #150 (x96) - (prostřední pomlčka)
    #151 (x97) - (dlouhá pomlčka)
    #130 (x82) - (jednoduchá uvozovka spodní 9)
    #132 (x84) - (dvojitá uvozovka spodní 99)
    #145 (x91) - (jednoduchá uvozovka horní 6)
    #146 (x92) - (jednoduchá uvozovka horní 9)
    #147 (x93) - (dvojitá uvozovka horní 66)
    #148 (x94) - (dvojitá uvozovka horní 99)
    #133 (x85) - (tři tečky)

    #$text =~ tr/\xBC\x8A\x8D\x8E\xBE\x9A\x9D\x9E\226/\xA5\xA9\xAB\xAE\xB5\xB9\xBB\xBE-/;
    $text =~ tr/\x8A\x8C\x8D\x8E\x8F\x9A\x9C\x9D\x9E\x9F\xA5\xB9\xBC\xBE/\xA9\xA6\xAB\xAE\xAC\xB9\xB6\xBB\xBE\xBC\xA1\xB1\xA5\xB5/;
    $text =~ tr/\x96\x97\x82\x84\x91\x92\x93\x94/\-\-'"''""/;
    $text =~ s/\x85/.../g;
    return $text;
}



#-----------------------------------------------------------------------------
# Převede řetězec z kódování ISO 8859-2 do ASCII.
#-----------------------------------------------------------------------------
sub iso2ascii
{
    my $text = $_[0];
    $text =~ tr/AÁBCČDĎEÉĚFGHIÍJKLMNŇOÓPQRŘSŠTŤUÚŮVWXYÝZŽaábcčdďeéěfghiíjklmnňoópqrřsštťuúůvwxyýzž/AABCCDDEEEFGHIIJKLMNNOOPQRRSSTTUUUVWXYYZZaabccddeeefghiijklmnnoopqrrssttuuuvwxyyzz/;
    return $text;
}



#-----------------------------------------------------------------------------
# Převede řetězec z kódování ISO 8859-2 do malých písmen ASCII (vhodné pro
# tvorbu jmen souborů). Mezery převede na pomlčky.
#-----------------------------------------------------------------------------
sub iso2lascii
{
    my $text = $_[0];
    $text =~ tr/AÁBCČDĎEÉĚFGHIÍJKLMNŇOÓPQRŘSŠTŤUÚŮVWXYÝZŽaábcčdďeéěfghiíjklmnňoópqrřsštťuúůvwxyýzž /aabccddeeefghiijklmnnoopqrrssttuuuvwxyyzzaabccddeeefghiijklmnnoopqrrssttuuuvwxyyzz-/;
    return $text;
}



#-----------------------------------------------------------------------------
# Převede řetězec z kódování ISO 8859-2 do Windows 1250.
#-----------------------------------------------------------------------------
sub iso2win
{
    my $text = $_[0];
    # Převést z kódové stránky ISO 8859-2 do Windows 1250.
    #188 <- #165 Ľ
    #138 <- #169 Š
    #141 <- #171 Ť
    #142 <- #174 Ž
    #190 <- #181 ľ
    #154 <- #185 š
    #157 <- #187 ť
    #158 <- #190 ž
    $text =~ tr/\xA5\xA9\xAB\xAE\xB5\xB9\xBB\xBE/\xBC\x8A\x8D\x8E\xBE\x9A\x9D\x9E/;
    return $text;
}



#-----------------------------------------------------------------------------
# Převede řetězec z kódování ISO 8859-2 do UTF-8.
#-----------------------------------------------------------------------------
sub iso2utf
{
    my $text = $_[0];
    # Převést z kódové stránky ISO 8859-2 do UTF-8.
    my %table =
    (
        "Á" => chr(hex("00C1")),
        "É" => chr(hex("00C9")),
        "Í" => chr(hex("00CD")),
        "Ó" => chr(hex("00D3")),
        "Ú" => chr(hex("00DA")),
        "Ý" => chr(hex("00DD")),
        "á" => chr(hex("00E1")),
        "é" => chr(hex("00E9")),
        "í" => chr(hex("00ED")),
        "ó" => chr(hex("00F3")),
        "ú" => chr(hex("00FA")),
        "ý" => chr(hex("00FD")),
        "Č" => chr(hex("010C")),
        "č" => chr(hex("010D")),
        "Ď" => chr(hex("010E")),
        "ď" => chr(hex("010F")),
        "Ě" => chr(hex("011A")),
        "ě" => chr(hex("011B")),
        "Ň" => chr(hex("0147")),
        "ň" => chr(hex("0148")),
        "Ř" => chr(hex("0158")),
        "ř" => chr(hex("0159")),
        "Š" => chr(hex("0160")),
        "š" => chr(hex("0161")),
        "Ť" => chr(hex("0164")),
        "ť" => chr(hex("0165")),
        "Ů" => chr(hex("016E")),
        "ů" => chr(hex("016F")),
        "Ž" => chr(hex("017D")),
        "ž" => chr(hex("017E"))
    );
    return join("", map{exists($table{$_}) ? $table{$_} : $_}(split(//, $text)));
}