Index: modules/mime/ChangeLog
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/mime/ChangeLog,v
retrieving revision 1.96
diff -w -u -r1.96 ChangeLog
--- modules/mime/ChangeLog	5 Nov 2007 23:16:36 -0000	1.96
+++ modules/mime/ChangeLog	14 May 2008 20:51:16 -0000
@@ -1,3 +1,14 @@
+2008-05-13  Andreas Kupries  <andreask@activestate.com>
+
+	* mime.tcl (::mime::parsepart): [SF Tcllib Bug 1961881]. Accepted
+	  patch, and extended. Now handling malformed input without having
+	  to throw an eror, and without going into an infinite loop. See
+	  also [Bug 631314], and Changelog entries 2003-06-06,
+	  2003-06-25. The testcases mime-3.{7,8} are not redundant, but
+	  significantly different. 3.7 actually has a terminating
+	  boundary, but misses the starting one, causing non-recognition
+	  of any terminating one.
+
 2007-11-05  Andreas Kupries  <andreask@activestate.com>
 
 	* mime.tcl (::mime::parsepart): Fixed [SF Tcllib Bug 1825092],
Index: modules/mime/mime.tcl
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/mime/mime.tcl,v
retrieving revision 1.60
diff -w -u -r1.60 mime.tcl
--- modules/mime/mime.tcl	5 Nov 2007 23:11:50 -0000	1.60
+++ modules/mime/mime.tcl	14 May 2008 20:51:16 -0000
@@ -825,15 +825,37 @@
 
     if {$fileP} {
         set pos [tell $state(fd)]
+	# This variable is like 'start', for the reasons laid out
+	# below, in the other branch of this conditional.
+	set initialpos $pos
+    } else {
+	# This variable is like 'start', a list of lines in the
+	# part. This record is made even before we find a starting
+	# boundary and used if we run into the terminating boundary
+	# before a starting boundary was found. In that case the lines
+	# before the terminator as recorded by tracelines are seen as
+	# the part, or at least we attempt to parse them as a
+	# part. See the forceoctet and nochild flags later. We cannot
+	# use 'start' as that records lines only after the starting
+	# boundary was found.
+	set tracelines [list]
     }
 
     set inP 0
     set moreP 1
