#!/usr/bin/perl # nethack.pl parses the NetHack record file and displays the high scores as an HTML page. # The high scores can be listed according to player name, character name, profession, # race, gender and alignment. The script uses tiles from the RLTiles project # to display different professions, races and genders # graphically. # This script is located at . # Copyright 2002-2005 by Susanna Winter & Humppa.CS (except RLTiles) # RLTiles Licence Notice: # Part of (or All) the graphic tiles used in this program is the public # domain roguelike tileset "RLTiles". # Some of the tiles have been modified by Susanna Winter. # You can find the original tileset at: # http://rltiles.sf.net # Version history: # v0.1 - Initial version in 2002 # v0.2 - 2002: added links to arrange the list according to name, profession etc. # v0.3 - March 2003: arranged professions, races and their .gif's differently, added version history # v0.4 - April 2003: added rounding to days played, added image titles, # changed some of the tiles: # The old ranger tile was actually the rogue, and the rogue tile was # actually the priest. But the priest looked like a naked old man to # me so the *new* priest is from the AllegroHack tile set. And I had # to search for a new ranger tile. # # Added tiles for gender, too: # The human and male tile is actually a shopkeeper since there is no (good) # human tile anywhere (I've searched numerous tile sets). The female # tile is a wood nymph but it will do. The elf female tile is probably # just an elf but it looks too girlish (or is it a gay-elf? ;) # # v0.5 - April 2003: added a date to display since when the highscores are gathered because # the administrator "accidentally" erased all the highscores :P # The date is currently semi-hardcoded; there is no way to get the creation date # of a file in Unix/Linux. Also added a check to the top 10 list to see if there are # less than 10 entries. # # v0.5.1 - March 2005: added RLTiles licence notice, updated the page footer, changed file open/read # error messages to English # TODO: arrange the list according to death reason # arrange the list according to multiple fields # display the death reason with a tile; this means identifying and #naming tons # of tiles so I'm probably not going to do this (any time soon anyway) use strict; use CGI qw(:standard); use File::stat; use Time::localtime; use Time::Local; use POSIX qw(ceil); my $filename = "nethack.pl"; my $record = "\/var\/games\/nethack\/record"; my $creationdate = "23.4.2003"; # this is a text file containing the names of the players # (format: "ID# name\n", each player on its own line) my $players = "nh_players.txt"; ### sub's sub fix_first_char { my $string = $_[0]; $string = ucfirst $string; return $string; } #end of fix_first_char sub fix_date { my $date = $_[0]; my @date = unpack "A4 A2 A2", $date; $date = "$date[2].$date[1].$date[0]"; return $date; } #end of fix_date sub fix_profession { my $prof = $_[0]; my $sexx = $_[1]; if ($prof eq "Cav") { if ($sexx eq "Female") { $prof = "Cavewoman"; } else { $prof = "Caveman"; } } elsif ($prof eq "Pri") { if ($sexx eq "Female") { $prof = "Priestess"; } else { $prof = "Priest"; } } elsif ($prof eq "Arc") { $prof = "Archeologist"; } elsif ($prof eq "Bar") { $prof = "Barbarian"; } elsif ($prof eq "Hea") { $prof = "Healer"; } elsif ($prof eq "Kni") { $prof = "Knight"; } elsif ($prof eq "Mon") { $prof = "Monk"; } elsif ($prof eq "Ran") { $prof = "Ranger"; } elsif ($prof eq "Rog") { $prof = "Rogue"; } elsif ($prof eq "Sam") { $prof = "Samurai"; } elsif ($prof eq "Tou") { $prof = "Tourist"; } elsif ($prof eq "Val") { $prof = "Valkyrie"; } elsif ($prof eq "Wiz") { $prof = "Wizard"; } return $prof; } sub fix_sex { my $gender = $_[0]; $gender =~ s/Mal/Male/; $gender =~ s/Fem/Female/; return $gender; } sub fix_race { my $r = $_[0]; if ($r eq "Hum") { $r = "Human"; } elsif ($r eq "Gno") { $r = "Gnome"; } elsif ($r eq "Dwa") { $r = "Dwarf"; } return $r; } sub fix_alignment { my $a = $_[0]; if ($a eq "Law") { $a = "Lawful"; } elsif ($a eq "Neu") { $a = "Neutral"; } elsif ($a eq "Cha") { $a = "Chaotic"; } return $a; } sub get_days { my $bd = $_[0]; my $dd = $_[1]; my ($year, $month, $day) = unpack "A4 A2 A2", $dd; my $end = timelocal (0, 0, 0, $day, $month-1, $year-1900); ($year, $month, $day) = unpack "A4 A2 A2", $bd; my $start = timelocal (0, 0, 0, $day, $month-1, $year-1900); my $days = ceil((($end - $start)/(60*60*24)+1)); return $days; } ### sub's declared ### main print header(); # read the nethack record file my @highscores; if (-e "$record") { open(INF, "$record") or print "

Cannot open record file $record.

\n"; @highscores = ; close(INF); } else { print "

Cannot find record file $record.

\n"; } my @players; if (-e "$players") { open(INF, "$players") or print "

Cannot open player ID file $players.

