#!/usr/bin/perl # CGI přístup k databázi her. Generuje jak seznamy, tak stránky o konkrétních hrách. # (c) prosinec 2002 Daniel Zeman # 30.12.2003: přechod na UTF-8 # 11.9.2007: přechod pod MySQL use utf8; use Encode; # Přinutit Perl, aby UTF8 vypisoval jako UTF8 a nevymýšlel pro mě "vhodné" osmibitové kódování. binmode STDOUT, ":utf8"; use cist; # Zjistit cestu pro odkazování na statické stránky hrejsi. open(KONFIG, "../cgi.cfg"); while() { if(m/(\S+)\s*=\s*([^\r\n]*)/) { $konfig{$1} = $2; } } close(KONFIG); $koren_hrejsi = $konfig{ccesta_html_www}; $koren_system = $konfig{scesta_html_www}; # Přečíst parametry. do "../formdata.pl"; precist_parametry_url(); precist_data_formulare() if($pole{formular}); upravit_konfig(\%pole); # Pro ladící účely si nachystat výpis parametrů na výstup. $ladeni = 0; if($ladeni) { foreach($key, sort(keys(%pole))) { $dbg_parametry .= "$key = $pole{$key}\n"; } $dbg_parametry = "

$dbg_parametry

\n"; } # Načíst procedury na čtení tabulky her. $hry = cist::precist_hry(); cist::precist_provedeni("provedeni.txt"); # Poslat MIME záhlaví dokumentu. print("Content-Type: text/html; charset=utf-8\n\n"); # Poslat začátek stránky. if($pole{hra} eq "") { print("\n"); print("\n"); print("\n"); print("Palubní pokladnice her\n"); # print("\n"); # print("\n"); print("\n"); print("\n"); print("\n"); print("\n"); # print("\n"); # print("\n"); print("\n"); print("\n"); print("\n"); print("\n"); print("\n"); print("\n"); print("\n"); print("\n"); print("

\n"); print("

\n"); print("\n"); print("\n"); print("\n"); print("\n"); print("\n"); print("

\n"); print("\n"); print("\n"); print("\n"); print("\n"); print("

\n"); print("

\n"); print(" \n"); print("\n"); print("$dbg_parametry\n"); print("

Pokladnice her

\n"); # Generovat část pro výběr řazení a filtru. generovat_vyber_razeni_a_filtru(\%pole); # Aplikovat současný filtr: Úplně zahodit hry, které filtrem neprošly. filtrovat($hry, \%pole); } else { # Najít záznam požadované hry. foreach my $hra (@{$hry}) { if($hra->{kod} eq $pole{hra}) { generovat_stranku_hry($hra); last; } } exit; } # Seskupit hry podle prvního třídícího kritéria. # Druhým kritériem je vždy abeceda, ale předpokládáme, že podle ní už hry za nás seřadil Microsoft Access před exportem. # Kdybychom si abecední řazení chtěli dělat sami, narazíme na problémy s Unicodem a systémovým locale. $skupiny = seskupit($hry, \%pole); # Vypsat hry. if($pole{razeni} ne "abecedne" && $pole{razeni} ne "") { foreach my $skupina (@{$skupiny}) { print("

$skupina->{nadpis}

\n"); print("

\n"); foreach my $hra (@{$skupina->{hry}}) { vypsat_odkaz_na_hru_do_seznamu($hra); } print("\n"); } } else { my @abeceda; foreach my $pismeno ("A", "B", "C", "Č", "D", "E", "F", "G", "H", "CH", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "Ř", "S", "Š", "T", "U", "V", "W", "X", "Y", "Z", "Ž") { push(@abeceda, "$pismeno"); } print("

", join(" | ", @abeceda), "

\n"); print("

\n"); for($i = 0; $i<=$#{$hry}; $i++) { $predch = vypsat_odkaz_na_hru_do_seznamu($hry->[$i], $predch); } print("\n"); } # Vypsat závěr stránky. print <

