Commit 38956b3f authored by Jan Idzikowski's avatar Jan Idzikowski
Browse files

Fix error with single line with 1 dot

Add more tests for handle single line dot in mask-dot and
in rfc2045-q-encode-string-to-stream
Add optional argument CATCH-ERRORS to run-tests, default is T
parent 2bf946c1
Version 20151023.1
2015.10.23
Fix error with single line with 1 dot
Thanks Francesco Bracchi for the bug report and patch
Add more tests for handle single line dot in mask-dot and
in rfc2045-q-encode-string-to-stream
Add optional argument CATCH-ERRORS to run-tests, default is T
Change cl-smtp.asd, cl-smtp.lisp, tests.lisp CHANGELOG
Version 20150521.1
2015.05.21
Add :license and :description in cl-smtp.asd and LICENSE file.
......@@ -13,7 +22,7 @@ Change cl-smtp.asd, cl-smtp.lisp, CHANGELOG
Version 20140128.1
2014.01.28
Add patch for converted username and password to base64 string,
ignore default wrap columns 80, so that no newline is inserted.
ignore default wrap columns 80, so that no newline is inserted.
Thanks Helmut G. Enders for the bug report and patch
Change cl-smtp.asd, cl-smtp.lisp, CHANGELOG
......@@ -25,7 +34,7 @@ Change cl-smtp.asd, cl-smtp.lisp, CHANGELOG
Version 20130822.1
2013.08.22
Add patch to use given external-format for ssl stream
Add patch to use given external-format for ssl stream
Thanks Anton Vodonosov for the bug report and patch
Change cl-smtp.asd, cl-smtp.lisp, CHANGELOG
......
......@@ -21,7 +21,7 @@
:licence "LLGPL"
:author "Jan Idzikowski <jidzikowski@common-lisp.net>"
:maintainer "Jan Idzikowski <jidzikowski@common-lisp.net>"
:version "20150521.1"
:version "20151023.1"
:perform (load-op :after (op webpage)
(pushnew :cl-smtp cl:*features*))
:depends-on (:usocket
......
......@@ -33,28 +33,24 @@
(error "the \"~A\" argument is not a string or cons" name))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar *line-with-one-dot* #.(format nil "~C~C.~C~C" #\Return #\NewLine
#\Return #\NewLine))
(defvar *line-with-two-dots* #.(format nil "~C~C..~C~C" #\Return #\NewLine
#\Return #\NewLine))
(defvar *return-newline* #.(format nil "~C~C" #\Return #\NewLine)))
(defun mask-dot (str)
"Replace all occurences of \r\n.\r\n in STR with \r\n..\r\n"
(let ((resultstr ""))
(labels ((mask (tempstr)
(let ((n (search *line-with-one-dot* tempstr)))
(cond
(n
(setf resultstr (concatenate 'string resultstr
(subseq tempstr 0 n)
*line-with-two-dots*))
(mask (subseq tempstr (+ n #.(length *line-with-one-dot*)))))
(t
(setf resultstr (concatenate 'string resultstr
tempstr)))))))
(mask str))
resultstr))
"Replace all occurences of single line #\. with #\.#\."
(with-output-to-string (s)
(mask-dot-stream str s)))
(defun mask-dot-stream (str stream)
"Replace all occurences of single line #\. with #\.#\."
(let ((l (length str)))
(loop for c across str
for i from 0
for pc = (when (> i 0) (elt str (1- i)))
for nc = (when (< (1+ i) l) (elt str (1+ i)))
do (if (and (eq c #\.) (or (eq pc #\Newline) (not pc))
(or (eq nc #\Return) (eq nc #\Newline) (not nc)))
(write-sequence ".." stream)
(write-char c stream)))))
(defun string-to-base64-string (str &key (external-format :utf-8)
(columns 80))
......@@ -103,13 +99,17 @@
(loop for c across str
for n from 0 to len
for column = (- n last-line-break)
for nc = (when (< (+ n 1) len) (elt str (+ n 1)))
for nc = (when (< (1+ n) len) (elt str (1+ n)))
do
(when (>= column columns)
(write-char #\= stream)
(write-blank-line stream)
(setf last-line-break n))
(cond
((and (char= c #\.) (or (= n 0) (= (1- n) last-line-break))
(or (eq nc #\Return) (eq nc #\Newline) (not nc)))
(write-char #\. stream)
(write-char #\. stream))
((char= c #\NewLine)
(setf last-line-break n)
(write-blank-line stream))
......@@ -513,7 +513,7 @@
message))
(rfc2045-q-encode-string-to-stream message stream
:external-format external-format))
(write-to-smtp stream message))
(mask-dot-stream message stream))
(write-blank-line stream)
(write-blank-line stream)
;;---------- Send Html text if needed -------------------------
......@@ -532,7 +532,7 @@
html-message))
(rfc2045-q-encode-string-to-stream
html-message stream :external-format external-format))
(write-to-smtp stream html-message))
(mask-dot-stream html-message stream))
(send-end-marker stream html-boundary)))
;;---------- Send Attachments -----------------------------------
(when attachments
......
......@@ -53,6 +53,14 @@ e schrieb, in Liebe und Ha=DF, als immerfort mitlebend zu behandel=
n !"
))))
(define-cl-smtp-test "rfc2045-q-encode-string-to-stream-5" ()
(let* ((str (format nil "check of masked dots.~C.~C.end" #\Newline #\Newline))
(qstr (with-output-to-string (s)
(rfc2045-q-encode-string-to-stream
str s :external-format :latin-1 :columns 64))))
(assert qstr)
(assert (string-equal qstr (format nil "check of masked dots.~C~C..~C~C.end" #\Return #\Newline #\Return #\Newline)))))
(define-cl-smtp-test "string-has-non-ascii-1" ()
(assert (string-has-non-ascii "test Ü ende")))
......@@ -138,12 +146,9 @@ n !"
(headerstr (with-output-to-string (s)
(send-attachment-header s boundary attachment :utf-8)))
(returnnewline (format nil (format nil "~C~C" #\Return #\NewLine)))
(tmpstr (format nil "--~A~AContent-type: text/plain;~% name*=UTF-8''foo%5cbar;~% name=\"foo\\\\bar\"~AContent-Disposition: attachment; filename*=UTF-8''foo%5cbar; filename=\"foo\\\\bar\"~AContent-Transfer-Encoding: base64~A~A"
(tmpstr (format nil "--~A~AContent-type: text/plain;~% name*=UTF-8''foo%5Cbar;~% name=\"foo\\\\bar\"~AContent-Disposition: attachment; filename*=UTF-8''foo%5Cbar; filename=\"foo\\\\bar\"~AContent-Transfer-Encoding: base64~A~A"
boundary returnnewline returnnewline returnnewline
returnnewline returnnewline)))
(print headerstr)
(print tmpstr)
(assert (equal headerstr tmpstr))
))
......@@ -163,8 +168,12 @@ n !"
#\Return #\NewLine)))
(assert (equal (mask-dot (format nil "~C.~C.~C.~C" #\Return #\NewLine
#\Return #\NewLine))
(format nil "~C.~C.~C.~C" #\Return #\NewLine
#\Return #\NewLine))))
(format nil "~C.~C..~C.~C" #\Return #\NewLine
#\Return #\NewLine)))
(assert (equal (mask-dot (format nil "~C.~C" #\NewLine #\NewLine))
(format nil "~C..~C" #\NewLine #\NewLine)))
(assert (equal (mask-dot (format nil ".~C.~C" #\NewLine #\NewLine))
(format nil "..~C..~C" #\NewLine #\NewLine))))
(define-cl-smtp-test "substitute-return-newline" ()
(assert (equal (substitute-return-newline
......@@ -220,7 +229,7 @@ n !"
(assert (string-equal (remove #\Return (remove #\Newline base64str1 :test #'equal) :test #'equal) base64str2))
))
(defun run-test (name)
(defun run-test (name &optional (catch-errors t))
(handler-case
(let ((test (gethash name *cl-smtp-tests*)))
(format t "~%run test: ~S ~@[(~A)~]~%" name (cadr test))
......@@ -228,16 +237,20 @@ n !"
(format t "pass~%")
t)
(simple-error (c)
(format t "failed: ~A" c)
nil)))
(if catch-errors
(format t "failed: ~A" c)
(error c)))))
(defun run-tests ()
(defun run-tests (&optional (catch-errors t))
(let ((n (hash-table-count *cl-smtp-tests*))
(failed '())
(pass 0))
(format t "~%run ~D cl-smtp-tests~%~%" (hash-table-count *cl-smtp-tests*))
(maphash #'(lambda (k v)
(declare (ignore v))
(when (run-test k)
(incf pass)))
(if (run-test k catch-errors)
(incf pass)
(push k failed)))
*cl-smtp-tests*)
(format t "~%pass: ~D | failed: ~D~%~%" pass (- n pass))))
(format t "~%pass: ~D | failed: ~D~%test failed: ~{~A~^, ~}~%~%"
pass (- n pass) failed)))
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment