source: trunk/gsdl/perllib/plugins/EMAILPlug.pm@ 1206

###########################################################################
#
# EMAILPlug.pm - a plugin for parsing email files
#
# A component of the Greenstone digital library software
# from the New Zealand Digital Library Project at the 
# University of Waikato, New Zealand.
#
# Copyright (C) 1999 New Zealand Digital Library Project
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
###########################################################################



# EMAILPlug
#
# by Gordon Paynter ([email protected])
#
# Email plug reads email files.  These are named with a simple
# number (i.e. as they appear in mh_mail folders) or with the 
# extension .email
#
# Document text:
#   The document text consists of all the text 
#   after the first blank line in the document.
#
# Metadata:
#   $Headers      All the header content
#   $Subject      Subject: header
#   $To           To: header
#   $From         From: header - this will be stored as Creator
#   $DateText     Date: header
#   $Date         Date: header in GSDL format (eg: 19990924)
#
# Version history
#
# 1.2   (2000 Jun 12) Major rewrite.
#       (The new version of Greenstone breaks some of the metadata.)
# 1.1.1 Compensated for two-digit years like "95"
# 1.1   (1999 Sep 20) Introduced the various metadata fileds
# 1.0   Based on the original HTMLPlug code
#


package EMAILPlug;

use BasPlug;
use sorttools;
use util;


# EMAILPlug is a sub-class of BasPlug.

sub BEGIN { 
    @ISA = ('BasPlug');
}


# Create a new EMAILPlug object with which to parse a file.
# Accomplished by creating a new BasPlug and using bless to 
# turn it into an EMAILPlug.

sub new {
    my ($class) = @_;
    $self = new BasPlug ();
    return bless $self, $class;
}


# Is EMAILPlug recursive?  No.

sub is_recursive {
    return 0; 
}


# Read a file and store its contents in a new document object.
# First, we check to see if it is an email message we're dealing
# with, then we extract the text and metadata, then we store
# all this information.
#
# Returns: number of files processed or undef if it can't process
# a file.  This plugin only processes one file at a time.

sub read {
    my $self = shift (@_);
    my ($pluginfo, $base_dir, $file, $metadata, $processor) = @_;

    #
    # Check that we're dealig with a valid mail file
    #

    # Make sure file exists 
    my $filename = &util::filename_cat($base_dir, $file);
    return undef unless (-e $filename);
    return undef unless ($filename =~ /\d+(\.email)?$/);

    # Read the text and make sure it is an email message
    open (FILE, $filename) || die "EMAILPlug::read - can't open $filename\n";
    my @text = <FILE>;
    my $text = join("", @text);
    return undef unless (($text =~ /From:/) || ($text =~ /To:/));

    print STDERR "EMAILPlug: processing $filename\n" if $processor->{'verbosity'};

    #
    # Parse the document's text and extract metadata
    #

    # Separate header from body of message
    my $Headers = $text;
    $Headers =~ s/\n\n.*//s;
    $text = substr $text, (length $Headers);

    # Extract basic metadata from header
    my @headers = ("From", "To", "Subject", "Date");
    my $value = ""; 
    my %raw;

    foreach my $name (@headers) {
    $value = $Headers; 
    $value =~ s/.*$name://s;
    $value =~ s/\S*:.*//s;
    $value =~ s/\s*$//;
    $value =~ s/\s+/ /g;
    $raw{$name} = $value;
    }

    # Process Date information
    if ($raw{"Date"}) {
    $raw{"DateText"} = $raw{"Date"};
    
    # Convert the date text to internal date format
    $value = $raw{"Date"};
    my ($day, $month, $year) = $value =~ /(\d?\d)\s([A-Z][a-z][a-z])\s(\d\d\d?\d?)/;
    if ($year < 100) { $year += 1900; }
    $raw{"Date"} = &sorttools::format_date($day, $month, $year);
    
    } else {
    # We have not extracted a date
    $raw{"DateText"} = "Unknown.";
    $raw{"Date"} = "19000000";
    }


    #
    # Create a new document object
    #

    my $doc_obj = new doc ($file, "indexed_doc");
    my $cursection = $doc_obj->get_top_section();

    # Add specilised metadata
    foreach my $name (keys %raw) {
    $value = $raw{$name};
    if ($value) {
        $value = &text_into_html($value);
    } else {
        $value = "No $name field";
    }
    $doc_obj->add_metadata ($cursection, $name, $value);
    }

    # Add "All headers" metadata
    $Headers = &text_into_html($Headers);
    $Headers = "No headers" unless ($Headers =~ /\w/);
    $doc_obj->add_metadata ($cursection, "Headers", $Headers);

    # Add document text
    $text = &text_into_html($text);
    $text = "No message" unless ($text =~ /\w/);
    $doc_obj->add_text ($cursection, $text);
    
    # Add the OID - that is, the big HASH value used as a unique ID
    $doc_obj->set_OID ();

    # Process the document
    $processor->process($doc_obj);

    # Return the number of documents processed
    return 1; 

}


# Convert a text string into HTML.
#
# The HTML is going to be inserted into a GML file, so 
# we have to be careful not to use symbols like ">",
# which ocurs frequently in email messages (and use
# &gt instead.
#
# This function also turns links and email addresses into hyperlinks,
# and replaces carriage returns with <BR> tags (and multiple carriage
# returns with <P> tags).


sub text_into_html {
    my ($text) = @_;

    # Convert problem charaters into HTML symbols
    $text =~ s/&/&amp;/go;
    $text =~ s/</&lt;/go;
    $text =~ s/>/&gt;/go;
    $text =~ s/\"/&quot;/go;

    # convert email addresses and URLs into links
    $text =~ s/([\w\d\.\-]+@[\w\d\.\-]+)/<a href=\"mailto:$1\">$1<\/a>/g;
    $text =~ s/(http:\/\/[\w\d\.\-]+[\/\w\d\.\-~]*)/<a href=\"$1\">$1<\/a>/g;

    # Clean up whitespace and convert \n charaters to <BR> or <P>
    $text =~ s/ +/ /go;
    $text =~ s/\s*$//o; 
    $text =~ s/^\s*//o; 
    $text =~ s/\n/\n<BR>/go;
    $text =~ s/<BR>\s*<BR>/<P>/go;

    return $text;
}


# Perl packages have to return true if they are run.
1;