#!/usr/bin/perl -w

#

# Frets on Fire World Charts in perl.

#

# v0.3 by The Almighty Pegasus Epsilon <pegasus@pimpninjas.org>

#

# Distribute Unmodified.

#

# Changelog:

#

# v0.1 first functioning version. new scores overwrite old.

# v0.2 first attempt at merging scores - failed.

# changed the skill level printing method.

# v0.3 fixed the merging.

# added $localonly.

# added $datapath.

# added check to see if we can write to $datapath when creating new charts.

# removed remote title storing trust - if song exists, old title assumed correct.

# created "fixtitle.pl" to manually change incorrect titles.

# added file locking - no more race conditions.

#

# To-Do:

#

# * strip out debug stuff, once confirming breakfast is solid.

# * everyone hates the sloppiness of the output. prettify it somehow.

use strict;

use Fcntl ':flock';

use Storable qw(lock_store store_fd retrieve_fd);

# path for save data & utilities. best kept outside of the document root.

my $datapath = '/home/pegasus/.fofcharts';

# restrict to local scores only

sub localonly {

# uncomment to force local

# $ENV{REMOTE_ADDR} =~ /^192\.168\.0\./ && fail "False"

}

# enable debug

my $debug = 0;

# redirect stderr to stdout for http error delivery

open STDERR, ">&STDOUT";

# make stdout hot

select(((select STDOUT), $| = 1)[0]);

my $contentset;

sub contenttype {

$contentset && return;

$contentset = print "Content-type: text/html\n\n";

# $contentset = print "Content-type: text/plain\n\n";

}

my @scope = ('main');

sub debug{

$debug || return;

my $q = shift || return;

$contentset || contenttype;

print "$scope[-1]: $q\n";

}

sub line { my $q = shift; $q && return ($q =~ /(.+)\n([\w\W]*)/); }

sub fail {

contenttype;

print "$_\n" for @_;

exit;

}

sub pprint {

my $obj = shift or return;

contenttype;

my $indent = scalar @_ ? shift : 0;

$indent || print "<pre>";

$obj =~ /^HASH/ && do {

print "$obj:\n";

for (sort keys %{$obj}) {

print "\t" for (0..$indent);

print "key $_: ";

pprint($obj->{$_},$indent+1);

}

print "\n";

return;

};

$obj =~ /^ARRAY/ && do {

print "$obj:\n";

for (0..@{$obj}-1) {

print "\t" for (0..$indent);

print "index $_: ";

pprint($obj->[$_],$indent+1);

}

print "\n";

return;

};

print "$obj\n";

$indent || print "</pre>";

}

sub breakfast {

# fucking upside-down python logic...

push @scope, 'breakfast';

my $cereal = shift;

debug "looking for cereal...";

while ($cereal) {

last if ($cereal =~ s/^cereal1\n//); $cereal =~ s/^.//;

}

unless ($cereal) {

warn "breakfast: cereal not found, giving up.";

pop @scope;

return;

};

debug "cereal found.";

(my $objcount,$cereal) = line($cereal);

debug "cereal contains $objcount objects.";

my @objects;

for (0..$objcount-1) {

(my $type,$cereal) = line($cereal);

$type =~ /dict/ && do {

debug "found dict, adding to object collection.";

my %hash; $objects[$_] = \%hash; next;

};

$type =~ /tuple/ && do {

debug "found tuple, initializing...";

my @array;

(my $items,$cereal) = line($cereal);

debug "tuple contains $items data items.";

for (0..$items-1) {

$cereal =~ s/^s// && do {

debug "data item #$_ is a string.";

(my $len,$cereal) = line($cereal);

debug "the string is $len bytes long.";

($array[$_],$cereal) = ($cereal =~ /(.{$len})([\w\W]*)/);

debug "this is the string: $array[$_]";

next;

};

$cereal =~ s/^i// && do {

debug "data item #$_ is an integer.";

($array[$_],$cereal) = line($cereal);

debug "this is the integer: $array[$_]";

next;

};

warn "breakfast: there's something icky in my cereal.";

}

$objects[$_] = \@array; next;

};

$type =~ /(list|set)/ && do

{ my @array; $objects[$_] = \@array; next; };

warn "breakfast: there's something icky in my cereal.";

}

debug "finalizing objects in hierarchy...\n";

my $object = 0;

while ($cereal) {

$cereal =~ /^r0/ && last;

if ($cereal =~ /^r/) { # sanity check

warn "breakfast: bad cereal: object count missing from object #$object.";

last;

}

(my $count,$cereal) = line($cereal);

debug "object #$object contains $count objects.";

my $ref = 0;

for (0..$count-1) {

($ref,$cereal) = line($cereal);

$ref =~ s/^r//;

debug "object #$_ in this object is object #$ref.";

my $name;

$cereal =~ s/^i// && do {

debug "object #$ref is a named object.";

($name,$cereal) = line($cereal);

debug "the name of object #$ref should be $name";

};

if ($objects[$object] =~ /HASH/) {

debug "inserting object #$ref into object #$object as \"$name\".";

$objects[$object]->{$name} = $objects[$ref];

}

if ($objects[$object] =~ /ARRAY/) {

# this could probably be rewritten to use push. maybe it should be.

debug "inserting object #$ref into object #$object as index $_.";

$objects[$object]->[$_] = $objects[$ref];

}

}

debug "object #$object is complete.\n";

