=head1 NAME

coursedb.pm - an object-oriented PAI for reading and processing
lecture course information from a coursedb.txt file

=cut

use lib '/anfs/www/tools/share/ucampas/perl-PlexTree';
use PlexTree;
use bytes;
use strict;

package Misc;
# Miscellaneous auxiliary routines, e.g. for writing HTML and CSV files

sub utf8_to_sgml {
    use Encode;
    return unless defined wantarray;
    my @s = @_;
    for my $s (@s) {
        $s=~s/&/&/g;
        $s=~s/</&lt;/g;
        $s=~s/>/&gt;/g;
	$s=~s/([\x00-\x08\x0b\x0c\x0e-\x1f\x7f])/sprintf("&#%d;", ord($1))/ge;
        no bytes;
        my $u;
        $s=~s/([\xc0-\xdf][\x80-\xbf]|[\xe0-\xef][\x80-\xbf]{2}|[\xf0-\xf7][\x80-\xbf]{3})/$u=$1,Encode::_utf8_on($u),sprintf("&#%d;", ord($u))/ge;
    }
    return wantarray ? @s : $s[0];
}

sub utf8_to_sgmlatt {
    use Encode;
    return unless defined wantarray;
    my @s = @_;
    for my $s (@s) {
        $s=~s/&/&amp;/g;
        $s=~s/</&lt;/g;
        $s=~s/>/&gt;/g;
        $s=~s/\'/&apos;/g;
        $s=~s/\"/&quot;/g;
	$s=~s/([\x00-\x08\x0b\x0c\x0e-\x1f\x7f])/sprintf("&#%d;", ord($1))/ge;
        no bytes;
        my $u;
        $s=~s/([\xc0-\xdf][\x80-\xbf]|[\xe0-\xef][\x80-\xbf]{2}|[\xf0-\xf7][\x80-\xbf]{3})/$u=$1,Encode::_utf8_on($u),sprintf("&#%d;", ord($u))/ge;
    }
    return wantarray ? @s : $s[0];
}

