From 238f92e411b064cb85c1dee579b7dcaea5e99499 Mon Sep 17 00:00:00 2001 From: "Steinar H. Gunderson" Date: Sat, 9 Jun 2012 19:12:02 +0200 Subject: [PATCH] Convert rating.pl to XML::Template. It is dog-slow, but much cleaner. --- include/XML/Template.pm | 170 +++++++++++++++++++++++++++++++++ common.pm => include/common.pm | 54 ++++++++++- templates/rating.xml | 97 +++++++++++++++++++ www/index.pl | 5 +- www/rating.pl | 144 ++++++++-------------------- 5 files changed, 361 insertions(+), 109 deletions(-) create mode 100644 include/XML/Template.pm rename common.pm => include/common.pm (56%) create mode 100644 templates/rating.xml diff --git a/include/XML/Template.pm b/include/XML/Template.pm new file mode 100644 index 0000000..3747f83 --- /dev/null +++ b/include/XML/Template.pm @@ -0,0 +1,170 @@ +#! /usr/bin/perl +use XML::DOM; +use XML::Parser; +use XML::NamespaceSupport; +use Scalar::Util; +package XML::Template; + +sub process_file { + my ($filename, $obj, $clean) = @_; + + my $parser = XML::DOM::Parser->new; + my $doc = $parser->parsefile($filename); + + process($doc, $obj, $clean); + + return $doc; +} + +sub process { + my ($node, $obj, $clean, $nsup) = @_; + $clean = 1 unless (defined($clean)); + + if (!defined($nsup)) { + $nsup = XML::NamespaceSupport->new; + } + + if (!ref($obj)) { # overwrite + for my $child ($node->getChildNodes) { + $node->removeChild($child); + } + $node->addText($obj); + } elsif (Scalar::Util::blessed($obj) && $obj->isa('XML::DOM::Node')) { # overwrite + for my $child ($node->getChildNodes) { + $node->removeChild($child); + } + + if ($obj->isa('XML::DOM::Document')) { + $obj = $obj->getDocumentElement; + } + + my $newobj = $obj->cloneNode(1); + if ($node->isa('XML::DOM::Document')) { + $newobj->setOwnerDocument($node); + } else { + $newobj->setOwnerDocument($node->getOwnerDocument); + } + $node->appendChild($newobj); + + process($newobj, {}, $clean, $nsup); + } elsif (ref($obj) eq 'HASH') { # substitute + for my $child ($node->getChildNodes) { + my $processed = 0; + $nsup->push_context; + + if ($child->getNodeType == XML::DOM::ELEMENT_NODE) { + # see if this node contains any namespace declarations that are relevant + # for us + my $attrs = $child->getAttributes; + if (defined($attrs)) { + for my $attr ($attrs->getValues) { + my $name = $attr->getName; + if ($name =~ /^xmlns:(.*)$/) { + $nsup->declare_prefix($1, $attr->getValue); + $child->removeAttribute($name) if ($clean); + } + } + } + + my (undef, undef, $tag) = $nsup->process_element_name($child->getTagName); + + my $id; + my $attrs = $child->getAttributes; + if (defined($attrs)) { + for my $attr ($attrs->getValues) { + next if ($attr->getName =~ /^xmlns(:|$)/); + + my ($nsuri, undef, $tag) = $nsup->process_attribute_name($attr->getName); + if ($nsuri eq 'http://template.sesse.net/' && $tag eq 'id') { + $id = $attr->getValue; + $child->removeAttribute($attr->getName) if ($clean); + } + } + } + + # check all substitutions to see if we found anything + # appropriate + for my $key (keys %$obj) { + if (($key =~ /^\Q$tag\E\/(.*)$/) || + (defined($id) && $key =~ /^#\Q$id\E\/(.*)$/)) { + $child->setAttribute($1, $obj->{$key}); + } + + next if ($processed); + if ($key eq $tag || (defined($id) && $key eq ('#'.$id))) { + process($child, $obj->{$key}, $clean, $nsup); + $processed = 1; + } + } + } + + process($child, $obj, $clean, $nsup) unless ($processed); + $nsup->pop_context; + } + } elsif (ref($obj) eq 'ARRAY') { # repeat + my $doc = $node->getOwnerDocument; + my $frag = $doc->createDocumentFragment; + + for my $child ($node->getChildNodes) { + $frag->appendChild($child); + } + for my $child ($node->getChildNodes) { + $node->removeChild($child); + } + + for my $instance (@$obj) { + next if (!defined($instance)); + + my $newnode = $frag->cloneNode(1); + process($newnode, $instance, $clean, $nsup); + $node->appendChild($newnode); + clean($newnode, $nsup) if ($clean); + } + + $frag->dispose; + } + + clean($node, $nsup) if $clean; +} + +sub clean { + my ($node, $nsup) = @_; + + if ($node->getNodeType == XML::DOM::ELEMENT_NODE) { + my ($nsuri) = $nsup->process_element_name($node->getTagName); + return unless ($nsuri eq 'http://template.sesse.net/'); + + # as this is a dummy node, we want to remove it and move everything further up + # after we've done any required replacements + my $doc = $node->getOwnerDocument; + my $frag = $doc->createDocumentFragment; + + for my $child ($node->getChildNodes) { + $frag->appendChild($child); + } + for my $child ($node->getChildNodes) { + $node->removeChild($child); + } + + my $parent = $node->getParentNode; + + $parent->replaceChild($frag, $node); + } +} + +sub alternate { + my ($tag, $array, @elems) = @_; + + my $i = 0; + my $num = scalar @elems; + + for my $ref (@$array) { + if (defined($ref)) { + $ref->{$tag} = $elems[$i++ % $num]; + } + } + + return $array; +} + +1; diff --git a/common.pm b/include/common.pm similarity index 56% rename from common.pm rename to include/common.pm index 60cc243..6ad6ae4 100644 --- a/common.pm +++ b/include/common.pm @@ -1,6 +1,7 @@ use strict; use warnings; use POSIX; +use XML::Template; package wloh_common; @@ -11,17 +12,22 @@ sub get_max_season { return $ref->{'max_sesong'}; } -sub output_last_sync { +sub get_last_sync { my $dbh = shift; my $ref = $dbh->selectrow_hashref('SELECT EXTRACT(EPOCH FROM last_sync) AS last_sync FROM last_sync'); if (!defined($ref)) { - print "

