#!/usr/bin/perl # Zobrazí nebo zpracuje hlasovací formulář. # Copyright © 2011-2015 Klára a Dan Zemanovi # Licence: GNU GPL use utf8; # říct Perlu, že konstantní řetězce ve zdrojáku jsou v UTF use Encode; # funkce pro překódování use DBI; # spolupráce se serverem MySQL # Říct Perlu, kde najde Danovy sdílené knihovny. # CGI skripty běží pod uživatelem apache, který nemá tyto knihovny v cestě. use lib '/s/w/lib/dan'; use dancgi; # čtení parametrů z webu nebo z ARGV use cas; # práce s daty a časem use jazyky; # jazykové verze textů use csort; # jazykově závislé řazení podle abecedy use mso; # funkce pro generování stránek o olympiádě binmode(STDOUT, ':utf8'); # říct Perlu, že UTF chceme i na výstupu # Připojit se k databázi. $databaze = mso::pripojit_se_k_databazi(); # Každý rok je potřeba nejdříve v databázi na serveru vytvořit novou tabulku, # ta stará tam zůstane jako archív. Dá se to udělat tak, že u loňské tabulky dám # export do SQL, v tom, co dostanu, umažu dlouhý příkaz INSERT pro vložení dat, # zbude nějaká inicializace a příkaz CREATE, v něm změním jméno tabulky na nový rok, # pak to zase vložím do záložky SQL databáze mso na serveru. # Potom musíme změnit název tabulky i tady. $tabulka = 'hlasovani_2015'; # Načíst parametry z URL. dancgi::cist_parametry(\%konfig); # Umožnit volat skript z příkazového řádku a předat parametry tam (např. perl partie.pl zdroj=cas). dancgi::rozebrat_parametry($ARGV[0], \%konfig); # Načíst formulář. if($konfig{co} eq 'zpracuj') { dancgi::cist_formular_post(\%konfig); } if($konfig{jazyk} eq '') { $konfig{jazyk} = 'cs'; } $jazyky::jazyk = $konfig{jazyk}; # Vždy lze hlasovat pouze pro jeden ročník: ten nejbližší, který bude, případně # ten, který právě probíhá. Zjistit, který ročník to je, a přepsat parametr rok, # ať už tam měl uživatel cokoli. $ted = cas::ted(); $roky = mso::dotazat_se_databaze($databaze, 'rok', 'konec', 'vcasne_prihlasky_do', 'rocniky ORDER BY rok'); for(my $i = 0; $i<=$#{$roky}; $i++) { $konfig{rok} = $roky->[$i]{rok}; $konfig{vcas} = $roky->[$i]{vcasne_prihlasky_do}; if($ted->{eden} <= cas::datum2eden($roky->[$i]{konec})) { last; } } if($konfig{co} ne 'zpracuj') { zobrazit_hlasovani($databaze, \%konfig); } else { zpracovat_hlasovani($databaze, $tabulka, \%konfig); } ############################################################################### # PODPROGRAMY ############################################################################### #------------------------------------------------------------------------------ # Zobrazí hlasovací formulář. #------------------------------------------------------------------------------ sub zobrazit_hlasovani { my $databaze = shift; my $konfig = shift; mso::vypsat_stranku( { 'nazev' => "MSO: $konfig->{rok}: ".jazyky::zjistit('Hlasovani'), 'nadpis' => jazyky::zjistit('hlasovani_nadpis', $konfig->{rok}), 'telo' => hlasovani($databaze, $konfig), 'rok' => $konfig->{rok} }); } #------------------------------------------------------------------------------ # Vypíše hlasovací formulář. #------------------------------------------------------------------------------ sub hlasovani { my $databaze = shift; my $konfig = shift; my $stranka; # Přečíst tabulku akcí. my $akce = mso::nacist_akce($databaze, $konfig->{rok}); # Rozebrat hlasovací kód. # Kdyby byl z nějakého důvodu vadný, tak to oznámit hned a vůbec jim nenabídnout hlasovací formulář. if($konfig->{hl_kod} =~ m/^(\d\d)(\d\d\d\d\d)(\d\d)$/) { $konfig->{hlasu_celkem}= $1; $konfig->{hlasu_celkem} =~ s/^0*(\d+?)$/$1/; $konfig->{kod_osoby} = $2; if($konfig->{hlasu_celkem} > 10 || $konfig->{hl_kod} % 11 != 0) { return "