$object++;

}

debug "returning final object hierarchy: ";

$debug && pprint $objects[0];

pop @scope;

$objects[0] =~ /HASH/ && return \%{$objects[0]};

$objects[0] =~ /ARRAY/ && return \@{$objects[0]};

# execution should never get here.

warn "breakfast: something has gone horribly wrong.";

}

sub merge {

# merge scores from %src into %dst, sort highest to lowest, truncate

# to five highest scores. this could probably be done more elegantly.

my %dst = %{(shift)};

my %src = %{(shift)};

my (%result, %skills);

$skills{$_} = 1 for (sort keys %src);

$skills{$_} = 1 for (sort keys %dst);

for my $skill (sort keys %skills) {

defined $src{$skill} && defined $dst{$skill} && do {

$result{$skill} = ();

my (@scores, %scores);

push @scores, $_ for (@{$dst{$skill}});

$scores{$_->[3]} = 1 for (@scores);

for my $score (@{$src{$skill}}) {

push @scores, $score unless (defined $scores{$score->[3]});

}

for my $score ((sort { $b->[0] <=> $a->[0] } @scores)[0..4]) {

last unless defined $score;

push @{$result{$skill}}, $score;

}

next;

};

defined $src{$skill} && do { $result{$skill} = $src{$skill}; };

defined $dst{$skill} && do { $result{$skill} = $dst{$skill}; };

}

return \%result;

}

### main ###

unless (-e "$datapath/fof.chart") {

my %chart;

lock_store \%chart, "$datapath/fof.chart"

or fail "Score chart not found, and I can't create it.";

}

open CHART, '+<', "$datapath/fof.chart" or die "can't open charts.";

flock CHART, LOCK_EX;

my %chart = %{retrieve_fd(\*CHART)};

if ($ENV{QUERY_STRING}) {

contenttype;

localonly;

my %query = split /[&=]/, $ENV{QUERY_STRING};

fail "False" unless (

defined $query{songHash} && length $query{songHash} &&

defined $query{songName} && length $query{songName} &&

defined $query{scores}

);

print "True"; close STDIN; close STDOUT; close STDERR; # detach

$query{songName} =~ s/\+/ /g;

$query{scores} =~ s/(..)/chr(hex($1))/ge;

$query{scores} = breakfast($query{scores});

my %song;

if (defined $chart{$query{songHash}}) {

$song{songname} = $chart{$query{songHash}}->{songname};

$song{scores} = merge($chart{$query{songHash}}->{scores}, $query{scores});

} else {

$song{songname} = $query{songName};

$song{scores} = $query{scores};

}

$chart{$query{songHash}} = \%song;

seek CHART, 0, 0;

store_fd \%chart, \*CHART;

} else {

contenttype;

print << 'songs';

<?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">

<head>

<title>pimpninjas.org Frets on Fire scores</title>

<style type="text/css">

* { -webkit-box-sizing: border-box; -moz-box-sizing: border-box; box-sizing: border-box; }

body { background: #000; color: #fff; font-family: sans-serif; }

h1,h2 { text-align: center; font-size: 1.5em; padding: 0; margin: 4px }

h2 { font-size: 1em; color: #444; background: #000; }

div { position: relative; width: 100%; float: left; text-align: center; }

.width33 { position: relative; width: 33%; }

table { border: 2px groove #111; position: relative; width: 100%; }

th { color: #fff; background: #111; }

td { text-align: center; }

a { border: 0; color: #aaf; text-decoration: none; }

</style>

</head>

<body>

<h1>The escape key is for pussies.</h1>

<div>

songs

my $count = 0;

my @skills = ("Amazing","Medium","Easy","Supaeasy");

for my $song (sort keys %chart) {

($count++ % 3) or print "</div><div>";

my %scores;

%scores = %{$chart{$song}->{scores}};

print '<div class="width33">';

print '<table><tr><th colspan="3">';

print "$chart{$song}->{songname}</th></tr>";

for my $skill (sort keys %scores) {

print "<tr><th colspan=\"3\">$skills[$skill]</th></tr>";

print "<tr><th>Name</th><th>Star Rating</th><th>Score</th></tr>";

for my $score (@{$scores{$skill}}) {

print "<tr><td>$score->[2]</td>";

print "<td>";

print '<img src="fof_star_on.png" alt="star" />' for (1..$score->[1]);

print '<img src="fof_star_off.png" alt="non-star" />' for ($score->[1]..4);

print "</td>";

# print "<td>$score->[1]</td>";

print "<td>$score->[0]</td></tr>";

}

}

print "</table></div>";

}

print << 'eof';

</div>

<h2><a href="http://pegasus.pimpninjas.org">The Almighty Pegasus Epsilon</a>

wrote this bitch in perl. So suck it.</h2>

<div>

<a href="http://validator.w3.org/check?uri=referer"><img alt="Valid XHTML 1.1" src="../validxhtml11.jpg" /></a>

<a href="http://no-www.org/verify.php?u=pimpninjas.org"><img alt="no-www.org certified class b" src="../class-b.png" /></a>

<!--

Commented until box-sizing: border-box (CSS3) goes final.

<a href="http://jigsaw.w3.org/css-validator/check?uri=referer"><img alt="Valid CSS" src="../validcss.jpg" /></a>

-->

</div>

</body>

</html>

eof

}

# abandon file handle and lock, exit, etc.