+    set forceoctet 0
     while {$moreP} {
         if {$fileP} {
             if {$pos > $last} {
-                 error "termination string missing in $state(content)"
+		# We have run over the end of the part per the outer
+		# information without finding a terminating boundary.
+		# We now fake the boundary and force the parser to
+		# give any new part coming of this a mime-type of
+		# application/octet-stream regardless of header
+		# information.
                  set line "--$boundary--"
+		set x [string length $line]
+		set forceoctet 1
             } else {
               if {[set x [gets $state(fd) line]] < 0} {
                   error "end-of-file encountered while parsing $state(content)"
@@ -865,47 +887,116 @@
              }
 
              continue
+        } else {
+	    lappend tracelines $line
         }
 
         if {!$inP} {
-            if {![string compare $line "--$boundary"]} {
+	    # Haven't seen the starting boundary yet. Check if the
+	    # current line contains this starting boundary.
+
+            if {[string equal $line "--$boundary"]} {
+		# Yes. Switch parser state to now search for the
+		# terminating boundary of the part and record where
+		# the part begins (or initialize the recorder for the
+		# lines in the part).
                 set inP 1
                 if {$fileP} {
                     set start $pos
                 } else {
 		    set start [list]
                 }
-            }
+		continue
+            } elseif {[string equal $line "--$boundary--"]} {
+		# We just saw a terminating boundary before we ever
+		# saw the starting boundary of a part. This forces us
+		# to stop parsing, we do this by forcing the parser
+		# into an accepting state. We will try to create a
+		# child part based on faked start position or recorded
+		# lines, or, if that fails, let the current part have
+		# no children.
+
+		# As an example note the test case mime-3.7 and the
+		# referenced file "badmail1.txt".
 
+                set inP 1
+                if {$fileP} {
+                    set start $initialpos
+                } else {
+		    set start $tracelines
+                }
+		set forceoctet 1
+		# Fall through. This brings to the creation of the new
+		# part instead of searching further and possible
+		# running over the end.
+	    } else {
             continue
         }
+	}
+
+	# Looking for the end of the current part. We accept both a
+	# terminating boundary and the starting boundary of the next
+	# part as the end of the current part.
 
         if {([set moreP [string compare $line "--$boundary--"]]) \
                 && ([string compare $line "--$boundary"])} {
+	    # The current part has not ended, so we record the line
+	    # if we are inside a part and doing string parsing.
             if {$inP && !$fileP} {
 		lappend start $line
             }
             continue
         }
+
+	# The current part has ended. We now determine the exact
+	# boundaries, create a mime part object for it and recursively
+	# parse it deeper as part of that action.
+
 	# FRINK: nocheck
         variable [set child $token-[incr state(cid)]]
 
         lappend state(parts) $child
 
+	set nochild 0
         if {$fileP} {
             if {[set count [expr {$pos-($start+$x+$crlf+1)}]] < 0} {
                 set count 0
             }
-
+	    if {$forceoctet} {
+		set ::errorInfo {}
+		if {[catch {
             mime::initializeaux $child \
                 -file $state(file) -root $state(root) \
                 -offset $start -count $count
-
+		}]} {
+		    set nochild 1
+		    set state(parts) [lrange $state(parts) 0 end-1]
+		}
+	    } else {
+		mime::initializeaux $child \
+		    -file $state(file) -root $state(root) \
+		    -offset $start -count $count
+	    }
             seek $state(fd) [set start $pos] start
         } else {
+	    if {$forceoctet} {
+		if {[catch {
 	    mime::initializeaux $child -lineslist $start
+		}]} {
+		    set nochild 1
+		    set state(parts) [lrange $state(parts) 0 end-1]
+		}
+	    } else {
+		mime::initializeaux $child -lineslist $start
+	    }
             set start ""
         }
+	if {$forceoctet && !$nochild} {
+	    variable $child
+	    upvar 0  $child childstate
+	    set childstate(content) application/octet-stream
+	}
+	set forceoctet 0
     }
 }
 
Index: modules/mime/mime.test
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/mime/mime.test,v
retrieving revision 1.29
diff -w -u -r1.29 mime.test
--- modules/mime/mime.test	5 Nov 2007 23:11:50 -0000	1.29
+++ modules/mime/mime.test	14 May 2008 20:51:16 -0000
@@ -169,20 +169,27 @@
 foo}"
 
 test mime-3.7 {Test mime with a bad email [SF Bug 631314 ]} {
-    catch {
 	set tok [mime::initialize -file \
 		[file join $tcltest::testsDirectory badmail1.txt]]
-    } msg ; #{}
-    set msg
-} {termination string missing in multipart/mixed}
+
+    set res {}
+    set ctok [lindex [mime::getproperty $tok parts] 0]
+    lappend res [dictsort [mime::getproperty $tok]]
+    lappend res [dictsort [mime::getproperty $ctok]]
+    mime::finalize $tok
+    string map [list $ctok CHILD] $res
+} {{content multipart/mixed encoding {} params {boundary ----------CSFNU9QKPGZL79} parts CHILD size 0} {content application/octet-stream encoding {} params {charset us-ascii} size 0}}
 
 test mime-3.8 {Test mime with another bad email [SF Bug 631314 ]} {
-    catch {
 	set tok [mime::initialize -file \
 		[file join $tcltest::testsDirectory badmail2.txt]]
-    } msg ; #{}
-    set msg
-} {termination string missing in multipart/related}
+    set res {}
+    set ctok [lindex [mime::getproperty $tok parts] 0]
+    lappend res [dictsort [mime::getproperty $tok]]
+    lappend res [dictsort [mime::getproperty $ctok]]
+    mime::finalize $tok
+    string map [list $ctok CHILD] $res
+} {{content multipart/related encoding {} params {boundary ----=_NextPart_000_0000_2CBA2CBA.150C56D2} parts CHILD size 659} {content application/octet-stream encoding base64 params {} size 659}}
 
 test mime-3.9 {Parse a MIME message with a charset encoded body and use getbody -decode to get it back} {
     set msg {MIME-Version: 1.0
