User:Lar/ClassificationTableGen/Backlev
From Wikipedia, the free encyclopedia
Perl code: This code generated User:Lar/Sandbox2 (version 6).. There is a lot of work to do on it yet but if you stumble across this, feedback welcome. Not ready for public release yet (if ever).
Updated as of ++Lar: t/c 05:06, 27 March 2006 (UTC)
#!/usr/bin/perl -w
#---------------------------------------------------------------------------#
# process files and generate a category table
# Author: Larry Pieniazek (IBM/Ascential Software) as hobby project
# Adapted from stuff I cribbed from all over.
# (c)Larry Pieniazek 2006. This library is free software; you can redistribute it
# and/or modify it under the same terms as Perl itself.
# additionally, can be redistributed and modified under GFDL or CC-SA as you choose
#
# Abstract:
# This perlscript is designed to parse category SQL dumps from wikipedia
# which are found here: http://download.wikimedia.org/enwiki/
# For example the 23 March dump is called
# http://download.wikimedia.org/enwiki/20060323/enwiki-20060323-categorylinks.sql.gz
#
# The parsing is to generate article classification tables such as those found at
# http://en.wikipedia.org/wiki/Wikipedia_talk:WikiProject_The_Beatles/Article_Classification
#
# In addition to the dump (currently must have been converted to linefeed delimited tuples)
# the other input is a list of categories of interest, one per line.
#
#---------------------------------------------------------------------------#
use strict;
use Data::Dumper;
use Getopt::Std;
# things we may want to use at some point
# use File::Spec::Functions;
#---------------------------------------------------------------------------#
# Subroutine prototypes: #
#---------------------------------------------------------------------------#
# setup
sub Usage; # print info message about how to use this
sub ProcessOptions; # Process Command Line Options.
# utility
sub ScoreToBlank; # underscores to blanks
sub BlankToScore; # blanks to underscores
sub FlipComma; # reverse a reversed comma string. "Lennon, John" -> "John Lennon"
sub UnEscape; # remove escapes with a clever rexp
# general
sub ReadCatFile; # read the category file into the catArray and is_catHash
sub ParseSQL; # parse the big SQL file and build the article data (hashref $collect)
sub WriteTable; # create the output
sub WriteTableHeader; # used by above, create header
sub WriteTableSecBreak; # used by above, create a section break (when the leading char changes)
# ------ option switches and related ---------
my(%options); # hash of switches, values
# ----- logging NOT IMPLEMENTED YET (ever?) --
my($logging); # Flag to denote we are writing to log.
my($log_dir); # Log Directory.
my($lfh); # Log File Handle.
my($LOG_FILE_NAME); # Name of Log File to be written -l value or default
# my($verbose); # -v Flag to denote verbose messaging.
my($debug); # -d Flag to denote REALLY verbose messaging.
my($sqlFileName); # -q <file name of SQL file to parse> (or 'enwiki-20060303-categorylinks.sql')
my($catFileName); # -c <file name of categories> (or 'categoryList.txt')
my($tableFileName); # -o <table file to create> (or 'tables.txt')
# ------ Data structures ---------------------
my $inCats=(); # what cats is the article in?
my $nameVersions=(); # what are the versions of the name (lex orders)
my $rec={}; # ref to one article's record
my $collect={}; # ref to all the articles keyed on the $artKey var
# what the data will look like
# my $rec={
# key => "178234", # numeric key from first tuple value (article key, believed unique)
# artLink => "link text" # text to use for link not same as sort
# sortKey => "sort text" # sort text (what order should article come out)
# inCats => [@inCats], # array of categories the article is in
# nameVersions => [@nameVersions] # array of version of the name of the article
# # this one may not be used for anything
# }; # one article's record
#
# my %collect={
# key => $rec
# }; # all the articles keyed on the $artKey var
# ------ work vars ----------------------------
my @catList;
my @catArray;
my %is_catHash;
# file handles
my $sqlH;
my $tableH;
my $cfH;
#---------------------------------------------------------------------------#
# Usage - Print Usage Information and exit.
#---------------------------------------------------------------------------#
sub Usage {
print <<END_USAGE;
Usage: $0 [-h] [-v] [-d] [-q <sqlFile>] [-c <catFile>] [-o <tableFile>]
Switch meanings:
-h --help print this help message.
-v --version print version message.
-d <0|1|2|3> debug:
0: quiet
1: Verbose Mode
2: REALLY verbose mode
3: Every frigging detail.
File switches:
-q <file name of SQL file to parse>
(or 'enwiki-20060303-categorylinks_sample.sql' by default)
-c <file name of categories>
(or 'categoryList.txt' by default)
-o <table file to create>
(or 'tables.txt' by default)
END_USAGE
print "Status: 99\n";
exit(99);
} # End of Usage.
sub Version {
print "\nfilterCategories version 0.04 - 26 March 2006, Larry Pieniazek."
." \n -- released under GFDL and CC-SA -- \n\n";
# really should print something else
}
# this stuff isn't quite right at the moment
# required for getopts to support --help and --version
sub HELP_MESSAGE{
&Usage();
}
# required for getopts to support --help and --version
sub VERSION_MESSAGE{
&Version();
}
#---------------------------------------------------------------------------#
# ProcessOptions - Process Command Line Options.
#---------------------------------------------------------------------------#
sub ProcessOptions {
&Version if ($options{'v'});
&Usage if ($options{'h'});
my %debugHash = (
'0'=>"silent" ,
'1'=>"normal trace",
'2'=>"very chatty",
'3'=>"insanely chatty" );
if (defined $options{'d'}) {
$debug=$options{'d'};
if ($debugHash{$debug}) {
print"...debug switch was ".$options{'d'}." giving setting: ".$debugHash{$debug}."\n"
unless 0 == $options{'d'} ; # if 0, then REALLY quiet
} else {
$debug=1;
print"...debug switch was ".$options{'d'}." defaulting debug to 1 - normal trace\n";
} # recognised option
} else { # default, no switch
$debug=1;
print"...debug switch not found, defaulting debug to 1 - normal trace\n";
}
if (defined $options{'q'}) {
$sqlFileName=$options{'q'};
} else {
$sqlFileName="enwiki-20060303-categorylinks_sample.sql";
}
if (defined $options{'c'}) {
$catFileName=$options{'c'};
} else {
$catFileName="categoryList.txt";
}
if (defined $options{'o'}) {
$tableFileName=$options{'o'};
} else {
$tableFileName="tables.txt";
}
} # End of ProcessOptions.
#---------------------------------------------------------------------------#
# ReadCatFile - read in categories to build article tracking tables for
#---------------------------------------------------------------------------#
sub ReadCatFile {
my $rc=0;
# $catFileName = $_[0]; # now set processOptions()
if ($debug>2) {
stat($catFileName);
print "Exists\n" if -e _;
print "Readable\n" if -r _;
print "Writable\n" if -w _;
print "Executable\n" if -x _;
print "Setuid\n" if -u _;
print "Setgid\n" if -g _;
print "Sticky\n" if -k _;
print "Text\n" if -T _;
print "Binary\n" if -B _;
}
if (( -e $catFileName ) && ( -r $catFileName )) {
if (!open $cfH, "<", $catFileName){ warn "can't open ".$catFileName."\n"; $rc=99; return $rc; }
} else {
print "error with ".$catFileName." ... does not exist or not readable \n";
$rc= 99;
return $rc;
}
%is_catHash = ();
if ($debug>0) {print "reading ".$catFileName."\n";}
# @catList=<$cfH>;
my $catListItem;
for (;;) {
undef $!;
unless (defined( $catListItem = <$cfH> )) {
die $! if $!;
last; # reached EOF
}
chomp $catListItem;
$catListItem=ScoreToBlank($catListItem);
push @catList, $catListItem;
# set up searchable hash...
$is_catHash{$catListItem} = 1;
}
if ($debug>0) {
print "\nCategories to process: \n";
for my $fe(@catList) {print( $fe."\n");};
print "\n";
}
if ($debug>1) {
print "\n\n... corresponding hash values: \n";
while (my ($key, $value) = each %is_catHash) {
print "$key = $value\n";
}
print "\n";
} # end chatty trace
$rc=0;
return $rc;
}
#---------------------------------------------------------------------------#
# ScoreToBlank - convert underscores to blanks
#---------------------------------------------------------------------------#
sub ScoreToBlank {
my $str=$_[0];
if ($debug>3) {print "ScoreToBlank \$str IN: $str\n";}
$str=~ s/_/ /g;
if ($debug>3) {print "ScoreToBlank \$str OUT: $str\n";}
return $str;
} # there
#---------------------------------------------------------------------------#
# BlankToScore - convert blanks to underscores
#---------------------------------------------------------------------------#
sub BlankToScore {
my $str=$_[0];
$str=~ s/ /_/g;
return $str;
} # and back again
#---------------------------------------------------------------------------#
# FlipComma - take a phrase with comma (and 1 blank) and flip it,
# "Lennon, John" -> "John Lennon"
#---------------------------------------------------------------------------#
sub FlipComma {
my $str=$_[0];
my ($first,$second)= split(/, /,$str,2);
if (length($second)>0) { # there is something there to flip
$str=$second." ".$first;
}
return $str;
} # round and round we go
#---------------------------------------------------------------------------#
# StripLeadTrail - strip leading s/^\s+// and trailing s/\s+$// blanks
#---------------------------------------------------------------------------#
sub StripLeadTrail {
my $str=$_[0];
$str=~ s/^\s+//;
$str=~ s/\s+$//;
return $str;
} # and back again
#---------------------------------------------------------------------------#
# UnEscape - remove escape chars unless they're escaped
# this code lifted from John Alden's Escape Delimiters
# http://search.cpan.org/src/JOHNA/Text-EscapeDelimiters-1.004/lib/Text/EscapeDelimiters.pm
# Text::EscapeDelimiters v1.004
# (c) John Alden 2005. This library is free software; you can redistribute it
# and/or modify it under the same terms as Perl itself.
#---------------------------------------------------------------------------#
sub UnEscape {
my($string) = $_[0];
my $eseq = "\\";
return $string unless($eseq); #no-op
#Remove escape characters apart from double-escapes
$string =~ s/\Q$eseq\E(?!\Q$eseq\E)//gs;
#Fold double-escapes down to single escapes
$string =~ s/\Q$eseq$eseq\E/$eseq/gs;
return $string;
}
#---------------------------------------------------------------------------#
# ParseSQL - read through the SQL file and build the data structures
# - read in one tuple at a time (currently one line but change to
# buffered read later)
# - for each tuple parse out the pieces we need
# - add or update record in $collect hash, recording category and lexical key
# (if we find a comma reversed version of the article name, it's probably
# a better lexical key than we have so take it.)
# - update lexical key, article name, category seen
# - possibly strip blanks, change _ to blanks, remove \ escapes,
# and reverse comma fields. (future: use list of articles with commas
# in their names as refinement)
#---------------------------------------------------------------------------#
sub ParseSQL {
my $rc=0;
if (( -e $sqlFileName ) && ( -r $sqlFileName )) {
open ($sqlH, "<", $sqlFileName) or die "can't open ".$sqlFileName." for reading \n";
} else {
print "error with ".$sqlFileName." ... does not exist or not readable \n";
$rc=99;
return $rc;
}
if ($debug>0) {print "reading ".$sqlFileName."\n"; }
my $sqlLine;
my $sqlLC=0;
$Data::Dumper::Indent = 2; # pretty print (3 is with array indices
$Data::Dumper::Useqq = 1; # print strings in double quotes
$Data::Dumper::Pair = " : "; # specify hash key/value separator
$Data::Dumper::Purity = 1; # fill in the holes for eval
$Data::Dumper::Maxdepth = 3; # no deeper than 3 refs down
$Data::Dumper::Deepcopy = 1; # deep copy
for (;;) {
undef $!;
unless (defined( $sqlLine = <$sqlH> )) {
die $! if $!;
last; # reached EOF
}
# we have to process lines that look like any of these
# (12731,'Catholics_not_in_communion_with_Rome','George Harrison',20060228150212),
# ordinary
# (12731,'Deaths_by_lung_cancer','Harrison, George',20050904074730),
# sort order is different (the article name is probably the first 12731 that doesn't
# have a comma in the article name
# (12731,'George_Harrison','',20060303000936),
# self ref... the category contains an article named the same thing
# (2246703,'The_Beatles_songs','Don\'t Pass Me By',20050719071328),
# embedded escaped ' will screw up parse if not careful.
# safe to process line as we got a line
$sqlLC++;
if ($debug>2) { print "line ".$sqlLC." was ".$sqlLine."\n"; }
chomp $sqlLine;
my($firstP, $secondP) = split(/',/, $sqlLine,2);
if ($debug>2) { print "firstP: >".$firstP."< secondP: >".$secondP."< \n";}
my($artKey, $catName) = split(/,'/,$firstP,2);
$artKey=substr($artKey,1);
$catName=ScoreToBlank($catName);
if ($debug>2) { print "artKey: >".$artKey."< catName: >".$catName."< \n"; }
my($artName, $timeStamp)=split(/',/,substr($secondP,1),2);
# $timeStamp=split(/),/,$timeStamp,1);
$timeStamp=substr($timeStamp,0,-2);
if ($debug>2) {print "artName: >".$artName."< timeStamp: >".$timeStamp."< \n";}
if (0==length($artName)) { # empty, this is the case of matching art/cat names
$artName=$catName;
} else {
$artName=StripLeadTrail(UnEscape($artName));
}
my $sortKey="";
my $skHasComma=0;
my $anHasComma=0;
if (exists($is_catHash{$catName}) ) {
if ($debug>1) {
print "artName: >".$artName.
"<\n timeStamp: >".$timeStamp.
"<\n artKey: >".$artKey.
"<\n catName: >".$catName."< \n";
print " ... one of our cats! \n";
}
if (exists($collect->{$artKey}) ) {
if ($debug>1) { print " ... and we have the article already\n"; };
$rec = $collect->{$artKey}; # get ref to existing one
$inCats= $rec->{inCats}; # and to the arrays it carries
$nameVersions = $rec->{nameVersions};
} else {
$rec={}; # make an empty one
$rec->{key}=$artKey; # uses same key
$inCats=();
$nameVersions=();
}
$inCats->{$catName}=1;
$nameVersions->{$artName}=1;
$rec->{'inCats'}=$inCats;
$rec->{'nameVersions'}=$nameVersions;
# put logic to handle making sure name of article for link is non comma
$anHasComma= ( $artName =~/,/ );
my $artNameSave=$artName;
if ($anHasComma) { # if article has comma flip it and save that as name
$artNameSave=FlipComma($artName);
}
if (!(exists($rec->{artLink}))) {
$rec->{artLink}=$artNameSave;
}
if ($debug>1) {print "\$artName: $artName \$artNameSave: $artNameSave \n"}
# put logic for sort key here
if (exists($rec->{sortKey})) {
$sortKey=$rec->{sortKey};
if ($debug>1) {print "sortKey: $sortKey\n"; }
if ($sortKey ne $artName) { # If the keys are the same do nothing
$skHasComma= ( $sortKey =~/,/ );
if ($debug>1) {print "anHasComma: $anHasComma skHasComma: $skHasComma\n";}
if ($anHasComma eq $skHasComma) {
# if neither has a comma, or both have a comma take whichever one is earlier in the alphabet
if ($sortKey gt $artName) {
$rec->{sortKey}= $artName;
} # else not needed because sortKey already earlier, leave it.
} else {
# If the new key has a comma in it, use that one, it's probably the sort key
if ($anHasComma) {
$rec->{sortKey}= $artName;
} # else not needed, leave as is
}
if ($debug>1) {print "sortKey now is ".$rec->{sortKey}."\n"; }
} # end of handling different keys
} else { # we don't have it, save it away
$rec->{sortKey}=$artName; # since it's new, the sort key is the name we found
if ($debug>1) {print "added sortKey: $rec->{sortKey}\n"; }
} # end if sortKey does/doesn't exist
$collect->{$artKey}=$rec;
} # end if category is one we care about
} # end for (;;) (the read loop)
if ($debug>0) {
print "...collect: \n";
print Dumper($collect);
}
if ($debug>0) {print "finished parsing SQL\n"; }
return $rc;
} # end ParseSQL
#---------------------------------------------------------------------------#
# WriteTableHeader - create output table header
#---------------------------------------------------------------------------#
sub WriteTableHeader {
# assumes that $tableH is open and valid
print $tableH <<END_TABLEH;
{|
|valign=top|
{| width="100%" border="1" cellpadding="2" cellspacing="0" style="margin: 1em 1em 1em 0; background: #f9f9f9; border: 1px #aaa solid; border-collapse: collapse; font-size: 85%;"
|-
!width=20%|Article
!width=15%|Categories
!width=7%|Assessed
!width=7%|Status
!width=5%|Uses Infobox
!width=37%|Comments and Pending tasks
!width=8%|Assessed by
END_TABLEH
return 0;
}
#---------------------------------------------------------------------------#
# WriteTableSecBreak - create output table break between sections
#---------------------------------------------------------------------------#
sub WriteTableSecBreak {
my $headChar=$_[0];
print $tableH "|-\n|colspan=\"7\" align=\"left\" style=\"background:white; font-size: 200%;"
." font-weight:bold; border-bottom:4px solid grey; \"| \n"
."====".$headChar."====\n";
return 0;
} # end WriteTableSecBreak
#---------------------------------------------------------------------------#
# WriteTable - create output table
# - sort the data structure by the sort keys (which are the lexical
# (sometimes comma inverted) article names) ... these keys are inside the
# structure
# - using the sorted array of keys, iterate the hash in sort order
# - every time the first letter of the key changes, write out a SecBreak
#---------------------------------------------------------------------------#
sub WriteTable {
my $rc=0;
if ($debug>2) {
print" statting: ".$tableFileName."\n";
stat($tableFileName);
print "Exists\n" if -e _;
print "Readable\n" if -r _;
print "Writable\n" if -w _;
print "Executable\n" if -x _;
print "Setuid\n" if -u _;
print "Setgid\n" if -g _;
print "Sticky\n" if -k _;
print "Text\n" if -T _;
print "Binary\n" if -B _;
}
open ($tableH, '>', $tableFileName) or die "can't open ".$tableFileName." for writing \n";
$rc=&WriteTableHeader();
if ($rc) { die "error building table header\n"; }
# we want to create line pairs of the form
# (with the pipe in col 1)
# |-
# |[[Abbey Road (album)]]||[[:category:The Beatles albums|]]|| ||{{/Unknown}}||unknown|| ||
# |-
# |[[Anthology 1]]||[[:category:The Beatles albums|]]|| ||{{/Unknown}}||unknown|| ||
#
# in sorted order
# make an array of the keys to the hash
# (the article keys, which are not in any particular alpha)
my @keys = sort { $collect->{$a}->{sortKey} # custom sort spec, use the lexical key
cmp # (which is embedded in the rec)
$collect->{$b}->{sortKey} }
keys %{$collect};
my $firstLet=chr(00); # has to be lower than any other character val!
# iterate in sorted order
foreach my $artKey ( @keys ) {
$rec = $collect->{$artKey}; # get easy access to the record
$inCats= $rec->{inCats}; # and to the category array it carries
my $artLink=$rec->{artLink};
my $trialFirst=substr($rec->{sortKey},0,1); # get first char
if ($trialFirst ne $firstLet) {
$firstLet=$trialFirst;
if ($debug>1) {print "Switching to new first letter: $firstLet \n";}
&WriteTableSecBreak($firstLet);
} # end if new first letter in lexical order
my ($catStr,$catV,$catK);
$catStr="";
while (($catK, $catV) = each %{$inCats}) {
if ("" ne $catStr) {
$catStr.="<br>";
}
$catStr.="[[:category:".$catK."|]]";
} # loop through the categories we saw
if ($debug>0) { print "key: ".$artKey." rec key ".$rec->{key}." article Link text ".$artLink."\n"; }
print $tableH "|-\n||[[".$artLink."]]||".$catStr."||| ||"
."{{Wikipedia:WikiProject The Beatles/Article Classification/Unknown}}"
."||unknown|| || \n";
} # end of iteration through the hash in sorted order
# finish off table
print $tableH "\n|}";
return $rc;
}
#---------------------------------------------------------------------------#
# Main routine -
# process options
# read in categories desired
# build hash of articles by parsing SQL file
# write out table file using hash
#---------------------------------------------------------------------------#
# main
my $rc=0;
# print "prior to getopts\n";
getopts('hvd:q:c:o:', \%options) or &Usage; # debug also d
# print "post getopts, pre process\n";
&ProcessOptions();
if ($debug>1) { print "post process, pre read cat\n"; }
$rc=&ReadCatFile();
if ($rc) { die "error reading category list\n"; }
$rc=&ParseSQL();
if ($rc) { die "error reading SQL or building structure\n"; }
$rc=&WriteTable();
if ($rc) { die "error building table\n"; }
exit 0;
