Changeset 2680 for trunk/gsdl/perllib/plugins/EMAILPlug.pm

Timestamp:

2001-07-31T13:58:05+12:00 (23 years ago)

Author:

jrm21

Message:

1. we escape 'and' chars in headers so greenstone doesn't try to expand it

as metadata.

2. fixed up FromName and FromAddr if the From: field isn't in the "Name" <addr>

format.

3. MIME boundaries are allowed spaces in them (didn't read RFC properly...)
4. Body is now correctly interpreted if in quoted-printable or base64 and

content-type is text/* (not multipart).

File:

• trunk/gsdl/perllib/plugins/EMAILPlug.pm (modified) (11 diffs)

trunk/gsdl/perllib/plugins/EMAILPlug.pm

@@ -128 +128 @@
     $Headers =~ s/\r?\n\r?\n(.*)$//s;
     $$textref = $1;
+    # escape [] so it isn't re-interpreted as metadata
+    $Headers =~ s/\[/[/g; $Headers =~ s/\]/]/g;
+
 
     # Unfold headers - see rfc822
@@ -166 +169 @@
     # Extract the name and e-mail address from the From metadata
     $frommeta = $raw{"From"};
-    $frommeta =~ m/(.*)<(.*)>/;
-    my $fromnamemeta=$1;
-    my $fromaddrmeta=$2;
+    my $fromnamemeta;
+    my $fromaddrmeta;
+
+    $frommeta =~ s/\s*$//;  # Remove trailing space, if any
+
+    if ($frommeta =~ m/(.+)\s*<(.+)>/) {
+    $fromnamemeta=$1;
+    $fromaddrmeta=$2;
+    } elsif ($frommeta =~ m/(.+@.+)\s+\((.*)\)/) {
+    $fromnamemeta=$2;
+    $fromaddrmeta=$1;
+    } 
     if (!defined($fromaddrmeta)) {
     $fromaddrmeta=$frommeta;
     }
+    $fromaddrmeta=~s/<//; $fromaddrmeta=~s/>//;
     $doc_obj->add_utf8_metadata ($cursection, "FromAddr", $fromaddrmeta);
 
     if (defined($fromnamemeta)) {
     $fromnamemeta =~ s/\"//g;
-    $fromnamemeta =~ s/(.*) /$1/;  # Remove trailing space
     }
     else {
@@ -220 +232 @@
     my $mimeinfo="";
     # Do MIME and encoding stuff
-    if ($Headers =~ /^content\-type:\s*([\w\/\-]+)\s*\;?\s*([^\s]+)\s*$/mi)
+    if ($Headers =~ /^content\-type:\s*([\w\/\-]+)\s*\;?\s*(.+?)\s*$/mi)
     {
         $mimetype=$1;
@@ -227 +239 @@
     }
 
+    my $transfer_encoding="7bit";
+    if ($Headers =~ /^content-transfer-encoding:\s*([^\s]+)\s*$/mi) {
+    $transfer_encoding=$1;
+    }
     if ($mimetype ne "text/plain") {
-    $$textref=text_from_mime_message($mimetype,$mimeinfo,$$textref);
-    } # end of not text/plain
+    $$textref=text_from_mime_message($mimetype,$mimeinfo,$$textref,
+                     $outhandle);
+    } elsif ($transfer_encoding =~ /quoted\-printable/) {
+    $$textref=qp_decode($$textref);
+    } elsif ($transfer_encoding =~ /base64/) {
+    $$textref=base64_decode($$textref);
+    }
     
 
@@ -294 +315 @@
 # the textref we are given DOES NOT include the header.
 sub text_from_mime_message {
-    my ($mimetype,$mimeinfo,$text)=(@_);
+    my ($mimetype,$mimeinfo,$text,$outhandle)=(@_);
 
     # Check for multiparts - $mimeinfo will be a boundary
     if ($mimetype =~ /multipart/) {
     $boundary="";
-    if ($mimeinfo =~ /boundary="?([^\s]+?)"?\s*$/im) {
+    if ($mimeinfo =~ /boundary=\"?([^"]+)\"?\s*$/im) {
         $boundary=$1;
     }
@@ -305 +326 @@
     # message ends with "--$boundary--"
     # RFC says boundary is <70 chars, [A-Za-z'()+_,-./:=?], so escape any
-    # that perl might want to interpolate.
+    # that perl might want to interpolate. Also allows spaces...
 
     $boundary=~s/\\/\\\\/g;
@@ -313 +334 @@
     shift @message_parts;
     my $last=pop @message_parts;
+    # if our boundaries are a bit dodgy and we only found 1 part...
+    if (!defined($last)) {$last="";}
     # make sure it is only -- and whitespace
     if ($last !~ /^\-\-\s*$/ms) {
@@ -358 +381 @@
         foreach my $message_part (@message_parts) {
         my $part_header=$message_part;
-        $part_header=~s/\r?\n\r?\n(.*)$//sg;
-        my $part_body=$1;
+        my $part_body;
+        if ($part_header=~s/\r?\n\r?\n(.*)$//sg) {
+            $part_body=$1;
+        } else {
+            # no header... use defaults
+            $part_body=$message_part;
+            $part_header="Content-type: text/plain; charset=us-ascii";
+        }
         $part_header =~ s/\r?\n[\t\ ]+/ /gs; #unfold
         my $part_content_type="";
@@ -367 +396 @@
             $part_content_type="message/rfc822";
         }
-        if ($part_header =~ m@^content\-type:\s*([\w+/\-]+)\s*\;?\s*([^\s]+)@mi) {
+        if ($part_header =~ m@^content\-type:\s*([\w+/\-]+)\s*\;?\s*([^\s]*)@mi) {
             $part_content_type=$1; $part_content_type =~ tr/A-Z/a-z/;
             $part_content_info=$2;
@@ -423 +452 @@
                 text_from_mime_message($message_content_type,
                                $message_content_info,
-                               $message_part_body);
+                               $message_part_body,
+                               $outhandle);
             } else {
                 $message_part_body=text_from_part($part_body);
@@ -443 +473 @@
             $tmptext=text_from_mime_message($part_content_type,
                             $part_content_info,
-                            $part_body);
+                            $part_body,
+                            $outhandle);
             $text.=$tmptext;
         } elsif ($text eq "") {