EOF ; ############################################################################### # Podprogramy ############################################################################### #------------------------------------------------------------------------------ # Zahodí hry, které neprojdou aktuálním filtrem. #------------------------------------------------------------------------------ sub filtrovat { my $hry = shift; # odkaz na pole hashů my $konfig = shift; # odkaz na hash for(my $i = 0; $i<=$#{$hry}; $i++) { my $hra = $hry->[$i]; my $vyhodit = 0; # Vynechat hry, kterým databáze účast ve webové pokladnici nedoporučuje # (buď o nich nemáme téměř žádné informace, nebo dokonce nejde o skutečné hry). if($hra->{noweb}) { $vyhodit = 1; } # Pokud to uživatel požaduje, vynechat hry, ke kterým nemáme pravidla. if($konfig->{filtr}{pravidla}) { # Pokusit se najít mezi odkazy odkaz na pravidla. my $nalezeno = 0; foreach my $odkaz (@{$hra->{_odkazy}}) { if($odkaz->{text} =~ m/^pravidla$/i) { $nalezeno = 1; last; } } $vyhodit = !$nalezeno; } # Pokud to uživatel požaduje, vynechat hry, které nemáme na Palubě. if($konfig->{filtr}{hrat} && !$hra->{_na_hrani}) { $vyhodit = 1; } # Pokud to uživatel požaduje, vynechat hry, které nemáme na prodej. if($konfig->{filtr}{koupit} && !$hra->{_prodej}) { $vyhodit = 1; } # Pokud hra neprošla, vyhodit ji. if($vyhodit) { splice(@{$hry}, $i, 1); $i--; } } } #------------------------------------------------------------------------------ # Seskupí hry podle prvního třídícího kritéria. # Druhým kritériem je vždy abeceda, ale předpokládáme, že podle ní už hry za # nás seřadil Microsoft Access před exportem. Kdybychom si abecední řazení # chtěli dělat sami, narazíme na problémy s Unicodem a systémovým locale. #------------------------------------------------------------------------------ sub seskupit { my $hry = shift; # odkaz na pole hashů my $konfig = shift; # odkaz na hash my %skupiny; foreach my $hra (@{$hry}) { my $skupids = zjistit_skupiny($hra, $konfig); # Pro každou skupinu si uložit tuto hru do příslušného seznamu. foreach my $skupina (@{$skupids}) { unless(exists($skupiny{$skupina})) { $skupiny{$skupina} = zalozit_skupinu($skupina, $konfig->{razeni}); } push(@{$skupiny{$skupina}{hry}}, $hra); } } my @skupiny = map{$skupiny{$_}}(sort{$skupiny{$a}{trid} cmp $skupiny{$b}{trid}}(keys(%skupiny))); return \@skupiny; } #------------------------------------------------------------------------------ # Podle požadovaného kritéria zjistí skupiny, do kterých hra patří. Každá hra # může patřit do několika skupin současně. Vrátí pole identifikátorů skupin. #------------------------------------------------------------------------------ sub zjistit_skupiny { my $hra = shift; # odkaz na hash my $konfig = shift; # odkaz na hash my $druh = $konfig->{razeni}; my @skupiny; if($druh eq "pocethracu") { # Zjistit možné počty hráčů pro tuto hru. my $mozne_pocty = $hra->{pocet_hracu}; # Odstranit ze seznamu počtů nepatřičné znaky. $mozne_pocty =~ s/[^0-9,]//g; # Rozsekat počty do pole. @skupiny = split(/,/, $mozne_pocty); } elsif($druh eq "vek") { if($hra->{min_vek}) { $skupiny[0] = $hra->{min_vek}; } } elsif($druh eq "cas") { if($hra->{max_delka}) { $skupiny[0] = $hra->{max_delka}; } } elsif($druh eq "rok") { if($hra->{rok_vydani}) { $skupiny[0] = $hra->{rok_vydani}; } } elsif($druh eq "autor") { if($hra->{autor}) { @skupiny = split(/[,;]\s*/, $hra->{autor}); } } elsif($druh eq "vydavatel") { @skupiny = @{$hra->{_vydavatele}}; } return \@skupiny; } #------------------------------------------------------------------------------ # Založí (zatím prázdnou) skupinu her vymezenou určitým kritériem, vytvoří pro # ni třídící hodnotu (aby bylo možné seřadit seznam skupin) a nadpis. #------------------------------------------------------------------------------ sub zalozit_skupinu { my $id = shift; # identifikátor skupiny my $druh = shift; # kritérium, jehož hodnotou je id my %skupina; if($druh eq "pocethracu") { %skupina = ( "nadpis" => "Hry pro $id hráč".($id>0 && $id<5 ? "e" : "ů"), "trid" => sprintf("%03d", $id) ); } elsif($druh eq "vek") { %skupina = ( "nadpis" => "Hry od $id let", "trid" => sprintf("%03d", $id) ); } elsif($druh eq "cas") { %skupina = ( "nadpis" => "Hry do $id minut", "trid" => sprintf("%04d", $id) ); } elsif($druh eq "rok") { %skupina = ( "nadpis" => $id, "trid" => sprintf("%05d", $id+5000) ); } elsif($druh eq "autor") { %skupina = ( "nadpis" => $id, "trid" => $id ); } elsif($druh eq "vydavatel") { %skupina = ( "nadpis" => $id, "trid" => $id ); } return \%skupina; } #------------------------------------------------------------------------------ # Vrátí název hry, abychom si ho mohli zapamatovat do příště a poznat, kdy # začíná nové písmeno abecedy. #------------------------------------------------------------------------------ sub vypsat_odkaz_na_hru_do_seznamu { my $hra = shift; # odkaz na hash my $predch = shift; # název předcházející hry (abychom poznali nové písmeno v abecedě) if($predch eq "") { $predch = $hra->{nazev}; } print("

