#!/usr/bin/perl
# Pokusí se ke jménům osob doplnit chybějící diakritiku a případně dokonce kód osoby z databáze.
# Hodí se při zpracování exportu ze špatně napsaných turnajových programů, jako je Jakubův čtyřšvýcar.
# Copyright © 2011 Dan Zeman <zeman@ufal.mff.cuni.cz>
# Licence: GNU GPL

use utf8; # říct Perlu, že konstantní řetězce ve zdrojáku jsou v UTF
use DBI; # spolupráce se serverem MySQL
use lib '/s/w/lib/dan';
use lib '/s/w/lib/cgi/mso';
use lib '/s/w/lib/cgi/mso/vnitro';
use dancgi; # čtení parametrů z webu nebo z ARGV
use dzsql; # sestavování a provádění dotazů SQL
use csort; # české a anglické abecední řazení UTF znaků
use ascii; # odstranění diakritiky ze znaků založených na latince
use mso; # funkce pro generování stránek o olympiádě
binmode(STDOUT, ':utf8'); # říct Perlu, že UTF chceme i na výstupu
binmode(STDERR, ':utf8');

# Připojit se k databázi.
$databaze = mso::pripojit_se_k_databazi();

# Výchozí nastavení parametru. Muže být pořbito parametry z URL/ARGV.
mso::provest_vychozi_nastaveni_parametru(\%konfig, $databaze);
# Načíst parametry z URL.
#dancgi::cist_parametry(\%konfig);
# Načíst parametry ze standardního vstupu (POST).
dancgi::cist_formular_post(\%konfig);
# Umožnit volat skript z příkazového řádku a předat parametry tam (např. perl prihlaseni.pl akce=caroly).
dancgi::rozebrat_parametry($ARGV[0], \%konfig);



# Vypsat formulář se vstupním oknem nebo odpověď.
if(exists($konfig{ohackovat}))
{
    ohackovat(\%konfig);
}
else
{
    vypsat_formular();
}



###############################################################################
# PODPROGRAMY
###############################################################################



#------------------------------------------------------------------------------
# Vypíše prázdný vstupní formulář.
#------------------------------------------------------------------------------
sub vypsat_formular
{
    vypsat_zahlavi('Háčkovač: vstup');
    # Poslat začátek stránky.
    print <<EOF
  <h1>Háčkovač</h1>
  <p>Do pole formuláře vložte tabulku se seznamem osob, na každý řádek jednu osobu.
     Háčkovač se pokusí ve jménech doplnit chybějící diakritiku podle databáze.</p>
  <p>Sloupce tabulky musí být oddělené tabulátory.
     CTRL+C a CTRL+V z&nbsp;Excelu udělá přesně to, co je potřeba.
     Háčkovač předpokládá, že první sloupec obsahuje čísla pořadí v&nbsp;turnaji,
     druhý a případně třetí sloupec obsahuje jméno a příjmení hráče
     (v&nbsp;libovolném pořadí; pokusí se automaticky odhadnout,
     zda je máte spojené v&nbsp;jednom sloupci, nebo oddělené ve dvou).
     Tabulka může obsahovat i další sloupce.</p>
EOF
    ;
    print("  <form action='hacky.pl' method=post>\n");
    print("    <textarea name=co cols=80 rows=25>\n");
    print("    </textarea><br/>\n");
    print("    <input type=submit name=ohackovat value='Oháčkovat' />\n");
    print("    <h2>Pokus se Čtyřpohárem</h2>\n");
    print("    Výsledky:\n");
    print("    <textarea name=cpvysledky></textarea>\n");
    print("    VýsledkyTýmy:\n");
    print("    <textarea name=cpvysledkytymy></textarea>\n");
    print("  </form>\n");
    print("  </body>\n");
    print("</html>\n");
    return; ###!!!
}



