#!/usr/bin/perl

=head1 NAME

OxQuery

=head1 SYNOPSIS

  use OxQuery;

  my $name = "howe";

  my %people = OxQuery->search( $name );

  foreach my $person ( sort( keys( %people ) ) ) {
    print "Person $person has email " . $people{$person} . "\n";
  }

=head1 DESCRIPTION

Module to query the Oxford University Contacts Search webpage.  Will return a
hash of the form people => email for a given surname.  Does an approximate
search, then only returns names containing the string for which you searched.

=head1 METHODS

=over 4

=cut

# $Id: OxQuery.pm 198 2007-02-06 13:57:03Z michael $
package OxQuery;

use strict;
use warnings;
use WWW::Mechanize;
use Exporter;
our @EXPORT_OK = qw( search );
our @ISA = qw( Exporter );


#die "Usage: $0 <name_to_query>, [[<other_name_to_query>], ...]\n"
#	if ! @ARGV;

$/ = '';	# Paragraph mode for input

my %results;

my $match_type = "approximate";	# exact or approximate
#my $match_type = "exact";	# exact or approximate

my $base_page = "http://www.ox.ac.uk/cgi-bin/contacts?match=$match_type+match&submit=Find+email+address&.cgifields=match&surname=";

sub getpeople {
	my $page = $_[0];
	my $surname = $_[1];

	my $m = WWW::Mechanize->new();
	$m->get( $page );
	my $c = $m->content;
	# The first table-worth of rows:
	my @outer = $c =~ m{<tr.*?>(.*?)</tr>}gs;
	foreach my $row (@outer) {
		my ($name, $mail_addr) = $row =~ m{<td.*?>(.*?)</td>}gs;
		$mail_addr = "" unless $mail_addr;
		if ( $mail_addr =~ m{mailto:} && $mail_addr =~ m/$surname/ ) {
			# We have an email!
			$mail_addr =~ s/<a href="mailto:(.*)".*<\/a>/$1/;
			# Hack the name about:
			$name =~ s{(.*?), (.*?)(\s.*|$)}{$2 $1};
			$results{$mail_addr} = $name;
		}
	}
	# The 'next' link:
	my ($endlink) = $c =~ m{.*<tr*?>(.*?)</tr>.*?</html>}gs;
	my ($nextlink) = $endlink =~ m{.*<a href="(.*)">Next page</a>.*};
	( defined( $nextlink ) ) && &getpeople( $nextlink, $surname );
}

=item search() 

Takes an array of surnames, and returns a hash containing name => email pairs
returned by the contact search.

=cut

sub search {
    my $self = shift;
    my @targets = @_;
    foreach my $surname( @targets ) {
	    $surname =~ s/,$//;  # Remove optional trailing comma.
	    $surname = lc( $surname );

	    my $qpage = $base_page . $surname;
	    &getpeople( $qpage, $surname );
    }
    return %results;

}

=back

=head1 AUTHOR

Michael Howe <michael@michaelhowe.org>

This program is free software; you can redistribute it
and/or modify it under the same terms as Perl itself.

=head1 CREDITS

Originally based on the mutt_ldap_query script from
http://wwwhome.cs.utwente.nl/~meentr/mutt-ldap.html

Thanks to Will for suggesting WWW:Mechanize, and also suggesting that I turn the
script into a module - 6 months later I got round to it.

=head1 BUGS

Could do with a way to set approximate or exact search, if anyone wants to use
it.
Probably many others.  WFM, YMMV, etc.  Fixes gratefully accepted.

=cut

1;
# vim: tw=80