"); # Začíná-li název hry na jiné písmeno než předcházející hra, vygenerovat # záložku pro skoky po abecedě. my $pismeno = substr($hra->{nazev}, 0, 1); $pismeno = "CH" if(substr($hra->{nazev}, 0, 2) =~ m/ch/i); if($pismeno ne substr($predch, 0, 1)) { print("\n"); } # U všech her přednostně nabízet dynamickou stránku. print("{kod}\">$hra->{nazev}"); # Vypsat všechny alternativní názvy hry. if(exists($hra->{_dalsi_nazvy})) { print(" (", join("; ", @{$hra->{_dalsi_nazvy}}), ")"); } # Závěr. print("

\n"); return $hra->{nazev}; } #------------------------------------------------------------------------------ # Zobrazí kořenovou stránku hry. #------------------------------------------------------------------------------ sub generovat_stranku_hry { my $hra = shift; # odkaz na hash se záznamem hry, jejíž stránka se má generovat my $slozka = $hra->{slozka_hrejsi}; my $pozadi = $hra->{htmlbgr}; my $text = $hra->{htmltext}; my $link = $hra->{htmllink}; my $vlink = $hra->{htmlvlink}; my $alink = $hra->{htmlalink}; my $nazev = $hra->{nazev}; my $dalsi_nazvy = join(", ", @{$hra->{_dalsi_nazvy}}); print("\n"); print("\n"); print("\n"); print("$hra->{nazev}\n"); print("{nazev}, $hra->{_dalsi_nazvy}, deskové hry, pravidla\">\n"); print("\n"); # Nastavit barvy pozadí a popředí. my $body = "seznam her ].\n"); print("

\n"); # Pokud existuje, zobrazit barevný nadpis. if($slozka ne "" && -f "$koren_system/$slozka/obr/nadpis.gif") # if($slozka ne "")# && -f $nadpis) Tahle kontrola nefunguje, protože cesta z pohledu webu není stejná jako skutečná cesta v rámci systému. { my $nadpis = "$koren_hrejsi/$slozka/obr/nadpis.gif"; print("

