# Knihovna funkcí pro interakci mezi daty v textových souborech a databázovými servery MySQL a PostgreSQL.
# Copyright © 2007 Dan Zeman <zeman@ufal.mff.cuni.cz>
# Licence: GNU GPL

package dzsql;
use utf8;
use open ':utf8';
use Carp;
use DBI;
use Encode;
use mail;



#------------------------------------------------------------------------------
# Funkce connect() byla přesunuta do modulu sitesql, který se liší obsahem pro
# web server ufal (sql server PostgreSQL na eulerovi) a pro web/sql server kub
# (MySQL).
#------------------------------------------------------------------------------



#------------------------------------------------------------------------------
# Přečte údaje z databáze. Vzorové volání:
# $odkaz_na_pole_hashu = dzsql::dotaz($db, "kod", "hry.nazev AS nazev",
# "zbozi.nazev", "hry INNER JOIN zbozi ON hry.kod = zbozi.kod ".$filtr.$razeni);
#------------------------------------------------------------------------------
sub dotaz
{
    my $databaze = shift;
    my $from = pop(@_);
    my @nazvy = @_;
    my $nazvy = join(", ", @nazvy);
    ###!!! Did we escape all apostrophes in the FROM part?
    ###!!! This will not catch all cases. Not those where a value contains an even number of apostrophes. But it will catch "'s" genitive in English.
    my $apfrom = $from;
    $apfrom =~ s/[^']//g; #'
    if(length($apfrom)%2)
    {
        confess("The FROM clause contains an odd number of apostrophes:\n$from");
    }
    # $dotaz je globální proměnná, aby si ji volající mohl prohlédnout za účelem ladění.
    $dotaz = "SELECT $nazvy FROM $from";
    if($debug) # globální v tomto modulu
    {
        print("<p style='color:red'>$dotaz</p>\n");
    }
    ###!!! 2016-06-04 Dan debug do logu
    #print STDERR ("SQL dotaz: $dotaz\n");
    ###!!! konec
    my $dtzobj = $databaze->prepare($dotaz);
    $dtzobj->execute();
    # Upravit názvy přejmenovaných polí.
    for(my $i = 0; $i<=$#nazvy; $i++)
    {
        $nazvy[$i] =~ s/^.*\s+AS\s+//i;
    }
    return nacist_vysledek_dotazu($dtzobj, \@nazvy);
}



#------------------------------------------------------------------------------
# Obalí řetězec apostrofy. Postará se o zneškodnění (zdvojení) případných
# apostrofů uvnitř řetězce. Slouží pro přípravu řetězcových konstant pro
# použití v dotazech SQL.
#------------------------------------------------------------------------------
sub ap
{
    my $x = shift;
    $x =~ s/'/''/g; # '
    return "'$x'";
}



#------------------------------------------------------------------------------
# Vyzvedne výsledek dotazu opakovaným voláním fetchrow_array().
#------------------------------------------------------------------------------
sub nacist_vysledek_dotazu
{
    my $dtzobj = shift; # dotaz, na který už bylo zavoláno execute()
    my $nazvy = shift; # odkaz na pole názvů sloupců (polí)
    my @pole;
    # Automaticky předpokládáme, že všechny naše databáze používají kódování UTF8.
    # Musíme si ale ručně nastavit příznak UTF8, protože fetchrow_array() vrací řetězec bajtů.
    while(my @radek = $dtzobj->fetchrow_array())
    {
        # Dříve bylo třeba ještě dekódovat došlá data, protože v databázi byla
        # sice uložena v kódování UTF-8, ale metoda fetchrow_array() je vracela
        # jako řetězec bajtů, nikoli znaků. Teď (5.5.2019) se ale zdá, že jsme
        # z fetchrow_array() dostali i "široké znaky" a Encode::decode() kvůli
        # nim padá. Pozorováno na počítači blackbird při komunikaci s Postgresem
        # na ÚFALu. Bohužel to neznamená, že ke stejné změně došlo i na jiných
        # serverech, kde komunikuju s databázemi. A nevím, jak detekovat, zda
        # dekódování mám, nebo nemám provést. Samotná přítomnost širokých znaků
        # nestačí:
        # Pokud šlo o sekvenci bajtů, které mají být, ale ještě nebyly dekódovány
        # jako UTF-8, pak žádný z nich nemá hodnotu vyšší než 255, ale některé
        # mají kódy mezi 128 a 255 včetně. Pokud šlo o již dekódované UTF-8,
        # které ale obsahuje pouze znaky, jež se vejdou do sady ISO Latin 1,
        # máme problém. Např. ord znaku "á" je 225, ale nechceme ho dekódovat,
        # protože dekódovaný už byl! A jeho skutečný kód UTF-8 by byl dvoubajtový.
        # Alternativně bychom mohli prostě naslepo pustit Encode::decode() a
        # chytit případnou výjimku. To je asi lepší, akorát v případě, že
        # v příchozích datech je někde chyba v UTF-8, pak dostaneme nedekódovaný
        # celý řádek.
        # ... # load the string into $_, then:
        # my $test;
        # eval "\$test = decode( 'utf8', \$_, Encode::FB_CROAK )";
        # if ( $@ ) {
        #   # Encode would fail/die if $_ was not a valid utf8 string
        # }
        ###!!! Zatím prostě dekódování vypínám. Na ÚFALu to bude fungovat a
        ###!!! jinde se uvidí.
        ### Jakub 2019-09-19: zase ho zapinam, protoze klare jede blbe obchod.
        if(1)
        {
            @radek = map {decode('utf8', $_)} (@radek);
        }
        my %zaznam;
        for(my $i = 0; $i<=$#{$nazvy}; $i++)
        {
            # Odstranit mezery na konci hodnot. MySQL to nedělal, ale PostgreSQL je tam vkládá.
            $radek[$i] =~ s/\s+$//s;
            # Uložit hodnotu do hashe pod názvem příslušného sloupce.
            $zaznam{$nazvy->[$i]} = $radek[$i];
        }
        push(@pole, \%zaznam);
    }
    return \@pole;
}



#------------------------------------------------------------------------------
# Získá vybrané řádky z tabulky. Tato funkce je zaměnitelná s výše uvedenou
# starší funkcí dotaz(), ale má jiné volání, které se více podobá voláním
# funkcí insert() a update() níže.
#
# Příklad:
#   $radky = select($db, 'hry', { values => \%zaznam, wfields => ['kod'], sfields => ['nazev', 'cena'], nfields => ['cena'] });
# Výsledný dotaz:
#   SELECT nazev, cena FROM hry WHERE kod = 'car';
#------------------------------------------------------------------------------
sub select
{
    my $databaze = shift;
    my $tabulka = shift; # název tabulky, popř. spojení tabulek (INNER|LEFT|RIGHT JOIN ... ON)
    my $p = rozebrat_parametry('select', @_);
    my $obalene = obalit_textove_hodnoty($p->{values}, $p->{nfields}, $p->{wfields});
    my $pole = join(', ', @{$p->{sfields}});
    my $filtr = join(' AND ', map {"$_ = $obalene->{$_}"} (@{$p->{wfields}}));
    # $dotaz je globální proměnná, aby si ji volající mohl prohlédnout za účelem ladění.
    $dotaz = "SELECT $pole FROM $tabulka WHERE $filtr;";
    my $dtz = $databaze->prepare($dotaz);
    $dtz->execute();
    return nacist_vysledek_dotazu($dtz, $p->{sfields});
}



#------------------------------------------------------------------------------
# Přidá řádek do tabulky. Předpokládá, že jsme připojeni k databázi. Nestará se
# o to, zda tabulka existuje (kdyžtak dojde k chybě) a zda jsme ji před
# přidáváním případně vyprázdnili. Řádek chce dostat jako odkaz na hash, kde
# klíče jsou názvy polí a hodnoty jsou skaláry. Dotaz v SQL ukládá do globální
# proměnné, aby si ho volající v případě neúspěchu mohl prohlédnout.
#
# Příklad:
#   insert($db, 'hry', \%zaznam, ['nazev', 'cena']);
# Alternativně:
#   insert($db, 'hry', { values => \%zaznam, ifields => ['nazev', 'cena'], nfields => ['cena'] });
# Výsledný dotaz:
#   INSERT INTO hry (nazev, cena) VALUES ('Carcassonne', 438);
#------------------------------------------------------------------------------
sub insert
{
    my $databaze = shift;
    my $tabulka = shift; # název tabulky
    my $p = rozebrat_parametry('insert', @_);
    # Seznam polí, která se mají vložit, musí být neprázdný, jinak nemáme práci.
    return 0 unless(scalar(@{$p->{ifields}}));
    my $obalene = obalit_textove_hodnoty($p->{values}, $p->{nfields}, $p->{ifields});
    my $pole = join(', ', @{$p->{ifields}});
    my $hodnoty = join(', ', map {$obalene->{$_}} (@{$p->{ifields}}));
    # $dotaz je globální proměnná, aby si ji volající mohl prohlédnout za účelem ladění.
    $dotaz = "INSERT INTO $tabulka ($pole) VALUES ($hodnoty);";
    return $databaze->do($dotaz);
}



#------------------------------------------------------------------------------
# Aktualizuje hodnoty existujícího řádku tabulky. Předpokládá, že jsme
# připojeni k databázi. Nestará se o to, zda tabulka existuje (kdyžtak dojde
# k chybě). Řádek chce dostat jako odkaz na hash, kde klíče jsou názvy polí a
# hodnoty jsou skaláry. Vrátí úspěch/neúspěch. Dotaz v SQL ukládá do globální
# proměnné, aby si ho volající v případě neúspěchu mohl prohlédnout.
#
# Příklad:
#   update($db, 'hry', \%zaznam, ['nazev', 'cena'], ['kod'], ['cena']);
# Alternativně:
#   update($db, 'hry', { values => \%zaznam, wfields => ['kod'], ufields => ['nazev', 'cena'], nfields => ['cena'] });
# Výsledný dotaz:
#   UPDATE hry SET nazev = 'Carcassonne', cena = '438' WHERE kod = 'car';
#------------------------------------------------------------------------------
sub update
{
    my $databaze = shift;
    my $tabulka = shift; # název tabulky
    my $p = rozebrat_parametry('update', @_);
    # Seznam polí identifikujících záznam a seznam polí, která se mají aktualizovat, musí být neprázdný, jinak nemáme práci.
    return 0 unless(scalar(@{$p->{wfields}}) && scalar(@{$p->{ufields}}));
    my $obalene = obalit_textove_hodnoty($p->{values}, $p->{nfields}, $p->{ufields}, $p->{wfields});
    # Sestavit seznam přiřazení nových hodnot.
    my $prirazeni = join(', ', map {"$_ = $obalene->{$_}"} (@{$p->{ufields}}));
    my $filtr = join(' AND ', map {"$_ = $obalene->{$_}"} (@{$p->{wfields}}));
    # $dotaz je globální proměnná, aby si ji volající mohl prohlédnout za účelem ladění.
    $dotaz = "UPDATE $tabulka SET $prirazeni WHERE $filtr;";
    return $databaze->do($dotaz);
}



#------------------------------------------------------------------------------
# Odstraní existující řádek tabulky. Předpokládá, že jsme připojeni k databázi.
# Nestará se o to, zda tabulka existuje (kdyžtak dojde k chybě). V souladu
# s voláním ostatních funkcí SQL očekává odkaz na hash, ve kterém budou
# vyplněna alespoň pole nezbytná pro identifikaci záznamu, a názvy polí, která
# se pro identifikaci mají použít. Vrátí úspěch/neúspěch. Dotaz v SQL ukládá do
# globální proměnné, aby si ho volající v případě neúspěchu mohl prohlédnout.
#
# Příklad:
#   delete($db, 'hry', { values => \%zaznam, wfields => ['kod'], nfields => ['cena'] });
# Výsledný dotaz:
#   DELETE FROM hry WHERE kod = 'car';
#------------------------------------------------------------------------------
sub delete
{
    my $databaze = shift;
    my $tabulka = shift; # název tabulky
    my $p = rozebrat_parametry('delete', @_);
    # Seznam polí identifikujících záznam musí být neprázdný, jinak nemáme práci.
    return 0 unless(scalar(@{$p->{wfields}}));
    my $obalene = obalit_textove_hodnoty($p->{values}, $p->{nfields}, $p->{wfields});
    # Sestavit seznam přiřazení nových hodnot.
    my $filtr = join(' AND ', map {"$_ = $obalene->{$_}"} (@{$p->{wfields}}));
    # $dotaz je globální proměnná, aby si ji volající mohl prohlédnout za účelem ladění.
    $dotaz = "DELETE FROM $tabulka WHERE $filtr;";
    return $databaze->do($dotaz);
}



#------------------------------------------------------------------------------
# Rozebere vstupní parametry funkce update() (různé druhy polí a hodnot). Vrátí
# hash, kde jsou parametry pojmenovány.
#------------------------------------------------------------------------------
sub rozebrat_parametry
{
    my $funkce = shift; # insert|update
    if(ref($_[0]) eq 'HASH' && exists($_[0]{values}) && !defined($_[1]))
    {
        return $_[0];
    }
    # insert nepotřebuje wfields pro identifikaci existujícího záznamu
    elsif($funkce eq 'insert')
    {
        return { 'values' => $_[0], 'ifields' => $_[1], 'nfields' => $_[2] };
    }
    else
    {
        return { 'values' => $_[0], 'ufields' => $_[1], 'wfields' => $_[2], 'nfields' => $_[3] };
    }
}



#------------------------------------------------------------------------------
# Převezme hash hodnot a seznam číselných polí. Vrátí jiný hash se stejnými
# klíči (názvy polí). Hodnoty číselných polí budou do nového hashe okopírovány
# tak, jak jsou, zatímco hodnoty ostatních (textových) polí budou obalené
# apostrofy, aby se daly vložit do výrazu SQL. Nepředpokládá se, že by hodnotou
# mohl být odkaz, a neprovádí se hloubková kopie.
#------------------------------------------------------------------------------
sub obalit_textove_hodnoty
{
    my $zdroj = shift; # odkaz na hash
    my $nfields = shift; # odkaz na pole názvů číselných hodnot
    # Volitelně též odkazy na jedno nebo několik dalších polí názvů.
    # Pokud tyto názvy ve zdroji chybí, obalením se pro ně vytvoří prázdná hodnota '' nebo 0,
    # aby jejich použití ve výrazu SQL nezpůsobilo syntaktickou chybu.
    my @klice = keys(%{$zdroj});
    push(@klice, @{$nfields});
    foreach my $pole (@_)
    {
        # Pokud se název nějakého sloupce opakuje v několika polích (např. wfields i ufields),
        # budeme hodnoty těchto polí obalovat a přepisovat opakovaně, ale pravděpodobně nás
        # to nezdrží víc, než kdybychom se nejdřív pokoušeli duplikáty identifikovat a přeskočit.
        push(@klice, @{$pole});
    }
    $fields = \@klice;
    my %cil;
    # Nahashovat si názvy číselných polí.
    my %cislo;
    map {$cislo{$_} = 1} (@{$nfields});
    # Okopírovat hodnoty do nového hashe.
    foreach my $klic (@{$fields})
    {
        if($cislo{$klic})
        {
            if(defined($zdroj->{$klic}))
            {
                $cil{$klic} = $zdroj->{$klic};
            }
            else
            {
                $cil{$klic} = 0;
            }
        }
        else
        {
            # ASCII apostrof používáme na ohraničení řetězců v SQL. Pokud má být součástí hodnoty, musíme ho zdvojit.
            # V MySQL se před počáteční apostrof ještě kladlo "_utf8", ale PostgreSQL tohle nepoužívá.
            my $x = $zdroj->{$klic};
            $x =~ s/'/''/sg;
            $cil{$klic} = "'$x'";
        }
    }
    return \%cil;
}



#------------------------------------------------------------------------------
# Přidá tabulku do databáze. Předpokládá, že jsme připojeni k databázi. Pokud
# tabulka existuje, smaže starou a založí ji znova. Tabulka je pole hashů,
# seznam klíčů se předává zvlášť jako pole @nazvy. Díky tomu nemusí mít všechny
# hashe všechny klíče, je možné určit výběr a pořadí klíčů. Funkce předpokládá,
# že klíče obsahují pouze znaky [a-z0-9_], takže nedojde k problémům v SQL.
#------------------------------------------------------------------------------
sub insert_table
{
    my $databaze = shift;
    my $nazev_tabulky = shift;
    my $tabulka = shift; # odkaz na pole hashů
    my $nazvy = shift; # odkaz na pole klíčů do hashů
    # Neznáme původní typy sloupců a předpokládáme, že to jsou samé řetězce.
    # Proběhnout tabulku a pro každý sloupec zjistit maximální délku hodnoty.
    my %maxdelky;
    # Žádnému sloupci nedovolit nulovou délku, to by SQL server nemusel strávit.
    foreach my $sloupec (@{$nazvy})
    {
        $maxdelky{$sloupec} = 1;
    }
    foreach my $radek (@{$tabulka})
    {
        foreach my $sloupec (@{$nazvy})
        {
            my $delka = length($radek->{$sloupec});
            if($delka>$maxdelky{$sloupec})
            {
                $maxdelky{$sloupec} = $delka;
            }
        }
    }
    # Každému sloupci určit typ. Pro sloupce s maximální délkou 255 nebo menší
    # to bude "CHAR". Pro delší řetězce to bude "TEXT" (může mít až 65535 znaků
    # (nebo bajtů?)).
    my %typy;
    foreach my $sloupec (@{$nazvy})
    {
        if($maxdelky{$sloupec}>255)
        {
            $typy{$sloupec} = "TEXT";
        }
        else
        {
            $typy{$sloupec} = "CHAR($maxdelky{$sloupec})";
        }
    }
    # Odstranit dosavadní tabulku z databáze.
    $databaze->do("DROP TABLE $nazev_tabulky;");
    # Vytvořit v databázi novou tabulku.
    my @sloupce = map {"$_ $typy{$_}"} @{$nazvy};
    my $dotaz = "CREATE TABLE $nazev_tabulky (".join(", ", @sloupce).");";
    $databaze->do($dotaz) or die("Nelze spustit dotaz $dotaz.\n");
    # Nalít do tabulky data.
    foreach my $radek (@{$tabulka})
    {
        insert($databaze, $nazev_tabulky, $radek, $nazvy);
    }
}



#------------------------------------------------------------------------------
# Pokusí se provést dotaz. Pokud se to nepovede, pošle e-mail s chybovým
# hlášením na udanou adresu. Tohle je důležité u objednávkových, přihláškových
# a podobných formulářů. Párkrát už se nám stalo, že se kvůli výpadku MySQL
# nepodařilo data z formuláře uložit do databáze a dozvěděli jsme se o tom
# pouze v případě, že se dotyčný uživatel sám ozval. Jeho přihláška nám sice
# přišla také e-mailem, ale nevšimli jsme si, že do databáze se nedostala.
#------------------------------------------------------------------------------
sub do_or_mail
{
    my $databaze = shift;
    my $dotaz = shift;
    my $adresa = shift;
    if(!$databaze->do($dotaz) || $DBI::errstr)
    {
        mail::odeslat
        (
            'From' => 'robot@hrejsi.cz',
            'To' => $adresa,
            'text' =>
                "Nepodařilo se vykonat tento dotaz SQL:\n".
                "$dotaz\n\n".
                "Databázová knihovna hlásí:\n".
                "$DBI::errstr\n"
        );
    }
}



#------------------------------------------------------------------------------
# Získá seznam tabulek v databázi. Pozor, tohle je specifický postup platný
# pro PostgreSQL! V MySQL je to jinak! Nebude na to nějaký společný nástroj
# v DBI, který by nás pomocí ovladačů odstínil od implementačních detailů?
#------------------------------------------------------------------------------
sub list_tables
{
    my $databaze = shift;
    # Omezením na vlastnictví uživatele "zeman" se zbavíme systémových tabulek.
    my $dotaz = "SELECT tablename FROM pg_tables WHERE tableowner='zeman';";
    ###!!! ještě zbývá provést dotaz a vrátit jeho výstup
    # @names = $dbh->tables( $catalog, $schema, $table, $type ); $type = "TABLE";
}
#txt2sql.pl db tbl < tbl.txt
#Předpokládá se, že skript zná cestu k databázovému serveru (ip, port, uživatel, heslo...) a umí rozlišit mysql a postgresql.
#První řádek textového souboru obsahuje názvy polí. Skript si je upraví, aby obsahovaly jen a-z0-9_
#Zatím stále platí, že textový soubor nenese informaci o typu sloupce ani o indexech. Skript si typy vymyslí, indexy netvoří.
#Na rozdíl od dosavadní praxe by skript měl umět poznat, že v databázi dotyčná tabulka existuje, a měl by vědět, jak se zachovat.
#Později bude skript vedle prostého importu umožňovat také synchronizaci textového souboru s databází.



1;