Chyba: neplatný hlasovací kód

\n"; } } else { return "

Chyba: neplatný hlasovací kód '$konfig->{hl_kod}'

\n"; } # Vypsat formulář hlasování. my $parametry = dancgi::sestavit_parametry_odkaz($konfig, 'telo=hlasovani.pl', 'co=zpracuj'); $stranka .= "
\n"; $stranka .= "

".jazyky::zjistit("hlasovaci_kod")."$konfig->{hl_kod}{hl_kod}\"/>

\n"; $stranka .= "

Vážený hráči, zde máte možnost hlasovat o turnajích podle Vaší preference.\n"; $stranka .= " Níže můžete hlasovat samostatně o \"starých\" hrách (tedy takových, které už na Deskohraní měly turnaj) a \"nových\" hrách, tedy takových, ve kterýce ještě turnaj na Deskohraní nebyl.\n"; $stranka .= "
Každé hře můžete přidělit 0 - 3 bodů tak, aby součet bodů u všech \"starých\" her byl nejvýše $konfig->{hlasu_celkem} bodů a rovněž tak u \"nových\" her musí být součet nejvýše $konfig->{hlasu_celkem} bodů. \n"; $stranka .= "
Hlasovací body jste dostali přidělené (3 - 10 bodů) podle množství a různorodosti turnajů, kterých jste se v předchozích 3 letech zúčastnili.\n"; $stranka .= " Z tohoto důvodu máte přidělený svůj hlasovací kod. Z každého kodu lze hlasovat pouze jednou.\n"; $stranka .= "

Hlasování bude ukončeno 20.8.2015.

Poté zařadíme do programu 3 turnaje ve \"starých\" a 3 v \"nových\", které získaly nejvíce hlasů.\n"; $stranka .= " Kromě toho zařadíme i pár dalších s přihlédnutím na hlasování i na celkovou koncepci festivalu. \n"; $stranka .= "

V záložce \"Turnaje a soutěže\" se můžete podívat, jaké stálice Vás čekají. Samozřejmě budou přibývat stále další informace, jak se domluvíme s jednotlivými organizátory.

\n"; $stranka .= "

Máte k dispozici:
\n"; $stranka .= "$konfig->{hlasu_celkem} hlasovacích bodů k rozdělení \x{201E}starým\x{201C} turnajům.
\n"; $stranka .= "a $konfig->{hlasu_celkem} hlasovacích bodů k rozdělení \x{201E}novým\x{201C} turnajům.

\n"; $stranka .= "

