#!/usr/bin/perl # Generuje seznam zboží na skladě ve formátu XML požadovaném srovnávacím serverem Heureka.cz. # Copyright © 2012-2015 Daniel Zeman # Licence: GNU GPL # 9.4.2015: stěhování na new.kub.cz use utf8; use open ':utf8'; use DBI; use lib '/s/w/lib/dan'; use lib '/s/w/lib/cgi/hry'; use dzsql; use sitesql; use csort; use cas; use pomoc; use kosik; # Přinutit Perl, aby UTF8 vypisoval jako UTF8 a nevymýšlel pro mě "vhodné" osmibitové kódování. binmode(STDOUT, ':utf8'); # Připojit se k databázi her. $dbh = sitesql::connect_obchod('hry'); $dbo = sitesql::connect_obchod('web_hrejsi_obchod'); # 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', 'heureka_cpc', 'kategorie_heureka' , 'nazev_heureka', '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', 'heureka_cpc', 'kategorie_heureka' , 'nazev_heureka', '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"); # U her vytváříme podle návodu Heuréky složitý název. U Zuzčiných korálků to ale nedává smysl. # Poznámka: Podle starší specifikace od Heuréky měl název obsahovat i kategorii, ale teď už to ve specifikaci nevidím # a většina obchodů tam kategorii taky neuvádí (ostatně je na ni ještě k dispozici samostatný prvek XML), takže ji ruším. my $productname = zneskodnit($z->{nazev_heureka}); # 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://obchod.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}) { # 2025 úprava parametrů, aby odpovídaly těm, které má zavedená Heureka print(" \n"); print(" Deskové\n"); print(" ano\n"); print(" \n"); my @pocet_hracu = split(/,/, $h->{pocet_hracu}); if(scalar(@pocet_hracu)>1) { $pocet_hracu[0] =~ s/\s+//g; $pocet_hracu[-1] =~ s/\s+//g; $pocet_hracu = join(' - ', $pocet_hracu[0], $pocet_hracu[-1]); } else { $pocet_hracu = $h->{pocet_hracu}; } print(" \n"); print(" Počet hráčů\n"); print(" $pocet_hracu\n"); print(" \n"); print(" \n"); print(" Délka hry\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(" Věk od\n"); print(" $h->{min_vek} let\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_heureka}) { $kategorie = zneskodnit($z->{kategorie_heureka}); } else { my %kategorie = ( 'deti' => 'Pro děti', 'rodina' => 'Rodinné', 'experti' => 'Pro experty', 'luxus' => 'Luxusní', 'mejdan' => 'Na mejdan', 'logicka' => 'Logické', 'jazykove' => 'Jazykové', 'postreh' => 'Na postřeh', 'vedomostni' => 'Vědomostní', 'cestovni' => 'Cestovní', 'rozsireni' => 'Rozšíření', 'karetni' => 'Karetní', 'pamet' => 'Na paměť', 'motorika' => 'Na motoriku', 'pro_2' => 'Pro dva', ); #my @hkat = map {$kategorie{$_}} (grep {$z->{$_}>0} (sort {$z->{$a} <=> $z->{$b}} (keys(%kategorie)))); # Heuréka netrvá na tom, abychom se trefili do jejích kategorií, ale poskytuje svůj strom kategorií na vzor, asi je dobré se do něj trefit. # Oni mají ovšem hry vedené pod dětským zbožím (což není úplně adekvátní) a navíc mají vedle sebe sesterské kategorie "Deskové hry" a "Stolní hry". # Což je pěkná blbost, ale nejraději bychom asi byli v obou. # Kategorie v katalogu Heuréky: # Heureka.cz | Dětské zboží | Hračky | Společenské hry | PODKATEGORIE: (viz též http://spolecenske-hry.heureka.cz/) # Cestovní hry; Deskové hry; Karetní hry; Ostatní společenské hry; Rodinné hry; Stolní hry # Zkusil jsem použít Stolní hry | Deskové hry najednou, ale akorát to způsobilo problémy s párováním. #$kategorie = zneskodnit(join(' | ', ('Společenské hry', 'Deskové hry', @hkat))); # -------------- 2025 - úprava na nové kategorie ------------------- # Kategorie jsme měli už nějakou dobu špatně # https://www.heureka.cz/direct/xml-export/shops/heureka-sekce.xml - zde je xml s kategoriemi # My nejčastěji budeme spadat sem: $kategorie = "Heureka.cz | Filmy, knihy, hry | Společenské hry a zábava | Stolní hry | Deskové hry"; # Takže pokud nezadáme do databáze, bude tam tahle } 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"); } # Překlad našich identifikátorů způsobů dopravy na identifikátory Heuréky. my %zpusoby_dopravy = ( 'posta' => 'ZASILKOVNA_NA_ADRESU', 'zasilkovna' => 'ZASILKOVNA', 'posta_do_ruky' => 'CESKA_POSTA', #'posta_na_postu' => 'CESKA_POSTA_NA_POSTU', #'dpd' => 'DPD', #'ulozenka' => 'HEUREKAPOINT', #'intimecz' => 'INTIME' ); foreach my $zpusob (sort {$zpusoby_dopravy{$a} cmp $zpusoby_dopravy{$b}} (keys(%zpusoby_dopravy))) { ###!!! Nechceme, aby Heuréka ve svém košíku nabízela dopravu pomocí Intime, protože je blbá a nabízí to i jako doručení na adresu domů. ###!!! Takže raději Heuréce vůbec neřekneme, že Intime známe. next if($zpusob eq 'intimecz'); my $zpusob_id_heureka = $zpusoby_dopravy{$zpusob}; my ($postovne_prevodem) = kosik::zjistit_cenu_dopravy({'celkem' => $z->{prodejni_cena}, 'platba' => 'převodem', 'odber' => $zpusob}); my ($postovne_dobirkou) = kosik::zjistit_cenu_dopravy({'celkem' => $z->{prodejni_cena}, 'platba' => 'hotově', 'odber' => $zpusob}); if($z->{prodejni_cena}>2500) { $postovne_prevodem = 0; $postovne_dobirkou = 0; } print(" \n"); print(" $zpusob_id_heureka\n"); print(" $postovne_prevodem\n"); print(" $postovne_dobirkou\n"); print(" \n"); } # ITEMGROUP_ID je moje identifikace skupin výrobků, které jsou navzájem svými variantami. ###!!! Pro začátek by skupinu mohlo tvořit zboží se stejným kódem hry, i když to není přesné (rozšíření není variantou základní hry). print(" $h->{kod}\n"); # Maximální cena, kterou jsme ochotni nabídnout Heuréce za proklik. print(" ".zneskodnit($z->{heureka_cpc})."\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; # Složka hrejsi je zastaralá věc #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 = "/var/web/hrejsi.cz/obr/k/$kod_hry/$soubor"; my $cesta_url = "https://obr.hrejsi.cz/k/$kod_hry/$soubor"; ###!!! foreach my $pripona (qw(jpg gif png)) { if(-f ($cesta_disk.'.'.$pripona)) { $odkaz = $cesta_url.'.'.$pripona; last; } } return $odkaz; }