#!/usr/bin/perl # Generuje seznam zboží na skladě ve formátu XML požadovaném srovnávacím serverem Heureka.cz. # Copyright © 2012 Daniel Zeman # Licence: GNU GPL use utf8; use open ':utf8'; use DBI; # Přidat Danovy sdílené knihovny. Skript běžící pod uživatelem apache by je jinak nenašel. use lib '/home/dan/lib'; use dzsql; use mysql; use csort; use cas; # Přinutit Perl, aby UTF8 vypisoval jako UTF8 a nevymýšlel pro mě "vhodné" osmibitové kódování. binmode(STDOUT, ':utf8'); use pomoc; use kosik; # 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řipojit se k databázi her. # Pokud je skript spuštěn webovým serverem (uživatel www-data), měl by mít dostatečná práva pro přístup k databázi. # Pokud je ale spuštěn uživatelem dan@kub.cz, práva nemá a musí se databázi hlásit jako root. V tom případě je potřeba, # aby příslušné heslo bylo v proměnné prostředí DBI_ROOT_PASS. if($ENV{USER} =~ m/^(dan|klara)$/) { if(!exists($ENV{DBI_ROOT_PASS})) { die("Pri spusteni jinym uzivatelem nez www-data musi byt v promenne prostredi DBI_ROOT_PASS heslo roota do databaze.\n"); } $dbi_uzivatel = 'root'; $dbi_heslo = $ENV{DBI_ROOT_PASS}; } $dbh = DBI->connect('DBI:mysql:hry', $dbi_uzivatel, $dbi_heslo) or print STDERR ("Nelze se pripojit k databazi: $DBI::errstr\n"); $dbo = DBI->connect('DBI:mysql:obchod', $dbi_uzivatel, $dbi_heslo) or print STDERR ("Nelze se pripojit k databazi: $DBI::errstr\n"); # Nastavit kódování klienta, spojení a výsledků. $dbh->prepare("SET NAMES 'utf8'")->execute(); $dbo->prepare("SET NAMES 'utf8'")->execute(); # Získat z databáze informace o hrách. my $hry = dzsql::dotaz($dbh, 'kod', 'nazev', 'upoutavka', 'charakteristika', 'slozka_hrejsi', 'pocet_hracu', 'delka_vysvetlovani', 'min_delka', 'max_delka', 'min_vek', 'autor', 'rok_vydani', 'oceneni', 'hry'); my %hry; foreach my $hra (@{$hry}) { $hry{$hra->{kod}} = $hra; } # Získat z databáze informace o skupinách ostatního zboží. my $skupiny = dzsql::dotaz($dbo, 'kod', 'nazev', 'oddeleni', 'upoutavka', 'charakteristika', 'slozka_hrejsi', 'autor', 'skupiny'); my %skupiny; foreach my $skupina (@{$skupiny}) { $skupiny{$skupina->{kod}} = $skupina; } # Získat z databáze informace o zboží od her. my $zbozi = dzsql::dotaz($dbh, 'kod', 'kod_hry', 'ean', 'nelze_koupit', 'nazev', 'vyrobce', 'zbozicz_cpc', 'kategorie_zbozicz' , 'nazev_zbozicz', 'prodejni_cena', 'bezna_cena', 'poznamka', 'popis_zbozi', 'lokalizace', 'deti', 'rodina', 'experti', 'luxus', 'mejdan', 'logicka', 'jazykove', 'postreh', 'vedomostni', 'cestovni', 'rozsireni', 'karetni', 'pamet', 'motorika', 'pro_2', 'cerny_most', 'paluba', 'dostupnost', 'dostupnost_poznamka', 'soucasny_dodavatel', 'zbozi'); my @zbozi = sort {$a->{kod} <=> $b->{kod}} (@{$zbozi}); # Získat informace o ostatním zboží kromě her. $zbozi = dzsql::dotaz($dbo, 'kod', 'kod_skupiny', 'ean', 'nelze_koupit', 'nazev', 'vyrobce', 'zbozicz_cpc', 'kategorie_zbozicz' , 'nazev_zbozicz', 'prodejni_cena', 'bezna_cena', 'poznamka', 'popis_zbozi', 'lokalizace', 'cerny_most', 'paluba', 'dostupnost', 'dostupnost_poznamka', 'soucasny_dodavatel', 'zbozi'); my @ostatni_zbozi = map {$_->{kod} = 'O'.$_->{kod}; $_} (sort {$a->{kod} <=> $b->{kod}} (@{$zbozi})); push(@zbozi, @ostatni_zbozi); # Poslat MIME záhlaví dokumentu. print("Content-Type: text/xml; charset=utf-8\n\n"); print("\n"); print("\n"); #open(NEFOTKY, ">nefotky.txt") or print("

NEJDE TO: $!

