package dancgi;
# Knihovna funkcí pro cgi skripty.
# (c) Daniel Zeman, 2002 - 2003
use Encode; # aby se mohly číst parametry ze souboru v UTF-8
use URI::Escape;



#-----------------------------------------------------------------------------
# Dekóduje bajty schované za procentem. S výsledkem naloží jako s řetězcem
# bajtů, které kódují znakový řetězec metodou UTF-8 (u většiny řetězců, které
# získáme z formulářů, to skutečně tak bude).
#-----------------------------------------------------------------------------
sub dekodovat
{
    my $parametr = shift;
    $parametr =~ s/\+/%20/g;
    $parametr = uri_unescape($parametr);
    $parametr = decode('utf8', $parametr);
    return $parametr;
}



#------------------------------------------------------------------------------
# Rozebere řetězec s parametry tvaru "x=7&y=-15.6&..." Společná část pro
# parametry získané různým způsobem (URL, formulář GET, POST...)
#------------------------------------------------------------------------------
sub rozebrat_parametry
{
    my $parametry = $_[0];
#    print("Rozebírám parametry $parametry\n");
    my $uloziste = $_[1]; # odkaz na cílový hash
    my %_lokalni_uloziste; # pro případ, že volající žádné úložiště neposkytl
    if($uloziste eq "")
    {
        $uloziste = \%_lokalni_uloziste;
    }
    # Rozsekat parametry po jednom do pole.
    my @parametry = split(/&/, $parametry);
    # Teď jsou všechny parametry soustředěné v poli @parametry.
    # Projít je a rozebrat.
    for(my $i = 0; $i<=$#parametry; $i++)
    {
        # Jestliže parametrický záznam obsahuje rovnítko, považovat ho za přiřazení atribut=hodnota.
        if($parametry[$i] =~ m/(.*?)=(.*)/)
        {
            my $atribut = $1;
            ###!!!my $hodnota = dekodovat_parametr_cgi($2);
            my $hodnota = dekodovat($2);
            # Jestliže je před jménem atributu zavináč, může mít více hodnot a ty se musí uložit do pole.
            if($atribut =~ s/^\@//)
            {
                push(@{$uloziste->{$atribut}}, $hodnota);
            }
            # Jinak nepředpokládáme, že se do tohoto atributu bude přiřazovat vícekrát.
            # Dojde-li k tomu, pozdější přiřazení přepíše hodnotu dřívějšího.
            else
            {
                $uloziste->{$atribut} = $hodnota;
            }
        }
        # Jestliže parametrický záznam neobsahuje rovnítko, považovat ho celý za název boolovského atributu.
        else
        {
            $uloziste->{$parametry[$i]} = 1;
        }
    }
    return %{$uloziste};
}



#------------------------------------------------------------------------------
# Přečte parametry CGI (jsou v prostředí v proměnné QUERY_STRING, ve tvaru
# atribut=hodnota, jednotlivá přiřazení jsou oddělena ampersandem. Dostaly se
# tam buď jako součást URL za otazníkem, nebo jako data z formuláře používají-
# cího metodu GET. Funkce vrací seznam parametrů v hashi.
#------------------------------------------------------------------------------
sub cist_parametry
{
    # Parametry dodané jako součást URL nebo formulářovou metodou GET jsou v proměnné prostředí QUERY_STRING.
    my $parametry = $ENV{"QUERY_STRING"};
    my $uloziste = $_[0]; # odkaz na cílový hash
    return rozebrat_parametry($parametry, $uloziste);
}



#------------------------------------------------------------------------------
# Přečte data z formuláře používajícího metodu POST. Od funkce cist_parametry
# se liší tím, že data čte ze standardního vstupu.
#------------------------------------------------------------------------------
sub cist_formular_post
{
    # Parametry z formuláře dodané metodou POST čekají na standardním vstupu.
    my $parametry;
    my $uloziste = $_[0]; # odkaz na cílový hash
    while(<STDIN>)
    {
        chomp;
        if($parametry ne "")
        {
            $parametry .= "&";
        }
        $parametry .= $_;
    }
    return rozebrat_parametry($parametry, $uloziste);
}



#------------------------------------------------------------------------------
# Přečte parametry z příkazového řádku.
#------------------------------------------------------------------------------
sub cist_parametry_argv
{
    my $uloziste = shift; # odkaz na cílový hash
    # Parametry dodané jako součást URL nebo formulářovou metodou GET jsou v proměnné prostředí QUERY_STRING.
    my $parametry = join("&", @main::ARGV);
    return rozebrat_parametry($parametry, $uloziste);
}



#-----------------------------------------------------------------------------
# Načte parametry ze souboru, jehož jméno dostane.
#-----------------------------------------------------------------------------
sub cist_parametry_ze_souboru
{
    my $jmeno_souboru = $_[0];
    my $parametry = $_[1]; # odkaz na hash
    open(PARAMETRY, $jmeno_souboru); # don't die
    while(<PARAMETRY>)
    {
        chomp;
        $_ = decode("utf8", $_);
        if(m/(.*?)=(.*)/)
        {
            $parametry->{$1} = $2;
        }
    }
    close(PARAMETRY);
}



#-----------------------------------------------------------------------------
# Sestaví parametry tohoto skriptu opět do jednoho řetězce QUERY_STRING.
# Na požádání některé z nich upraví. Používá se při formulování odkazů na
# spřátelené skripty nebo sebe sama, kde chceme zachovat všechny parametry
# až na několik.
#-----------------------------------------------------------------------------
sub sestavit_parametry
{
    return sestavit_parametry_odkaz(\%main::param, @_);
}



#-----------------------------------------------------------------------------
# Sestaví parametry tohoto skriptu opět do jednoho řetězce ve stejném formátu
# jako QUERY_STRING. Na požádání některé z nich upraví. Používá se při
# formulování odkazů na spřátelené skripty nebo sebe sama, když chceme
# zachovat všechny parametry až na několik.
#-----------------------------------------------------------------------------
sub sestavit_parametry_odkaz
{
    my $parametry = shift; # odkaz na hash s původními parametry
    # Další parametry této funkce jsou případné požadavky na změny ve tvaru
    # parametr=hodnota.
    my @zmeny = @_;
    # Současné parametry skriptu se přebírají z globálního hashe %param.
    my %nove;
    while(my ($klic, $hodnota) = each(%{$parametry}))
    {
        # Z původních parametrů vyházet všechny, jejichž název začínal podtržítkem.
        # Ty jsou dopočítané skriptem a uživatele nezajímají.
        if($klic !~ m/^_/)
        {
            $nove{$klic} = $hodnota;
        }
    }
    # Aplikovat změny.
    for(my $i = 0; $i<=$#zmeny; $i++)
    {
        if($zmeny[$i] =~ m/(.*?)=(.*)/)
        {
            $nove{$1} = $2;
        }
        # Parametr uvedený bez nové hodnoty se má vymazat.
        else
        {
            delete($nove{$zmeny[$i]});
        }
    }
    # Sestavit QUERY_STRING.
    my $retezec;
    while(my ($klic, $hodnota) = each(%nove))
    {
        # Zakódovat zvláštní znaky v hodnotách i v klíčích.
        my @znaky = split(//, $hodnota);
        for(my $i = 0; $i<=$#znaky; $i++)
        {
            my $kod = ord($znaky[$i]);
            if($kod<=64 && !($kod>=48 && $kod<=58) && $znaky[$i] !~ m/[\.,]/ || $kod>=128)
            {
#                $znaky[$i] = sprintf("%%%04X", $kod);
                $znaky[$i] = sprintf("%%%02X", $kod);
            }
        }
        # Po zakódování přidat do řetězce.
        $retezec .= "&amp;$klic=".join("", @znaky);
    }
    $retezec =~ s/^&amp;//;
    return $retezec;
}



1;