#------------------------------------------------------------------------------
# Vypíše osoby ze vstupu spolu s informacemi, které se k nim podaří najít
# v databázi.
#------------------------------------------------------------------------------
sub ohackovat
{
    my $konfig = shift;
    vypsat_zahlavi('Háčkovač: výstup');
    # Poslat začátek stránky.
    print("  <h1>Háčkovač</h1>\n");
    print("  <p>Na vstupu byly tyto osoby:</p>\n");
    print("  <table border>\n");
    # Načíst z databáze seznam osob.
    my $osoby = mso::dotazat_se_databaze($databaze, 'kod', 'jmeno', 'prijmeni', 'osoby');
    # Ke každé osobě si zapamatovat odháčkovanou verzi jejího jména převedenou na malá písmena.
    map
    {
        $_->{cele_jmeno} = $_->{jmeno}.' '.$_->{prijmeni};
        $_->{cele_jmeno} =~ s/^\s+//;
        $_->{cele_jmeno} =~ s/\s+$//;
        $_->{cele_jmeno} =~ s/\s+/ /g;
        $_->{kanonicky} = ascii::ascii(lc($_->{cele_jmeno}));
    }
    (@{$osoby});
    # Rozebrat vstup po řádcích.
    my @radky = split(/\r?\n/, $konfig->{co});
    # Nejdřív tabulku proběhnout nanečisto a odhadnout, jestli se jméno a příjmení nachází dohromady ve druhém sloupci,
    # nebo zvlášť ve druhém a třetím sloupci.
    # Pokud jsou v jednom sloupci, bude tento sloupec často obsahovat mezeru obklopenou písmeny.
    # Pokud jsou ve dvou sloupcích, bude pravý sloupec často obsahovat písmena, zatímco jinak typicky obsahuje čísla (body).
    my $n_radku = scalar(@radky);
    my $n_mezer_vlevo = 0;
    my $n_slov_vpravo = 0;
    my $n_sloupcu = 0;
    foreach my $radek (@radky)
    {
        my @bunky = split(/\t/, $radek);
        $n_mezer_vlevo++ if($bunky[1] =~ m/\pL\s+\pL/);
        $n_slov_vpravo++ if($bunky[2] =~ m/\pL\pL/);
        $n_sloupcu = scalar(@bunky) if(scalar(@bunky)>$n_sloupcu);
    }
    my $dva_sloupce = $n_mezer_vlevo<0.1 && $n_slov_vpravo>0.9;
    my $n_sloupcu_jmeno = $dva_sloupce ? 2 : 1;
    my $n_kriterii = $n_sloupcu - $n_sloupcu_jmeno - 1;
    print("    <tr><th>Kód DB</th><th>Pořadí</th><th colspan=$n_kriterii>Kritéria</th><th colspan=$n_sloupcu_jmeno>Hledané jméno</th><th>Jméno DB</th></tr>\n");
    # A teď projít podruhé a hledat v databázi.
    foreach my $radek (@radky)
    {
        # Prázdné řádky přeskočit. "Našly" by se k nim všechny osoby v databázi.
        next if($radek =~ m/^\s*$/);
        # Řádek tabulky obsahuje posloupnost buněk, z nichž jedna až dvě obsahují jméno hledané osoby.
        # Jestliže jde o kopii z Excelu přes schránku, jsou buňky oddělené tabulátorem.
        my @bunky = split(/\t/, $radek);
        my $hledano;
        if($dva_sloupce)
        {
            $hledano = $bunky[1].' '.$bunky[2];
            push(@bunky, $bunky[1], $bunky[2]);
            splice(@bunky, 1, 2);
        }
        else
        {
            $hledano = $bunky[1];
            push(@bunky, $bunky[1]);
            splice(@bunky, 1, 1);
        }
        # Připravit buňky k opsání na výstup.
        my $bunky_td = join('', map {'<td>'.$_.'</td>'} (@bunky));
        $hledano =~ s/^\s+//;
        $hledano =~ s/\s+$//;
        $hledano =~ s/\s+/ /g;
        my @nalezy = hledat($hledano, $osoby);
        if(@nalezy)
        {
            my $style = scalar(@nalezy)>1 ? " style='color:blue'" : $nalezy[0]->{cele_jmeno} ne $hledano ? " style='color:green'" : '';
            foreach my $nalez (@nalezy)
            {
                # Označit fialově nálezy, které mají menší délku než hledaný řetězec.
                # Může to znamenat, že jsme našli nesmysl (např. když záznam v databázi má jen jedno písmeno), nebo že je potřeba záznam v databázi doplnit.
                if(length($hledano)>length($nalez->{cele_jmeno}))
                {
                    $style = " style='color:magenta'";
                }
                print("    <tr$style><td>$nalez->{kod}</td>$bunky_td<td>$nalez->{cele_jmeno}</td></tr>\n");
            }
        }
        else
        {
            print("    <tr style='color:red'><td>NENALEZENO</td>$bunky_td<td>$hledano</td></tr>\n");
        }
    }
    print("  </table>\n");
    print("  <p>Legenda:</p>\n");
    print("  <ul>\n");
    print("    <li style='color:red'>V&nbsp;databázi nebylo nalezeno odpovídající jméno.</li>\n");
    print("    <li style='color:magenta'>Nalezeno pasující jméno, ale je kratší, takže buď chceme do databáze něco doplnit, nebo je to chybný nález.</li>\n");
    print("    <li style='color:blue'>Nalezeno několik pasujících jmen, musíme rozhodnout, který záznam je ten pravý.</li>\n");
    print("    <li style='color:green'>Nalezeno právě jedno stejně dlouhé jméno, které se liší od hledaného řetězce v&nbsp;diakritice nebo v&nbsp;pořadí jména a příjmení.</li>\n");
    print("    <li>Nalezeno právě jedno stejně dlouhé jméno, které se od hledaného řetězce nijak neliší.</li>\n");
    print("  </ul>\n");
    if($konfig->{cpvysledkytymy})
    {
        my $druzstva = cist_vysledky_tymy($konfig);
        my $body_hracu = cist_vysledky_ctyrpohar($konfig);
        if($druzstva)
        {
            vypsat_ctyrpohar($druzstva, $body_hracu, $osoby);
        }
    }
    print("  </body>\n");
    print("</html>\n");
}