Databasen ble sist synkronisert (ukjent).

\n"; + return "(ukjent)"; } else { - my $ts = POSIX::strftime("%Y-%m-%d %H:%M %Z", localtime($ref->{'last_sync'})); - print "

Databasen ble sist synkronisert $ts.

\n"; + return POSIX::strftime("%Y-%m-%d %H:%M %Z", localtime($ref->{'last_sync'})); } } +sub output_last_sync { + my $dbh = shift; + my $ts = get_last_sync($dbh); + print "

Databasen ble sist synkronisert $ts.

\n"; +} + sub get_locale { my $cgi = shift; my $url = $cgi->url(-absolute => 1); @@ -42,6 +48,39 @@ sub get_auxillary_parameters { return $aux_parms; } +sub get_navbar { + my ($cgi, $dbh, $locale) = @_; + my $url = $cgi->url(-relative => 1); + + print "

"; + + my $q = $dbh->prepare('SELECT spraak, kultur FROM fotballspraak WHERE nyestesesong <> -1 ORDER BY id'); + $q->execute; + + my @languages = (); + + my $first = 1; + while (my $ref = $q->fetchrow_hashref) { + my %lang = (); + if ($first) { + $lang{'separator'} = ''; + } + $first = 0; + + if ($ref->{'kultur'} eq $locale) { + $lang{'lang-with-link'} = ''; + $lang{'lang-no-link'} = $ref->{'spraak'}; + } else { + $lang{'a'} = $ref->{'spraak'}; + $lang{'a/href'} = sprintf "/%s/%s", $ref->{'kultur'}, $url; + $lang{'lang-no-link'} = ''; + } + push @languages, \%lang; + } + + return \@languages; +} + sub print_navbar { my ($cgi, $dbh, $locale) = @_; my $url = $cgi->url(-relative => 1); @@ -67,4 +106,11 @@ sub print_navbar { print "

\n"; } +sub process_template { + my ($filename, $parms) = @_; + + my $doc = XML::Template::process_file('../templates/' . $filename, $parms); + print $doc->toString; +} + 1; diff --git a/templates/rating.xml b/templates/rating.xml new file mode 100644 index 0000000..05bfa4c --- /dev/null +++ b/templates/rating.xml @@ -0,0 +1,97 @@ + + + + + WLoH-rating + + + +

+ + :: + + + +

+ +

WLoH-rating

+ +

Dette er et hobbyprosjekt fra tredjepart, og ikke en offisiell del av + Wordfeud Leage of Honour.

+ +

Ratingen er dog basert på spilledata fra WLoH (takk til Lobotommy + for tilgang!), og oppdateres + hver hele time. Den er fullstendig uoffisiell, og har ingen innflytelse + på WLoH, men brukes for å estimere vinnersannsynligheter i + sannsynlighetsberegningen.

+ +

Modellen kan endre seg når som helst når jeg føler for det :-) + Ikke ta ratingen alt for alvorlig, selv om den er basert på + relativt fornuftige matematiske modeller. Husk at all statistikk + sier mer om fortiden enn om framtiden.

+ +

Modellparametre

+ +

For de som vet litt om slikt. Det finnes også en lengre, mer detaljert + forklaring beregnet på ikke-matematikere.

+ + + +

Divisjonsoversikt

+ + + + + + + + + + + + + + + +
Div.SnittStd.avvik
+ + + +
+ +

Rankingliste

+ + + + + + + + + + + + + + + + + +
NickRatingStd.avvikSist sett
+ + +
+ +

Databasen ble sist synkronisert .

+ + diff --git a/www/index.pl b/www/index.pl index a039cea..966f5c7 100755 --- a/www/index.pl +++ b/www/index.pl @@ -11,8 +11,9 @@ use HTML::Entities; use Encode; use utf8; use locale; -require '../config.pm'; -require '../common.pm'; +use lib qw(../include); +require 'config.pm'; +require 'common.pm'; my $cgi = CGI->new; diff --git a/www/rating.pl b/www/rating.pl index 9580fb6..c69d5a7 100755 --- a/www/rating.pl +++ b/www/rating.pl @@ -10,8 +10,9 @@ use POSIX; use HTML::Entities; use utf8; use locale; -require '../config.pm'; -require '../common.pm'; +use lib qw(../include); +require 'config.pm'; +require 'common.pm'; my $dbh = DBI->connect($config::local_connstr, $config::local_username, $config::local_password) or die "connect: " . $DBI::errstr; @@ -24,68 +25,9 @@ my $cgi = CGI->new; my $locale = wloh_common::get_locale($cgi); my $aux_parms = wloh_common::get_auxillary_parameters($dbh, $locale); -my $match_stddev = $aux_parms->{'score_stddev'} * sqrt(2.0); -print CGI->header(-type=>'text/html; charset=utf-8', -expires=>'+5m'); POSIX::setlocale(&POSIX::LC_ALL, 'nb_NO.UTF-8'); -print <<"EOF"; - - - - - WLoH-rating - - - -EOF - -wloh_common::print_navbar($cgi, $dbh, $locale); - -printf <<"EOF", $aux_parms->{'rating_prior_stddev'}, $match_stddev; -

WLoH-rating

- -

Dette er et hobbyprosjekt fra tredjepart, og ikke en offisiell del av - Wordfeud Leage of Honour.

- -

Ratingen er dog basert på spilledata fra WLoH (takk til Lobotommy - for tilgang!), og oppdateres - hver hele time. Den er fullstendig uoffisiell, og har ingen innflytelse - på WLoH, men brukes for å estimere vinnersannsynligheter i - sannsynlighetsberegningen.

- -

Modellen kan endre seg når som helst når jeg føler for det :-) - Ikke ta ratingen alt for alvorlig, selv om den er basert på - relativt fornuftige matematiske modeller. Husk at all statistikk - sier mer om fortiden enn om framtiden.

- -

Modellparametre

- -

For de som vet litt om slikt. Det finnes også en lengre, mer detaljert - forklaring beregnet på ikke-matematikere.

- - - -

Divisjonsoversikt

- - - - - - - -EOF - my $season = wloh_common::get_max_season($dbh, $locale); # Pick up all the subdivisions' ratings. @@ -104,38 +46,29 @@ while (my $ref = $q->fetchrow_hashref) { $q = $dbh->prepare('SELECT divisjon,AVG(rating) AS avg_rating,STDDEV(rating) AS stddev_rating FROM ratings NATURAL JOIN siste_divisjon NATURAL JOIN spiller_kultur WHERE kultur=? AND sesong=? GROUP BY divisjon ORDER BY divisjon'); $q->execute($locale, $season); +my @divisions = (); + my $i = 0; while (my $ref = $q->fetchrow_hashref) { - if (++$i % 2 == 0) { - print " \n"; - } else { - print " \n"; - } - printf " \n", $ref->{'divisjon'}; - printf " \n", $ref->{'avg_rating'}; - printf " \n", $ref->{'stddev_rating'}; + my %division = (); + $division{'#rank'} = sprintf "%d.", $ref->{'divisjon'}; + $division{'#average'} = sprintf "%.1f", $ref->{'avg_rating'}; + $division{'#stddev'} = sprintf "%.1f", $ref->{'stddev_rating'}; + + my @subdivisions = (); for my $arr (@{$subdivision_ratings{$ref->{'divisjon'}}}) { my ($id, $rating) = @$arr; - printf " \n", $id, $rating; + push @subdivisions, { + '#divlink' => sprintf("%.1f", $rating), + '#divlink/href' => sprintf("http://wordfeud.aasmul.net/serie-%d", $id) + }; } - print " \n"; -} - -print <<"EOF"; -
Div.SnittStd.avvik
%d.%.1f%.1f%.1f
-

Rankingliste

+ $division{'subdivisions'} = \@subdivisions; - - - - - - - - -EOF + push @divisions, \%division; +} $q = $dbh->prepare(' SELECT * @@ -147,27 +80,32 @@ WHERE kultur=? ORDER BY rating DESC'); $q->execute($locale); +my @players = (); + $i = 0; while (my $ref = $q->fetchrow_hashref) { - if (++$i % 2 == 0) { - print " \n"; - } else { - print " \n"; - } - printf " \n", $i; - printf " \n", $ref->{'id'}, HTML::Entities::encode_entities(Encode::decode_utf8($ref->{'navn'})); - printf " \n", $ref->{'rating'}; - printf " \n", $ref->{'rating_stddev'}; - printf " \n", $ref->{'serie_id'}, $ref->{'serie_navn'}; - print " \n"; -} -print "
NickRatingStd.avvikSist sett
%d.%s%.1f%.1f%s
\n"; + my %player = (); -wloh_common::output_last_sync($dbh); + $player{'#rank'} = sprintf "%d.", ++$i; + $player{'#user'} = Encode::decode_utf8($ref->{'navn'}); + $player{'#user/href'} = sprintf "http://wordfeud.aasmul.net/bruker-%d", $ref->{'id'}; + $player{'#rating'} = sprintf "%.1f", $ref->{'rating'}; + $player{'#stddev'} = sprintf "%.1f", $ref->{'rating_stddev'}; + $player{'#divlink'} = $ref->{'serie_navn'}; + $player{'#divlink/href'} = sprintf "http://wordfeud.aasmul.net/serie-%d", $ref->{'serie_id'}; -print <<"EOF"; - - -EOF + push @players, \%player; +} + +print CGI->header(-type=>'text/html; charset=utf-8', -expires=>'+5m'); +wloh_common::process_template('rating.xml', { + '#navbar' => wloh_common::get_navbar($cgi, $dbh, $locale), + 'iterations' => $aux_parms->{'num_iterations'}, + 'rating-prior-stddev' => sprintf("%.1f", $aux_parms->{'rating_prior_stddev'}), + 'match-stddev' => sprintf("%.1f", $aux_parms->{'score_stddev'} * sqrt(2.0)), + '#divisions' => XML::Template::alternate('tr/class', \@divisions, 'even', 'odd'), + '#players' => XML::Template::alternate('tr/class', \@players, 'even', 'odd'), + 'last-sync' => wloh_common::get_last_sync($dbh) +}); $dbh->rollback; -- 2.39.2