@@ -1,3 +1,17 @@

+2006-11-16  Ahmon Dancy  <dancy@dancy>

+

+	bug16495: 

+	  

+	* smtp.cl: send-smtp-1: New external-format keyword arg.

+                                Now processes input in terms of bytes

+	                        instead of characters.  

+

+	* mime-api.cl: make-mime-part: Default external-format is :utf8

+	now.  Default encoding changed once again.  Now always base64,

+	except for when :text is supplied and is stringp, in which case

+	the encoded version of the string is examined to see if 7bit can

+	be used).

+

 2006-10-18  Ahmon Dancy  <dancy@dancy>

 	* mime-api.cl: bug16479: Improve default content-transfer-encoding

@@ -1,18 +1,20 @@

 #+(version= 8 0)

-(sys:defpatch "mime" 1

+(sys:defpatch "mime" 2

   "v0: New module.  See documentation.;

-v1: Improve default transfer encoding determination."

+v1: Improve default transfer encoding determination;

+v2: make-mime-part: Default external-format is :utf8."

   :type :system

   :post-loadable t)

 #+(version= 7 0)

-(sys:defpatch "mime" 1

+(sys:defpatch "mime" 2

   "v0: New module.  See documentation.;

-v1: Improve default transfer encoding determination."

+v1: Improve default transfer encoding determination;

+v2: make-mime-part: Default external-format is :utf8."

   :type :system

   :post-loadable t)

-;; $Id: mime-api.cl,v 1.3 2006/10/18 18:41:57 layer Exp $

+;; $Id: mime-api.cl,v 1.4 2006/11/17 00:32:07 layer Exp $

 (defpackage :net.post-office

   (:use #:lisp #:excl)

@@ -100,10 +102,10 @@ v1: Improve default transfer encoding determination."

 (defun make-mime-part (&key content-type encoding headers 

 			    (attachmentp nil attachmentp-supplied)

 			    name text (start 0) end file

-			    subparts (external-format :default)

+			    subparts (external-format :utf8)

 			    parameters charset id description)

   (let ((part (make-instance 'mime-part-constructed))

-	type subtype multipart textp filepath)

+	type subtype multipart textp filepath orig-text)

     (if* (and text file)

        then (error "Only one of :text or :file may be specified"))

@@ -115,7 +117,8 @@ v1: Improve default transfer encoding determination."

       (if* (streamp file)

 	 then (setf filepath (ignore-errors (namestring file)))

 	 else (setf filepath file)))

-    

+

+    ;; Select default content-type

     (when (null content-type)

       (if* filepath

 	 then (setf content-type (lookup-mime-type filepath)))

@@ -145,21 +148,34 @@ v1: Improve default transfer encoding determination."

     (if* (and (not multipart) (null text) (null file))

        then (error "One of :text or :file must be specified"))

+

+    ;; Select default charset

     (if* (and (null charset) textp)

        then (setf charset 

 	      (or 

 	       (guess-charset-from-ef (find-external-format external-format))

 	       "us-ascii")))

+

+    ;; For :text, break down to the final usb8.

+    (when text

+      (setf orig-text text)

+      (setf text (if* (stringp text)

+		    then (string-to-octets text :null-terminate nil

+					   :external-format external-format

+					   :start start

+					   :end end)

+		    else (subseq text start end))))

+    ;; Select default encoding, which is always base64 except for

+    ;; when :text was supplied as a string, in which case we scan to

+    ;; choose between 7bit and base64.

     (when (and (not multipart) (null encoding))

-      (if* textp

-	 then (if* (member charset '("us-ascii" "iso-2022-jp")

-			   :test #'equalp)

-		 then (setf encoding "7bit")

-		 else (setf encoding "8bit"))

-	 else (setf encoding "base64")))

-

+      (setf encoding

+	(if* (and (stringp orig-text) (not (8-bit-array-p text)))

+	   then "7bit"

+	   else "base64")))

+  

     (setf (mime-part-type part) type)

     (setf (mime-part-subtype part) subtype)

     (setf (mime-part-parameters part) parameters)

@@ -179,11 +195,7 @@ v1: Improve default transfer encoding determination."

 	    (if* (not attachmentp-supplied)

 	       then (setf attachmentp t))

        else (setf (source-type part) :usb8)

-	    (setf (source part) 

-	      (if* (stringp text)

-		 then (string-to-octets text :null-terminate nil

-					:external-format external-format)

-		 else (subseq text start end))))

+	    (setf (source part) text))

     (if* (and (not textp) (not attachmentp) (not multipart))

        then (setf (disposition part) "inline"))

@@ -206,6 +218,14 @@ v1: Improve default transfer encoding determination."

     part))

+(defun 8-bit-array-p (usb8)

+  (declare (optimize (speed 3) (safety 0))

+	   ((simple-array (unsigned-byte 8) (*)) usb8))

+  (dotimes (n (length usb8))

+    (declare (fixnum n))

+    (if (> (aref usb8 n) 127)

+	(return t))))

+

 (defparameter *ef-nick-to-mime-charset*

     '((:ascii . "us-ascii")

       (:iso-2022-jp . "iso-2022-jp")

@@ -223,7 +243,7 @@ v1: Improve default transfer encoding determination."

   (let ((ef-name (string-downcase (symbol-name (ef-name (crlf-base-ef ef))))))

     ;; Try iso-8559-x names.

     (multiple-value-bind (found ignore suffix)

-	(match-re (load-time-value "^iso8859-(\\d+)-base") ef-name)

+	(match-re "^iso8859-(\\d+)-base" ef-name)

       (declare (ignore ignore))

       (if found

 	  (return-from guess-charset-from-ef 

@@ -231,7 +251,7 @@ v1: Improve default transfer encoding determination."

     ;; Try windows- names.

     (multiple-value-bind (found whole value)

-	(match-re (load-time-value "^(\\d+)-base$") ef-name)

+	(match-re "^(\\d+)-base$" ef-name)

       (declare (ignore whole))

       (if found

 	  (return-from guess-charset-from-ef

@@ -1,17 +1,19 @@

 #+(version= 8 0)

-(sys:defpatch "smtp" 4

+(sys:defpatch "smtp" 5

   "v1: send-letter w/attachments; send-smtp* can take streams;

 v2: add :port argument to send-letter, send-smtp, send-smtp-auth;

 v3: fix incompatibility introduced in v2;

-v4: remove stray force-output of t."

+v4: remove stray force-output of t;

+v5: send-smtp-1: New external-format keyword arg."

   :type :system

   :post-loadable t)

 #+(version= 7 0)

-(sys:defpatch "smtp" 4

+(sys:defpatch "smtp" 5

   "v2: send-letter w/attachments; send-smtp* can take streams;

 v3: add :port argument to send-letter, send-smtp, send-smtp-auth;

-v4: fix incompatibility introduced in v3."

+v4: fix incompatibility introduced in v3;

+v5: rm stray force-output of t; send-smtp-1: New external-format keyword arg."

   :type :system

   :post-loadable t)

@@ -41,7 +43,7 @@ v4: fix incompatibility introduced in v3."

 ;; Suite 330, Boston, MA  02111-1307  USA

 ;;

 ;;

-;; $Id: smtp.cl,v 1.20 2006/10/16 17:35:38 layer Exp $

+;; $Id: smtp.cl,v 1.21 2006/11/17 00:32:07 layer Exp $

 ;; Description:

 ;;   send mail to an smtp server.  See rfc821 for the spec.

@@ -247,7 +249,8 @@ Attachments must be filenames, streams, or mime-part-constructed, not ~s"

 (defun send-smtp-auth (server from to login password &rest messages)

   (send-smtp-1 server from to login password messages))

-(defun send-smtp-1 (server from to login password messages)

+(defun send-smtp-1 (server from to login password messages

+		    &key (external-format :default))

   ;; send the effective concatenation of the messages via

   ;; smtp to the mail server

   ;; Each message should be a string or a stream.

@@ -297,24 +300,24 @@ Attachments must be filenames, streams, or mime-part-constructed, not ~s"

 	      (when message

 		(setf stream (if* (streamp message)

 				then message 

-				else (make-string-input-stream message)))

-		(unwind-protect 

-		    (progn

-		      (while (setf ch (read-char stream nil nil))

-			(if* (and at-bol (eq ch #\.))

-			   then ;; to prevent . from being interpreted as eol

-				(write-char #\. sock))

-			(if* (eq ch #\newline)

-			   then (setq at-bol t)

-				(if* (not (eq prev-ch #\return))

-				   then (write-char #\return sock))

-			   else (setq at-bol nil))

-			(write-char ch sock)

-			(setq prev-ch ch)))

-		  ;; unwind-protect

-		  (if* (not (streamp message))

-		     then (close stream))))))

-		

+				else (make-buffer-input-stream

+				      (string-to-octets 

+				       message 

+				       :null-terminate nil

+				       :external-format external-format))))

+

+		(while (setf ch (read-byte stream nil))

+		  (if* (and at-bol (eq ch #.(char-code #\.)))

+		     then ;; to prevent . from being interpreted as eol

+			  (write-char #\. sock))

+		  (if* (eq ch #.(char-code #\newline))

+		     then (setq at-bol t)

+			  (if* (not (eq prev-ch #.(char-code #\return)))

+			     then (write-char #\return sock))

+		     else (setq at-bol nil))

+		  (write-byte ch sock)

+		  (setq prev-ch ch)))))

+

 	  (write-char #\return sock) (write-char #\linefeed sock)

 	  (write-char #\. sock)

 	  (write-char #\return sock) (write-char #\linefeed sock)