#------------------------------------------------------------------------------
# Projde tabulku osob a najde všechny záznamy, jejichž jméno odpovídá hledané
# osobě.
#------------------------------------------------------------------------------
sub hledat
{
    my $hledana = shift;
    my $osoby = shift;
    my $kanon = ascii::ascii(lc($hledana));
    # Kromě chybějící diakritiky se může stát, že je prohozené jméno a příjmení, zkusíme tedy obojí.
    my @nonak = split(/\s+/, $kanon);
    unshift(@nonak, pop(@nonak));
    my $nonak = join(' ', @nonak);
    my @nalezy;
    # Bohužel nemůžeme použít hash, protože chceme hledat pomocí regulárních výrazů.
    foreach my $osoba (@{$osoby})
    {
        # Přeskočit bezejmenné osoby, tam bychom porovnávali pouze mezeru s mezerou.
        next if($osoba->{kanonicky} =~ m/^\s*$/);
        if($osoba->{kanonicky} =~ m/\Q$kanon\E/i || $kanon =~ m/\Q$osoba->{kanonicky}\E/ ||
           $osoba->{kanonicky} =~ m/\Q$nonak\E/i || $nonak =~ m/\Q$osoba->{kanonicky}\E/)
        {
            push(@nalezy, $osoba);
        }
    }
    # V databázi je mnoho záznamů, kterým chybí křestní jméno nebo příjmení.
    # Pokud hledané jméno obsahuje mezeru (tj. skládá se alespoň ze dvou slov) a našli jsme alespoň jeden záznam, jehož jméno také obsahuje mezeru,
    # zahodit všechny nálezy, které mezeru neobsahují.
    my @nalezy_s_mezerou = grep {$_->{kanonicky} =~ m/\s/} (@nalezy);
    if($kanon =~ m/\s/ && @nalezy_s_mezerou)
    {
        @nalezy = @nalezy_s_mezerou;
    }
    return @nalezy;
}



