Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
What's new
10
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Open sidebar
x0r
cl-smtp
Commits
19f2d569
Commit
19f2d569
authored
Apr 22, 2010
by
Jan Idzikowski
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Fixed encoding errors in header strings
parent
4dd11e1f
Changes
2
Hide whitespace changes
Inline
Side-by-side
Showing
2 changed files
with
45 additions
and
8 deletions
+45
-8
CHANGELOG
CHANGELOG
+6
-0
cl-smtp.lisp
cl-smtp.lisp
+39
-8
No files found.
CHANGELOG
View file @
19f2d569
Version 20100422.1
2010.04.22
Fixed encoding errors in header strings,
new function q-encode-str to encode strings in header
Change cl-smtp.lisp, CHANGELOG
Version 20100420.1
2010.04.20
Fixed error when send more than 1 attachment,
...
...
cl-smtp.lisp
View file @
19f2d569
...
...
@@ -62,6 +62,28 @@
#+
allegro
(
excl:string-to-base64-string
str
)
#-
allegro
(
cl-base64:string-to-base64-string
str
))
(
defun
q-encode-str
(
str
&key
(
external-format
(
flex:make-external-format
:iso-8859-15
)))
(
let
((
line-has-non-ascii
nil
))
(
with-output-to-string
(
s
)
(
loop
for
c
across
str
do
(
cond
((
<
127
(
char-code
c
))
(
unless
line-has-non-ascii
(
format
s
"=?~A?Q?"
(
flex:external-format-name
external-format
))
(
setf
line-has-non-ascii
t
))
(
loop
for
byte
across
(
flex:string-to-octets
(
make-string
1
:initial-element
c
)
:external-format
external-format
)
do
(
format
s
"=~2,'0X"
byte
)))
(
t
(
when
line-has-non-ascii
(
format
s
"?="
)
(
setf
line-has-non-ascii
nil
))
(
format
s
"~C"
c
))))
(
when
line-has-non-ascii
(
format
s
"?="
)))))
(
define-condition
smtp-error
(
error
)
())
...
...
@@ -104,7 +126,13 @@
lines
))
(
defun
do-with-smtp-mail
(
host
from
to
thunk
&key
port
authentication
ssl
local-hostname
)
(
usocket:with-client-socket
(
socket
stream
host
port
)
(
usocket:with-client-socket
(
socket
stream
host
port
:element-type
'
(
unsigned-byte
8
))
(
setf
stream
(
flexi-streams:make-flexi-stream
stream
:external-format
(
flexi-streams:make-external-format
:latin-1
:eol-style
:lf
)))
(
let
((
stream
(
smtp-handshake
stream
:authentication
authentication
:ssl
ssl
...
...
@@ -155,6 +183,7 @@
:authentication
authentication
:ssl
ssl
:local-hostname
local-hostname
)
(
setf
(
in-header
stream
)
nil
)
(
let*
((
boundary
(
make-random-boundary
))
(
html-boundary
(
if
(
and
attachments
html-message
)
(
make-random-boundary
)
...
...
@@ -288,9 +317,9 @@
(
setf
stream
#+
allegro
(
socket:make-ssl-client-stream
stream
)
#-
allegro
(
let
((
s
stream
))
(
let
((
s
(
flexi-streams:flexi-stream-stream
stream
)
))
(
cl+ssl:make-ssl-client-stream
(
cl+ssl:stream-fd
s
tream
)
(
cl+ssl:stream-fd
s
)
:close-callback
(
lambda
()
(
close
s
)))))
#-
allegro
(
setf
stream
(
flexi-streams:make-flexi-stream
...
...
@@ -360,14 +389,16 @@
server connected to on STREAM. The server is expected to have
previously accepted the DATA SMTP command."
(
write-to-smtp
stream
(
format
nil
"Date: ~A"
(
get-email-date-string
)))
(
write-to-smtp
stream
(
format
nil
"From: ~@[~A <~]~A~@[>~]"
display-name
from
display-name
))
(
if
display-name
(
write-to-smtp
stream
(
format
nil
"From: ~A <~A>"
(
q-encode-str
display-name
)
from
))
(
write-to-smtp
stream
(
format
nil
"From: ~A"
from
)))
(
write-to-smtp
stream
(
format
nil
"To: ~{ ~a~^,~}"
to
))
(
when
cc
(
write-to-smtp
stream
(
format
nil
"Cc: ~{ ~a~^,~}"
cc
)))
(
write-to-smtp
stream
(
format
nil
"Subject: ~A"
subject
))
(
write-to-smtp
stream
(
format
nil
"Subject: ~A"
(
q-encode-str
subject
))
)
(
write-to-smtp
stream
(
format
nil
"X-Mailer: cl-smtp ~A"
*x-mailer*
))
(
q-encode-str
*x-mailer*
))
)
(
when
reply-to
(
write-to-smtp
stream
(
format
nil
"Reply-To: ~A"
reply-to
)))
(
when
(
and
extra-headers
...
...
@@ -388,7 +419,7 @@
(
defun
write-to-smtp
(
stream
command
)
(
print-debug
(
format
nil
"to server: ~A"
command
))
(
write-s
tring
command
stream
)
(
write-s
equence
command
stream
)
(
write-char
#\Return
stream
)
(
write-char
#\NewLine
stream
)
(
force-output
stream
))
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment