--- /dev/null
+#! /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;
use strict;
use warnings;
use POSIX;
+use XML::Template;
package wloh_common;
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 " <p class=\"lastsync\">Databasen ble sist synkronisert (ukjent).</p>\n";
+ return "(ukjent)";
} else {
- my $ts = POSIX::strftime("%Y-%m-%d %H:%M %Z", localtime($ref->{'last_sync'}));
- print " <p class=\"lastsync\">Databasen ble sist synkronisert $ts.</p>\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 " <p class=\"lastsync\">Databasen ble sist synkronisert $ts.</p>\n";
+}
+
sub get_locale {
my $cgi = shift;
my $url = $cgi->url(-absolute => 1);
return $aux_parms;
}
+sub get_navbar {
+ my ($cgi, $dbh, $locale) = @_;
+ my $url = $cgi->url(-relative => 1);
+
+ print "<p style=\"font-size: smaller;\">";
+
+ 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);
print "</p>\n";
}
+sub process_template {
+ my ($filename, $parms) = @_;
+
+ my $doc = XML::Template::process_file('../templates/' . $filename, $parms);
+ print $doc->toString;
+}
+
1;
--- /dev/null
+<?xml version="1.0" encoding="UTF-8" ?>
+<!DOCTYPE
+ html PUBLIC "-//W3C//DTD XHTML 1.1//EN"
+ "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="no" xmlns:t="http://template.sesse.net/">
+ <head>
+ <title>WLoH-rating</title>
+ <link rel="stylesheet" href="style" type="text/css" />
+ </head>
+ <body>
+ <p style="font-size: smaller;" t:id="navbar">
+ <t:languages>
+ <t:separator>::</t:separator>
+ <t:lang-with-link><a /></t:lang-with-link>
+ <t:lang-no-link />
+ </t:languages>
+ </p>
+
+ <h1>WLoH-rating</h1>
+
+ <p><em>Dette er et hobbyprosjekt fra tredjepart, og ikke en offisiell del av
+ <a href="http://wordfeud.aasmul.net/">Wordfeud Leage of Honour</a>.</em></p>
+
+ <p>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
+ <a href="index">sannsynlighetsberegningen</a>.</p>
+
+ <p>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.</p>
+
+ <h2>Modellparametre</h2>
+
+ <p>For de som vet litt om slikt. Det finnes også en lengre, mer detaljert
+ <a href="ratings-explained">forklaring</a> beregnet på ikke-matematikere.</p>
+
+ <ul>
+ <li>MLE-basert modell med én skalar (styrke) per spiller og to globale skalarer (begge standardavvik, se under), løst med syklisk MM (minorization-maximization). Antall iterasjoner før konvergens: <t:iterations />.</li>
+ <li>Rimelighetfunksjon, prior: Normalfordeling med µ=500, σ=<t:rating-prior-stddev /> (est.)</li>
+ <li>Rimelighetfunksjon, per kamp: Normalfordeling med µ=(score1 - score2), σ=<t:match-stddev /> (est.)</li>
+ <li>Vekting: Inneværende sesong samt de tre siste vektes fullt ut
+ (likt med prior). Deretter eksponentielt synkende vekting, med
+ halveringstid på tre sesonger. Spill som er registrert med
+ 0-0, 150-0, 0-150 eller 150-150 ignoreres.</li>
+ </ul>
+
+ <h2>Divisjonsoversikt</h2>
+
+ <table>
+ <thead>
+ <tr>
+ <th>Div.</th>
+ <th>Snitt</th>
+ <th>Std.avvik</th>
+ </tr>
+ </thead>
+ <tbody t:id="divisions">
+ <tr>
+ <th t:id="rank" />
+ <td class="num" t:id="average" />
+ <td class="num" t:id="stddev" />
+ <t:subdivisions>
+ <td class="num"><a t:id="divlink" /></td>
+ </t:subdivisions>
+ </tr>
+ </tbody>
+ </table>
+
+ <h2>Rankingliste</h2>
+
+ <table>
+ <thead>
+ <tr>
+ <th></th>
+ <th>Nick</th>
+ <th>Rating</th>
+ <th>Std.avvik</th>
+ <th>Sist sett</th>
+ </tr>
+ </thead>
+ <tbody t:id="players">
+ <tr>
+ <th t:id="rank" />
+ <td><a t:id="user" /></td>
+ <td class="num" t:id="rating" />
+ <td class="num" t:id="stddev" />
+ <td><a t:id="divlink" /></td>
+ </tr>
+ </tbody>
+ </table>
+
+ <p class="lastsync">Databasen ble sist synkronisert <t:last-sync />.</p>
+ </body>
+</html>
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;
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;
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";
-<?xml version="1.0" encoding="UTF-8" ?>
-<!DOCTYPE
- html PUBLIC "-//W3C//DTD XHTML 1.1//EN"
- "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
-<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="no">
- <head>
- <title>WLoH-rating</title>
- <link rel="stylesheet" href="style" type="text/css" />
- </head>
- <body>
-EOF
-
-wloh_common::print_navbar($cgi, $dbh, $locale);
-
-printf <<"EOF", $aux_parms->{'rating_prior_stddev'}, $match_stddev;
- <h1>WLoH-rating</h1>
-
- <p><em>Dette er et hobbyprosjekt fra tredjepart, og ikke en offisiell del av
- <a href="http://wordfeud.aasmul.net/">Wordfeud Leage of Honour</a>.</em></p>
-
- <p>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
- <a href="index">sannsynlighetsberegningen</a>.</p>
-
- <p>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.</p>
-
- <h2>Modellparametre</h2>
-
- <p>For de som vet litt om slikt. Det finnes også en lengre, mer detaljert
- <a href="ratings-explained">forklaring</a> beregnet på ikke-matematikere.</p>
-
- <ul>
- <li>MLE-basert modell med én skalar (styrke) per spiller og to globale skalarer (begge standardavvik, se under), løst med syklisk MM (minorization-maximization). Antall iterasjoner før konvergens: $aux_parms->{num_iterations}.</li>
- <li>Rimelighetfunksjon, prior: Normalfordeling med µ=500, σ=%.1f (est.)</li>
- <li>Rimelighetfunksjon, per kamp: Normalfordeling med µ=(score1 - score2), σ=%.1f (est.)</li>
- <li>Vekting: Inneværende sesong samt de tre siste vektes fullt ut
- (likt med prior). Deretter eksponentielt synkende vekting, med
- halveringstid på tre sesonger. Spill som er registrert med
- 0-0, 150-0, 0-150 eller 150-150 ignoreres.</li>
- </ul>
-
- <h2>Divisjonsoversikt</h2>
-
- <table>
- <tr>
- <th>Div.</th>
- <th>Snitt</th>
- <th>Std.avvik</th>
- </tr>
-EOF
-
my $season = wloh_common::get_max_season($dbh, $locale);
# Pick up all the subdivisions' ratings.
$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 " <tr class=\"odd\">\n";
- } else {
- print " <tr class=\"even\">\n";
- }
- printf " <th>%d.</th>\n", $ref->{'divisjon'};
- printf " <td class=\"num\">%.1f</td>\n", $ref->{'avg_rating'};
- printf " <td class=\"num\">%.1f</td>\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 " <td class=\"num\"><a href=\"http://wordfeud.aasmul.net/serie-%d\">%.1f</a></td>\n", $id, $rating;
+ push @subdivisions, {
+ '#divlink' => sprintf("%.1f", $rating),
+ '#divlink/href' => sprintf("http://wordfeud.aasmul.net/serie-%d", $id)
+ };
}
- print " </tr>\n";
-}
-
-print <<"EOF";
- </table>
- <h2>Rankingliste</h2>
+ $division{'subdivisions'} = \@subdivisions;
- <table>
- <tr>
- <th></th>
- <th>Nick</th>
- <th>Rating</th>
- <th>Std.avvik</th>
- <th>Sist sett</th>
- </tr>
-EOF
+ push @divisions, \%division;
+}
$q = $dbh->prepare('
SELECT *
ORDER BY rating DESC');
$q->execute($locale);
+my @players = ();
+
$i = 0;
while (my $ref = $q->fetchrow_hashref) {
- if (++$i % 2 == 0) {
- print " <tr class=\"odd\">\n";
- } else {
- print " <tr class=\"even\">\n";
- }
- printf " <th>%d.</th>\n", $i;
- printf " <td><a href=\"http://wordfeud.aasmul.net/bruker-%d\">%s</a></td>\n", $ref->{'id'}, HTML::Entities::encode_entities(Encode::decode_utf8($ref->{'navn'}));
- printf " <td class=\"num\">%.1f</td>\n", $ref->{'rating'};
- printf " <td class=\"num\">%.1f</td>\n", $ref->{'rating_stddev'};
- printf " <td><a href=\"http://wordfeud.aasmul.net/serie-%d\">%s</a></td>\n", $ref->{'serie_id'}, $ref->{'serie_navn'};
- print " </tr>\n";
-}
-print " </table>\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";
- </body>
-</html>
-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;
projects / wloh / commitdiff