$\"$nazev\"$

\n"); } else { print("

$nazev

\n"); } my $neboli; if($dalsi_nazvy) { $neboli = $dalsi_nazvy; $neboli = "neboli $neboli"; } print("$neboli\n"); print("

\n"); print("

Charakteristika

\n"); if($hra->{pocet_hracu} ne "") { print("

Počet hráčů: $hra->{pocet_hracu}.\n"); } if($hra->{min_vek}!=0) { print("
Doporučený věk: alespoň $hra->{min_vek} let.\n"); } if($hra->{min_delka}!=0) { if($hra->{min_delka}>=60*24) { $dnymin = sprintf("%d", ($hra->{min_delka}/60/24)+0.5); $dnymax = sprintf("%d", ($hra->{max_delka}/60/24)+0.5); printf("
Délka hry: %s %s.\n", $dnymax==$dnymin ? $dnymax : "$dnymin až $dnymax", $dnymax==1 ? "den" : $dnymax>=2 && $dnymax<=4 ? "dny" : "dnů"); } elsif($hra->{min_delka}>=100) { $hodmin = sprintf("%.1f", ($hra->{min_delka}/60)+0.05); $hodmax = sprintf("%.1f", ($hra->{max_delka}/60)+0.05); print("
Délka hry: $hodmin až $hodmax hod.\n"); } else { print("
Délka hry: $hra->{min_delka} až $hra->{max_delka} minut.\n"); } } if(scalar(@{$hra->{_vydavatele}})>0) { print("
Vydavatel: ", join(", ", @{$hra->{_vydavatele}}), ".\n"); } if($hra->{rok_vydani}!=0) { print("
Rok vydání: $hra->{rok_vydani}.\n"); } if($hra->{autor} ne "") { print("
Autor: $hra->{autor}.\n"); } if($hra->{oceneni} ne "") { print("
Ocenění: $hra->{oceneni}.

\n"); } print("

$hra->{upoutavka}

\n"); print("

$hra->{charakteristika}

\n"); # Vypsat odkazy na stránky o této hře. my $odkazy = $hra->{_odkazy}; print("

$odkazy->[$i]{text}
{kod}\">Hru lze koupit
{nazev}\">Tato hra na deskovehry.cz

\n"); print("

