#!/usr/bin/perl # Generuje doplňkový seznam zboží a jeho dostupnosti na skladě ve formátu XML požadovaném srovnávacím serverem Heureka.cz. # Copyright © 2014 Daniel Zeman # Licence: GNU GPL ###!!! # XML soubor generovaný tímto skriptem je možné si nechat zkontrolovat na adrese # http://sluzby.heureka.cz/napoveda/dostupnostni-feed/ # Momentálně (22.10.2014) je problém s tím, že server kub.cz neposílá HTTP záhlaví Content-length, které Heureka vyžaduje. 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 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 zboží od her. my $zbozi = dzsql::dotaz($dbh, 'kod', 'kod_hry', 'ean', 'nelze_koupit', 'nazev', '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', '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); # Zjistit aktuální čas. Od něj se odvíjí termíny objednání a dodání, které můžeme slíbit. my $ted = cas::nastavit_ted(); # Naše vnitřní pravidla: # Jestliže objednávka přijde do 9:00 ve všední den, můžeme to ještě týž den dopoledne zabalit a odvézt na poštu. # (V Jenštejně přijímají do 14:30, ale v pondělí a ve středu mají otevřeno až od 15:00, takže to by se muselo jet na jinou poštu.) # Pošta garantuje dodání následující pracovní den. Umí garantovat doručení do 14:00, ale to je doplňková služba; někde naopak nabízí po dohodě odpolední # doručení do 19:00, resp. v Praze do 20:00; proto bude nejbezpečnější zvolit 20:00 jako námi slíbený nejzazší termín dodání. # Naše zvláštní pravidla: # O vánočních prázdninách nefungujeme, pouze výjimečně pošleme nějaký balík z Tanvaldu. V tomto období nic neslibovat! if(cas::gtmd($ted, '1223')) { $ted = cas::plus_rok(cas::xset_md('0103', $ted)); } my $termin_objednani; # Abychom předešli nedorozumění způsobenému rozdílně nastavenými hodinami u nás a u Heuréky, přestaneme nabízet daný den ne 10, ale už 11 minut před termínem. if(cas::je_pracovni_den($ted) && cas::lthm($ted, '0849')) { $termin_objednani = cas::xset_hm('0900', $ted); } else { $termin_objednani = cas::xset_hm('0900', cas::plus_pracovni_den($ted)); } my $termin_doruceni = cas::xset_hm('2000', cas::plus_pracovni_den($termin_objednani)); # Heureka zobrazuje upozornění typu "Doručení do úterý? Objednejte dnes, do 23:59." # Problém: zobrazuje ho jen tehdy, když termín objednání je dnes nebo zítra (na termínu doručení nezáleží). # Takže když je pátek a my máme termín objednání pondělí 9:00 (pro doručení do úterý), Heureka u nás nezobrazí nic. # Řešení: Jestliže termín objednání je později než zítra, posunout ho zpět na zítra 23:59. my $zitra = cas::xset_hm('2359', cas::plus_den($ted)); if($termin_objednani > $zitra) { $termin_objednani = $zitra; } # Podle pravidel Heureky nesmí být čas doručení dále než 7 dnů od času objednání. # Údajně je zajímá rozdíl mezi termínem doručení a termínem objednání, které jsme právě vypočítali. # Ale co když si zákazník objedná zboží ještě před uplynutím termínu objednání, třeba teď hned? # A co když jsou vánoční prázdniny a my jsme oba termíny posunuli až na leden? # Mezi termínem doručení a objednání je pořád méně než 7 dní, ale mezi termínem doručení a aktuálním okamžikem je třeba 10 dní! # Nebude to Heurece vadit? my $nic_neni_skladem = cas::rozdil_den($termin_doruceni, $termin_objednani) > 7; sub format_cas_heureka { my $esek = shift; my $vystup = cas::rmdhms($esek); $vystup =~ s/^(\d+)(\d\d)(\d\d)(\d\d)(\d\d)\d\d$/$1-$2-$3 $4:$5/; return $vystup; } my $tobj = format_cas_heureka($termin_objednani); my $tdor = format_cas_heureka($termin_doruceni); my $xml = "\n"; $xml .= "\n"; foreach my $z (@zbozi) { last if($nic_neni_skladem); # Vynechat zboží, které nelze koupit, protože jsme ho trvale vyřadili z nabídky. next if($z->{nelze_koupit}); # Vynechat zboží, které nemáme skladem. next if($z->{cerny_most} <= 0); $xml .= " {kod}\">\n"; # Počet kusů připravených k okamžité expedici. $xml .= " $z->{cerny_most}\n"; # Za jak dlouho jsme schopni dodat tento produkt zákazníkovi? # Hodnota musí být platná pro celé Česko, čili asi to nemohou být pobočky Uloženky, ale může to být to nejrychlejší a nejdražší doručení poštou. # Vždy je potřeba zákazníkovi říct, dokdy musí zboží objednat, abychom mu mohli čas doručení garantovat. Termín objednání musí být alespoň 10 minut vzdálený. $xml .= " $tdor\n"; $xml .= " \n"; } $xml .= "\n"; # Heureka chce vědět, jak velký dokument jí posíláme. # Správně bychom měli přepočítat znaky UTF8 na bajty, ale tady to snad není potřeba, protože výstup by měl obsahovat jen znaky ASCII. my $length = length($xml); # Poslat MIME záhlaví dokumentu. print("Content-Type: text/xml; charset=utf-8\n"); print("Content-Length: $length\n"); print("\n"); # Poslat dokument. print($xml); ############################################################################### # 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; }