#------------------------------------------------------------------------------
# Projde tabulku osob a najde všechny záznamy, jejichž jméno odpovídá hledané
# osobě. Tahle verze nejdřív rozdělí hledané jméno na slova a potom hledá každé
# zvlášť. U variant hledá obojí.
#------------------------------------------------------------------------------
sub hledat2
{
    my $hledana = shift;
    my $osoby = shift;
    ###!!! Tohle je potřeba zavolat jednou na začátku a sem to předávat jako parametr!
    my $altjmena = nahashovat_alternativni_jmena();
    ###!!! Tohle bychom také měli dělat jen jednou na začátku a sem to předávat jako parametr!
    # U osob v databázi si nahashujeme jejich jména a příjmení, alternativy už hashovat nemusíme (ty stačí řešit z jedné strany).
    my %dbindex;
    foreach my $osoba (@{$osoby})
    {
        # Nahashovat všechna křestní jména této osoby.
        foreach my $jmeno (split(/\s+/, $osoba->{jmeno}))
        {
            my $jmeno1 = ascii::ascii($jmeno);
            push(@{$dbindex{$jmeno1}}, $osoba);
        }
        # Nahashovat všechna příjmení této osoby.
        foreach my $prijmeni (split(/\s+/, $osoba->{prijmeni}))
        {
            my $prijmeni1 = ascii::ascii($prijmeni);
            push(@{$dbindex{$prijmeni1}}, $osoba);
        }
    }
    # Rozdělit hledané jméno na slova (typicky jméno a příjmení, ale může jich být i několik).
    $hledana =~ s/^\s+//;
    $hledana =~ s/\s+$//;
    $hledana =~ s/\s+/ /g;
    my @hljmena = split(/\s+/, ascii::ascii($hledana));
    # Nevíme, v jakém pořadí jsou jména uvedena a která jména jsou křestní, nicméně ke křestním potřebujeme hledat i alternativy.
    # Ke každému jménu může existovat libovolný počet alternativ.
    # Pokud k danému jménu nemáme ve slovníku žádnou alternativu (např. proto, že je to příjmení), hledáme jen to jméno.
    # Pro každé slovo hledaného jména najít všechny záznamy v databázi, které ho obsahují.
    # Pro každý záznam v databázi si pamatovat, kolik hledaných slov se v něm našlo ve jméně a kolik v příjmení.
    # Abychom na konci zbytečně nehlásili všechny Martiny, jestliže jsme našli i hledaného Martina Procházku.
    my %hljosoby;
    foreach my $hlj (@hljmena)
    {
        # Poznamenat si všechny osoby, které mají toto slovo ve jméně.
        # Nezapomenout na alternativní znění téhož jména.
        foreach my $althlj (@{$altjmena->{$hlj}})
        {
            foreach my $osoba (@{$dbindex{$althlj}})
            {
                # Na konci budeme chtít vědět, zda se v daném záznamu v databázi našly všechny části jména (plný počet),
                # nebo jen některé části (menší než plný počet). Teoreticky je možné, že v jednom záznamu najdeme
                # křestní jméno i některé jeho alternativy, takže bychom tady neměli zvedat čítač za každou nalezenou
                # alternativu, ale jen za první nalezenou alternativu daného jména. Např. je možné, že pro hledanou
                # osobu "Jarda Novák" bude mít nejvyšší skóre záznam, ve kterém bude uvedeno "Jaroslav Jarda Novák".
                # V praxi je to ale velmi nepravděpodobné, takže si tím nebudeme komplikovat život.
                $hljosoby{$osoba}++;
            }
        }
    }
    # Zjistit, jaký je nejvyšší počet částí hledaného jména, který se v nějakém záznamu našel
    # (typicky 2, pokud se našlo jméno i příjmení, jinak 1 za křestní jméno, popř. příjmení).
    my @nalezy = sort {$hljosoby{$b} <=> $hljosoby{$a}} (keys(%hljosoby));
    my $maxn = scalar(@nalezy) ? $hljosoby{$nalezy[0]} : 0;
    # Zahodit záznamy, ve kterých se rozpoznalo méně částí hledaného jména.
    @nalezy = grep {$hljosoby{$_}==$maxn} (@nalezy);
    ###!!! Má to ještě háček. Když místo "Martina Nováka" najdeme jenom "M Nováka", "Nováka", popř. i úplně jiného "Nováka",
    # asi nám nevadí vrátit všechny nalezené Nováky, ať si s tím Klárka nějak poradí. Na druhou stranu ale určitě nechceme
    # vrátit několik desítek "Martinů"! Musíme buď zacházet odlišně se jménem a příjmením, což by asi byl pěknej vopruz,
    # nebo, což by bylo možná lepší, ale také ne jednoduché, kontrolovat částečnou shodu (regulární výrazy, překlepy)
    # u zbytku jména (těch částí, které se nenašly).
    return @nalezy;
}