\n"); #!!! Chtělo by to kontrolu, že soubor s fotkou existuje!!! if($slozka ne "" && -f "$koren_system/$slozka/obr/fotka.jpg") { print(" $\"fotografie\"$ \n"); } print("

\n"); print("

\n"); print("\n"); print("

Vytvořil tým Klubu deskových her Paluba.

\n"); print("

Obsah webových stránek je chráněn autorskými právy. Jeho reprodukce za komerčními účely je zakázána.

\n"); print("

The contents of these web pages is copyrighted. Any reproduction for commercial use is prohibited.

\n"); print("

$\"[PALUBA]\"$ \n"); print("

\n"); print("\n") if($hry{"$hra: htmltuc"}); print("\n"); print("\n"); } #------------------------------------------------------------------------------ # Generuje HTML kód pro výběr řazení a filtru. #------------------------------------------------------------------------------ sub generovat_vyber_razeni_a_filtru { my $konfig = shift; # odkaz na hash my $formular = 0; unless($formular) { # Zobrazit současné nastavení filtru. print("

Současné nastavení filtru

\n"); my $html; if($konfig->{filtr}{pravidla}) { $html .= "

pouze hry s elektronickými pravidly na hrejsi.cz

\n"; } if($konfig->{filtr}{hrat}) { $html .= "

pouze hry, které si na Palubě můžete zahrát

\n"; } if($konfig->{filtr}{koupit}) { $html .= "

pouze hry, které si na Palubě můžete koupit

\n"; } if($html ne "") { print("

\n$html\n"); } else { print("

žádné omezující podmínky

\n"); } # Nabídnout rozšíření filtru. my $html; unless($konfig->{filtr}{pravidla}) { my $href = vytvorit_odkaz($konfig, "filtr+pravidla"); $html .= "

pouze hry s elektronickými pravidly na hrejsi.cz

\n"; } unless($konfig->{filtr}{hrat}) { my $href = vytvorit_odkaz($konfig, "filtr+hrat"); $html .= "

pouze hry, které si na Palubě můžete zahrát

\n"; } unless($konfig->{filtr}{koupit}) { my $href = vytvorit_odkaz($konfig, "filtr+koupit"); $html .= "

pouze hry, které si na Palubě můžete koupit

\n"; } if($html ne "") { print("

Přidat podmínku do filtru

\n"); print("

\n$html\n"); } # Zobrazit současné nastavení řazení. my %raz = ( "pocethracu" => "podle počtu hráčů", "vek" => "podle doporučeného minimálního věku", "cas" => "podle časové náročnosti", "rok" => "podle roku vydání", "autor" => "podle autora", "vydavatel" => "podle vydavatele", "abecedne" => "abecedně" ); print("

Současné nastavení řazení

\n"); print("

$raz{$konfig->{razeni}}
abecedně

\n"); # Nabídnout změnu řazení. $html = ""; foreach my $razeni ("pocethracu", "vek", "cas", "rok", "autor", "vydavatel") { unless($konfig->{razeni} eq $razeni) { my $href = vytvorit_odkaz($konfig, "razeni=$razeni"); $html .= "

$raz{$razeni}

\n"; } } if($html ne "") { print("

Změnit způsob řazení

\n"); print("

\n$html\n"); } } else # Archív: Dříve pro výběr sloužil formulář, který je sice příjemnější pro # uživatele, ale bohužel dělá problémy při generování statického otisku # stránek. Pozor, pokud by měl být opět oživen, je třeba mít na paměti, že # tato část nebyla aktualizována a neposkytuje tak bohatý výběr jako # obyčejná soustava odkazů výše! { print("\n"); } } #------------------------------------------------------------------------------ # Generuje HTML odkaz s novými parametry. #------------------------------------------------------------------------------ sub vytvorit_odkaz { # Vytvořit si kopii konfigurace. my $stary_konfig = shift; # Potřebujeme oddělit kopii od originálu, a to na všech úrovních! my %konfig = %{$stary_konfig}; delete($konfig{filtr}); %{$konfig{filtr}} = %{$stary_konfig->{filtr}}; # Aplikovat požadované změny. while(my $zmena = shift) { if($zmena =~ m/^filtr\+(.*)/) { $konfig{filtr}{$1} = 1; } elsif($zmena =~ m/(.*)=(.*)/) { $konfig{$1} = $2; } } # Vygenerovat seznam parametrů. my @param; foreach my $filtr (sort(keys(%{$konfig{filtr}}))) { if($konfig{filtr}{$filtr}) { push(@param, "f$filtr=1"); } } foreach my $klic (sort(keys(%konfig))) { unless($klic eq "filtr") { push(@param, "$klic=$konfig{$klic}"); } } # Vytvořit odkaz v takovém tvaru, aby se dalo napsat . my $href = "\"hry.pl"; if(scalar(@param)) { $href .= "?".join("&", @param); } $href .= "\""; return $href; } #------------------------------------------------------------------------------ # Upraví hash s načtenými parametry. #------------------------------------------------------------------------------ sub upravit_konfig { my $konfig = shift; # odkaz na hash foreach my $klic (keys(%{$konfig})) { if($klic =~ m/^f(.*)/ && $klic ne "filtr" && $konfig->{$klic}==1) { $konfig->{filtr}{$1} = 1; delete($konfig->{$klic}); } } }