package cgi;
require 5.000;
require Exporter;

@ISA = qw(Exporter);
#@EXPORT = qw();

#!/usr/bin/perl
# Knihovna funkcí pro cgi skripty.
# (c) Daniel Zeman, 2002 - 2003



#-----------------------------------------------------------------------------
# Odstraní z řetězce zvláštní kódy používané při předávání parametrů cgi.
#-----------------------------------------------------------------------------
sub dekodovat_parametr_cgi
{
    my $parametr = $_[0];
    # Dekódovat mezeru (je zapsána jako "+").
    $parametr =~ s/\+/ /g;
    # Dekódovat zvláštní znaky v datech (jsou zapsány jako %hex).
    for(my $j = 32; $j<256; $j++)
    {
        if($j!=hex("3C"))
        {
            my $hex = sprintf("%02X", $j);
            my $znak = chr($j);
            $parametr =~ s/%$hex/$znak/ig;
        }
    }
    $parametr =~ s/(%0D)?%0A/\n/ig;
    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);
            # 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);
}



#-----------------------------------------------------------------------------
# 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;
        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
{
    # 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 = %param;
    # 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
        {
            undef($nove{$zmeny[$i]});
        }
    }
    # Sestavit QUERY_STRING.
    my $retezec;
    my ($klic, $hodnota);
    while(($klic, $hodnota) = each(%nove))
    {
        # Zakódovat zvláštní znaky v hodnotách i v klíčích.
        # Ze všeho nejdříve zakódovat samotný kódovací znak - procento.
        $hodnota =~ s/%/%25/g;
        for(my $j = 128; $j<256; $j++)
        {
            if($j!=hex("3C") && $j!=hex("25"))
            {
                my $hex = sprintf("%02X", $j);
                my $znak = chr($j);
                $hodnota =~ s/$znak/%$hex/g;
            }
        }
        # Po zakódování přidat do řetězce.
        $retezec .= "&amp;$klic=$hodnota";
    }
    $retezec =~ s/^&amp;//;
    return $retezec;
}



#------------------------------------------------------------------------------
# Vypíše dobu, po kterou program běžel. K tomu potřebuje dostat časové otisky
# začátku a konce.
#------------------------------------------------------------------------------
sub vypsat_delku_trvani_programu
{
    my $starttime = $_[0];
    my $stoptime = $_[1];
    my $cas = $stoptime-$starttime;
    my $hod = int($cas/3600);
    my $min = int(($cas%3600)/60);
    my $sek = $cas%60;
    my $hlaseni;
    if($hod==0)
    {
        if($min==0)
        {
            $hlaseni = sprintf("Program běžel $sek vteřin.\n");
        }
        else
        {
            $hlaseni = sprintf("Program běžel %d:%02d minut.\n", $min, $sek);
        }
    }
    else
    {
        $hlaseni = sprintf("Program běžel %2d:%02d:%02d hodin.\n", $hod, $min, $sek);
    }
}