\n"; @players = ; close(INF); } else { print "

Cannot find player ID file $players.

\n"; } my %players = (); foreach my $line (@players) { chomp($line); my ($u, $p) = split(/ /, $line); $players{$u} = $p; } my @topN; if ( !(param()) ) { if (scalar(@highscores) < 10) { @topN = @highscores[0..scalar(@highscores)-1]; } else { @topN = @highscores[0..9]; } } elsif ( (param("top")) && (scalar(@highscores) >= param("top")) ) { my $top = param("top")-1; @topN = @highscores[0..$top]; } else { @topN = @highscores; } if (scalar(@topN) > 0) { my $q_player = ""; my $q_prof = ""; my $q_char = ""; my $q_race = ""; my $q_sex = ""; my $q_align = ""; my $title = ""; if ( !(param()) ) { print "
(since $creationdate)

\n\n"; print "\n\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\n"; } else { if (param("player")) { $q_player = param("player"); $title = "Games played by " . fix_first_char($q_player); } elsif (param("charname")) { $q_char = param("charname"); $title = "Games played with a character named " . fix_first_char($q_char); } elsif (param("profession")) { $q_prof = param("profession"); if ($q_prof =~ /cave/i) { $title = "Cavemen & Cavewomen"; $q_prof = "cave"; } elsif ($q_prof =~ /priest/i) { $title = "Priests & Priestesses"; $q_prof = "priest"; } else { $title = $q_prof . "s"; } } elsif (param("race")) { $q_race = param("race"); if ($q_race =~ /^elf$/i) { $title = "Elves"; } elsif ($q_race =~ /^dwarf$/i) { $title = "Dwarves"; } else { $title = $q_race . "s"; } } elsif (param("sex")) { $q_sex = param("sex"); $title = $q_sex . "s"; } elsif (param("align")) { $q_align = param("align"); $title = $q_align . "s"; } elsif (param("top")) { $title = "Best " . scalar(@topN) . " games"; } print "\n\n"; print "\n\n\tNetHack Top100 \@untamo - $title\n\t\n\n\n"; print "\n\"Humppa.CS\"
\n\n
\n"; print "\"Etusivu\" \"Uutiset\" \"Humppaajat\" \"Matsit\" \"Muuta\" \"Galleria\" \"#humppa.cs\"\n
\n
\n\n"; print "

NetHack Top100 \@untamo - $title

\n"; print "
(since $creationdate)

\n\n"; print "
 NamePointsDlvlHPProfessionRaceGenderAlignmentQuit dateQuit reason
\n\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\n"; } my ($nethack_version, $points, $something, $deathlvl, $maxlvl, $hp, $maxhp, $deaths, $ddate, $birthdate, $uid, $profession, $race, $sex, $align, $name_reason); my ($charname, $reason); my $j=1; my $color; foreach my $line (@topN) { if ($j % 2) { $color = "gray"; } else { $color = "blue"; } chomp($line); $line =~ s/\s+/ /g; ($nethack_version, $points, $something, $deathlvl, $maxlvl, $hp, $maxhp, $deaths, $ddate, $birthdate, $uid, $profession, $race, $sex, $align, $name_reason) = split(/ /, $line, 16); ($charname, $reason) = split(/,/, $name_reason); my $deathdate = fix_date($ddate); $race = fix_race($race); $sex = fix_sex($sex); $align = fix_alignment($align); $profession = fix_profession($profession, $sex); $charname = fix_first_char($charname); $reason = fix_first_char($reason) . "."; my $prof_lc = lc $profession; my $race_lc = lc $race; my $sex_lc = lc $sex; if ( !(param()) ) { print "\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\n"; $j++; } else { if ( (param("player") && ($players{$uid} =~ /^$q_player$/i)) || (param("charname") && ($charname =~ /^$q_char$/i)) || (param("profession") && ($profession =~ /$q_prof/i)) || (param("race") && ($race =~ /^$q_race$/i)) || (param("sex") && ($sex =~ /^$q_sex$/i)) || (param("align") && ($align =~ /^$q_align$/i)) || param("top") ) { print "\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\n"; $j++; } } } print "
 PlayerCharacter namePointsDlvlHPProfessionRaceGenderAlignmentDeathsDays playedQuit dateQuit reason
$j$charname$points$deathlvl/$maxlvl$hp/$maxhp$profession\"$profession\"$race\"$race\"$sex\"$sex\"$align$deathdate$reason
$j$players{$uid}$charname$points$deathlvl/$maxlvl$hp/$maxhp\"$profession\"$profession\"$race\"$race$sex\"$sex\"$align$deaths" . get_days($birthdate,$ddate) . "$deathdate$reason
\n"; print "

View the entire Top100 list.

\n\n"; if (param()) { print "
\n\"bananana\"\"Ook!\"\n"; my $last_modified = (ctime(stat($filename)->mtime)); my ($day_of_week, $month, $day, $time, $year) = split(" ", $last_modified, 5); print "$filename last modified: $day_of_week $month $day, $year.
© 2002-$year by Susanna Winter & Humppa.CS.
NetHack tiles from the RLTiles project. Yes, they're public domain.\n\n\n\n"; } } ### end of main