Volba z turnajů, co už na Deskohraní byly (\"staré\" turnaje)

\n"; $stranka .= "

Prosíme, přidělte hrám v součtu nejvýše $konfig->{hlasu_celkem} hlasovacích bodů.

\n"; $stranka .= "

\n"; $stranka .= " 7 divů světa

\n"; $stranka .= "

\n"; $stranka .= " Afrika

\n"; $stranka .= "

\n"; $stranka .= " Burgundské hrady

\n"; $stranka .= "

\n"; $stranka .= " Dědictví

\n"; $stranka .= "

\n"; $stranka .= " Dixit

\n"; $stranka .= "

\n"; $stranka .= " Doba Kamenná

\n"; $stranka .= "

\n"; $stranka .= " Farmáři

\n"; $stranka .= "

\n"; $stranka .= " Funkenschlag (Vysoké napětí)

\n"; $stranka .= "

\n"; $stranka .= " Galaxy Trucker

\n"; $stranka .= "

\n"; $stranka .= " Istanbul

\n"; $stranka .= "

\n"; $stranka .= " Kaleidoskop (Genial)

\n"; $stranka .= "

\n"; $stranka .= " Kingdom Builder

\n"; $stranka .= "

\n"; $stranka .= " Kronika panství (Village)

\n"; $stranka .= "

\n"; $stranka .= " Malacca

\n"; $stranka .= "

\n"; $stranka .= " Notre Dame

\n"; $stranka .= "

\n"; $stranka .= " Port Royal

\n"; $stranka .= "

\n"; $stranka .= " Poštovní kurýr

\n"; $stranka .= "

\n"; $stranka .= " Proroctví

\n"; $stranka .= "

\n"; $stranka .= " Puerto Rico

\n"; $stranka .= "

\n"; $stranka .= " San Juan

\n"; $stranka .= "

\n"; $stranka .= " Sankt Petersburg

\n"; $stranka .= "

\n"; $stranka .= " Trans America či Trans Evropa

\n"; $stranka .= "

\n"; $stranka .= " Ubongo

\n"; $stranka .= "

\n"; $stranka .= " Údolí králů (Egizia)

\n"; $stranka .= "

Volba nových turnajů - ještě na Deskohraní nebyly! (\"nové\" turnaje)

\n"; $stranka .= "

Některé z nich jsou naprosté novinky! Stejně jako u \"starých\" i zde máte k dispozici $konfig->{hlasu_celkem} bodů k rozdělení podle Vašeho uvážení.

\n"; $stranka .= "

\n"; $stranka .= " Concordia \n"; $stranka .= "Kolonizujete Římskou říši, budujete města a obchodujete se surovinami. (90-120 min,12+)

\n"; $stranka .= "

\n"; $stranka .= " Dobyvatelé vesmíru (Race for the Galaxy) \n"; $stranka .= "Hráči závodí v průzkumu galaxie - objevují nové planety a vynalézají nové technologie(45-60 min,12+)

\n"; $stranka .= "

\n"; $stranka .= " Fresco \n"; $stranka .= "Staňte se na chvíli restaurátorem fresky starobylého kostela.Nominace Spiel des Jahres 2010. (60-80 min,10+)

\n"; $stranka .= "

\n"; $stranka .= " Glen More \n"; $stranka .= "Jako vůdce skotských horalů rozšiřujete svoje území pokládáním destiček pastvin, vesnic, jezer a hradů. Jediná hra, kde můžete vypálit whisky! :) (60-90 min,10+)

\n"; $stranka .= "

\n"; $stranka .= " Lancaster \n"; $stranka .= "Boj o moc mezi šlechtickými rody ve středověké Anglii v období Stoleté války s Francií. (60-90 min,10+)

\n"; $stranka .= "

\n"; $stranka .= " London \n"; $stranka .= "Vybudujte město od katedrály sv. Pavla až po první metro na světě. Hra je založená na mechanismu vykládání karet, z nichž ale polovinu vždy musíte nabídnout soupeřům! (90-120 min,13+)

\n"; $stranka .= "

\n"; $stranka .= " Ludvík XIV \n"; $stranka .= "Hráči jsou dvořané a mají zhruba 100 minut na dosažení svých cílů u dvora. Pochopitelně, svou roli zde hraje i sám Král Slunce. (90-120 min,12+)

\n"; $stranka .= "

\n"; $stranka .= " Patchwork \n"; $stranka .= "Se svou přikrývkou dosáhne zaslouženého vítězství ten, kdo chytře zvolí a nejlépe zkombinuje vybrané záplaty., (30-45 min,8+)

\n"; $stranka .= "

\n"; $stranka .= " Pravěk \n"; $stranka .= "podobné mechanismy jako Funkenschlag - Vysoké napětí, (60-90 min,12+)

\n"; $stranka .= "

\n"; $stranka .= " Russian Railroads (Ruské koleje) \n"; $stranka .= "Hráči představují železniční velkopodnikatele, kterým byl svěřen úkol vybudovat Transsibiřskou magistrálu a dvě další páteřní železniční tratě, (120-180 min,12+)

\n"; $stranka .= "

\n"; $stranka .= " Settlers: Zrod impéria \n"; $stranka .= "Hráči produkují suroviny, staví budovy a rozšiřují možnosti svého národa. Každý národ má jiné schopnosti., (60-90 min,10+)

\n"; $stranka .= "

\n"; $stranka .= " Splendor \n"; $stranka .= "V roli bohatého obchodníka za časů renesance budete využívat své zdroje na získávání dolů, dopravních prostředků a řemeslníků, kteří přetvoří surové drahokamy v nádherné šperky, (30-45 min,10+)

\n"; $stranka .= "

\n"; $stranka .= " Star Realms \n"; $stranka .= "Deck-buildingová hra na sci-fi téma (s vytvářením balíčku během hry). Má výrazně interaktivní prvek, který spočívá v tom, že se snaží dobýt soupeřovu základnu, (20-30 min,8+)

\n"; $stranka .= "

\n"; $stranka .= " Takenoko \n"; $stranka .= "Budete obdělávat a zavlažovat pole a snažit se vypěstovat co nejvíce bambusů. Je to totiž jediná potrava, co jí panda, kterou máte na starosti přímo od císaře, (40-60 min,8+)

\n"; $stranka .= "

\n"; $stranka .= " Tash Kalar \n"; $stranka .= "Soubojová hra, kde hráči vyvolávají bytosti budoucnosti v aréně a bojují s nimi, (30-40 min,12+)

\n"; $stranka .= "

\n"; $stranka .= " Ticket to Ride \n"; $stranka .= "Železniční hra podobná Trans Americe. Na mapě spojujete města železniční sítí, přičemž skryté karty určují, která připojená města vám přinesou body, (30-60 min,8+)

\n"; $stranka .= "

\n"; $stranka .= " Troyes \n"; $stranka .= " Každý hráč je zástupce části populace města v oblasti Champagne ve Francii.(90 - 120 min,12+)

\n"; $stranka .= "

\n"; $stranka .= "Místo pro Váš návrh:

\n"; $stranka .= "

\n"; $stranka .= "Místo pro Váš 2. návrh:

\n"; my $parametry = dancgi::sestavit_parametry_odkaz($konfig, "telo=hlasovani.pl", "hra=pet", "turnaj=oly"); $stranka .= " \n"; $stranka .= "
\n"; # Přidat parametry, které uživatele nezajímají, ale my je potřebujeme. $stranka .= " \n"; $stranka .= " \n"; my $cas = cas::ted()->{rmdhms}; $stranka .= " \n"; # Přidat tlačítka pro odeslání nebo vymazání formuláře. $stranka .= "

\n"; $stranka .= " \n"; $stranka .= " \n"; $stranka .= "

\n"; $stranka .= "
\n"; return $stranka; } #============================================================================== # Funkce pro zpracování vyplněného formuláře #============================================================================== #------------------------------------------------------------------------------ # Zkontroluje údaje z formuláře, uloží je do databáze, pošle je e-mailem # organizátorům a uživateli vygeneruje odpověď. #------------------------------------------------------------------------------ sub zpracovat_hlasovani { my $databaze = shift; my $tabulka = shift; my $konfig = shift; # Údaje z formuláře jsou v hashi %{$konfig} pohromadě s případnými dalšími # parametry skriptu. Přidat mezi údaje datum a čas odeslání formuláře. $konfig->{casode} = cas::ted()->{rmdhms}; # Zkontrolovat údaje. my $chyby = zkontrolovat_hlasovani($databaze, $tabulka, $konfig); # Pokud byla kontrola úspěšná, uložit údaje do databáze a odeslat je e-mailem organizátorům. unless(scalar(@{$chyby})) { ulozit_hlasovani_do_databaze($databaze, $tabulka, $konfig); odeslat_hlasovani_e_mailem($databaze, $konfig); } # Vygenerovat odpověď pro uživatele. zobrazit_potvrzovaci_stranku($databaze, $konfig, $chyby); } #------------------------------------------------------------------------------ # Zkontroluje údaje z formuláře a vrátí seznam chyb, které najde. #------------------------------------------------------------------------------ sub zkontrolovat_hlasovani { my $databaze = shift; my $tabulka = shift; my $konfig = shift; my @chyby; # Zkontrolovat platnost hlasovacího kódu. my $kod = $konfig->{kod_hlas} = $konfig->{hl_kod}; # Kód se skládá z osmi číslic a je dělitelný jedenácti. První dvě číslice znamenají počet hlasů, který není vyšší než 10. my $kod_osoby; my $n_hlasu; my $kontrola; if($kod =~ m/^(\d\d)(\d\d\d\d\d)(\d\d)$/) { $konfig->{hlasu_celkem} = $n_hlasu = $1; $konfig->{kod_osoby} = $kod_osoby = $2; $kontrola = $3; if($n_hlasu > 10 || $kod % 11 != 0) { push(@chyby, 'chyba_neplatny_kod'); } else { # Zjistit, zda už s tímto kódem někdo nehlasoval. my $drivejsi = mso::dotazat_se_databaze($databaze, 'kod_hlas', "$tabulka WHERE kod_osoby = '$kod_osoby'"); if(scalar(@{$drivejsi})) { push(@chyby, 'chyba_pouzity_kod'); } } } else { push(@chyby, 'chyba_neplatny_kod'); } # Projít všechny parametry. # Jestliže jejich název jsou 4 písmena nebo číslice, první je 's' nebo 'n', # a jestliže hodnotou parametru je 0, 1, 2 nebo 3, považovat je za kód hry. my @stare_hry = grep {m/^s[a-z0-9]{3}$/ && $konfig->{$_} =~ m/^[0-3]$/} (keys(%{$konfig})); my @nove_hry = grep {m/^(n[a-z0-9]{3}|novinka[12])$/ && $konfig->{$_} =~ m/^[0-3]$/} (keys(%{$konfig})); $konfig->{stare} = \@stare_hry; $konfig->{nove} = \@nove_hry; # Zkontrolovat, že počet hlasů udělených starým hrám nepřekročil maximální počet hlasů, které má dotyčný uživatel k dispozici. my $soucet_stare = 0; foreach my $hra (@stare_hry) { $soucet_stare += $konfig->{$hra}; } if($soucet_stare>$n_hlasu) { push(@chyby, sprintf("chyba_moc_starych_%d_%d", $soucet_stare, $n_hlasu)); } # Zkontrolovat, že počet hlasů udělených novým hrám nepřekročil maximální počet hlasů, které má dotyčný uživatel k dispozici. my $soucet_nove = 0; foreach my $hra (@nove_hry) { $soucet_nove += $konfig->{$hra}; } if($soucet_nove>$n_hlasu) { push(@chyby, sprintf("chyba_moc_novych_%d_%d", $soucet_nove, $n_hlasu)); } # Jestliže novinka1 nebo novinka2 dostala hlas, nesmí zůstat prázdné pole s názvem hry. if($konfig->{novinka1}>0 && $konfig->{novinka1_nazev} =~ m/^\s*$/ || $konfig->{novinka2}>0 && $konfig->{novinka2_nazev} =~ m/^\s*$/) { push(@chyby, 'chyba_prazdna_novinka'); } # Zkontrolovat, že se dal hlas alespoň jedné hře. if($soucet_stare==0 && $soucet_nove==0) { push(@chyby, 'chyba_zadne_hlasy'); } return \@chyby; } #------------------------------------------------------------------------------ # Uloží údaje z formuláře do databáze MySQL na serveru. #------------------------------------------------------------------------------ sub ulozit_hlasovani_do_databaze { my $databaze = shift; my $tabulka = shift; my $konfig = shift; my @nazvy = qw(kod_hlas kod_osoby hlasu_celkem kod_hry hlasu nazev_hry); my $seznam_poli = join(', ', @nazvy); foreach my $hra (@{$konfig->{stare}}, @{$konfig->{nove}}) { next unless($konfig->{$hra}>0); my $kod_hry = $hra; $kod_hry =~ s/^[sn]// unless($kod_hry =~ m/^novinka/); # Řetězcové hodnoty musí být v apostrofech, číselné bez apostrofů. my @hodnoty = ( "'$konfig->{kod_hlas}'", $konfig->{kod_osoby}, $konfig->{hlasu_celkem}, "'$kod_hry'", $konfig->{$hra} ); if($hra =~ m/^novinka\d$/) { my $nazev = $konfig->{$hra.'_nazev'}; push(@hodnoty, "'$nazev'"); } else { push(@hodnoty, "''"); } # The MySQL driver must get the data as a sequence of bytes, not of varying-width characters. my $seznam_hodnot = encode('utf8', join(', ', @hodnoty)); my $dotaz = "INSERT INTO $tabulka ($seznam_poli) VALUES ($seznam_hodnot);"; $databaze->do($dotaz); } } #------------------------------------------------------------------------------ # Odešle údaje z formuláře e-mailem organizátorům. #------------------------------------------------------------------------------ sub odeslat_hlasovani_e_mailem { my $databaze = shift; my $konfig = shift; my $sendmail; if(-e "/usr/lib/sendmail") { $sendmail = "|/usr/lib/sendmail -oi -t"; } else { $sendmail = ">posledni-prihlaska.txt"; } my $adresat = "klara\@hrejsi.cz, zeman\@ufal.mff.cuni.cz"; my $mail; $mail .= "From: Robot Hrejsi \n"; $mail .= "To: $adresat\n"; $mail .= "Subject: MSO hlasovani\n"; $mail .= "Content-Type: text/plain; charset=\"utf-8\"\n"; $mail .= "Content-Transfer-Encoding: 8bit\n\n"; # Sestavit tělo zprávy. $mail .= "kod = $konfig->{kod_hlas}\n"; my @hry = grep {$konfig->{$_}>0} (@{$konfig->{stare}}, @{$konfig->{nove}}); $mail .= join(', ', map {"$_=$konfig->{$_}"} (sort(@hry)))."\n\n"; $mail .= "novinka1_nazev=$konfig->{novinka1_nazev}\n"; $mail .= "novinka2_nazev=$konfig->{novinka2_nazev}\n"; # Odeslat zprávu organizátorům. open(SENDMAIL, $sendmail) or print "Nemůžu najít sendmail: $!\n"; print SENDMAIL ($mail); close(SENDMAIL); open(KOPIE, ">posledni_hlasovani.txt"); print KOPIE ($mail); close(KOPIE); open(KOPIE, ">>archiv_hlasovani.txt"); print KOPIE ("----------------------------------------------------------------------\n"); print KOPIE ($mail); close(KOPIE); } #------------------------------------------------------------------------------ # Vygeneruje pro uživatele stránku se zprávou o úspěchu či neúspěchu jím # odeslaného formuláře. #------------------------------------------------------------------------------ sub zobrazit_potvrzovaci_stranku { my $databaze = shift; my $konfig = shift; my $chyby = shift; my $nadpis; my $stranka; # Pokud byly v hlasování nalezeny chyby, upozornit uživatele, že hlasování nebylo přijato. if(scalar(@{$chyby})) { $nadpis = jazyky::zjistit("hlasovani_nadpis_chyba"); $stranka .= "

".jazyky::zjistit("hlasovani_nadpis2_chyba")."

\n"; $stranka .= "\n"; } # Pokud byla přihláška bez chyb, ukázat uživateli přehled údajů a oznámit mu, že přihláška byla přijata. else { $nadpis = jazyky::zjistit("hlasovani_potvrzeni"); $stranka .= jazyky::zjistit("hlasovani_potvrzeni_nadpis"); } # Obalit stránku jednotným záhlavím a zápatím a poslat ji na výstup. mso::vypsat_stranku( { 'nazev' => "MSO: $konfig->{rok}: ".jazyky::zjistit("Hlasovani"), 'nadpis' => $nadpis, 'telo' => $stranka, 'rok' => $konfig->{rok} }); }