#------------------------------------------------------------------------------
# Načte list VýsledkyTýmy z výsledků Čtyřpoháru.
#------------------------------------------------------------------------------
sub cist_vysledky_tymy
{
    my $konfig = shift;
    my $tabulka = $konfig->{cpvysledkytymy};
    my @radky = split(/\r?\n/, $tabulka);
    # První řádek tabulky může být prázdný.
    while(@radky && $radky[0] =~ m/^\s*$/)
    {
        shift(@radky);
    }
    # První neprázdný řádek tabulky by měl obsahovat názvy sloupců.
    my @nazvy = split(/\t/, shift(@radky));
    my %index;
    for(my $i = 0; $i<=$#nazvy; $i++)
    {
        $index{$nazvy[$i]} = $i;
    }
    # Ostatní řádky obsahují složení a body týmů.
    my @druzstva;
    foreach my $radek (@radky)
    {
        my @bunky = split(/\t/, $radek);
        my %zaznam =
        (
            'los'      => $bunky[$index{'Los'}],
            'druzstvo' => $bunky[$index{'Družstvo'}],
            'hraci'    =>
            [
                $bunky[$index{'1.hráč'}],
                $bunky[$index{'2.hráč'}],
                $bunky[$index{'3.hráč'}],
                $bunky[$index{'4.hráč'}]
            ],
            'body'     => $bunky[$index{'Body'}]
        );
        push(@druzstva, \%zaznam);
    }
    return \@druzstva;
}



#------------------------------------------------------------------------------
# Načte list Výsledky z výsledků Čtyřpoháru.
#------------------------------------------------------------------------------
sub cist_vysledky_ctyrpohar
{
    my $konfig = shift;
    my $tabulka = $konfig->{cpvysledky};
    my @radky = split(/\r?\n/, $tabulka);
    # První čtyři řádky tabulky nás nezajímají.
    splice(@radky, 0, 4);
    # Následuje vždy po pěti řádcích na každé družstvo:
    # První řádek obsahuje součty za družstvo.
    # Další čtyři řádky obsahují body jednotlivých hráčů.
    # Sloupce: Skrytý sloupec, Los (kód), Jméno
    # čtyřikrát po třech sloupcích za každé kolo: Skóre, Pořadí, Body
    # dva sloupce celkem: Pořadí (možná zatím nevyplněné) a Body
    # Prozatím pouze nahashovat součet bodů každého hráče. Použijeme ho jako druhotné kritérium.
    my %hash;
    foreach my $radek (@radky)
    {
        my @bunky = split(/\t/, $radek);
        # Je nám celkem jedno, že vedle sebe nahashujeme body družstev i hráčů.
        # Ptát se pak budeme jenom na hráče.
        # Spíš by vadilo, kdyby se dva různí hráči jmenovali stejně.
        my $jmeno = $bunky[2];
        my $body = $bunky[16];
        $hash{$jmeno} = $body;
    }
    return \%hash;
}



#------------------------------------------------------------------------------
# Vypíše tabulku s výsledky Čtyřpoháru.
#------------------------------------------------------------------------------
sub vypsat_ctyrpohar
{
    # Načtená tabulka VýsledkyTýmy:
    my $druzstva = shift;
    my $body_hracu = shift;
    my $osoby = shift;
    # Seřadit družstva sestupně podle počtu bodů.
    my @sdruzstva = sort
    {
        my $aa = $a->{body};
        my $bb = $b->{body};
        $aa =~ s/,/./;
        $bb =~ s/,/./;
        $bb <=> $aa
    } (@{$druzstva});
    print("<table border=1>\n");
    print("  <tr>\n");
    print("    <th>Kód hráče</th>\n");
    print("    <th>Jméno hráče</th>\n");
    print("    <th>Opravené jméno hráče</th>\n");
    print("    <th>Pořadí</th>\n");
    print("    <th>Body družstva</th>\n");
    print("    <th>Družstvo</th>\n");
    print("    <th>Body hráče</th>\n");
    print("  </tr>\n");
    my $poradi = 1;
    foreach my $d (@sdruzstva)
    {
        # Seřadit hráče podle bodů, kterými družstvu přispěli.
        my @sh = sort
        {
            my $aa = $body_hracu->{$a};
            my $bb = $body_hracu->{$b};
            $aa =~ s/,/./;
            $bb =~ s/,/./;
            $bb <=> $aa
        } (@{$d->{hraci}});
        # Zopakovat řádek pro každého hráče.
        foreach my $h (@sh)
        {
            # Hledat hráče v databázi.
            my $oh = opravit_jmeno($h);
            my @nalezy = hledat($oh, $osoby);
            my $kod = join(' nebo ', map {$_->{kod}} (@nalezy));
            print("  <tr>\n");
            print("    <td>$kod</td>\n");
            print("    <td>$h</td>\n");
            $oh = '' if($oh eq $h);
            print("    <td>$oh</td>\n");
            print("    <td>$poradi</td>\n");
            print("    <td>$d->{body}</td>\n");
            print("    <td>$d->{druzstvo}</td>\n");
            print("    <td>$body_hracu->{$h}</td>\n");
            print("  </tr>\n");
        }
        $poradi++;
    }
    print("</table>\n");
}



#------------------------------------------------------------------------------
# Vrátí odkaz na hash, ve kterém pro každé znění každého jména najdeme seznam
# všech ekvivalentních znění. (Seznam zahrnuje pouze jména, která mají alespoň
# dvě alternativy.)
#------------------------------------------------------------------------------
sub nahashovat_alternativni_jmena
{
    my @altjmena =
    (
        ['Alexandr', 'Saša'],
        ['Alexandra', 'Saša'],
        ['Antonín', 'Tonda'],
        ['Barbora', 'Bára'],
        ['Bohumil', 'Bohouš', 'Bob'],
        ['Bohumír', 'Bohouš', 'Bob'],
        ['Bohuslav', 'Bohouš', 'Bob', 'Slávek'],
        ['Dagmar', 'Dáša'],
        ['Daniel', 'Dan'],
        ['Daniela', 'Dana'],
        ['František', 'Franta', 'Fanda'],
        ['Gabriela', 'Gábina'],
        ['Hana', 'Hanka'],
        ['Ilona', 'Ilča'],
        ['Ivana', 'Iva'],
        ['Jakub', 'Kuba'],
        ['Jan', 'Honza'],
        ['Jaromír', 'Jarek', 'Jarda'],
        ['Jaroslav', 'Jarda', 'Jarek'],
        ['Jindřich', 'Jindra'],
        ['Jindřiška', 'Jindra'],
        ['Jiří', 'Jirka'],
        ['Josef', 'Pepa'],
        ['Karolína', 'Kája'],
        ['Kateřina', 'Katka'],
        ['Ladislav', 'Láďa'],
        ['Lucie', 'Lucka'],
        ['Marie', 'Maruška'],
        ['Miloslav', 'Miloš', 'Slávek'],
        ['Miroslav', 'Mirek'],
        ['Oldřich', 'Olda'],
        ['Olga', 'Olina'],
        ['Ondřej', 'Ondra'],
        ['Rudolf', 'Ruda'],
        ['Slavomil', 'Slávek'],
        ['Slavomír', 'Slávek'],
        ['Stanislav', 'Standa'],
        ['Svatava', 'Svaťka'],
        ['Václav', 'Vašek'],
        ['Vladimír', 'Vláďa', 'Láďa'],
        ['Vladislav', 'Vláďa', 'Láďa'],
        ['Vojtěch', 'Vojta'],
        ['Vratislav', 'Vráťa'],
        ['Zdena', 'Zdeňka'],
        ['Zuzana', 'Zuzka'],
    );
    my %hash;
    foreach my $seznam (@altjmena)
    {
        foreach my $alternativa (@{$seznam})
        {
            # Pozor! Některé alternativy se vyskytují na několika různých seznamech.
            # Proto do hashe nemůžeme prostě strčit odkaz na aktuální seznam. Musíme tam prvky seznamu opsat.
            # Jinak bychom mohli v hashi přepsat odkaz na jiný seznam, na kterém byla aktuální alternativa.
            push(@{$hash{$alternativa}}, @{$seznam});
        }
    }
    return \%hash;
}



#------------------------------------------------------------------------------
# Převede domáckou podobu křestního jména na úřední. Nepočítá s výjimkami, kdy
# má někdo domáckou podobu zapsanou přímo v občance (Mirek Topolánek, Zuzka
# Ruibrová). Nemění ale jména tam, kde jsou obě podoby relativně běžné (např.
# Magda vs. Magdalena, Dana vs. Daniela) nebo kde nelze jednoznačně určit
# úřední podobu (Slávek může být zkratka za mnoho různých jmen).
#------------------------------------------------------------------------------
sub opravit_jmeno
{
    my $jmeno = shift;
    $jmeno =~ s/Bára/Barbora/;
    # Dan: úředně existuje Dan i Daniel, ale Daniel je asi běžnější
    $jmeno =~ s/Dáša/Dagmar/;
    $jmeno =~ s/Hanka/Hana/;
    $jmeno =~ s/Honza/Jan/;
    $jmeno =~ s/Ilča/Ilona/;
    # Jarda, Jarek: Jaromír nebo Jaroslav
    # Jindra: Jindra, Jindřich nebo Jindřiška
    $jmeno =~ s/Jirka/Jiří/;
    $jmeno =~ s/Katka/Kateřina/;
    $jmeno =~ s/Kuba/Jakub/;
    $jmeno =~ s/Láďa/Ladislav/;
    $jmeno =~ s/Lucka/Lucie/;
    $jmeno =~ s/Maruška/Marie/;
    $jmeno =~ s/Mirek/Miroslav/;
    $jmeno =~ s/Olda/Oldřich/;
    $jmeno =~ s/Olina/Olga/;
    $jmeno =~ s/Ondra/Ondřej/;
    $jmeno =~ s/Pepa/Josef/;
    $jmeno =~ s/Ruda/Rudolf/;
    # Saša: Alexandr nebo Alexandra
    # Slávek: Slavomír, Bohuslav, Miloslav, Miroslav, Jaroslav...
    $jmeno =~ s/Standa/Stanislav/;
    $jmeno =~ s/Svaťka/Svatava/;
    $jmeno =~ s/Tonda/Antonín/;
    $jmeno =~ s/Vašek/Václav/;
    # Vláďa: Vladimír nebo Vladislav
    $jmeno =~ s/Vojta/Vojtěch/;
    $jmeno =~ s/Zuzka/Zuzana/;
    return $jmeno;
}



#------------------------------------------------------------------------------
# Vypíše záhlaví MIME a HTML.
#------------------------------------------------------------------------------
sub vypsat_zahlavi
{
    my $title = shift;
    my $redir = shift; # chceme-li přesměrovat na sebe sama bez parametrů
    my $metaredir = $redir ? "    <meta http-equiv=\"Refresh\" content=\"5; URL=$redir\">\n" : '';
    # Poslat MIME záhlaví dokumentu.
    print("Content-Type: text/html; charset=utf-8\n\n");
    # Poslat záhlaví HTML a počáteční značku těla, abychom mohli vypisovat i ladící a chybová hlášení.
    # Na druhou stranu to znamená, že nemůžeme přizpůsobit <title> parametrům a obsahu stránky (např. přidat do něj jméno osoby).
    print <<EOF
<html>
  <head>
$metaredir    <meta http-equiv="Content-Language" content="cs">
    <meta http-equiv="Content-Type" content="text/html; charset=utf-8">
    <title>$title</title>
  </head>
  <body>
EOF
    ;
    # Když už je vypsáno záhlaví, můžeme vypsat i případná ladící hlášení,
    # která se do této chvíle nashromáždila.
    vyprazdnit_schranku();
}



#------------------------------------------------------------------------------
# Vypíše barevné ladící hlášení na právě generované webové stránce.
# Pokud ještě nebylo odesláno záhlaví MIME a HTML, uloží hlášení do schránky,
# aby se mohlo vypsat, jakmile to bude možné.
#------------------------------------------------------------------------------
sub debug
{
    my $zprava = join('', @_);
    my $hlaseni = "<p><font color=magenta>$zprava</font></p>\n";
    if($global_zahlavi_vypsano)
    {
        print($hlaseni);
    }
    else
    {
        $global_buffer .= $hlaseni;
    }
}



#------------------------------------------------------------------------------
# Ohlásí chybu barevným nápisem na právě generované webové stránce.
# Pokud ještě nebylo odesláno záhlaví MIME a HTML, uloží hlášení do schránky,
# aby se mohlo vypsat, jakmile to bude možné.
#------------------------------------------------------------------------------
sub chyba
{
    my $chyba = join('', @_);
    debug("Chyba: $chyba");
}



#------------------------------------------------------------------------------
# Vypíše všechna ladící hlášení, která se nashromáždila v době, kdy ještě
# nebylo odesláno záhlaví MIME a HTML.
#------------------------------------------------------------------------------
sub vyprazdnit_schranku
{
    print($global_buffer);
    $global_buffer = '';
    $global_zahlavi_vypsano = 1;
}



#------------------------------------------------------------------------------
# Ohlásí chybu a skončí. Používá se pro fatální chyby při ukládání změn, kvůli
# kterým nelze pokračovat v ukládání. Nahrazuje funkci Perlu die(), kterou
# nechceme použít, protože by klient nedostal chybové hlášení.
#------------------------------------------------------------------------------
sub fatalni_chyba
{
    my $chyba = shift;
    print <<EOF
<html>
  <head>
    <meta http-equiv="Content-Language" content="cs">
    <meta http-equiv="Content-Type" content="text/html; charset=utf-8">
    <title>Přehled osob: Chyba při ukládání změn</title>
  </head>
  <body>
    <h1>Chyba</h1>
    <p>$chyba</p>
  </body>
</html>
EOF
    ;
    exit;
}