\n"); foreach my $z (@zbozi) { # Vynechat zboží, které nelze koupit, protože jsme ho trvale vyřadili z nabídky. next if($z->{nelze_koupit}); # Zjistit hru, ke které zboží patří. my $h = $hry{$z->{kod_hry}}; print(" \n"); print(" $z->{kod}\n"); my $productname = zneskodnit($z->{nazev_zbozicz}); # V našem případě bude a obsahovat totéž. # Pravidlo je, že obsahuje přesný název výrobku důležitý pro spárování, např. "Mindok Carcassonne Základní hra". # musí obsahovat , ale může navíc obsahovat přívlastky, např. "plus dárek zdarma", "včetně prvního rozšíření" apod. Tohle se zobrazí zákazníkům. print(" $productname\n"); print(" $productname\n"); my $popis = zneskodnit("$h->{upoutavka}\n$h->{charakteristika}\n$z->{popis_zbozi}\n$z->{lokalizace}\n$z->{poznamka}"); print(" $popis\n"); # U zboží z jiných oddělení než hry neznáme kód hry. my $parametr_kod_hry; if(defined($z->{kod_hry})) { $parametr_kod_hry = "&hra=$z->{kod_hry}"; } else { my $oddeleni = $skupiny{$z->{kod_skupiny}}{oddeleni}; if(defined($oddeleni)) { ###!!! Z neznámého důvodu máme v databázi oddělení "korálky" s diakritikou, ale v parametrech CGI používáme "koralky" bez diakritiky. Sjednotit! $oddeleni =~ s/á/a/g; $parametr_kod_hry = "&odd=$oddeleni"; } } print(" http://hrejsi.cz/cgi/hry/prodej.pl?pohled=zbozi$parametr_kod_hry&zbozi=$z->{kod}\n"); my $fotka = foto($h->{slozka_hrejsi}, $h->{kod}, $z->{kod}); if($fotka) { print(" $fotka\n"); } # else # fungovalo mi to pouze při puštění z příkazového řádku přímo na kubu # { # print NEFOTKY ("$z->{kod_hry}\t$z->{kod}\n"); # } print(" $z->{prodejni_cena}\n"); # Následující parametry se týkají pouze her. U ostatních druhů zboží vynechat. if($z->{kod_hry}) { print(" \n"); print(" počet hráčů\n"); print(" $h->{pocet_hracu}\n"); print(" \n"); # Vynechat parametr delka_vysvetlovani, protože Klárka ho do databáze nevyplňuje a u většiny her tam zůstává výchozích 10 minut. print(" \n"); print(" minimální délka\n"); print(" $h->{min_delka} min\n"); print(" \n"); print(" \n"); print(" maximální délka\n"); print(" $h->{max_delka} min\n"); print(" \n"); print(" \n"); print(" minimální věk\n"); print(" $h->{min_vek}\n"); print(" \n"); if($h->{autor}) { print(" \n"); print(" autor\n"); print(" ".zneskodnit($h->{autor})."\n"); print(" \n"); } if($h->{rok_vydani}) { print(" \n"); print(" rok vydání\n"); print(" $h->{rok_vydani}\n"); print(" \n"); } if($h->{oceneni}) { print(" \n"); print(" ocenění\n"); print(" ".zneskodnit($h->{oceneni})."\n"); print(" \n"); } } print(" ".zneskodnit($z->{vyrobce})."\n"); ###!!! Kategorii momentálně umíme určit jen pro hry. Ale u ostatního zboží by se mohla odvozovat alespoň od názvu oddělení. if($z->{kod_hry}) { my $kategorie; if($z->{kategorie_zbozicz}) { $kategorie = zneskodnit($z->{kategorie_zbozicz}); } print(" $kategorie\n"); } #elsif($skupiny{$z->{kod_skupiny}}{oddeleni} eq 'korálky') #{ # V případě Zuzčiných korálků přiřazujeme jedinou pasující kategorii ze stromu sekcí zveřejněného Heurékou na adrese # http://www.heureka.cz/direct/xml-export/shops/heureka-sekce.xml # my $kategorie = zneskodnit('Heureka.cz | Oblečení a móda | Módní doplňky | Šperky | Soupravy šperků a bižuterie'); # print(" $kategorie\n"); #} if($z->{ean}) { print(" ".zneskodnit($z->{ean})."\n"); } # Poznámka: Od 4.11.2014 dodáváme Heuréce také tzv. dostupnostní XML soubor, ve kterém jsou údaje o zboží skladem a o dodacích lhůtách. # Dostupnostní XML soubor má přednost před údaji uvedenými zde. Viz xml-heureka-dostupnost.pl. # Datum odeslání: # 2012-12-05 ... pokud bude k dispozici až v budoucnosti, ale lze předobjednat # 5 ... počet dní od přijetí platby do odeslání zboží (může být i 0, znamená "týž den") # prvek DELIVERY_DATE vynechat, jestliže zboží není skladem, čili doba dodání není známa if($z->{cerny_most}>=1) { print(" 0\n"); } # Maximální cena, kterou jsme ochotni nabídnout zboží.cz za proklik a MAX_CPC_SEARCH je vyhledávání ve fultextu. print(" ".zneskodnit($z->{zbozicz_cpc})."\n"); print(" ".zneskodnit($z->{zbozicz_cpc})."\n"); print(" free_store_pickup\n"); print(" \n"); } print("\n"); #close(NEFOTKY); ############################################################################### # Podprogramy ############################################################################### #------------------------------------------------------------------------------ # Zneškodní znaky, které mají v XML zvláštní význam. #------------------------------------------------------------------------------ sub zneskodnit { my $retezec = shift; $retezec =~ s/&/&/g; $retezec =~ s//>/g; return $retezec; } #------------------------------------------------------------------------------ # Vrátí URL fotky zboží. Pokud fotka není k dispozici, vrátí prázdný řetězec. #------------------------------------------------------------------------------ sub foto { my $slozka = shift; # položka slozka_hrejsi k dané hře v databázi my $kod_hry = shift; my $kod_zbozi = shift; my $odkaz; if($slozka eq '') { return ''; } my $soubor; if($kod_hry ne '' && $kod_zbozi ne '') { $soubor = 'zbo'.$kod_hry.$kod_zbozi; } else { $soubor = 'fotka'; } my $cesta_disk = "$main::koren_system/$slozka/obr/$soubor"; my $cesta_url = "$main::koren_hrejsi/$slozka/obr/$soubor"; foreach my $pripona (qw(jpg gif png)) { if(-f ($cesta_disk.'.'.$pripona)) { $odkaz = $cesta_url.'.'.$pripona; last; } } return $odkaz; }