# Convert an array into a comma-separated value line
# according to http://tools.ietf.org/html/rfc4180
sub csv_line {
    return join(',', map {
	if (/[\r\n\",]/) {
	    # quote
	    my $s = $_;
	    s/\"/\"\"/g;
	    '"'.$s.'"';
	} else {
	    # quoting not necessary
	    $_;
	}
    } @_) . "\r\n";
}

# Output an RFC2822 header field, folding the unstructured body
# to not exceed the recommended maximum line length of 78 characters.
# $name  name of the header field (wihout trailing colon)
# $sep   set to ',' to output a comma separated list, otherwise ''.
# @body  sequence of body elements that will be output as foldable white space
# http://www.ietf.org/rfc/rfc2822.txt (section 2.2)
sub mail_header {
    my ($name, $sep, @body) = @_;
    local $_;

    $name =~ /^[!-9;-~]+$/
	or die("Invalid character in mail header-field name '$name'\n");

    my @h;
    my $col;
    push @h, $name, ':';
    $col += length($name) + 1;
    while ($_ = shift @body) {
	/[\n\r]/ and
	    die("Invalid CR or LF in mail header-field body element '$_'\n");
	$_ .= $sep if @body;
	if ($col + 1 + length($_) > 78) {
	    push @h, "\n";
	    $col = 0;
	}
	push @h, ' ', $_;
	$col += 1 + length($_);
    }
    push @h, "\n";

    return join('', @h);
}

package CourseDB;
# Load PlexTree datastructure into memory and map its main nodes onto
# suitable subclasses such that we can add domain-specific methods
# here without having to copy the whole tree into new objects.
use PlexTree;
use PlexTree::Text;

our @ISA = ("PlexTreeMem");

sub load {
    my ($fndb) = @_;
    my $db = bless PlexTree::Text::load($fndb) => 'CourseDB';
    $db->update_indices;
    my @errors = $db->verify;
    die(@errors) if @errors;
    return $db;
}

# initialize access indices
sub update_indices {
    my ($db) = @_;
    my $groups = $db->cd('groups');
    my $classes = $db->cd('classes');
    if (defined $groups) {
	warn("Both groups and classes are defined, ignoring classes!\n")
	    if defined $classes;
	$db->setaux('class', {
	    map { $_->str => (bless $_ => 'Class') }
	    grep { $_->listlen == 0 }
	    $groups->lfind(undef, 'all')
	});
	$db->setaux('classes', [
			map { bless $_ => 'Class' }
			grep { $_->listlen == 0 }
	    $groups->lfind(undef, 'all')
	]);
    } elsif (defined $classes) {
	$db->setaux('class', {
	    map { $_->str => (bless $classes->cd($_) => 'Class') }
	    grep { $_->tag == PlexTree::TEXT }
	    $classes->keys
	});
	$db->setaux('classes', [
	    map { bless $_->cd($_) => 'Class' }
	    grep { $_->tag == PlexTree::TEXT }
	    $classes->keys
        ]);
    }
    my $courses = $db->cd('courses');
    if (defined $courses) {
	$db->setaux('course', {
	    map { $_->str => (bless $courses->cd($_) => 'Course') }
	    grep { $_->tag == PlexTree::TEXT }
	    $courses->keys
	});
    }
    my $lecturers = $db->cd('lecturers');
    if (defined $lecturers) {
	$db->setaux('lecturer', {
	    map { $_->str => (bless $lecturers->cd($_) => 'Lecturer') }
	    grep { $_->tag == PlexTree::TEXT }
	    $lecturers->keys
	});
    }

    foreach my $course ($db->courses) {
	next unless $course->takes_place;
	# index what each lecturer teaches
	foreach my $lecturer ($course->proprietors, $course->contributors) {
	    $lecturer->addkey('teaches')->addkey(text($course->code));
	}
    }
    
}

sub verify {
    my ($db) = @_;
    my @errors;

    my $myear=$db->get('myear');
    unless ($myear > 1950 && $myear < 2020) {
	push @errors, "Attribute mtern must specify the 4-digit calendar year of the Michaelmas term,\n" .
	    "e.g. mterm='2007'\n";
    }

    foreach my $class ($db->classes) {
	push @errors, $class->verify;
    }
    foreach my $course ($db->courses) {
	push @errors, $course->verify;
    }
    foreach my $lecturer ($db->lecturers) {
	push @errors, $lecturer->verify;
    }
    return @errors;
}

sub class {
    my ($db, $code) = @_;
    return $db->aux('class')->{$code};
}
sub course {
    my ($db, $code) = @_;
    return $db->aux('course')->{$code};
}
sub lecturer {
    my ($db, $code) = @_;
    return $db->aux('lecturer')->{$code};
}
sub classes {
    my ($db) = @_;
    return @{$db->aux('classes')};
}
sub courses {
    my ($db) = @_;
    my @l = values %{$db->aux('course')};
    use locale;
    return sort { $a->title cmp $b->title } @l;
}
sub lecturers {
    my ($db) = @_;
    my @l = values %{$db->aux('lecturer')};
    use locale;
    return sort { $a->surname cmp $b->surname } @l;
}

# notations for the academic year, e.g. 1112 for 2011/2012
sub year{
    my ($db, $notation, $offset) = @_;
    my $myear=$db->get('myear');
    $myear += $offset if defined $offset;
    if ($notation eq '22') {
	return sprintf("%02d%02d", $myear % 100, ($myear+1) % 100);
    } elsif ($notation eq '4-2') {
	return sprintf("%4d–%02d", $myear, ($myear+1) % 100);
    } else {
	die("year(): unknown notation '$notation'\n");
    }
}


# Domain-specific subclasses of PlexTreeMem for courses, lecturers and classes


package Course;
use PlexTree;
our @ISA = ("PlexTreeMem");

# override cl() to switch back to PlexTreeMem class
sub cl { my ($self, @pos)  = @_; (bless [@$self] => $ISA[0])->cd(@pos);  }
# override cd() to switch back to PlexTreeMem class and to implement a
# sabbatical-cover attribute, which can contain overriding attributes
sub cd {
    my ($self, @keys)  = @_;
    my $baseself = bless [@$self] => $ISA[0];
    my $try = $baseself->cd(text 'sabbatical-cover', @keys);
    return $try if defined $try;
    $baseself->cd(@keys);
}

# Check for a parameters first in the course node, then in the node
# associated with the first class that attends this course, and
# finally at the top-level, returning a node cursor to the first value
# found.
sub paramc {
    my ($self, $pname) = @_;
    my $v;
    my $n;
    $v = $self->cd(text $pname);
    return $v if defined $v;
    my @classes = $self->classes;
    return $classes[0]->paramc($pname) if @classes;
    return;
}

# Like paramc, but return a string instead of a node cursor
sub param {
    my ($self, $pname) = @_;
    my $v = $self->paramc($pname);
    return undef unless defined $v;
    return $v->str_text;
}

sub title($) {
    my ($self) = @_;
    return $self->str_text;
}

sub code($) {
    my ($self) = @_;
    return $self->key->str_text;
}

sub needs_directory {
    my ($self) = @_;
    return 0 unless $self->takes_place;
    return 0 if $self->get('url');
    return 0 if $self->param('directory') eq '0';
    return 1;
}

sub url($) {
    my ($self, $pathprefix) = @_;
    return 0 unless $self->takes_place;
    my $url = $self->get('url');
    return $url if $url;
    return $pathprefix . $self->code . '/'
	unless $self->param('directory') eq '0';
    return;
}

sub html {
    my ($self, $pathprefix) = @_;
    my $html = Misc::utf8_to_sgml($self->title);
    my $url = $self->url($pathprefix);
    $html = '<a href="' . Misc::utf8_to_sgmlatt($url) . '">' . $html . '</a>'
 	if $url;
    return $html;
}

sub verify {
    my ($self) = @_;
    my $l = $self->cd('lecturer');
    return () unless defined $l;
    my $db = $self->top;
    my @l;
    push @l, $l->str if $l->str;
    push @l, map { $_->str_text } $l->list;
    @l = grep { !defined $db->lecturer($_) } @l;
    return ( "Course '" . $self->code . "': unknown lecturers " .
	     join(', ', map { "'$_'" } @l) . ".\n" )
	if @l;
    return ();
}

sub proprietors {
    my ($self) = @_;
    my $l = $self->cd('lecturer');
    return () unless defined $l;
    my $db = $self->top;
    if ($l->str) {
	# we have one course proprietor, and optionally several contributors
	return ($db->lecturer($l->str));
    } else {
	# all contributors are proprietors
	return map { $db->lecturer($_->str) } $l->list;
    }
}

sub contributors {
    my ($self) = @_;
    my $l = $self->cd('lecturer');
    return () unless defined $l;
    my $db = $self->top;
    if ($l->str) {
	# we have one course proprietor, and optionally several contributors
	return map { $db->lecturer($_->str) } $l->list;
    } else {
	# all contributors are proprietors
	return ();
    }
}

sub oldnames($) {
    my ($self) = @_;
    my $oldnames = $self->cd('oldnames');
    return map {$_->str_text} $oldnames->list if defined $oldnames;
    return ();
}

sub takes_place {
    my ($self) = @_;
    # empty terms attribute means that the course will not take
    # place this year, e.g. due to sabbatical leave
    return defined $self->get('term');
}

sub terms {
    my ($self) = @_;
    return grep { defined $_ } ($self->get('term'),
				$self->cd('term')->getl(0));
}

sub in_term {
    my ($self, $term) = @_;
    my $t = $self->cd('term');
    return unless defined $t;
    return $term eq $t->str_text;
}

sub continues_in_term {
    my ($self, $term) = @_;
    my $t = $self->cd('term');
    return unless defined $t;
    return $term eq $t->getl(0);
}

sub classes {
    my ($self) = @_;
    my $c = $self->cd('classes');
    return () unless defined $c;
    my $db = $self->top;
    return map { $db->class($_->str) || die("Unknown class " .$_->str)} $c->keys;
}

sub group {
    my ($self) = @_;
    my @classes = $self->classes;
    return $classes[0]->group if @classes;
    return;
}

my $pastexamsdir = '/anfs/www/html/teaching/exams/pastpapers/';
my $pastexamsurl = 'http://www.cl.cam.ac.uk/teaching/exams/pastpapers/';

# return (title => url, title => url, ...) list of pages with related past exam questions)
sub examlinks {
    my ($self) = @_;

    my @l;
    for my $coursename ($self->title, $self->oldnames) {
	my $fn = $coursename;
	$fn =~ s/\s//g;
	$fn =~ s/ //g; # also eliminate NBSP
	$fn = "t-$fn.html";
	if (-r "$pastexamsdir$fn") {
	    push @l,  $coursename => "$pastexamsurl$fn";
	}
    }
    return @l;
}


package Lecturer;
use PlexTree;
our @ISA = ("PlexTreeMem");

# override cd() and cl() to switch back to PlexTreeMem class
sub cd { my ($self, @keys) = @_; (bless [@$self] => 'PlexTreeMem')->cd(@keys); }
sub cl { my ($self, @pos)  = @_; (bless [@$self] => 'PlexTreeMem')->cd(@pos);  }

sub code {
    return $_[0]->key->str;
}

sub fullname {
    return $_[0]->str;
}

sub title {
    my $name = $_[0]->fullname;
    $name =~ /^(Prof|Dr|Mr|Ms|Mrs|Miss) /;
    return $1;
}

sub firstnames {
    my $name = $_[0]->fullname;
    $name =~ /^(?:(?:Prof|Dr|Mr|Ms|Mrs|Miss) )?(.+) \S+$/;
    return $1;
}

sub surname {
    my $name = $_[0]->fullname;
    $name =~ /(\S+)$/;
    return $1;
}

sub url {
    my ($self) = @_;
    my $url = $self->get('url');
    return $url if defined $url;
    my $l = $self->code;
    if (-r "/home/$l/public_html/index.html" ||
	-r "/home/$l/public_html/.htaccess") {
	$url = "http://www.cl.cam.ac.uk/~$l/";
	$self->setatt('url' => $url);
    }
    return $url;
}

sub html {
    my ($self) = @_;
    my $html = Misc::utf8_to_sgml($self->fullname) || '[name unknown]';
    my $url = $self->url;
    if (defined $url) {
	$html = '<a href="' . Misc::utf8_to_sgmlatt($url) . '">' . $html . '</a>'
    }
    return $html;
}

sub teaches {
    my ($self) = @_;
    my $t = $self->cd('teaches');
    return unless defined $t;
    my $db = $self->top;
    return map { $db->course($_->str) } $t->keys
}

sub verify {
    my @errors;
    return @errors;
}


package Class;
use PlexTree;
our @ISA = ("PlexTreeMem");

# override cd() and cl() to switch back to PlexTreeMem class
sub cd { my ($self, @keys) = @_; (bless [@$self] => 'PlexTreeMem')->cd(@keys); }
sub cl { my ($self, @pos)  = @_; (bless [@$self] => 'PlexTreeMem')->cd(@pos);  }

# Check for a parameters first in the class node, then in the year node,
# then in the groups node, and finally in the top node,
# returning a node cursor to the first value found.
sub paramc {
    my ($self, $pname) = @_;
    my $v;
    my $n;
    $pname = text($pname); # convert attribute to text compound
    while (defined $self) {
	$v = $self->cd($pname);
	return $v if defined $v;
	$self = $self->parent;
    }
    return;
}

# Like paramc, but return a string instead of a node cursor
sub param {
    my ($self, $pname) = @_;
    my $v = $self->paramc($pname);
    return undef unless defined $v;
    return $v->str_text;
}

sub code {
    my ($self) = @_;
    if (defined $self->pos) {
	return $self->str;
    } else {
	return $self->key->str;
    }
}

sub title {
    my ($self) = @_;
    if (defined $self->pos) {
	return $self->get('title');
    } else {
	return $self->str;
    }
}

sub html {
    my ($self, $pathprefix) = @_;
    my $html = Misc::utf8_to_sgml($self->title);
    $html = '<a href="' . $pathprefix . $self->code . '.html">' . $html . '</a>'
 	if $self->param('index') || 1;
    return $html;
}

sub group {
    my ($self) = @_;
    if (defined $self->pos && $self->depth == 3) {
	return $self->parent;
    } else {
	die("unexpected location: ", join('/', map {$_->str} $self->path));
    }
    return;
}

sub verify {
    my @errors;
    return @errors;
}

1;