Accueil Explorateur Aide
Connexion
lamperi
/
pna
Suivre 1
Voter 0
Bifurcation 0
Code Tickets 0 Demandes d'ajout 0 Versions 0 Wiki Activité
PNA.fi koodi
4 Révisions
1 Branches
Aborescence: a835cdbbab
Branches Tags
${ item.name }
Créer la branche ${ searchTerm }
de 'a835cdbbab'
${ noResults }
pna/food.pl

food.pl 14KB
Historique Brut

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469 
  1. #!/usr/bin/env perl

  2. 

  3. # Ruokalistaparseri v1.5.3

  4. # Copyright (c) 2007-2010 Timo Sirainen

  5. #               2011-2012 Toni Fadjukoff

  6. # This is Public Domain

  7. 

  8. use strict;

  9. use POSIX qw(strftime mktime);

  10. use HTML::TokeParser;

  11. use HTML::Entities;

  12. 

  13. use vars qw(@day_names);

  14. @day_names = ( "Maanantai", "Tiistai", "Keskiviikko", "Torstai", 

  15. 	       "Perjantai", "Lauantai", "Sunnuntai" );

  16. 

  17. require 'amica.pl';

  18. require 'sodexo.pl';

  19. require 'juvenes.pl';

  20. require 'pky.pl';

  21. 

  22. my @allergies = ( "M", "L", "VL", "G", "K", "Ve" );

  23. my %allergy_descriptions = (

  24.   "M" => "Maidoton",

  25.   "L" => "Laktoositon",

  26.   "VL" => "Vähälaktoosinen",

  27.   "G" => "Gluteiiniton",

  28.   "K" => "Kasvis",

  29.   "Ve" => "Vegaani"

  30. );

  31. 

  32. my $global_prefix = "";

  33. my $use_old = 0; # 1 is good for testing, 0 for production system!

  34. my @unordered;

  35. 

  36. my @l = localtime;

  37. my $this_week = strftime("%V", @l);

  38. 

  39. push @unordered, get_juvenes_restaurants($use_old);

  40. push @unordered, get_amica_restaurant($use_old);

  41. push @unordered, get_sodexo_restaurants($use_old);

  42. push @unordered, get_pky_restaurants($use_old, $l[6] == 0 || $l[6] == 6);

  43. 

  44. my $max_week = 0;

  45. foreach my $r (@unordered) {

  46.   my $week = @{$r}[2];

  47.   $max_week = $week if ($week > $max_week || $week == 1);

  48. }

  49. 

  50. if ($l[6] != 0 && $this_week != $max_week) {

  51.   # it's not sunday, don't force next week's menu yet

  52.   $max_week = $this_week;

  53. }

  54. 

  55. my $stamp = time() - 3600*24*7;

  56. my $max_week_daterange = "";

  57. if ($max_week >= 1 && $max_week <= 52) {

  58.   # figure out the date range

  59.   for (;;) {

  60.     my $stamp_week = strftime("%V", localtime($stamp));

  61.     last if ($stamp_week == $max_week);

  62.     $stamp += 3600*24;

  63.   }

  64.   my @l1 = localtime($stamp);

  65.   my @l2 = localtime($stamp + 3600*24*6);

  66.   if ($l1[4] == $l2[4]) {

  67.     # same month

  68.     $max_week_daterange = $l1[3]."-".$l2[3].".".($l1[4]+1).".";

  69.   } else {

  70.     # different months

  71.     $max_week_daterange = $l1[3].".".($l1[4]+1)."-".$l2[3].".".($l2[4]+1).".";

  72.   }

  73.   $max_week_daterange = " ($max_week_daterange)"

  74. }

  75. 

  76. my $file_header = '<?xml version="1.0" encoding="iso-8859-1"?>

  77. <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">

  78. <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="fi" lang="fi">

  79. <head>

  80.   <title>Ruokalistat</title>

  81.   <link rel="stylesheet" type="text/css" href="'.$global_prefix.'/ruoka.css" />

  82. </head>

  83. <body onload="set_allergies()">

  84. 

  85. 

  86. <form method="get" action="/cgi-bin/food.cgi">

  87. ';

  88. my $file_footer = "<div class=\"footer\">Päivitetty ".

  89.     strftime("%d.%m.%Y %H:%M:%S", localtime).

  90.     " <input type=\"submit\" value=\"Päivitä nyt\" />".

  91.     " / Palaute <a href=\"mailto:lamperi+pna\@gmail.com\">lamperi+pna\@gmail.com</a>".

  92.     " / <a href=\"$global_prefix/code.html\">Koodit täältä</a>".

  93.     " / <a href=\"$global_prefix/pna.html\">Mikä on PNA?</a>".

  94.     "</div>\n</form>\n</body></html>\n";

  95. 

  96. sub find_last_day_with_foods {

  97.   my $restaurants_ref = shift;

  98. 

  99.   my $last_day = 0;

  100.   foreach my $r (@${restaurants_ref}) {

  101.     my ($title, $open_hours, $week, $week_foods_ref) = @{$r};

  102.     my @week_foods = @{$week_foods_ref};

  103.     for (my $day = 0; $day < 7; $day++) {

  104.       if (defined($week_foods[$day])) {

  105. 	$last_day = $day if ($day > $last_day);

  106.       }

  107.     }

  108.   }

  109.   return $last_day;

  110. }

  111. 

  112. sub write_days_header {

  113.   my ($fout, $day, $last_day) = @_;

  114.   

  115.   print $fout "  <span class=\"days\">";

  116.   for (my $i = 0; $i <= $last_day; $i++) {

  117.     if ($i == $day) {

  118.       print $fout $day_names[$i]." ";

  119.     } else {

  120.       print $fout "<a href=\"".($i+1).".html\">".$day_names[$i]."</a> ";

  121.     }

  122.   }

  123.   if ($day < 0) {

  124.     print $fout "Taulukko";

  125.   } else {

  126.     print $fout "<a href=\"table.html\">Taulukko</a>";

  127.   }

  128.   print $fout "</span>\n";

  129. }

  130. 

  131. sub write_prefix_header {

  132.   my ($fout, $prefix, $day) = @_;

  133.   

  134.   $day = "table" if ($day == 0);

  135.   print $fout "<span class=\"location\">";

  136.   if ($prefix eq "") {

  137.     print $fout "Kaikki ";

  138.   } else {

  139.     print $fout "<a href=\"$global_prefix/$day.html\">Kaikki</a> ";

  140.   }

  141.   if ($prefix eq "tay/") {

  142.     print $fout "TaY ";

  143.   } else {

  144.     print $fout "<a href=\"$global_prefix/tay/$day.html\">TaY</a> ";

  145.   }

  146.   if ($prefix eq "tays/") {

  147.     print $fout "TAYS ";

  148.   } else {

  149.     print $fout "<a href=\"$global_prefix/tays/$day.html\">TAYS</a> ";

  150.   }

  151.   if ($prefix eq "tty/") {

  152.     print $fout "TTY ";

  153.   } else {

  154.     print $fout "<a href=\"$global_prefix/tty/$day.html\">TTY</a> ";

  155.   }

  156.   print $fout "</span>\n";

  157. }

  158. 

  159. sub write_day {

  160.   my ($day, $header, $outfname, $last_day, $restaurants_ref, $prefix) = @_;

  161.   my @restaurants = @{$restaurants_ref};

  162. 

  163.   open(my $fout, ">$outfname") || die ("Can't create file $outfname");

  164.   print $fout "$file_header<h1>$header</h1>\n";

  165.   # print weekday links

  166.   print $fout "<div class=\"title\">\n";

  167.   write_days_header($fout, $day, $last_day);

  168.   print $fout "  <span class=\"allergy\">Näytä: ";

  169.   foreach my $a (@allergies) {

  170.     print $fout "<input type=\"checkbox\" name=\"allergy_$a\" id=\"allergy_$a\" onclick=\"highlight()\" />";

  171.     print $fout "<span title=\"".$allergy_descriptions{$a}."\">$a</span>";

  172.   }

  173.   print $fout "</span>\n";

  174.   write_prefix_header($fout, $prefix, $day+1);

  175.   print $fout "</div>\n";

  176. 

  177.   # print foods

  178.   my $foodnum = 0;

  179.   my %eatable_food_numbers;

  180.   my %maybe_eatable_food_numbers;

  181.   my $class = "left";

  182.   print $fout "<div class=\"foods\"><div class=\"$class\">\n";

  183.   foreach my $r (@restaurants) {

  184.     my ($title, $open_hours, $week, $week_foods_ref, $info_ref) = @{$r};

  185.     my ($title2, $url, $lazy_allergies, $info_class) = @{$info_ref};

  186.     my @week_foods = @{$week_foods_ref};

  187.     if (defined($week_foods[$day]) || $day < 5) {

  188.       # Bio+Kliininen often have the same foods

  189.       next if (try_merge_bio_kliininen(\$title, $day));

  190. 

  191.       if ($info_class ne $class) {

  192. 	$class = $info_class;

  193. 	print $fout "</div><div class=\"$class\">\n";

  194.       }

  195.       $url =~ s/&/&amp;/g;

  196.       print $fout "<h2><a href=\"$url\">$title</a></h2>\n";

  197.       

  198.       if (!defined($week_foods[$day])) {

  199. 	print $fout "<p class=\"missing\">Ruokalistaa ei saatavilla.</p>";

  200. 	next;

  201.       }

  202.       if ($week ne "" && $week != $max_week) {

  203. 	if ($week > $max_week || ($week == 1 && $max_week == 52)) {

  204. 	  # early..

  205. 	  print $fout "<p class=\"nextweek\">Viikon $week ruokalista:</p>";

  206. 	} else {

  207. 	  print $fout "<p class=\"missing\">Saatavilla vain viikon $week ruokalista.</p>";

  208. 	  next;

  209. 	}

  210.       }

  211.       if (scalar(@{$week_foods[$day]}) == 0) {

  212. 	print $fout "<p class=\"missing\">Ei ruokatietoja päivälle.</p>";

  213. 	next;

  214.       }

  215.       

  216.       print $fout "<ul class=\"food\">\n";

  217.       foreach my $food (@{$week_foods[$day]}) {

  218. 	my $output = "";

  219. 	my %total_allergies;

  220. 	my %maybe_allergies;

  221. 	my $part_count = 0;

  222. 	foreach my $part (split("\n", $food)) {

  223. 	  next if ($part =~ /^(Peruna|Riisi) /); # who cares?

  224. 	  # fries: well, maybe we do care, but we don't care about allergy stuff

  225. 	  # and keep it in the same line as the previous food so as not to

  226. 	  # waste visible space

  227. 	  my $fries = ($part =~ /^(Tikkuperunat|Ranskalaiset perunat)/);

  228. 	  $part_count++;

  229. 	  

  230. 	  # add missing () around allergies

  231. 	  $part =~ s/ (([MLGK]|VL|Ve|Veg|Hot)(,([MLGK]|VL|Ve|Veg|Hot|))+)$/ ($1)/;

  232. 	  

  233. 	  if ($part =~ /^(.*) \(([^\)]+)\)$/) {

  234. 	    # fix allergy issues

  235. 	    my ($food, $allergy) = ($1, $2);

  236. 	    # standardization

  237. 	    $allergy =~ s/Kasvis/K/g;

  238. 	    $allergy =~ s/([MLGK]|VL)([MLGK]|VL)/$1,$2/g;

  239. 	    # spaces to commas

  240. 	    $allergy =~ s/saatavana[: ]+(.*)$/eriks: $1/;

  241. 	    $allergy =~ s/ +/,/g;

  242. 	    # remove double commas

  243. 	    $allergy =~ s/,+/,/g;

  244. 	    # eriks: standardization

  245. 	    $allergy =~ s/,?eriks:,?/, eriks: /g;

  246. 	    # remove extra commas/spaces from beginning/end

  247. 	    $allergy =~ s/^[, ]+//;

  248. 	    $allergy =~ s/[, ]+$//;

  249. 	    $part = "$food ($allergy)";

  250. 	  }

  251. 	  

  252. 	  $output .= "<br />\n" if ($output ne "" && !$fries);

  253. 	  if ($part =~ /Saatavana myös: (.*)/) {

  254. 	    # standardize allergy stuff

  255. 	    my $alt = $1;

  256. 	    $alt =~ s/^\((.*)\)$/$1/;

  257. 	    $alt =~ s/[, ]+/,/g;

  258. 	    $alt =~ s/^,+//;

  259. 	    $alt =~ s/,+$//;

  260. 	    $part =~ s/\)[- ]*Saatavana myös:.*/, eriks: $alt)/;

  261. 	    $part =~ s/[- ]*Saatavana myös:.*/ (eriks: $alt)/;

  262. 	  }

  263. 	  if ($part =~ /^(.*)(\([^\)]+\))$/) {

  264. 	    my ($text, $allergy) = ($1, $2);

  265. 	    if ($fries) {

  266. 	      $output .= ", $text";

  267. 	    } else {

  268. 	      $output .= "$text <span class=\"allergy\">$allergy</span>";

  269. 	    }

  270. 	    $allergy =~ s/^\((.*)\)$/$1/;

  271. 	    $allergy =~ s/ *eriks: //;

  272. 	    my %this_allergies;

  273. 	    foreach my $a (split(/[, ]/, $allergy)) {

  274. 	      foreach my $al (@allergies) {

  275. 		if ($a eq $al) {

  276. 		  $this_allergies{$a} = 1;

  277. 		  last;

  278. 		}

  279. 	      }

  280. 	    }

  281. 	    # is M=L always correct? not at least in all restaurants..

  282. 	    #$this_allergies{"L"} = 1 if ($this_allergies{"M"});

  283. 	    $this_allergies{"VL"} = 1 if ($this_allergies{"L"});

  284. 	    foreach my $a (keys %this_allergies) {

  285. 	      $total_allergies{$a}++;

  286. 	      $maybe_allergies{$a}++;

  287. 	    }

  288. 	    if ($lazy_allergies =~ /M/) {

  289. 	      # L might mean M

  290. 	      if ($this_allergies{"L"} && !$this_allergies{"M"}) {

  291. 		$maybe_allergies{"M"}++;

  292. 	      }

  293. 	    }

  294. 	  } else {

  295. 	    if ($lazy_allergies eq "all") {

  296. 	      # no allergy info, make everything maybe

  297. 	      foreach my $a (@allergies) {

  298. 		$maybe_allergies{$a}++;

  299. 	      }

  300. 	    }

  301. 	    $output .= $part;

  302. 	  }

  303. 	}

  304. 	my $allergy_output = "";

  305. 	foreach my $a (@allergies) {

  306. 	  if ($total_allergies{$a} == $part_count) {

  307. 	    if (!defined($eatable_food_numbers{$a})) {

  308. 	      $eatable_food_numbers{$a} = "";

  309. 	    } else {

  310. 	      $eatable_food_numbers{$a} .= ",";

  311. 	    }

  312. 	    $eatable_food_numbers{$a} .= $foodnum;

  313. 	  } elsif ($maybe_allergies{$a} == $part_count) {

  314. 	    if (!defined($maybe_eatable_food_numbers{$a})) {

  315. 	      $maybe_eatable_food_numbers{$a} = "";

  316. 	    } else {

  317. 	      $maybe_eatable_food_numbers{$a} .= ",";

  318. 	    }

  319. 	    $maybe_eatable_food_numbers{$a} .= $foodnum;

  320. 	  }

  321. 	}

  322. 	print $fout "  <li id=\"f$foodnum\">$output</li>\n";

  323. 	$foodnum++;

  324.       }

  325.       print $fout "</ul>\n";

  326.     }

  327.   }

  328.   # write allergy scripts

  329.   print $fout '<script type="text/javascript" src="'.$global_prefix.'/ruoka.js"></script>';

  330.   print $fout '<script type="text/javascript">';

  331.   print $fout "var eatable_foods = [];";

  332.   print $fout "var maybe_eatable_foods = [];";

  333.   foreach my $a (@allergies) {

  334.     print $fout "eatable_foods[\"$a\"] = [".$eatable_food_numbers{$a}."];\n";

  335.     print $fout "maybe_eatable_foods[\"$a\"] = [".$maybe_eatable_food_numbers{$a}."];\n";

  336.   }

  337.   my @allergy_strings = map('"'.$_.'"', @allergies);

  338.   print $fout "var allergies = [".join(",", @allergy_strings)."];\n";

  339.   print $fout "var food_count = $foodnum\n";

  340.   print $fout "</script>\n";

  341. 

  342.   print $fout "</div></div>$file_footer";

  343.   close $fout;

  344. }

  345. 

  346. sub write_all_days {

  347.   my ($restaurants_ref, $prefix, $title) = @_;

  348.   my $last_day = find_last_day_with_foods($restaurants_ref);

  349.   

  350.   for (my $day = 0; $day < 7; $day++) {

  351.     my $outfname = $prefix.($day+1).".html";

  352.     if ($day > $last_day) {

  353.       unlink($outfname);

  354.       next;

  355.     }

  356.     my $header = $day_names[$day]." - $title vko $max_week$max_week_daterange";

  357.     write_day($day, $header, $outfname, $last_day, $restaurants_ref, $prefix);

  358.   }

  359. }

  360. 

  361. sub write_table {

  362.   my ($restaurants_ref, $prefix, $title) = @_;

  363.   my @restaurants = @{$restaurants_ref};

  364.   my $last_day = find_last_day_with_foods($restaurants_ref);

  365. 

  366.   my $outfname = $prefix."table.html";

  367.   open(my $fout, ">$outfname") || die ("Can't create file $outfname");

  368.   my $header = "$title vko $max_week$max_week_daterange";

  369.   print $fout "$file_header<h1>$header</h1>\n";

  370.   print $fout "<div class=\"title\">\n";

  371.   write_days_header($fout, -1, $last_day);

  372.   write_prefix_header($fout, $prefix, 0);

  373.   print $fout "</div><table border=\"1\"><tr><th>Päivä</th>";

  374.   foreach my $r (@restaurants) {

  375.     my ($title, $open_hours, $week, $week_foods_ref, $info_ref) = @{$r};

  376.     my ($title2, $url) = @{$info_ref};

  377.     $url =~ s/&/&nbsp;/g;

  378.     print $fout "<th><a href=\"$url\">$title</a></th>";

  379.   }

  380.   print $fout "</tr>\n";

  381.   for (my $day = 0; $day <= $last_day; $day++) {

  382.     print $fout "<tr><td>".$day_names[$day]."</td>\n";

  383.     foreach my $r (@restaurants) {

  384.       my ($title, $open_hours, $week, $week_foods_ref, $info_ref) = @{$r};

  385.       my @week_foods = @{$week_foods_ref};

  386.       if (defined($week_foods[$day]) && ($week eq "" || $week == $max_week)) {

  387. 	print $fout "<td><ul>\n";

  388. 	foreach my $food (@{$week_foods[$day]}) {

  389. 	  print $fout "<li>$food</li>";

  390. 	}

  391. 	print $fout "</ul></td>\n";

  392.       } else {

  393. 	print $fout "<td></td>\n";

  394.       }

  395.     }

  396.     print $fout "</tr>\n";

  397.   }

  398.   print $fout "</table>$file_footer";

  399.   close $fout;

  400. }

  401. 

  402. sub get_restaurants_sorted {

  403.   my @restaurants = @_;

  404.   my @out;

  405.   foreach my $r (@restaurants) {

  406.     push @out, $r if (@{@{$r}[4]}[3] eq "left");

  407.   }

  408.   foreach my $r (@restaurants) {

  409.     push @out, $r if (@{@{$r}[4]}[3] eq "right");

  410.   }

  411.   foreach my $r (@restaurants) {

  412.     my @e = @{@{$r}[4]};

  413.     push @out, $r if ($e[3] eq "middle" && $e[1] !~ /TAMK/);

  414.   }

  415.   foreach my $r (@restaurants) {

  416.     my @e = @{@{$r}[4]};

  417.     push @out, $r if ($e[3] eq "middle" && $e[1] =~ /TAMK/);

  418.   }

  419.   return @out;

  420. }

  421. 

  422. sub get_restaurants_with_prefix {

  423.   my $prefix = shift;

  424.   my @out;

  425.   foreach my $r (@_) {

  426.     my $name = @{$r}[0];

  427.     if ($name =~ /^\($prefix\)/) {

  428.       push @out, $r;

  429.     }

  430.   }

  431.   return get_restaurants_sorted(@out);

  432. }

  433. 

  434. my $tty_title = "TTY:n ruokalistat";

  435. my @tty = get_restaurants_with_prefix("TTY", @unordered);

  436. write_all_days(\@tty, "tty/", $tty_title);

  437. write_table(\@tty, "tty/", $tty_title);

  438. 

  439. my $tay_title = "Tampereen yliopiston ruokalistat";

  440. my @tay = get_restaurants_with_prefix("TaY", @unordered);

  441. write_all_days(\@tay, "tay/", $tay_title);

  442. write_table(\@tay, "tay/", $tay_title);

  443. 

  444. my $tays_title = "TAYS:n ruokalistat";

  445. my @tays = get_restaurants_with_prefix("TAYS", @unordered);

  446. write_all_days(\@tays, "tays/", $tays_title);

  447. write_table(\@tays, "tays/", $tays_title);

  448. 

  449. foreach my $r (@unordered) {

  450.   if (@{$r}[0] =~ /^\(TaY\)/) {

  451.     @{@{$r}[4]}[3] = "left";

  452.   }

  453.   if (@{$r}[0] =~ /^\(TTY\)/) {

  454.     @{@{$r}[4]}[3] = "right";

  455.   }

  456.   if (@{$r}[0] =~ /^\(TAYS\)/) {

  457.     @{@{$r}[4]}[3] = "middle";

  458.   }

  459. }

  460. 

  461. my $all_title = "Tampereen yliopistojen ruokalistat";

  462. my @all_restaurants = get_restaurants_sorted(@unordered);

  463. # move fusion kitchen last

  464. my @fusion = splice(@all_restaurants, 1, 1);

  465. splice(@all_restaurants, 4, 0, @fusion);

  466. 

  467. write_all_days(\@all_restaurants, "", $all_title);

  468. write_table(\@all_restaurants, "", $all_title);