--- /dev/null
+2001-08-20 John Foderaro <jkf@tiger.franz.com>
+
+ * imap.cl (parse-mail-header): fix parse when a #\return was found
+ in the header. [bug11124]
+
+*******************************************************************************
+merge from trunk to acl61 branch
+command: ../../join.sh trunk acl61 trunk_to_acl61_merge1 imap
+*******************************************************************************
+
+2001-08-10 John Foderaro <jkf@tiger.franz.com>
+
+ * imap.cl - fix problems of too many #\returns in the header
+
+2001-06-26 John Foderaro <jkf@tiger.franz.com>
+
+ * imap.cl - fix typo in exported identifier
+
+2001-05-11 John Foderaro <jkf@tiger.franz.com>
+
+ * smtp.cl: add test-email-address function to check to see
+ if an email address can be determined to be bogus without
+ sending a letter.
+
+2001-05-02 John Foderaro <jkf@tiger.franz.com>
+1.8
+ * imap will signal a :response-too-large error if it encounter
+ a letter it can't store in a lisp array.
+
+2000-06-08 <jkf@CROW>
+1.7
+ * imap.cl: add parse-mail-header function to return mail headers
+ as an assoc list.
+
+2000-06-06 John Foderaro <jkf@tiger.franz.com>
+1.6
+ * imap.cl: fix header parsing bug where it go into a loop
+ when encountering a blank header.
+
+Fri May 26 22:52:42 PST 2000 Duane Rettig <duane@beta>
+
+ * makefile: set SHELL variable
+
+2000-04-26 John Foderaro <jkf@tiger.franz.com>
+
+ * package changed from post-office to net.post-office
+ the po nickname was removed.
+
+
+2000-04-21 John Foderaro <jkf@tiger.franz.com>
+versio 1.4
+ * imap.cl: added pop commands unique-id and top-lines
+ plus make-envelope-from-text
+
+ * imap.html - update document
+
+
+1999-11-29 John Foderaro <jkf@tiger.franz.com>
+version 1.3
+ * imap.cl - fixed bug where extra ^b's ended up in strings
+ * imap.html - fixed ref to wrong function
+
+1999-10-27 John Foderaro <jkf@tiger.franz.com>
+version 1.2
+
+ * imap.cl - add condtions
+ * imap.html - document conditions
+ * t-imap.cl - fix test suite
+
+
+1999-09-29 John Foderaro <jkf@tiger.franz.com>
+version 1.1
+
+ * imap.html - document send-letter, send-smtp
+ * smtp.cl - add this to the imap module
+ * t-imap.cl - adjust for the change in package
+
+
+
+1999-09-27 John Foderaro <jkf@tiger.franz.com>
+version 1.0
+ * start ChangeLog.
+ * imap.cl - the code for the imap and pop interface
+ * imap.html - the documentation
+ * t-imap.cl - the test suite
+ * rfc1939.html - pop spec
+ * rfc2060.txt - imap spec
+
+
+
--- /dev/null
+cl-smtp (1.0-1) unstable; urgency=low
+
+ * Initial Release (closes: #)
+
+ -- Kevin M. Rosenberg <kmr@debian.org> Wed, 9 Oct 2002 04:30:08 -0600
+
--- /dev/null
+Source: cl-postoffice
+Section: devel
+Priority: optional
+Maintainer: Kevin M. Rosenberg <kmr@debian.org>
+Build-Depends: debhelper (>= 4.0.0)
+Standards-Version: 3.5.7.0
+
+Package: cl-postoffice
+Architecture: all
+Depends: ${shlibs:Depends}, cl-acl-compat
+Description: SMTP, POP, & IMAP interface library for Common Lisp Programs
+ This is a Franz's open-source Postoffice package which includes
+ libraries for SMTP, POP, and IMAP clients. This package uses the
+ ACL-COMPAT module for operation on non-Allegro Common Lisp implementations.
--- /dev/null
+This package was debianized by Kevin M. Rosenberg <kmr@debian.org> on
+Wed, 9 Oct 2002 04:30:08 -0600.
+
+It was downloaded from http://opensource.franz.com/smtp/
+
+Upstream Author(s): Franz, Inc.
+
+Changes compared to upstream version:
+ Use ACL-COMPAT socket routines
+
+
+Copyright (c) 1986-2000 Franz Inc, Berkeley, CA
+
+This code is free software; you can redistribute it and/or modify it
+under the terms of the version 2.1 of the GNU Lesser General Public
+License as published by the Free Software Foundation, as clarified by
+the Franz preamble to the LGPL found in
+http://opensource.franz.com/preamble.html. The preambled is copied below.
+
+This code is distributed in the hope that it will be useful,
+but without any warranty; without even the implied warranty of
+merchantability or fitness for a particular purpose. See the GNU
+Lesser General Public License for more details.
+
+The GNU Lessor General Public License can be found in your Debian file
+system in /usr/share/common-licenses/LGPL.
+
+Preamble to the Gnu Lesser General Public License
+-------------------------------------------------
+Copyright (c) 2000 Franz Incorporated, Berkeley, CA 94704
+
+The concept of the GNU Lesser General Public License version 2.1
+("LGPL") has been adopted to govern the use and distribution of
+above-mentioned application. However, the LGPL uses terminology that
+is more appropriate for a program written in C than one written in
+Lisp. Nevertheless, the LGPL can still be applied to a Lisp program if
+certain clarifications are made. This document details those
+clarifications. Accordingly, the license for the open-source Lisp
+applications consists of this document plus the LGPL. Wherever there
+is a conflict between this document and the LGPL, this document takes
+precedence over the LGPL.
+
+A "Library" in Lisp is a collection of Lisp functions, data and
+foreign modules. The form of the Library can be Lisp source code (for
+processing by an interpreter) or object code (usually the result of
+compilation of source code or built with some other
+mechanisms). Foreign modules are object code in a form that can be
+linked into a Lisp executable. When we speak of functions we do so in
+the most general way to include, in addition, methods and unnamed
+functions. Lisp "data" is also a general term that includes the data
+structures resulting from defining Lisp classes. A Lisp application
+may include the same set of Lisp objects as does a Library, but this
+does not mean that the application is necessarily a "work based on the
+Library" it contains.
+
+The Library consists of everything in the distribution file set before
+any modifications are made to the files. If any of the functions or
+classes in the Library are redefined in other files, then those
+redefinitions ARE considered a work based on the Library. If
+additional methods are added to generic functions in the Library,
+those additional methods are NOT considered a work based on the
+Library. If Library classes are subclassed, these subclasses are NOT
+considered a work based on the Library. If the Library is modified to
+explicitly call other functions that are neither part of Lisp itself
+nor an available add-on module to Lisp, then the functions called by
+the modified Library ARE considered a work based on the Library. The
+goal is to ensure that the Library will compile and run without
+getting undefined function errors.
+
+It is permitted to add proprietary source code to the Library, but it
+must be done in a way such that the Library will still run without
+that proprietary code present. Section 5 of the LGPL distinguishes
+between the case of a library being dynamically linked at runtime and
+one being statically linked at build time. Section 5 of the LGPL
+states that the former results in an executable that is a "work that
+uses the Library." Section 5 of the LGPL states that the latter
+results in one that is a "derivative of the Library", which is
+therefore covered by the LGPL. Since Lisp only offers one choice,
+which is to link the Library into an executable at build time, we
+declare that, for the purpose applying the LGPL to the Library, an
+executable that results from linking a "work that uses the Library"
+with the Library is considered a "work that uses the Library" and is
+therefore NOT covered by the LGPL.
+
+Because of this declaration, section 6 of LGPL is not applicable to
+the Library. However, in connection with each distribution of this
+executable, you must also deliver, in accordance with the terms and
+conditions of the LGPL, the source code of Library (or your derivative
+thereof) that is incorporated into this executable.
+
--- /dev/null
+#! /bin/sh
+# postinst script for postoffice
+#
+# see: dh_installdeb(1)
+
+set -e
+
+# package name according to lisp
+LISP_PKG=postoffice
+
+# summary of how this script can be called:
+# * <postinst> `configure' <most-recently-configured-version>
+# * <old-postinst> `abort-upgrade' <new version>
+# * <conflictor's-postinst> `abort-remove' `in-favour' <package>
+# <new-version>
+# * <deconfigured's-postinst> `abort-deconfigure' `in-favour'
+# <failed-install-package> <version> `removing'
+# <conflicting-package> <version>
+# for details, see http://www.debian.org/doc/debian-policy/ or
+# the debian-policy package
+#
+# quoting from the policy:
+# Any necessary prompting should almost always be confined to the
+# post-installation script, and should be protected with a conditional
+# so that unnecessary prompting doesn't happen if a package's
+# installation fails and the `postinst' is called with `abort-upgrade',
+# `abort-remove' or `abort-deconfigure'.
+
+case "$1" in
+ configure)
+ #clc-only-compatible $LISP_PKG allegro cmucl lispworks openmcl
+ /usr/sbin/register-common-lisp-source $LISP_PKG
+ ;;
+
+ abort-upgrade|abort-remove|abort-deconfigure)
+
+ ;;
+
+ *)
+ echo "postinst called with unknown argument \`$1'" >&2
+ exit 1
+ ;;
+esac
+
+# dh_installdeb will replace this with shell code automatically
+# generated by other debhelper scripts.
+
+#DEBHELPER#
+
+exit 0
+
+
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: postoffice.asd
+;;;; Purpose: ASDF definition file for Postoffice
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Sep 2002
+;;;;
+;;;; $Id: postoffice.asd,v 1.1 2002/10/09 14:25:14 kevin Exp $
+;;;;
+;;;; This file, part of cl-postoffice, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; cl-postoffice users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU Lesser General Public License
+;;;; (http://www.gnu.org/licenses/lgpl.html)
+;;;; *************************************************************************
+
+(in-package :asdf)
+
+(defsystem :postoffice
+ :name "cl-postoffice"
+ :author "Kevin Layer, Franz, Inc"
+ :version "2.2.12.2.6.1"
+ :maintainer "Kevin M. Rosenberg <kmr@debian.org>"
+ :licence "GNU Lesser General Public License"
+ :description "Franz's Post Office Package"
+ :long-description "Post Office provides an interface to the SMTP, POP, and IMAP servers. It uses the ACL-COMPAT library for use with non-Allegro CL implementations."
+
+ :perform (load-op :after (op postoffice)
+ (pushnew :postoffice cl:*features*))
+
+ :components
+ ((:file "smtp")
+ (:file "imap"))
+ #-allegro :depends-on #-allegro (:acl-compat)
+ )
+
+(when (ignore-errors (find-class 'load-compiled-op))
+ (defmethod perform :after ((op load-compiled-op) (c (eql (find-system :postoffice))))
+ (pushnew :postoffice cl:*features*)))
+
--- /dev/null
+#! /bin/sh
+# prerm script for postoffice
+#
+# see: dh_installdeb(1)
+
+set -e
+
+# package name according to lisp
+LISP_PKG=postoffice
+
+# summary of how this script can be called:
+# * <prerm> `remove'
+# * <old-prerm> `upgrade' <new-version>
+# * <new-prerm> `failed-upgrade' <old-version>
+# * <conflictor's-prerm> `remove' `in-favour' <package> <new-version>
+# * <deconfigured's-prerm> `deconfigure' `in-favour'
+# <package-being-installed> <version> `removing'
+# <conflicting-package> <version>
+# for details, see http://www.debian.org/doc/debian-policy/ or
+# the debian-policy package
+
+
+case "$1" in
+ remove|upgrade|deconfigure)
+ /usr/sbin/unregister-common-lisp-source $LISP_PKG
+ ;;
+ failed-upgrade)
+ ;;
+ *)
+ echo "prerm called with unknown argument \`$1'" >&2
+ exit 1
+ ;;
+esac
+
+# dh_installdeb will replace this with shell code automatically
+# generated by other debhelper scripts.
+
+#DEBHELPER#
+
+exit 0
+
+
--- /dev/null
+#!/usr/bin/make -f
+
+export DH_COMPAT=4
+
+pkg := postoffice
+debpkg := cl-postoffice
+
+
+clc-source := usr/share/common-lisp/source
+clc-systems := usr/share/common-lisp/systems
+clc-postoffice := $(clc-source)/$(pkg)
+
+doc-dir := usr/share/doc/$(debpkg)
+
+
+configure: configure-stamp
+configure-stamp:
+ dh_testdir
+ # Add here commands to configure the package.
+ touch configure-stamp
+
+
+build: build-stamp
+
+build-stamp: configure-stamp
+ dh_testdir
+ # Add here commands to compile the package.
+ touch build-stamp
+
+clean:
+ dh_testdir
+ dh_testroot
+ rm -f build-stamp configure-stamp
+ # Add here commands to clean up after the build process.
+ rm -f debian/cl-postoffice.postinst.* debian/cl-postoffice.prerm.*
+ dh_clean
+
+install: build
+ dh_testdir
+ dh_testroot
+ dh_clean -k
+ # Add here commands to install the package into debian/postoffice.
+ dh_installdirs $(clc-systems) $(clc-postoffice) $(doc-dir)
+ dh_install debian/postoffice.asd $(shell echo *.lisp) $(clc-postoffice)
+ dh_link $(clc-postoffice)/postoffice.asd $(clc-systems)/postoffice.asd
+
+# Build architecture-independent files here.
+binary-indep: build install
+
+
+# Build architecture-dependent files here.
+binary-arch: build install
+ dh_testdir
+ dh_testroot
+# dh_installdebconf
+ dh_installdocs
+# dh_installmenu
+# dh_installlogrotate
+# dh_installemacsen
+# dh_installpam
+# dh_installmime
+# dh_installinit
+# dh_installcron
+# dh_installman
+# dh_installinfo
+# dh_undocumented
+ dh_installchangelogs
+ dh_strip
+ dh_compress
+ dh_fixperms
+# dh_makeshlibs
+ dh_installdeb
+# dh_perl
+ dh_shlibdeps
+ dh_gencontrol
+ dh_md5sums
+ dh_builddeb
+
+binary: binary-indep binary-arch
+.PHONY: build clean binary-indep binary-arch binary install configure
+
--- /dev/null
+;; -*- mode: common-lisp; package: net.post-office -*-
+;;
+;; imap.cl
+;; imap and pop interface
+;;
+;; copyright (c) 1999 Franz Inc, Berkeley, CA - All rights reserved.
+;;
+;; The software, data and information contained herein are proprietary
+;; to, and comprise valuable trade secrets of, Franz, Inc. They are
+;; given in confidence by Franz, Inc. pursuant to a written license
+;; agreement, and may be stored and used only in accordance with the terms
+;; of such license.
+;;
+;; Restricted Rights Legend
+;; ------------------------
+;; Use, duplication, and disclosure of the software, data and information
+;; contained herein by any agency, department or entity of the U.S.
+;; Government are subject to restrictions of Restricted Rights for
+;; Commercial Software developed at private expense as specified in
+;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
+;;
+;; $Id: imap.cl,v 1.1 2002/10/09 14:26:11 kevin Exp $
+
+;; Description:
+;;
+;;
+;;- This code in this file obeys the Lisp Coding Standard found in
+;;- http://www.franz.com/~jkf/coding_standards.html
+;;-
+
+
+(defpackage :net.post-office
+ (:use :lisp :excl)
+ (:export
+ #:address-name
+ #:address-additional
+ #:address-mailbox
+ #:address-host
+
+ #:alter-flags
+ #:close-connection
+ #:close-mailbox
+ #:copy-to-mailbox
+ #:create-mailbox
+ #:delete-letter
+ #:delete-mailbox
+
+ #:envelope-date
+ #:envelope-subject
+ #:envelope-from
+ #:envelope-sender
+ #:envelope-reply-to
+ #:envelope-to
+ #:envelope-cc
+ #:envelope-bcc
+ #:envelope-in-reply-to
+ #:envelope-message-id
+
+ #:expunge-mailbox
+ #:fetch-field
+ #:fetch-letter
+ #:fetch-parts
+ #:*imap-version-number*
+ #:make-envelope-from-text
+ #:mailbox-flags ; accessor
+ #:mailbox-permanent-flags ; acc
+ #:mailbox-list
+ #:mailbox-list-flags
+ #:mailbox-list-separator
+ #:mailbox-list-name
+ #:mailbox-message-count ; accessor
+ #:mailbox-recent-messages ; ac
+ #:mailbox-separator ; accessor
+ #:mailbox-uidvalidity
+ #:make-imap-connection
+ #:make-pop-connection
+ #:noop
+ #:parse-mail-header
+ #:top-lines ; pop only
+ #:unique-id ; pop only
+
+ #:po-condition
+ #:po-condition-identifier
+ #:po-condition-server-string
+ #:po-error
+
+ #:rename-mailbox
+ #:search-mailbox
+ #:select-mailbox
+
+ )
+ )
+
+(in-package :net.post-office)
+
+(provide :imap)
+
+(defparameter *imap-version-number* '(:major 1 :minor 8)) ; major.minor
+
+;; todo
+;; have the list of tags selected done on a per connection basis to
+;; eliminate any possible multithreading problems
+;;
+;;
+
+(defvar *debug-imap* nil)
+
+
+
+
+
+(defclass post-office ()
+ ((socket :initarg :socket
+ :accessor post-office-socket)
+
+ (host :initarg :host
+ :accessor post-office-host
+ :initform nil)
+ (user :initarg :user
+ :accessor post-office-user
+ :initform nil)
+
+ (state :accessor post-office-state
+ :initarg :state
+ :initform :unconnected)
+
+ (timeout
+ ;; time to wait for network activity for actions that should
+ ;; happen very quickly when things are operating normally
+ :initarg :timeout
+ :initform 60
+ :accessor timeout)
+ ))
+
+(defclass imap-mailbox (post-office)
+ ((mailbox-name ; currently selected mailbox
+ :accessor mailbox-name
+ :initform nil)
+
+ (separator
+ ;; string that separates mailbox names in the hierarchy
+ :accessor mailbox-separator
+ :initform "")
+
+ ;;; these slots hold information about the currently selected mailbox:
+
+ (message-count ; how many in the mailbox
+ :accessor mailbox-message-count
+ :initform 0)
+
+ (recent-messages ; how many messages since we last checked
+ :accessor mailbox-recent-messages
+ :initform 0)
+
+ (uidvalidity ; used to denote messages uniquely
+ :accessor mailbox-uidvalidity
+ :initform 0)
+
+ (uidnext
+ :accessor mailbox-uidnext ;; predicted next uid
+ :initform 0)
+
+ (flags ; list of flags that can be stored in a message
+ :accessor mailbox-flags
+ :initform nil)
+
+ (permanent-flags ; list of flags that be stored permanently
+ :accessor mailbox-permanent-flags
+ :initform nil)
+
+ (first-unseen ; number of the first unseen message
+ :accessor first-unseen
+ :initform 0)
+
+ ;;; end list of values for the currently selected mailbox
+ )
+ )
+
+
+(defclass pop-mailbox (post-office)
+ ((message-count ; how many in the mailbox
+ :accessor mailbox-message-count
+ :initform 0)))
+
+
+
+(defstruct (mailbox-list (:type list))
+ ;; a list of these are returned by mailbox-list
+ flags
+ separator
+ name)
+
+
+
+(defstruct (envelope (:type list))
+ ;; returned by fetch-letter as the value of the envelope property
+ date
+ subject
+ from
+ sender
+ reply-to
+ to
+ cc
+ bcc
+ in-reply-to
+ message-id)
+
+
+(defstruct (address (:type list))
+ name ;; often the person's full name
+ additional
+ mailbox ;; the login name
+ host ;; the name of the machine
+ )
+
+
+
+;--------------------------------
+; conditions
+;
+; We define a set of conditions that are signalled due to events
+; in the imap interface.
+; Each condition has an indentifier which is a keyword. That can
+; be used in the handling code to identify the class of error.
+; All our conditions are po-condition or po-error (which is a subclass of
+; po-condition).
+;
+; A condition will have a server-string value if it as initiated by
+; something returned by the server.
+; A condition will have a format-control value if we want to display
+; something we generated in response to
+;
+;
+;
+;; identifiers used in conditions/errors
+
+; :problem condition
+; the server responded with 'no' followed by an explanation.
+; this mean that something unusual happend and doesn't necessarily
+; mean that the command has completely failed (but it might).
+;
+; :unknown-ok condition
+; the server responded with an 'ok' followed by something
+; we don't recognize. It's probably safe to ignore this.
+;
+; :unknown-untagged condition
+; the server responded with some untagged command we don't
+; recognize. it's probaby ok to ignore this.
+;
+; :error-response error
+; the command failed.
+;
+; :syntax-error error
+; the data passed to a function in this interface was malformed
+;
+; :unexpected error
+; the server responded an unexpected way.
+;
+; :server-shutdown-connection error
+; the server has shut down the connection, don't attempt to
+; send any more commands to this connection, or even close it.
+;
+; :timeout error
+; server failed to respond within the timeout period
+;
+; :response-too-large error
+; contents of a response is too large to store in a Lisp array.
+
+
+;; conditions
+(define-condition po-condition ()
+ ;; used to notify user of things that shouldn't necessarily stop
+ ;; program flow
+ ((identifier
+ ;; keyword identifying the error (or :unknown)
+ :reader po-condition-identifier
+ :initform :unknown
+ :initarg :identifier
+ )
+ (server-string
+ ;; message from the imap server
+ :reader po-condition-server-string
+ :initform ""
+ :initarg :server-string
+ ))
+ (:report
+ (lambda (con stream)
+ (with-slots (identifier server-string) con
+ ;; a condition either has a server-string or it has a
+ ;; format-control string
+ (format stream "Post Office condition: ~s~%" identifier)
+ (if* (and (slot-boundp con 'excl::format-control)
+ (excl::simple-condition-format-control con))
+ then (apply #'format stream
+ (excl::simple-condition-format-control con)
+ (excl::simple-condition-format-arguments con)))
+ (if* server-string
+ then (format stream
+ "~&Message from server: ~s"
+ (string-left-trim " " server-string)))))))
+
+
+
+(define-condition po-error (po-condition error)
+ ;; used to denote things that should stop program flow
+ ())
+
+
+
+;; aignalling the conditions
+
+(defun po-condition (identifier &key server-string format-control
+ format-arguments)
+ (signal (make-instance 'po-condition
+ :identifier identifier
+ :server-string server-string
+ :format-control format-control
+ :format-arguments format-arguments
+ )))
+
+(defun po-error (identifier &key server-string
+ format-control format-arguments)
+ (error (make-instance 'po-error
+ :identifier identifier
+ :server-string server-string
+ :format-control format-control
+ :format-arguments format-arguments)))
+
+
+
+;----------------------------------------------
+
+
+
+
+
+
+(defparameter *imap-tags* '("t01" "t02" "t03" "t04" "t05" "t06" "t07"))
+(defvar *cur-imap-tags* nil)
+
+(defvar *crlf*
+ (let ((str (make-string 2)))
+ (setf (aref str 0) #\return)
+ (setf (aref str 1) #\linefeed)
+ str))
+
+(defun make-imap-connection (host &key (port 143)
+ user
+ password
+ (timeout 30))
+ (let* ((sock (socket:make-socket :remote-host host
+ :remote-port port))
+ (imap (make-instance 'imap-mailbox
+ :socket sock
+ :host host
+ :timeout timeout
+ :state :unauthorized)))
+
+ (multiple-value-bind (tag cmd count extra comment)
+ (get-and-parse-from-imap-server imap)
+ (declare (ignore cmd count extra))
+ (if* (not (eq :untagged tag))
+ then (po-error :error-response
+ :server-string comment)))
+
+ ; now login
+ (send-command-get-results imap
+ (format nil "login ~a ~a" user password)
+ #'handle-untagged-response
+ #'(lambda (mb command count extra comment)
+ (check-for-success mb command count extra
+ comment
+ "login")))
+
+ ; find the separator character
+ (let ((res (mailbox-list imap)))
+ ;;
+ (let ((sep (cadr (car res))))
+ (if* sep
+ then (setf (mailbox-separator imap) sep))))
+
+
+
+ imap))
+
+
+(defmethod close-connection ((mb imap-mailbox))
+
+ (let ((sock (post-office-socket mb)))
+ (if* sock
+ then (ignore-errors
+ (send-command-get-results
+ mb
+ "logout"
+ ; don't want to get confused by untagged
+ ; bye command, which is expected here
+ #'(lambda (mb command count extra)
+ (declare (ignore mb command count extra))
+ nil)
+ #'(lambda (mb command count extra comment)
+ (check-for-success mb command count extra
+ comment
+ "logout")))))
+ (setf (post-office-socket mb) nil)
+ (if* sock then (ignore-errors (close sock)))
+ t))
+
+
+(defmethod close-connection ((pb pop-mailbox))
+ (let ((sock (post-office-socket pb)))
+ (if* sock
+ then (ignore-errors
+ (send-pop-command-get-results
+ pb
+ "QUIT")))
+ (setf (post-office-socket pb) nil)
+ (if* sock then (ignore-errors (close sock)))
+ t))
+
+
+
+(defun make-pop-connection (host &key (port 110)
+ user
+ password
+ (timeout 30))
+ (let* ((sock (socket:make-socket :remote-host host
+ :remote-port port))
+ (pop (make-instance 'pop-mailbox
+ :socket sock
+ :host host
+ :timeout timeout
+ :state :unauthorized)))
+
+ (multiple-value-bind (result)
+ (get-and-parse-from-pop-server pop)
+ (if* (not (eq :ok result))
+ then (po-error :error-response
+ :format-control
+ "unexpected line from server after connect")))
+
+ ; now login
+ (send-pop-command-get-results pop (format nil "user ~a" user))
+ (send-pop-command-get-results pop (format nil "pass ~a" password))
+
+ (let ((res (send-pop-command-get-results pop "stat")))
+ (setf (mailbox-message-count pop) (car res)))
+
+
+
+ pop))
+
+
+(defmethod send-command-get-results ((mb imap-mailbox)
+ command untagged-handler tagged-handler)
+ ;; send a command and retrieve results until we get the tagged
+ ;; response for the command we sent
+ ;;
+ (let ((tag (get-next-tag)))
+ (format (post-office-socket mb)
+ "~a ~a~a" tag command *crlf*)
+ (force-output (post-office-socket mb))
+
+ (if* *debug-imap*
+ then (format t
+ "~a ~a~a" tag command *crlf*)
+ (force-output))
+ (loop
+ (multiple-value-bind (got-tag cmd count extra comment)
+ (get-and-parse-from-imap-server mb)
+ (if* (eq got-tag :untagged)
+ then (funcall untagged-handler mb cmd count extra comment)
+ elseif (equal tag got-tag)
+ then (funcall tagged-handler mb cmd count extra comment)
+ (return)
+ else (po-error :error-response
+ :format-control "received tag ~s out of order"
+ :format-arguments (list got-tag)
+ :server-string comment))))))
+
+
+(defun get-next-tag ()
+ (let ((tag (pop *cur-imap-tags*)))
+ (if* tag
+ thenret
+ else (setq *cur-imap-tags* *imap-tags*)
+ (pop *cur-imap-tags*))))
+
+(defun handle-untagged-response (mb command count extra comment)
+ ;; default function to handle untagged responses, which are
+ ;; really just returning general state information about
+ ;; the mailbox
+ (case command
+ (:exists (setf (mailbox-message-count mb) count))
+ (:recent (setf (mailbox-recent-messages mb) count))
+ (:flags (setf (mailbox-flags mb) (mapcar #'kwd-intern extra)))
+ (:bye ; occurs when connection times out or mailbox lock is stolen
+ (ignore-errors (close (post-office-socket mb)))
+ (po-error :server-shutdown-connection
+ :server-string "server shut down the connection"))
+ (:no ; used when grabbing a lock from another process
+ (po-condition :problem :server-string comment))
+ (:ok ; a whole variety of things
+ (if* extra
+ then (if* (equalp (car extra) "unseen")
+ then (setf (first-unseen mb) (cadr extra))
+ elseif (equalp (car extra) "uidvalidity")
+ then (setf (mailbox-uidvalidity mb) (cadr extra))
+ elseif (equalp (car extra) "uidnext")
+ then (setf (mailbox-uidnext mb) (cadr extra))
+ elseif (equalp (car extra) "permanentflags")
+ then (setf (mailbox-permanent-flags mb)
+ (mapcar #'kwd-intern (cadr extra)))
+ else (po-condition :unknown-ok :server-string comment))))
+ (t (po-condition :unknown-untagged :server-string comment)))
+
+ )
+
+
+
+(defun send-pop-command-get-results (pop command &optional extrap)
+ ;; send the given command to the pop server
+ ;; if extrap is true and if the response is +ok, then data
+ ;; will follow the command (up to and excluding the first line consisting
+ ;; of just a period)
+ ;;
+ ;; if the pop server returns an error code we signal a lisp error.
+ ;; otherwise
+ ;; return
+ ;; extrap is nil -- return the list of tokens on the line after +ok
+ ;; extrap is true -- return the extra object (a big string)
+ ;;
+ (format (post-office-socket pop) "~a~a" command *crlf*)
+ (force-output (post-office-socket pop))
+
+ (if* *debug-imap*
+ then (format t "~a~a" command *crlf*)
+ (force-output t))
+
+ (multiple-value-bind (result parsed line)
+ (get-and-parse-from-pop-server pop)
+ (if* (not (eq result :ok))
+ then (po-error :error-response
+ :server-string line))
+
+ (if* extrap
+ then ;; get the rest of the data
+ ;; many but not all pop servers return the size of the data
+ ;; after the +ok, so we use that to initially size the
+ ;; retreival buffer.
+ (let ((buf (get-line-buffer (+ (if* (fixnump (car parsed))
+ then (car parsed)
+ else 2048 ; reasonable size
+ )
+ 50)))
+ (pos 0)
+ ; states
+ ; 1 - after lf
+ ; 2 - seen dot at beginning of line
+ ; 3 - seen regular char on line
+ (state 1)
+ (sock (post-office-socket pop)))
+ (flet ((add-to-buffer (ch)
+ (if* (>= pos (length buf))
+ then ; grow buffer
+ (if* (>= (length buf)
+ (1- array-total-size-limit))
+ then ; can't grow it any further
+ (po-error
+ :response-too-large
+ :format-control
+ "response from mail server is too large to hold in a lisp array"))
+ (let ((new-buf (get-line-buffer
+ (* (length buf) 2))))
+ (init-line-buffer new-buf buf)
+ (free-line-buffer buf)
+ (setq buf new-buf)))
+ (setf (schar buf pos) ch)
+ (incf pos)))
+ (loop
+ (let ((ch (read-char sock nil nil)))
+ (if* (null ch)
+ then (po-error :unexpected
+ :format-control "premature end of file from server"))
+ (if* (eq ch #\return)
+ thenret ; ignore crs
+ else (case state
+ (1 (if* (eq ch #\.)
+ then (setq state 2)
+ elseif (eq ch #\linefeed)
+ then (add-to-buffer ch)
+ ; state stays at 1
+ else (add-to-buffer ch)
+ (setq state 3)))
+ (2 ; seen first dot
+ (if* (eq ch #\linefeed)
+ then ; end of message
+ (return)
+ else (add-to-buffer ch)
+ (setq state 3)))
+ (3 ; normal reading
+ (add-to-buffer ch)
+ (if* (eq ch #\linefeed)
+ then (setq state 1))))))))
+ (prog1 (subseq buf 0 pos)
+ (free-line-buffer buf)))
+ else parsed)))
+
+
+
+
+(defun convert-flags-plist (plist)
+ ;; scan the plist looking for "flags" indicators and
+ ;; turn value into a list of symbols rather than strings
+ (do ((xx plist (cddr xx)))
+ ((null xx) plist)
+ (if* (equalp "flags" (car xx))
+ then (setf (cadr xx) (mapcar #'kwd-intern (cadr xx))))))
+
+
+(defmethod select-mailbox ((mb imap-mailbox) name)
+ ;; select the given mailbox
+ (send-command-get-results mb
+ (format nil "select ~a" name)
+ #'handle-untagged-response
+ #'(lambda (mb command count extra comment)
+ (declare (ignore mb count extra))
+ (if* (not (eq command :ok))
+ then (po-error
+ :problem
+ :format-control
+ "imap mailbox select failed"
+ :server-string comment))))
+ (setf (mailbox-name mb) name)
+ t
+ )
+
+
+(defmethod fetch-letter ((mb imap-mailbox) number &key uid)
+ ;; return the whole letter
+ (fetch-field number "body[]"
+ (fetch-parts mb number "body[]" :uid uid)
+ :uid uid))
+
+
+(defmethod fetch-letter ((pb pop-mailbox) number &key uid)
+ (declare (ignore uid))
+ (send-pop-command-get-results pb
+ (format nil "RETR ~d" number)
+ t ; extra stuff
+ ))
+
+(defmethod fetch-parts ((mb imap-mailbox) number parts &key uid)
+ (let (res)
+ (send-command-get-results
+ mb
+ (format nil "~afetch ~a ~a"
+ (if* uid then "uid " else "")
+ (message-set-string number)
+ (or parts "body[]")
+ )
+ #'(lambda (mb command count extra comment)
+ (if* (eq command :fetch)
+ then (push (list count (internalize-flags extra)) res)
+ else (handle-untagged-response
+ mb command count extra comment)))
+ #'(lambda (mb command count extra comment)
+ (declare (ignore mb count extra))
+ (if* (not (eq command :ok))
+ then (po-error :problem
+ :format-control "imap mailbox fetch failed"
+ :server-string comment))))
+ res))
+
+
+(defun fetch-field (letter-number field-name info &key uid)
+ ;; given the information from a fetch-letter, return the
+ ;; particular field for the particular letter
+ ;;
+ ;; info is as returned by fetch
+ ;; field-name is a string, case doesn't matter.
+ ;;
+ (dolist (item info)
+ ;; item is (messagenumber plist-info)
+ ;; the same messagenumber may appear in multiple items
+ (let (use-this)
+ (if* uid
+ then ; uid appears as a property in the value, not
+ ; as the top level message sequence number
+ (do ((xx (cadr item) (cddr xx)))
+ ((null xx))
+ (if* (equalp "uid" (car xx))
+ then (if* (eql letter-number (cadr xx))
+ then (return (setq use-this t))
+ else (return))))
+ else ; just a message sequence number
+ (setq use-this (eql letter-number (car item))))
+
+ (if* use-this
+ then (do ((xx (cadr item) (cddr xx)))
+ ((null xx))
+ (if* (equalp field-name (car xx))
+ then (return-from fetch-field (cadr xx))))))))
+
+
+
+(defun internalize-flags (stuff)
+ ;; given a plist like object, look for items labelled "flags" and
+ ;; convert the contents to internal flags objects
+ (do ((xx stuff (cddr xx)))
+ ((null xx))
+ (if* (equalp (car xx) "flags")
+ then (setf (cadr xx) (mapcar #'kwd-intern (cadr xx)))
+ (return)))
+
+ stuff)
+
+
+
+
+(defmethod delete-letter ((mb imap-mailbox) messages &key (expunge t) uid)
+ ;; delete all the mesasges and do the expunge to make
+ ;; it permanent if expunge is true
+ (alter-flags mb messages :add-flags :\\deleted :uid uid)
+ (if* expunge then (expunge-mailbox mb)))
+
+(defmethod delete-letter ((pb pop-mailbox) messages &key (expunge nil) uid)
+ ;; delete all the messages. We can't expunge without quitting so
+ ;; we don't expunge
+ (declare (ignore expunge uid))
+
+ (if* (or (numberp messages)
+ (and (consp messages) (eq :seq (car messages))))
+ then (setq messages (list messages)))
+
+ (if* (not (consp messages))
+ then (po-error :syntax-error
+ :format-control "expect a mesage number or list of messages, not ~s"
+ :format-arguments (list messages)))
+
+ (dolist (message messages)
+ (if* (numberp message)
+ then (send-pop-command-get-results pb
+ (format nil "DELE ~d" message))
+ elseif (and (consp message) (eq :seq (car message)))
+ then (do ((start (cadr message) (1+ start))
+ (end (caddr message)))
+ ((> start end))
+ (send-pop-command-get-results pb
+ (format nil "DELE ~d" start)))
+ else (po-error :syntax-error
+ :format-control "bad message number ~s"
+ :format-arguments (list message)))))
+
+
+
+
+
+(defmethod noop ((mb imap-mailbox))
+ ;; just poke the server... keeping it awake and checking for
+ ;; new letters
+ (send-command-get-results mb
+ "noop"
+ #'handle-untagged-response
+ #'(lambda (mb command count extra comment)
+ (check-for-success
+ mb command count extra
+ comment
+ "noop"))))
+
+
+(defmethod noop ((pb pop-mailbox))
+ ;; send the stat command instead so we can update the message count
+ (let ((res (send-pop-command-get-results pb "stat")))
+ (setf (mailbox-message-count pb) (car res)))
+ )
+
+
+(defmethod unique-id ((pb pop-mailbox) &optional message)
+ ;; if message is given, return the unique id of that
+ ;; message,
+ ;; if message is not given then return a list of lists:
+ ;; (message unique-id)
+ ;; for all messages not marked as deleted
+ ;;
+ (if* message
+ then (let ((res (send-pop-command-get-results pb
+ (format nil
+ "UIDL ~d"
+ message))))
+ (cadr res))
+ else ; get all of them
+ (let* ((res (send-pop-command-get-results pb "UIDL" t))
+ (end (length res))
+ kind
+ mnum
+ mid
+ (next 0))
+
+
+ (let ((coll))
+ (loop
+ (multiple-value-setq (kind mnum next)
+ (get-next-token res next end))
+
+ (if* (eq :eof kind) then (return))
+
+ (if* (not (eq :number kind))
+ then ; hmm. bogus
+ (po-error :unexpected
+ :format-control "uidl returned illegal message number in ~s"
+ :format-arguments (list res)))
+
+ ; now get message id
+
+ (multiple-value-setq (kind mid next)
+ (get-next-token res next end))
+
+ (if* (eq :number kind)
+ then ; looked like a number to the tokenizer,
+ ; make it a string to be consistent
+ (setq mid (format nil "~d" mid))
+ elseif (not (eq :string kind))
+ then ; didn't find the uid
+ (po-error :unexpected
+ :format-control "uidl returned illegal message id in ~s"
+ :format-arguments (list res)))
+
+ (push (list mnum mid) coll))
+
+ (nreverse coll)))))
+
+(defmethod top-lines ((pb pop-mailbox) message lines)
+ ;; return the header and the given number of top lines of the message
+
+ (let ((res (send-pop-command-get-results pb
+ (format nil
+ "TOP ~d ~d"
+ message
+ lines)
+ t ; extra
+ )))
+ res))
+
+
+
+
+
+
+(defun check-for-success (mb command count extra comment command-string )
+ (declare (ignore mb count extra))
+ (if* (not (eq command :ok))
+ then (po-error :error-response
+ :format-control "imap ~a failed"
+ :format-arguments (list command-string)
+ :server-string comment)))
+
+
+
+
+
+(defmethod mailbox-list ((mb imap-mailbox) &key (reference "") (pattern ""))
+ ;; return a list of mailbox names with respect to a given
+ (let (res)
+ (send-command-get-results mb
+ (format nil "list ~s ~s" reference pattern)
+ #'(lambda (mb command count extra comment)
+ (if* (eq command :list)
+ then (push extra res)
+ else (handle-untagged-response
+ mb command count extra
+ comment)))
+ #'(lambda (mb command count extra comment)
+ (check-for-success
+ mb command count extra
+ comment "list")))
+
+ ;; the car of each list is a set of keywords, make that so
+ (dolist (rr res)
+ (setf (car rr) (mapcar #'kwd-intern (car rr))))
+
+ res
+
+
+ ))
+
+
+(defmethod create-mailbox ((mb imap-mailbox) mailbox-name)
+ ;; create a mailbox name of the given name.
+ ;; use mailbox-separator if you want to create a hierarchy
+ (send-command-get-results mb
+ (format nil "create ~s" mailbox-name)
+ #'handle-untagged-response
+ #'(lambda (mb command count extra comment)
+ (check-for-success
+ mb command count extra
+ comment "create")))
+ t)
+
+
+(defmethod delete-mailbox ((mb imap-mailbox) mailbox-name)
+ ;; create a mailbox name of the given name.
+ ;; use mailbox-separator if you want to create a hierarchy
+ (send-command-get-results mb
+ (format nil "delete ~s" mailbox-name)
+ #'handle-untagged-response
+ #'(lambda (mb command count extra comment)
+ (check-for-success
+ mb command count extra
+ comment "delete"))))
+
+(defmethod rename-mailbox ((mb imap-mailbox) old-mailbox-name new-mailbox-name)
+ ;; create a mailbox name of the given name.
+ ;; use mailbox-separator if you want to create a hierarchy
+ (send-command-get-results mb
+ (format nil "rename ~s ~s"
+ old-mailbox-name
+ new-mailbox-name)
+ #'handle-untagged-response
+ #'(lambda (mb command count extra comment)
+ (check-for-success
+ mb command count extra
+ comment
+ "rename"))))
+
+
+
+(defmethod alter-flags ((mb imap-mailbox)
+ messages &key (flags nil flags-p)
+ add-flags remove-flags
+ silent uid)
+ ;;
+ ;; change the flags using the store command
+ ;;
+ (let (cmd val res)
+ (if* flags-p
+ then (setq cmd "flags" val flags)
+ elseif add-flags
+ then (setq cmd "+flags" val add-flags)
+ elseif remove-flags
+ then (setq cmd "-flags" val remove-flags)
+ else (return-from alter-flags nil))
+
+ (if* (atom val) then (setq val (list val)))
+
+ (send-command-get-results mb
+ (format nil "~astore ~a ~a~a ~a"
+ (if* uid then "uid " else "")
+ (message-set-string messages)
+ cmd
+ (if* silent
+ then ".silent"
+ else "")
+ (if* val
+ thenret
+ else "()"))
+ #'(lambda (mb command count extra comment)
+ (if* (eq command :fetch)
+ then (push (list count
+ (convert-flags-plist
+ extra))
+ res)
+ else (handle-untagged-response
+ mb command count extra
+ comment)))
+
+ #'(lambda (mb command count extra comment)
+ (check-for-success
+ mb command count extra
+ comment "store")))
+ res))
+
+
+(defun message-set-string (messages)
+ ;; return a string that describes the messages which may be a
+ ;; single number or a sequence of numbers
+
+ (if* (atom messages)
+ then (format nil "~a" messages)
+ else (if* (and (consp messages)
+ (eq :seq (car messages)))
+ then (format nil "~a:~a" (cadr messages) (caddr messages))
+ else (let ((str (make-string-output-stream))
+ (precomma nil))
+ (dolist (msg messages)
+ (if* precomma then (format str ","))
+ (if* (atom msg)
+ then (format str "~a" msg)
+ elseif (eq :seq (car msg))
+ then (format str
+ "~a:~a" (cadr msg) (caddr msg))
+ else (po-error :syntax-error
+ :format-control "bad message list ~s"
+ :format-arguments (list msg)))
+ (setq precomma t))
+ (get-output-stream-string str)))))
+
+
+
+
+
+
+(defmethod expunge-mailbox ((mb imap-mailbox))
+ ;; remove messages marked as deleted
+ (let (res)
+ (send-command-get-results mb
+ "expunge"
+ #'(lambda (mb command count extra
+ comment)
+ (if* (eq command :expunge)
+ then (push count res)
+ else (handle-untagged-response
+ mb command count extra
+ comment)))
+ #'(lambda (mb command count extra comment)
+ (check-for-success
+ mb command count extra
+ comment "expunge")))
+ (nreverse res)))
+
+
+
+(defmethod close-mailbox ((mb imap-mailbox))
+ ;; remove messages marked as deleted
+ (send-command-get-results mb
+ "close"
+ #'handle-untagged-response
+
+ #'(lambda (mb command count extra comment)
+ (check-for-success
+ mb command count extra
+ comment "close")))
+ t)
+
+
+
+(defmethod copy-to-mailbox ((mb imap-mailbox) message-list destination
+ &key uid)
+ (send-command-get-results mb
+ (format nil "~acopy ~a ~s"
+ (if* uid then "uid " else "")
+ (message-set-string message-list)
+ destination)
+ #'handle-untagged-response
+ #'(lambda (mb command count extra comment)
+ (check-for-success
+ mb command count extra
+ comment "copy")))
+ t)
+
+
+;; search command
+
+(defmethod search-mailbox ((mb imap-mailbox) search-expression &key uid)
+ (let (res)
+ (send-command-get-results mb
+ (format nil "~asearch ~a"
+ (if* uid then "uid " else "")
+ (build-search-string search-expression))
+ #'(lambda (mb command count extra comment)
+ (if* (eq command :search)
+ then (setq res (append res extra))
+ else (handle-untagged-response
+ mb command count extra
+ comment)))
+ #'(lambda (mb command count extra comment)
+ (check-for-success
+ mb command count extra
+ comment "search")))
+ res))
+
+
+(defmacro defsearchop (name &rest operands)
+ (if* (null operands)
+ then `(setf (get ',name 'imap-search-no-args) t)
+ else `(setf (get ',name 'imap-search-args) ',operands)))
+
+(defsearchop :all)
+(defsearchop :answered)
+(defsearchop :bcc :str)
+(defsearchop :before :date)
+(defsearchop :body :str)
+(defsearchop :cc :str)
+(defsearchop :deleted)
+(defsearchop :draft)
+(defsearchop :flagged)
+(defsearchop :from :str)
+(defsearchop :header :str :str)
+(defsearchop :keyword :flag)
+(defsearchop :larger :number)
+(defsearchop :new)
+(defsearchop :old)
+(defsearchop :on :date)
+(defsearchop :recent)
+(defsearchop :seen)
+(defsearchop :sentbefore :date)
+(defsearchop :senton :date)
+(defsearchop :sentsince :date)
+(defsearchop :since :date)
+(defsearchop :smaller :number)
+(defsearchop :subject :str)
+(defsearchop :text :str)
+(defsearchop :to :str)
+(defsearchop :uid :messageset)
+(defsearchop :unanswered)
+(defsearchop :undeleted)
+(defsearchop :undraft)
+(defsearchop :unflagged)
+(defsearchop :unkeyword :flag)
+(defsearchop :unseen)
+
+
+
+(defun build-search-string (search)
+ ;; take the lisp search form and turn it into a string that can be
+ ;; passed to imap
+
+ (if* (null search)
+ then ""
+ else (let ((str (make-string-output-stream)))
+ (bss-int search str)
+ (get-output-stream-string str))))
+
+(defun bss-int (search str)
+ ;;* it turns out that imap (on linux) is very picky about spaces....
+ ;; any extra whitespace will result in failed searches
+ ;;
+ (labels ((and-ify (srch str)
+ (let ((spaceout nil))
+ (dolist (xx srch)
+ (if* spaceout then (format str " "))
+ (bss-int xx str)
+ (setq spaceout t))))
+ (or-ify (srch str)
+ ; only binary or allowed in imap but we support n-ary
+ ; or in this interface
+ (if* (null (cdr srch))
+ then (bss-int (car srch) str)
+ elseif (cddr srch)
+ then ; over two clauses
+ (format str "or (")
+ (bss-int (car srch) str)
+ (format str ") (")
+ (or-ify (cdr srch) str)
+ (format str ")")
+ else ; 2 args
+ (format str "or (" )
+ (bss-int (car srch) str)
+ (format str ") (")
+ (bss-int (cadr srch) str)
+ (format str ")")))
+ (set-ify (srch str)
+ ;; a sequence of messages
+ (do* ((xsrch srch (cdr xsrch))
+ (val (car xsrch) (car xsrch)))
+ ((null xsrch))
+ (if* (integerp val)
+ then (format str "~s" val)
+ elseif (and (consp val)
+ (eq :seq (car val))
+ (eq 3 (length val)))
+ then (format str "~s:~s" (cadr val) (caddr val))
+ else (po-error :syntax-error
+ :format-control "illegal set format ~s"
+ :format-arguments (list val)))
+ (if* (cdr xsrch) then (format str ","))))
+ (arg-process (str args arginfo)
+ ;; process and print each arg to str
+ ;; assert (length of args and arginfo are the same)
+ (do* ((x-args args (cdr x-args))
+ (val (car x-args) (car x-args))
+ (x-arginfo arginfo (cdr x-arginfo)))
+ ((null x-args))
+ (ecase (car x-arginfo)
+ (:str
+ ; print it as a string
+ (format str " \"~a\"" (car x-args)))
+ (:date
+
+ (if* (integerp val)
+ then (setq val (universal-time-to-rfc822-date
+ val))
+ elseif (not (stringp val))
+ then (po-error :syntax-error
+ :format-control "illegal value for date search ~s"
+ :format-arguments (list val)))
+ ;; val is now a string
+ (format str " ~s" val))
+ (:number
+
+ (if* (not (integerp val))
+ then (po-error :syntax-error
+ :format-control "illegal value for number in search ~s"
+ :format-arguments (list val)))
+ (format str " ~s" val))
+ (:flag
+
+ ;; should be a symbol in the kwd package
+ (setq val (string val))
+ (format str " ~s" val))
+ (:messageset
+ (if* (numberp val)
+ then (format str " ~s" val)
+ elseif (consp val)
+ then (set-ify val str)
+ else (po-error :syntax-error
+ :format-control "illegal message set ~s"
+ :format-arguments (list val))))
+
+ ))))
+
+ (if* (symbolp search)
+ then (if* (get search 'imap-search-no-args)
+ then (format str "~a" (string-upcase
+ (string search)))
+ else (po-error :syntax-error
+ :format-control "illegal search word: ~s"
+ :format-arguments (list search)))
+ elseif (consp search)
+ then (case (car search)
+ (and (if* (null (cdr search))
+ then (bss-int :all str)
+ elseif (null (cddr search))
+ then (bss-int (cadr search) str)
+ else (and-ify (cdr search) str)))
+ (or (if* (null (cdr search))
+ then (bss-int :all str)
+ elseif (null (cddr search))
+ then (bss-int (cadr search) str)
+ else (or-ify (cdr search) str)))
+ (not (if* (not (eql (length search) 2))
+ then (po-error :syntax-error
+ :format-control "not takes one argument: ~s"
+ :format-arguments (list search)))
+ (format str "not (" )
+ (bss-int (cadr search) str)
+ (format str ")"))
+ (:seq
+ (set-ify (list search) str))
+ (t (let (arginfo)
+ (if* (and (symbolp (car search))
+ (setq arginfo (get (car search)
+ 'imap-search-args)))
+ then
+ (format str "~a" (string-upcase
+ (string (car search))))
+ (if* (not (equal (length (cdr search))
+ (length arginfo)))
+ then (po-error :syntax-error
+ :format-control "wrong number of arguments to ~s"
+ :format-arguments search))
+
+ (arg-process str (cdr search) arginfo)
+
+ elseif (integerp (car search))
+ then (set-ify search str)
+ else (po-error :syntax-error
+ :format-control "Illegal form ~s in search string"
+ :format-arguments (list search))))))
+ elseif (integerp search)
+ then ; a message number
+ (format str "~s" search)
+ else (po-error :syntax-error
+ :format-control "Illegal form ~s in search string"
+ :format-arguments (list search)))))
+
+
+
+
+
+(defun parse-mail-header (text)
+ ;; given the partial text of a mail message that includes
+ ;; at least the header part, return an assoc list of
+ ;; (header . content) items
+ ;; Note that the header is string with most likely mixed case names
+ ;; as it's conventional to capitalize header names.
+ (let ((next 0)
+ (end (length text))
+ header
+ value
+ kind
+ headers)
+ (labels ((next-header-line ()
+ ;; find the next header line return
+ ;; :eof - no more
+ ;; :start - beginning of header value, header and
+ ;; value set
+ ;; :continue - continuation of previous header line
+
+
+ (let ((state 1)
+ beginv ; charpos beginning value
+ beginh ; charpos beginning header
+ ch
+ )
+ (tagbody again
+
+ (return-from next-header-line
+
+ (loop ; for each character
+
+ (if* (>= next end)
+ then (return :eof))
+
+ (setq ch (char text next))
+ (if* (eq ch #\return)
+ thenret ; ignore return, (handle following linefeed)
+ else (case state
+ (1 ; no characters seen
+ (if* (eq ch #\linefeed)
+ then (incf next)
+ (return :eof)
+ elseif (member ch
+ '(#\space
+ #\tab))
+ then ; continuation
+ (setq state 2)
+ else (setq beginh next)
+ (setq state 3)
+ ))
+ (2 ; looking for first non blank in value
+ (if* (eq ch #\linefeed)
+ then ; empty continuation line, ignore
+ (incf next)
+ (go again)
+ elseif (not (member ch
+ (member ch
+ '(#\space
+ #\tab))))
+ then ; begin value part
+ (setq beginv next)
+ (setq state 4)))
+ (3 ; reading the header
+ (if* (eq ch #\linefeed)
+ then ; bogus header line, ignore
+ (go again)
+ elseif (eq ch #\:)
+ then (setq header
+ (subseq text beginh next))
+ (setq state 2)))
+ (4 ; looking for the end of the value
+ (if* (eq ch #\linefeed)
+ then (setq value
+ (subseq text beginv
+ (if* (eq #\return
+ (char text
+ (1- next)))
+ then (1- next)
+ else next)))
+ (incf next)
+ (return (if* header
+ then :start
+ else :continue))))))
+ (incf next)))))))
+
+
+
+ (loop ; for each header line
+ (setq header nil)
+ (if* (eq :eof (setq kind (next-header-line)))
+ then (return))
+ (case kind
+ (:start (push (cons header value) headers))
+ (:continue
+ (if* headers
+ then ; append to previous one
+ (setf (cdr (car headers))
+ (concatenate 'string (cdr (car headers))
+ " "
+ value)))))))
+ (values headers
+ (subseq text next end))))
+
+
+(defun make-envelope-from-text (text)
+ ;; given at least the headers part of a message return
+ ;; an envelope structure containing the contents
+ ;; This is useful for parsing the headers of things returned by
+ ;; a pop server
+ ;;
+ (let ((headers (parse-mail-header text)))
+
+ (make-envelope
+ :date (cdr (assoc "date" headers :test #'equalp))
+ :subject (cdr (assoc "subject" headers :test #'equalp))
+ :from (cdr (assoc "from" headers :test #'equalp))
+ :sender (cdr (assoc "sender" headers :test #'equalp))
+ :reply-to (cdr (assoc "reply-to" headers :test #'equalp))
+ :to (cdr (assoc "to" headers :test #'equalp))
+ :cc (cdr (assoc "cc" headers :test #'equalp))
+ :bcc (cdr (assoc "bcc" headers :test #'equalp))
+ :in-reply-to (cdr (assoc "in-reply-to" headers :test #'equalp))
+ :message-id (cdr (assoc "message-id" headers :test #'equalp))
+ )))
+
+
+
+
+
+
+
+
+
+
+(defmethod get-and-parse-from-imap-server ((mb imap-mailbox))
+ ;; read the next line and parse it
+ ;;
+ ;;
+ (multiple-value-bind (line count)
+ (get-line-from-server mb)
+ (if* *debug-imap*
+ then (format t "from server: ")
+ (dotimes (i count)(write-char (schar line i)))
+ (terpri)
+ (force-output))
+
+ (parse-imap-response line count)
+ ))
+
+
+
+(defmethod get-and-parse-from-pop-server ((mb pop-mailbox))
+ ;; read the next line from the pop server
+ ;;
+ ;; return 3 values:
+ ;; :ok or :error
+ ;; a list of rest of the tokens on the line
+ ;; the whole line after the +ok or -err
+
+ (multiple-value-bind (line count)
+ (get-line-from-server mb)
+
+ (if* *debug-imap*
+ then (format t "from server: " count)
+ (dotimes (i count)(write-char (schar line i)))
+ (terpri))
+
+ (parse-pop-response line count)))
+
+
+
+;; Parse and return the data from each line
+;; values returned
+;; tag -- either a string or the symbol :untagged
+;; command -- a keyword symbol naming the command, like :ok
+;; count -- a number which preceeded the command, or nil if
+;; there wasn't a command
+;; bracketted - a list of objects found in []'s after the command
+;; or in ()'s after the command or sometimes just
+;; out in the open after the command (like the search)
+;; comment -- the whole of the part after the command
+;;
+(defun parse-imap-response (line end)
+ (let (kind value next
+ tag count command extra-data
+ comment)
+
+ ;; get tag
+ (multiple-value-setq (kind value next)
+ (get-next-token line 0 end))
+
+ (case kind
+ (:string (setq tag (if* (equal value "*")
+ then :untagged
+ else value)))
+ (t (po-error :unexpected
+ :format-control "Illegal tag on response: ~s"
+ :format-arguments (list (subseq line 0 count))
+ :server-string (subseq line 0 end)
+ )))
+
+ ;; get command
+ (multiple-value-setq (kind value next)
+ (get-next-token line next end))
+
+ (tagbody again
+ (case kind
+ (:number (setq count value)
+ (multiple-value-setq (kind value next)
+ (get-next-token line next end))
+ (go again))
+ (:string (setq command (kwd-intern value)))
+ (t (po-error :unexpected
+ :format-control "Illegal command on response: ~s"
+ :format-arguments (list (subseq line 0 count))
+ :server-string (subseq line 0 end)))))
+
+ (setq comment (subseq line next end))
+
+ ;; now the part after the command... this gets tricky
+ (loop
+ (multiple-value-setq (kind value next)
+ (get-next-token line next end))
+
+ (case kind
+ ((:lbracket :lparen)
+ (multiple-value-setq (kind value next)
+ (get-next-sexpr line (1- next) end))
+ (case kind
+ (:sexpr (push value extra-data))
+ (t (po-error :syntax-error :format-control "bad sexpr form"))))
+ (:eof (return nil))
+ ((:number :string :nil) (push value extra-data))
+ (t ; should never happen
+ (return)))
+
+ (if* (not (member command '(:list :search) :test #'eq))
+ then ; only one item returned
+ (setq extra-data (car extra-data))
+ (return)))
+
+ (if* (member command '(:list :search) :test #'eq)
+ then (setq extra-data (nreverse extra-data)))
+
+
+ (values tag command count extra-data comment)))
+
+
+
+(defun get-next-sexpr (line start end)
+ ;; read a whole s-expression
+ ;; return 3 values
+ ;; kind -- :sexpr or :rparen or :rbracket
+ ;; value - the sexpr value
+ ;; next - next charpos to scan
+ ;;
+ (let ( kind value next)
+ (multiple-value-setq (kind value next) (get-next-token line start end))
+
+ (case kind
+ ((:string :number :nil)
+ (values :sexpr value next))
+ (:eof (po-error :syntax-error
+ :format-control "eof inside sexpr"))
+ ((:lbracket :lparen)
+ (let (res)
+ (loop
+ (multiple-value-setq (kind value next)
+ (get-next-sexpr line next end))
+ (case kind
+ (:sexpr (push value res))
+ ((:rparen :rbracket)
+ (return (values :sexpr (nreverse res) next)))
+ (t (po-error :syntax-error
+ :format-control "bad sexpression"))))))
+ ((:rbracket :rparen)
+ (values kind nil next))
+ (t (po-error :syntax-error
+ :format-control "bad sexpression")))))
+
+
+(defun parse-pop-response (line end)
+ ;; return 3 values:
+ ;; :ok or :error
+ ;; a list of rest of the tokens on the line, the tokens
+ ;; being either strings or integers
+ ;; the whole line after the +ok or -err
+ ;;
+ (let (res lineres result)
+ (multiple-value-bind (kind value next)
+ (get-next-token line 0 end)
+
+ (case kind
+ (:string (setq result (if* (equal "+OK" value)
+ then :ok
+ else :error)))
+ (t (po-error :unexpected
+ :format-control "bad response from server"
+ :server-string (subseq line 0 end))))
+
+ (setq lineres (subseq line next end))
+
+ (loop
+ (multiple-value-setq (kind value next)
+ (get-next-token line next end))
+
+ (case kind
+ (:eof (return))
+ ((:string :number) (push value res))))
+
+ (values result (nreverse res) lineres))))
+
+
+
+
+
+
+
+
+
+
+(defparameter *char-to-kind*
+ (let ((arr (make-array 256 :initial-element nil)))
+
+ (do ((i #.(char-code #\0) (1+ i)))
+ ((> i #.(char-code #\9)))
+ (setf (aref arr i) :number))
+
+ (setf (aref arr #.(char-code #\space)) :space)
+ (setf (aref arr #.(char-code #\tab)) :space)
+ (setf (aref arr #.(char-code #\return)) :space)
+ (setf (aref arr #.(char-code #\linefeed)) :space)
+
+ (setf (aref arr #.(char-code #\[)) :lbracket)
+ (setf (aref arr #.(char-code #\])) :rbracket)
+ (setf (aref arr #.(char-code #\()) :lparen)
+ (setf (aref arr #.(char-code #\))) :rparen)
+ (setf (aref arr #.(char-code #\")) :dquote)
+
+ (setf (aref arr #.(char-code #\^b)) :big-string) ; our own invention
+
+ arr))
+
+
+(defun get-next-token (line start end)
+ ;; scan past whitespace for the next token
+ ;; return three values:
+ ;; kind: :string , :number, :eof, :lbracket, :rbracket,
+ ;; :lparen, :rparen
+ ;; value: the value, either a string or number or nil
+ ;; next: the character pos to start scanning for the next token
+ ;;
+ (let (ch chkind colstart (count 0) (state :looking)
+ collector right-bracket-is-normal)
+ (loop
+ ; pick up the next character
+ (if* (>= start end)
+ then (if* (eq state :looking)
+ then (return (values :eof nil start))
+ else (setq ch #\space))
+ else (setq ch (schar line start)))
+
+ (setq chkind (aref *char-to-kind* (char-code ch)))
+
+ (case state
+ (:looking
+ (case chkind
+ (:space nil)
+ (:number (setq state :number)
+ (setq colstart start)
+ (setq count (- (char-code ch) #.(char-code #\0))))
+ ((:lbracket :lparen :rbracket :rparen)
+ (return (values chkind nil (1+ start))))
+ (:dquote
+ (setq collector (make-array 10
+ :element-type 'character
+ :adjustable t
+ :fill-pointer 0))
+ (setq state :qstring))
+ (:big-string
+ (setq colstart (1+ start))
+ (setq state :big-string))
+ (t (setq colstart start)
+ (setq state :literal))))
+ (:number
+ (case chkind
+ ((:space :lbracket :lparen :rbracket :rparen
+ :dquote) ; end of number
+ (return (values :number count start)))
+ (:number ; more number
+ (setq count (+ (* count 10)
+ (- (char-code ch) #.(char-code #\0)))))
+ (t ; turn into an literal
+ (setq state :literal))))
+ (:literal
+ (case chkind
+ ((:space :rbracket :lparen :rparen :dquote) ; end of literal
+ (if* (and (eq chkind :rbracket)
+ right-bracket-is-normal)
+ then nil ; don't stop now
+ else (let ((seq (subseq line colstart start)))
+ (if* (equal "NIL" seq)
+ then (return (values :nil
+ nil
+ start))
+ else (return (values :string
+ seq
+ start))))))
+ (t (if* (eq chkind :lbracket)
+ then ; imbedded left bracket so right bracket isn't
+ ; a break char
+ (setq right-bracket-is-normal t))
+ nil)))
+ (:qstring
+ ;; quoted string
+ ; (format t "start is ~s kind is ~s~%" start chkind)
+ (case chkind
+ (:dquote
+ ;; end of string
+ (return (values :string collector (1+ start))))
+ (t (if* (eq ch #\\)
+ then ; escaping the next character
+ (incf start)
+ (if* (>= start end)
+ then (po-error :unexpected
+ :format-control "eof in string returned"))
+ (setq ch (schar line start)))
+ (vector-push-extend ch collector)
+
+ (if* (>= start end)
+ then ; we overran the end of the input
+ (po-error :unexpected
+ :format-control "eof in string returned")))))
+ (:big-string
+ ;; super string... just a block of data
+ ; (format t "start is ~s kind is ~s~%" start chkind)
+ (case chkind
+ (:big-string
+ ;; end of string
+ (return (values :string
+ (subseq line colstart start)
+ (1+ start))))
+ (t nil)))
+
+
+ )
+
+ (incf start))))
+
+
+
+; this used to be exported from the excl package
+#+(version>= 6 0)
+(defvar *keyword-package* (find-package :keyword))
+
+
+(defun kwd-intern (string)
+ ;; convert the string to the current preferred case
+ ;; and then intern
+ (intern (case excl::*current-case-mode*
+ ((:case-sensitive-lower
+ :case-insensitive-lower) (string-downcase string))
+ (t (string-upcase string)))
+ *keyword-package*))
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+;; low level i/o to server
+
+(defun get-line-from-server (mailbox)
+ ;; Return two values: a buffer and a character count.
+ ;; The character count includes up to but excluding the cr lf that
+ ;; was read from the socket.
+ ;;
+ (let* ((buff (get-line-buffer 0))
+ (len (length buff))
+ (i 0)
+ (p (post-office-socket mailbox))
+ (ch nil)
+ (whole-count)
+ )
+
+ (handler-case
+ (flet ((grow-buffer (size)
+ (let ((newbuff (get-line-buffer size)))
+ (dotimes (j i)
+ (setf (schar newbuff j) (schar buff j)))
+ (free-line-buffer buff)
+ (setq buff newbuff)
+ (setq len (length buff)))))
+
+ ;; increase the buffer to at least size
+ ;; this is somewhat complex to ensure that we aren't doing
+ ;; buffer allocation within the with-timeout form, since
+ ;; that could trigger a gc which could then cause the
+ ;; with-timeout form to expire.
+ (loop
+
+ (if* whole-count
+ then ; we should now read in this may bytes and
+ ; append it to this buffer
+ (multiple-value-bind (ans this-count)
+ (get-block-of-data-from-server mailbox whole-count)
+ ; now put this data in the current buffer
+ (if* (> (+ i whole-count 5) len)
+ then ; grow the initial buffer
+ (grow-buffer (+ i whole-count 100)))
+
+ (dotimes (ind this-count)
+ (setf (schar buff i) (schar ans ind))
+ (incf i))
+ (setf (schar buff i) #\^b) ; end of inset string
+ (incf i)
+ (free-line-buffer ans)
+ (setq whole-count nil)
+ )
+ elseif ch
+ then ; we're growing the buffer holding the line data
+ (grow-buffer (+ len 200))
+ (setf (schar buff i) ch)
+ (incf i))
+
+
+ (block timeout
+ (mp:with-timeout ((timeout mailbox)
+ (po-error :timeout
+ :format-control "imap server failed to respond"))
+ ;; read up to lf (lf most likely preceeded by cr)
+ (loop
+ (setq ch (read-char p))
+ (if* (eq #\linefeed ch)
+ then ; end of line. Don't save the return
+ (if* (and (> i 0)
+ (eq (schar buff (1- i)) #\return))
+ then ; remove #\return, replace with newline
+ (decf i)
+ (setf (schar buff i) #\newline)
+ )
+ ;; must check for an extended return value which
+ ;; is indicated by a {nnn} at the end of the line
+ (block count-check
+ (let ((ind (1- i)))
+ (if* (and (>= i 0) (eq (schar buff ind) #\}))
+ then (let ((count 0)
+ (mult 1))
+ (loop
+ (decf ind)
+ (if* (< ind 0)
+ then ; no of the form {nnn}
+ (return-from count-check))
+ (setf ch (schar buff ind))
+ (if* (eq ch #\{)
+ then ; must now read that many bytes
+ (setf (schar buff ind) #\^b)
+ (setq whole-count count)
+ (setq i (1+ ind))
+ (return-from timeout)
+ elseif (<= #.(char-code #\0)
+ (char-code ch)
+ #.(char-code #\9))
+ then ; is a digit
+ (setq count
+ (+ count
+ (* mult
+ (- (char-code ch)
+ #.(char-code #\0)))))
+ (setq mult (* 10 mult))
+ else ; invalid form, get out
+ (return-from count-check)))))))
+
+
+ (return-from get-line-from-server
+ (values buff i))
+ else ; save character
+ (if* (>= i len)
+ then ; need bigger buffer
+ (return))
+ (setf (schar buff i) ch)
+ (incf i)))))))
+ (error (con)
+ ;; most likely error is that the server went away
+ (ignore-errors (close p))
+ (po-error :server-shutdown-connection
+ :format-control "condition signalled: ~a~%most likely server shut down the connection."
+ :format-arguments (list con)))
+ )))
+
+
+(defun get-block-of-data-from-server (mb count &key save-returns)
+ ;; read count bytes from the server returning it in a line buffer object
+ ;; return as a second value the number of characters saved
+ ;; (we drop #\return's so that lines are sepisarated by a #\newline
+ ;; like lisp likes).
+ ;;
+ (let ((buff (get-line-buffer count))
+ (p (post-office-socket mb))
+ (ind 0))
+ (mp:with-timeout ((timeout mb)
+ (po-error :timeout
+ :format-control "imap server timed out"))
+
+ (dotimes (i count)
+ (if* (eq #\return (setf (schar buff ind) (read-char p)))
+ then (if* save-returns then (incf ind)) ; drop #\returns
+ else (incf ind)))
+
+
+ (values buff ind))))
+
+
+;;-- reusable line buffers
+
+(defvar *line-buffers* nil)
+
+(defun get-line-buffer (size)
+ ;; get a buffer of at least size bytes
+ (setq size (min size (1- array-total-size-limit)))
+ (mp::without-scheduling
+ (dolist (buff *line-buffers* (make-string size))
+ (if* (>= (length buff) size)
+ then ; use this one
+ (setq *line-buffers* (delete buff *line-buffers*))
+ (return buff)))))
+
+
+(defun free-line-buffer (buff)
+ (mp:without-scheduling
+ (push buff *line-buffers*)))
+
+(defun init-line-buffer (new old)
+ ;; copy old into new
+ (declare (optimize (speed 3)))
+ (dotimes (i (length old))
+ (declare (fixnum i))
+ (setf (schar new i) (schar old i))))
+
+
+
+
+ ;;;;;;;
+
+; date functions
+
+(defun universal-time-to-rfc822-date (ut)
+ ;; convert a lisp universal time to rfc 822 date
+ ;;
+ (multiple-value-bind
+ (sec min hour date month year day-of-week dsp time-zone)
+ (decode-universal-time ut 0)
+ (declare (ignore time-zone sec min hour day-of-week dsp time-zone))
+ (format nil "~d-~a-~d"
+ date
+ (svref
+ '#(nil "Jan" "Feb" "Mar" "Apr" "May" "Jun"
+ "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")
+ month
+ )
+ year)))
+
+
+
+
--- /dev/null
+<html>
+
+<head>
+<title>Allegro CL imap and pop interface</title>
+<meta name="GENERATOR" content="Microsoft FrontPage 3.0">
+</head>
+
+<body>
+
+<h1 align="center">Allegro CL imap and pop interface</h1>
+
+<p align="left">copyright (c) 1999 Franz Inc.</p>
+
+<p align="left"> </p>
+
+<p align="left"><strong>imap</strong> is a client-server protocol for processing
+electronic mail boxes. <strong>imap </strong>is the successor to the <strong>pop</strong>
+protocol. It is <strong>not</strong> an upward compatible successor.
+ The main focus of this document is the <strong>imap</strong>
+protocol. Only one small section describes the functions in the <strong>pop</strong>
+interface.</p>
+
+<p align="left">The contents of this document are:</p>
+
+<ul>
+ <li><p align="left">the <strong>imap</strong> interface</p>
+ </li>
+ <li><p align="left"><a href="#pop">the <strong>pop</strong> interface</a></p>
+ </li>
+ <li><p align="left"><a href="#conditions">the <strong>conditions</strong> signaled by the <strong>imap</strong>
+ and <strong>pop</strong> interfaces.</a></p>
+ </li>
+ <li><p align="left"><a href="#smtp">the <strong>smtp</strong> interface</a> (used for
+ sending mail)</p>
+ </li>
+</ul>
+
+<p align="left">The imap interface is based on the Imap4rev1 protocol described in
+rfc2060. Where this document is describing the actions of the imap commands it
+should be considered a secondary source of information about those commands and rfc2060
+should be considered the primary source.</p>
+
+<p align="left">The advantages of <strong>imap</strong> over <strong>pop</strong> are:</p>
+
+<ol>
+ <li><p align="left"><strong>imap </strong>can work with multiple mailboxes (<strong>pop </strong>works
+ with a single mailbox)</p>
+ </li>
+ <li><p align="left">With <strong>imap</strong> you're encouraged to leave mail in mailboxes
+ on the server machine, thus it can be read from any machine on the network.
+ With <strong>pop</strong> you're encouraged to download the mail to the client machine's
+ disk, and it thus becomes inaccessible to all other client machines.</p>
+ </li>
+ <li><p align="left"><strong>imap</strong> parses the headers of messages thus allowing
+ easier analysis of mail messages by the client program.</p>
+ </li>
+ <li><p align="left"><strong>imap</strong> supports searching messages for data and sorting
+ by date.</p>
+ </li>
+ <li><p align="left"><strong>imap </strong>supports annotating messages with flags, thus
+ making subsequent searching easier.</p>
+ </li>
+</ol>
+
+<p align="left"> </p>
+
+<h1 align="left">Package</h1>
+
+<p align="left">The functions in this interface are defined in the <strong>net.post-office</strong>
+package. The previous version of this module gave this package the <strong>po</strong>
+nickname. We've removed that nickname to reduce the possibility of clashing with
+user-defined packages. You are free to add that nickname back if you so desire.</p>
+
+<p align="left"> </p>
+
+<h1 align="left">Mailboxes</h1>
+
+<p align="left">Mailboxes are repositories for messages. Mailboxes are named
+by Lisp strings. The mailbox "inbox" always exists and it is the mailbox
+in which new messages are stored. New mailboxes can be created.
+ They can have simple names, like "foo" or they can have
+hierarchical names (like "clients/california/widgetco"). After
+connecting to an imap server you can determine what string of characters you must use
+between simple names to create a hierarchical name (in this example "/" was the
+separator character). </p>
+
+<p align="left">Each mailbox has an associated unique number called its <strong>uidvalidity</strong>.
+ This number won't change as long as <strong>imap</strong> is the only
+program used to manipulate the mailbox. In fact if you see that the number has
+changed then that means that some other program has done something to the mailbox that
+destroyed the information that <strong>imap</strong> had been keeping about the
+mailbox. In particular you can't now retrieve messages by their unique
+ids that you had used before.</p>
+
+<h1 align="left">Messages</h1>
+
+<p align="left">Messages in a mailbox can be denoted in one of two ways: message
+sequence number or unique id. </p>
+
+<p align="left">The <em>message sequence number</em> is the normal way. The messages
+in a mailbox are numbered from 1 to N where N is the number of messages in the mailbox.
+ There are never any gaps in the sequence numbers. If you tell <strong>imap</strong>
+to delete messages 3,4 and 5 then it will return a value telling you the it has deleted
+messages 3,3 and 3. This is because when you deleted message 3, message 4 became the
+new message 3 just before it was deleted and then message 5 became message 3 just before
+it was deleted.</p>
+
+<p align="left">A <em>unique id </em>of a message is a number associated with a message
+that is unique only within a mailbox. As long as the uidvalidity value of a
+mailbox doesn't change, the unique ids used in deleted messages will never be reused for
+new messages. </p>
+
+<h1 align="left">Flags</h1>
+
+<p align="left">A flag is a symbol denoting that a message or mailbox has a certain
+property. We use keywords in Lisp to denote flags. There are two
+kinds of flags - System and User flags. System flags begin with the backslash
+character, which is an unfortunate design decision since that means that in Lisp we
+have to remember to use two backslashes (e.g. <strong>:\\deleted</strong>).
+ A subset of the flags can be stored permanently in the mailbox with the
+messages. When a connection is made to an <strong>imap</strong> server it will
+return the list of flags and permanent flags (and these are stored in the mailbox object
+returned for access by the program). If the list of permanent flags includes <strong>:\\*</strong>
+then the program can create its own flag names (not beginning with a backslash) and can
+store them permanently in messages.</p>
+
+<p align="left">Some of the important system flags are:</p>
+
+<ul>
+ <li><p align="left"><strong>:\\seen</strong> - this means that the message has been read
+ (a <strong>fetch-letter</strong> has been done that includes the content of the
+ message, not just its headers)</p>
+ </li>
+ <li><p align="left"><strong>:\\deleted </strong>- the message will be deleted the next time
+ an <strong>expunge-mailbox</strong> or <strong>close-mailbox</strong> is done.</p>
+ </li>
+ <li><p align="left"><strong>:\\recent </strong>- this is the first session to have been
+ notified about this message being present in the mailbox.</p>
+ </li>
+</ul>
+
+<p align="left"> </p>
+
+<h1 align="left">Connecting to the server</h1>
+
+<p align="left"> </p>
+
+<p align="left"><font face="Courier New">(<strong>make-imap-connection host &key user
+password port timeout)</strong></font></p>
+
+<p align="left">This creates a connection to the <strong>imap</strong> server on machine <strong>host</strong>
+and logs in as <strong>user </strong>with password <strong>password. </strong>The
+<strong>port</strong> argument defaults to143, which is the port on which the <strong>imap</strong>
+server normally listens. The <strong>timeout</strong> argument defaults
+to 30 (seconds) and this value is used to limit the amount of time this imap interface
+code will wait for a response from the server before giving up. In
+certain circumstances the server may get so busy that you see timeout errors signaled in
+this code. In that case you should specify a larger timeout when connecting. </p>
+
+<p align="left">The <strong>make-imap-connection</strong> function returns a <strong>mailbox</strong>
+object which is then passed to other functions in this interface. From this
+one connection you can access all of the mailboxes owned by <strong>user</strong>.</p>
+
+<p align="left">After the connection is established a mailbox is <strong>not</strong>
+selected. In this state attempting to execute message access functions may
+result in cryptic error messages from the <strong>imap</strong> server that won't tell you
+what you need to know -- that a mailbox is not selected. Therefore be sure to
+select a mailbox using <strong>select-mailbox</strong> shortly after connecting.</p>
+
+<p align="left"> </p>
+
+<p align="left"> </p>
+
+<p align="left"><strong><font face="Courier New">(close-connection mailbox)</font></strong></p>
+
+<p align="left">This sends a <strong>logout</strong> command to the <strong>imap</strong>
+server and then closes the socket that's communicating with the <strong>imap</strong>
+server. <strong>mailbox </strong>is the object returned by <strong>make-imap-connection.</strong>
+ This does <em>not</em> close the currently select mailbox before logging out,
+thus messages marked to be deleted in the currently selected mailbox will <em>not</em> be
+removed from the mailbox. Use <strong>close-mailbox</strong> or <strong>expunge-mailbox</strong>
+before calling this <strong>close-connection</strong> to ensure that messages to be
+deleted are deleted.</p>
+
+<p align="left"> </p>
+
+<p align="left"> </p>
+
+<h1 align="left">Mailbox manipulation</h1>
+
+<p align="left">These functions work on mailboxes as a whole. The <strong>mailbox</strong>
+argument to the functions is is the object returned by <strong>make-imap-connection.
+ </strong>If a return value isn't specified for a function then the return value
+isn't important - if something goes wrong an error will be signaled.</p>
+
+<p align="left"> </p>
+
+<p align="left"><font face="Courier New"><strong>(select-mailbox mailbox name)</strong></font></p>
+
+<p align="left">makes the mailbox named by the string <strong>name</strong> be the current
+mailbox and store statistics about that mailbox in the <strong>mailbox</strong> object
+where they can be retrieved by the accessors described below. The
+selected mailbox is the source for all message manipulation functions.</p>
+
+<p align="left"> </p>
+
+<p align="left"><font face="Courier New"><strong>(create-mailbox mailbox name)</strong></font></p>
+
+<p align="left">creates a new mailbox with the given <strong>name</strong>. It
+is an error if the mailbox already exists. If you want to create a mailbox in a
+hierarchy then you should be sure that it uses the correct hierarchy separator character
+string (see <strong>mailbox-separator)</strong>. You do <strong>not</strong>
+ have to create intermediate levels of the hierarchy yourself -- just provide the
+complete name and the <strong>imap</strong> server will create all necessary levels.</p>
+
+<p align="left"> </p>
+
+<p align="left"><font face="Courier New"><strong>(delete-mailbox mailbox name)</strong></font></p>
+
+<p align="left">deletes the mailbox with the given name.</p>
+
+<p align="left"> </p>
+
+<p align="left"><font face="Courier New"><strong>(rename-mailbox mailbox old-name
+new-name)</strong></font></p>
+
+<p align="left">changes the name of mailbox <strong>old-name</strong> to <strong>new-name</strong>.
+ It's an error if <strong>new-name</strong> already exists. There's a special
+behavior if <strong>old-name</strong> is "inbox". In this case all of the
+messages in "inbox" are moved to <strong>new-name </strong>mailbox, but the
+"inbox" mailbox continues to exist. Note: The <strong>imap </strong>server
+supplied with Linux does <strong>not</strong> support this special behavior of renaming
+"inbox".</p>
+
+<p align="left"> </p>
+
+<p align="left"><strong><font face="Courier New">(mailbox-list mailbox &key reference
+pattern)</font></strong></p>
+
+<p align="left">returns a list of items describing the mailboxes that match the arguments.
+ The <strong>reference</strong> is the root of the hierarchy to
+scan. By default is is the empty string (from which all mailboxes are reachable).
+ The <strong>pattern </strong>is a string matched against all mailbox
+names reachable from <strong>reference. </strong>There are two special characters allowed
+in the <strong>pattern: </strong>Asterisk (*) matches all characters including
+hierarchy delimiters. Percent (%) matches all characters but not the hierarchy
+delimiter. Thus</p>
+
+<p align="center"><font face="Courier New">(mailbox-list mailbox :pattern "*")</font></p>
+
+<p align="left">returns a list of all mailboxes at all depths in the hierarchy.
+ </p>
+
+<p align="left">The value returned is a list of lists, but we've created the <strong>mailbox-list
+</strong>struct definition in order to make accessing the parts of the inner lists
+easier. The accessors for that structure are:</p>
+
+<p align="left"> </p>
+
+<p align="left"><font face="Courier New"><strong>(mailbox-list-flags mailbox-list) </strong></font></p>
+
+<p align="left">returns the flags describing this entry. The most important
+flag to check is <strong>:\\noselect</strong> as this specifies that this is not a mailbox
+but instead just a directory in the hierarchy of mailboxes. The flag <strong>:\\noinferiors</strong>
+specifies that you can't create a hierarchical mailbox name with this as a prefix.
+ This flag is often associated with the special mailbox "inbox".</p>
+
+<p align="left"> </p>
+
+<p align="left"><font face="Courier New"><strong>(mailbox-list-separator mailbox-list)</strong></font></p>
+
+<p align="left">returns a string containing the characters used to separate names in a
+hierarchical name.</p>
+
+<p align="left"> </p>
+
+<p align="left"><font face="Courier New"><strong>(mailbox-list-name mailbox-list)</strong></font></p>
+
+<p align="left">returns the name of the mailbox or directory (see mailbox-list-flags to
+determine which it is).</p>
+
+<p align="left"> </p>
+
+<h1 align="left">Message manipulation</h1>
+
+<p align="left">These functions work with the messages in the currently selected mailbox.
+ The <strong>mailbox</strong> argument is the object returned by <strong>make-imap-connection.</strong>
+ The <strong>messages</strong> argument is either a number (denoting a single
+message), or is the list <strong>(:seq N M) </strong>denoting messages <strong>N</strong>
+through <strong>M, </strong>or is a list of numbers and <strong>:seq </strong>forms
+denoting the messages specified in the list.</p>
+
+<p align="left"> </p>
+
+<p align="left">(<font face="Courier New"><strong>alter-flags mailbox messages &key
+flags add-flags remove-flags silent uid)</strong></font></p>
+
+<p>changes the flags of the messages in the specified way. Exactly one of <strong>flags,
+add-flags</strong>, and <strong>remove-flags</strong> must be specified. <strong>flags</strong>
+specifies the complete set of flags to be stores in the <strong>messages</strong> and the
+other two add or remove flags. If <strong>uid</strong> is true then <strong>messages</strong>
+will be interpreted as unique ids rather than message sequence numbers.
+ Normally <strong>alter-flags</strong> returns a data structure
+that describes the state of the flags after the alternation has been done. This data
+structure can be examined with the <strong>fetch-field</strong> function.
+ If <strong>silent</strong> is true then this data structure won't be created
+thus saving some time and space.</p>
+
+<p>Removing a message from a mailbox is done by adding the <strong>:\\deleted</strong>
+flag to the message and then either calling <strong>close-mailbox </strong>or <strong>expunge-mailbox.</strong></p>
+
+<p> </p>
+
+<p><font face="Courier New"><strong>(close-mailbox mailbox)</strong></font></p>
+
+<p>permanently removes all messages flagged as <strong>:\\deleted</strong> from the
+currently selected mailbox and then un-selects the currently selected mailbox. After
+this command has finished there is no currently selected mailbox.</p>
+
+<p align="left"> </p>
+
+<p align="left"><strong><font face="Courier New">(copy-to-mailbox mailbox messages
+destination &key uid)</font></strong></p>
+
+<p align="left">copies the specified <strong>messages </strong>from the currently selected
+mailbox to the mailbox named <strong>destination</strong> (given as a string). The
+flags are copied as well. The destination mailbox must already exist. The messages
+are <strong>not</strong> removed from the selected mailbox after the copy .If <strong>uid</strong>
+is true then the <strong>messages</strong> are considered to be unique ids rather than
+message sequence numbers. </p>
+
+<p align="left"> </p>
+
+<p align="left"><font face="Courier New"><strong>(delete-letter mailbox messages &key
+expunge uid</strong></font>)</p>
+
+<p align="left">Mark the <strong>messages</strong> for deletion and then remove them
+permanently (using <strong>expunge-mailbox</strong>) if <strong>expunge</strong> is true.
+ <strong>expunge </strong>defaults to true. If <strong>uid</strong>
+is true then the message numbers are unique ids instead of messages sequence numbers.</p>
+
+<p align="left"> </p>
+
+<p align="left"><font face="Courier New"><strong>(expunge-mailbox mailbox)</strong></font></p>
+
+<p align="left">permanently removes all messages flagged as <strong>:\\deleted</strong>
+from the currently selected mailbox. The currently selected mailbox stays
+selected.</p>
+
+<p align="left"> </p>
+
+<p align="left"><font face="Courier New"><strong>(fetch-field message part info &key
+uid)</strong></font></p>
+
+<p align="left">is used to extract the desired information from the value returned by <strong>fetch-letter</strong>.
+ With <strong>fetch-letter</strong> you can retrieve a variety of
+information about one or more messages and <strong>fetch-field</strong> can search though
+that information and return a particular piece of information about a particular
+letter. <strong>message</strong> is the message number (it's assumed to be a
+message sequence number unless <strong>uid </strong>is true, in which case it's a unique
+id). <strong>part </strong>is the type of information desired. It is a
+string just as used in the call to <strong>fetch-letter</strong>.</p>
+
+<p align="left"> </p>
+
+<p align="left"><strong><font face="Courier New">(fetch-letter mailbox message &key
+uid)</font></strong></p>
+
+<p align="left">Return the complete message, headers and body, as one big string.
+This is a combination of <strong>fetch-field</strong> and <strong>fetch-parts</strong>
+where the part specification is "body[]".</p>
+
+<p align="left"> </p>
+
+<p align="left"><font face="Courier New"><strong>(fetch-parts mailbox messages parts
+&key uid)</strong></font></p>
+
+<p align="left">retrieves the specified <strong>parts</strong> of the specified <strong>messages.
+ </strong>If <strong>uid</strong> is true then the <strong>messages</strong>
+are considered to be unique ids rather than message sequence numbers.
+ The description of what can be specified for <strong>parts </strong>is
+quite complex and is described in the section below "Fetching a Letter".</p>
+
+<p align="left">The return value from this function is a structure that can be examined
+with <strong>fetch-field</strong>.</p>
+
+<p align="left">When the result returned includes an envelope value the following
+functions can be used to extract the components of the envelope:</p>
+
+<ul>
+ <li><p align="left"><font face="Courier New"><strong>envelope-date</strong></font></p>
+ </li>
+ <li><p align="left"><font face="Courier New"><strong>envelope-subject</strong></font></p>
+ </li>
+ <li><p align="left"><font face="Courier New"><strong>envelope-from</strong></font></p>
+ </li>
+ <li><p align="left"><font face="Courier New"><strong>envelope-sender</strong></font></p>
+ </li>
+ <li><p align="left"><font face="Courier New"><strong>envelope-reply-to</strong></font></p>
+ </li>
+ <li><p align="left"><font face="Courier New"><strong>envelope-to</strong></font></p>
+ </li>
+ <li><p align="left"><font face="Courier New"><strong>envelope-cc</strong></font></p>
+ </li>
+ <li><p align="left"><font face="Courier New"><strong>envelope-bcc</strong></font></p>
+ </li>
+ <li><p align="left"><font face="Courier New"><strong>envelope-in-reply-to</strong></font></p>
+ </li>
+ <li><p align="left"><font face="Courier New"><strong>envelope-message-id</strong></font></p>
+ </li>
+</ul>
+
+<p align="left"> </p>
+
+<p align="left"> </p>
+
+<p align="left"><strong><font face="Courier New">(noop mailbox)</font></strong></p>
+
+<p align="left">does nothing but remind the <strong>imap</strong> server that this
+client is still active, thus resetting the timers used in the server that will
+automatically shut down this connection after a period of inactivity. Like all
+other commands if messages have been added to the currently selected mailbox, the server
+will return the new message count as a response to the <strong>noop</strong> command, and
+this can be check using <strong>mailbox-message-count</strong>. </p>
+
+<p align="left"> </p>
+
+<p align="left"><font face="Courier New"><strong>(search-mailbox mailbox search-expression
+&key uid)</strong></font></p>
+
+<p align="left">return a list of messages in the mailbox that satisfy the<strong>
+search-expression. </strong>If <strong>uid</strong> is true then unique ids
+will be returned instead of message sequence numbers. See the section
+"Searching for messages" for details on the <strong>search-expression</strong>.</p>
+
+<p align="left"> </p>
+
+<h1 align="left">Mailbox Accessors</h1>
+
+<p align="left">The mailbox object contains information about the <strong>imap </strong>server
+it's connected to as well as the currently selected mailbox. This information
+can potentially be updated each time a request is made to the <strong>imap </strong>server.
+ The following functions access values from the mailbox object. </p>
+
+<p align="left"><font face="Courier New"><strong>(mailbox-flags mailbox)</strong></font></p>
+
+<p align="left">returns a complete list of flags used in all the messages in this mailbox.</p>
+
+<p align="left"> </p>
+
+<p align="left"><font face="Courier New"><strong>(mailbox-permanent-flags mailbox)</strong></font></p>
+
+<p align="left">returns a list of flags that can be stored permanently in a message.
+ If the flag <strong>:\\*</strong> is present then it means that the client can
+create its own flags.</p>
+
+<p align="left"> </p>
+
+<p align="left"><font face="Courier New"><strong>(mailbox-message-count mailbox)</strong></font></p>
+
+<p align="left">returns the number of messages in the currently selected mailbox</p>
+
+<p align="left"> </p>
+
+<p align="left"><font face="Courier New"><strong>(mailbox-recent-messages mailbox)</strong></font></p>
+
+<p align="left">returns the number of messages have just arrived in the mailbox.</p>
+
+<p align="left"> </p>
+
+<p align="left"><font face="Courier New"><strong>(mailbox-separator mailbox)</strong></font></p>
+
+<p align="left">returns the hierarchy separator string for this <strong>imap </strong>server.</p>
+
+<p align="left"> </p>
+
+<p align="left"><font face="Courier New"><strong>(mailbox-uidnext mailbox)</strong></font></p>
+
+<p align="left">returns the value predicated to be the unique id assigned to the
+next message.</p>
+
+<p align="left"> </p>
+
+<p align="left"><font face="Courier New"><strong>(mailbox-uidvalidty mailbox)</strong></font></p>
+
+<p align="left">returns the uidvalidity value for the currently selected mailbox.</p>
+
+<p align="left"> </p>
+
+<p align="left"> </p>
+
+<h1 align="left">Fetching a Letter</h1>
+
+<p align="left">When using <strong>fetch-parts</strong> to access letters, you must
+specify the parts of the messages in which you're interested. There are a wide
+variety of specifiers, some redundant and overlapping, described in the imap specification
+in rfe2060. We'll describe the most common ones here. The specification
+is always a string but it may be specified more than one thing by the use of parentheses
+in the string, e.g. "(flags envelope)". </p>
+
+<p align="left">The most common specifiers are:</p>
+
+<ul>
+ <li><p align="left"><strong>body[]</strong> - this returns the full message: headers and
+ body. You can use <strong>fetch-letter</strong> if you only want this part and
+ you want to avoid having to call <strong>fetch-field</strong>.</p>
+ </li>
+ <li><p align="left"><strong>body[text]</strong> - this returns just the the text of the body
+ of the message, not the header.</p>
+ </li>
+ <li><p align="left"><strong>body</strong> - this returns a list describing the structure of
+ the message.</p>
+ </li>
+ <li><p align="left"><strong>envelope</strong> - this parses the header and returns a list of
+ information in it. We've defined a set of accessors <strong>(</strong>like<strong>
+ envelope-xxx</strong>) that allow you to retrieve the envelope information easily.</p>
+ </li>
+ <li><p align="left"><strong>flags</strong> - return a list of the flags in the message</p>
+ </li>
+ <li><p align="left"><strong>uid</strong> - the unique identifier of the message</p>
+ </li>
+</ul>
+
+<p align="left"> </p>
+
+<p align="left">The result of a <strong>fetch-parts</strong> is a data structure
+containing all of the requested information. The <strong>fetch-field</strong>
+function is then used to extract the particular information for the particular message.</p>
+
+<p align="left"> </p>
+
+<h1 align="left">Searching for Messages</h1>
+
+<p align="left">.The <strong>imap</strong> server is able to search for messages matching
+a search expression. A search-expression is a predicate or one of
+these forms:</p>
+
+<ul>
+ <li><p align="left">(<strong>and</strong> search-expression ...)</p>
+ </li>
+ <li><p align="left">(<strong>or</strong> search-expression ...)</p>
+ </li>
+ <li><p align="left">(<strong>not</strong> search-expression)</p>
+ </li>
+</ul>
+
+<p align="left">A predicate is </p>
+
+<ul>
+ <li><p align="left">a number in which case the predicate is true if and only if we're are
+ considering this message</p>
+ </li>
+ <li><p align="left">a <strong>(:seq N M)</strong> expression that is true if we're
+ considering messages N through M.</p>
+ </li>
+ <li><p align="left"><strong>:all</strong> - this predicate is always true</p>
+ </li>
+ <li><p align="left"><strong>:answered</strong> - true if the message has the <strong>:\\answered</strong>
+ flag</p>
+ </li>
+ <li><p align="left"><strong>(:bcc "string") </strong>- true if the envelope
+ structure's bcc field contains this "string".</p>
+ </li>
+ <li><p align="left"><strong>(:before date)</strong> - true if the messages internal date is
+ before this date. The date can either be a string in the rfc822 form (e.g.
+ "7-Mar-1999") or a lisp universal time.</p>
+ </li>
+ <li><p align="left"><strong>(:body "string") </strong>- true if the body of the
+ message contains "string"</p>
+ </li>
+ <li><p align="left"><strong>(:cc "string")</strong> - true if the envelope
+ structure's cc field contains this "string".</p>
+ </li>
+ <li><p align="left"><strong>:deleted</strong> - true if the <strong>:\\deleted</strong> flag
+ is set for this message</p>
+ </li>
+ <li><p align="left"><strong>:draft</strong> - true if the <strong>:\\draft </strong>flag is
+ set for this message</p>
+ </li>
+ <li><p align="left"><strong>:flagged </strong>- true if the <strong>:\\flagged</strong> flag
+ is set for this message</p>
+ </li>
+ <li><p align="left"><strong>(:from "string")</strong> - true if the envelope
+ structure's from field contains this "string".</p>
+ </li>
+ <li><p align="left"><strong>(:header "field" "string")</strong> - true
+ if the message contains a header named "field" and its value contains
+ "string".</p>
+ </li>
+ <li><p align="left"><strong>(:keyword flag)</strong> - true if the specified flag is set for
+ this message</p>
+ </li>
+ <li><p align="left"><strong>(:larger N)</strong> - true if the rfc822 size of the message is
+ larger than N.</p>
+ </li>
+ <li><p align="left"><strong>:new </strong>- true if the message has the <strong>:\\recent</strong>
+ flag set but not the <strong>:\\seen </strong>flag.</p>
+ </li>
+ <li><p align="left"><strong>:seen </strong>- true if the message has the <strong>:\\seen </strong>flag
+ set.</p>
+ </li>
+ <li><p align="left"><strong>(:sentbefore date)</strong> - true if the message's Date header
+ is earlier than the given date. See the description of :before for the format of
+ dates.</p>
+ </li>
+ <li><p align="left"><strong>(:senton date)</strong> - true if the message's Date header is
+ within the specified date.</p>
+ </li>
+ <li><p align="left"><strong>(:sentsince date) </strong>- true if the message's Date header
+ is within or since the given date.</p>
+ </li>
+ <li><p align="left"><strong>(:smaller N)</strong> - true if the rfc822 size of the message
+ is smaller than N</p>
+ </li>
+ <li><p align="left"><strong>(:subject "string") </strong>- true if the Subject
+ header line of the message contains "string"</p>
+ </li>
+ <li><p align="left"><strong>(:text "string") </strong>- true if the message's
+ header or body contains the specified "string"</p>
+ </li>
+ <li><p align="left"><strong>(:to "string")</strong> - true if the envelope
+ structure's to field contains this "string".</p>
+ </li>
+ <li><p align="left"><strong>(:uid message-set)</strong> - true if the message is one of the
+ message denoted by the message set, where the message set describes messages by unique id.</p>
+ </li>
+ <li><p align="left"><strong>:unanswered</strong> - true if the message does not have the <strong>:\\answered</strong>
+ flag set</p>
+ </li>
+ <li><p align="left"><strong>:undeleted</strong> - true if the message does not have the <strong>:\\deleted</strong>
+ flag set</p>
+ </li>
+ <li><p align="left"><strong>:undraft </strong>- true if the message does not have the <strong>:\\draft
+ </strong>flag set.</p>
+ </li>
+ <li><p align="left"><strong>:unflagged </strong>- true if the message does not have the <strong>:\\flagged</strong>
+ flag set.</p>
+ </li>
+ <li><p align="left"><strong>(:unkeyword flag)</strong> - true if the message does not have
+ the specified flag set.</p>
+ </li>
+ <li><p align="left"><strong>:unseen </strong>- true if the message does not have the <strong>:\\seen
+ </strong>flag set.</p>
+ </li>
+</ul>
+
+<p align="left"> </p>
+
+<h1 align="left">Examples</h1>
+
+<p align="left">We show an example of using this interface</p>
+
+<p align="left"> </p>
+
+<p align="left"><strong>Connect to the imap server on the machine holding the email:</strong></p>
+<div align="left">
+
+<pre>user(2): (setq mb (make-imap-connection "mailmachine.franz.com"
+
+ :user "myacct"
+
+ :password "mypasswd"))
+
+#<mailbox::imap-mailbox @ #x2064ca4a></pre>
+</div>
+
+<p align="left"> </p>
+
+<p align="left"><strong>Select the inbox, that's where the incoming mail arrives:</strong></p>
+<div align="left">
+
+<pre>
+
+user(3): (select-mailbox mb "inbox")
+
+t</pre>
+</div>
+
+<p align="left"> </p>
+
+<p align="left"><strong>Check how many messages are in the mailbox:</strong></p>
+<div align="left">
+
+<pre>
+
+user(4): (mailbox-message-count mb)
+
+7</pre>
+</div>
+
+<p align="left"><strong>There are seven messages at the moment. Fetch the
+whole 4th message. We could call (fetch-letter mb 4) here instead and then not have
+to call fetch-field later.</strong></p>
+<div align="left">
+
+<pre>
+
+user(5): (setq body (fetch-parts mb 4 "body[]"))
+
+((4
+
+("BODY[]" "Return-Path: <jkfmail@tiger.franz.com>
+
+Received: from tiger.franz.com (jkf@tiger [192.132.95.103])
+
+ by tiger.franz.com (8.8.7/8.8.7) with SMTP id LAA20261
+
+ for <jkfmail@tiger.franz.com>; Mon, 13 Sep 1999 11:36:26 -0700
+
+Date: Mon, 13 Sep 1999 11:36:26 -0700
+
+From: jkf mail tester <jkfmail@tiger.franz.com>
+
+Message-Id: <199909131836.LAA20261@tiger.franz.com>
+
+
+
+message number 5
+
+")))</pre>
+</div>
+
+<p align="left"><strong>The value was returned inside a data structure designed to hold
+information about one or more messages. In order to extract the particular
+information we want we use fetch-field:</strong></p>
+<div align="left">
+
+<pre>
+
+user(6): (fetch-field 4 "body[]" body)
+
+"Return-Path: <jkfmail@tiger.franz.com>
+
+Received: from tiger.franz.com (jkf@tiger [192.132.95.103])
+
+ by tiger.franz.com (8.8.7/8.8.7) with SMTP id LAA20261
+
+ for <jkfmail@tiger.franz.com>; Mon, 13 Sep 1999 11:36:26 -0700
+
+Date: Mon, 13 Sep 1999 11:36:26 -0700
+
+From: jkf mail tester <jkfmail@tiger.franz.com>
+
+Message-Id: <199909131836.LAA20261@tiger.franz.com>
+
+
+
+message number 5
+
+"</pre>
+</div>
+
+<p align="left"><strong>We use the search function to find all the messages containing the
+word blitzfig. It turns out there is only one. We then extract the contents of
+that message.</strong></p>
+<div align="left">
+
+<pre>
+
+user(7): (search-mailbox mb '(:text "blitzfig"))
+
+(7)
+
+user(8): (fetch-field 7 "body[]" (fetch-letter mb 7 "body[]"))
+
+"Return-Path: <jkf@verada.com>
+
+Received: from main.verada.com (main.verada.com [208.164.216.3])
+
+ by tiger.franz.com (8.8.7/8.8.7) with ESMTP id NAA20541
+
+ for <jkfmail@tiger.franz.com>; Mon, 13 Sep 1999 13:37:24 -0700
+
+Received: from main.verada.com (IDENT:jkf@localhost [127.0.0.1])
+
+ by main.verada.com (8.9.3/8.9.3) with ESMTP id NAA06121
+
+ for <jkfmail@tiger.franz.com>; Mon, 13 Sep 1999 13:36:54 -0700
+
+Message-Id: <199909132036.NAA06121@main.verada.com>
+
+To: jkfmail@tiger.franz.com
+
+Subject: s test
+
+Date: Mon, 13 Sep 1999 13:36:54 -0700
+
+From: jkf <jkf@verada.com>
+
+
+
+secret word: blitzfig
+
+ok?
+
+"</pre>
+</div>
+
+<p align="left"><strong>We've been using message sequence numbers up to now.
+The are the simplest to use but if you're concerned with keeping track of messages when
+deletions are being done then using unique id's is useful. Here we do the
+above search example using uids:</strong></p>
+<div align="left">
+
+<pre>
+
+user(9): (search-mailbox mb '(:text "blitzfig") :uid t)
+
+(68)
+
+user(10): (fetch-field 68 "body[]" (fetch-letter mb 68 "body[]" :uid t) :uid t)
+
+"Return-Path: <jkf@verada.com>
+
+Received: from main.verada.com (main.verada.com [208.164.216.3])
+
+ by tiger.franz.com (8.8.7/8.8.7) with ESMTP id NAA20541
+
+ for <jkfmail@tiger.franz.com>; Mon, 13 Sep 1999 13:37:24 -0700
+
+Received: from main.verada.com (IDENT:jkf@localhost [127.0.0.1])
+
+ by main.verada.com (8.9.3/8.9.3) with ESMTP id NAA06121
+
+ for <jkfmail@tiger.franz.com>; Mon, 13 Sep 1999 13:36:54 -0700
+
+Message-Id: <199909132036.NAA06121@main.verada.com>
+
+To: jkfmail@tiger.franz.com
+
+Subject: s test
+
+Date: Mon, 13 Sep 1999 13:36:54 -0700
+
+From: jkf <jkf@verada.com>
+
+
+
+secret word: blitzfig
+
+ok?
+
+"</pre>
+</div>
+
+<p align="left"><strong>We'll delete that letter with the secret word and then note that
+we have only six messages in the mailbox.</strong></p>
+<div align="left">
+
+<pre>
+
+user(11): (delete-letter mb 68 :uid t)
+
+(7)
+
+user(12): (mailbox-message-count mb)
+
+6</pre>
+</div>
+
+<p align="left"><strong>Now we assume that a bit of time has passed and we want to see if
+any new messages have been delivered into the mailbox. In order to find out we
+have to send a command to the imap server since it will only notify us of new messages
+when it responds to a command. Since we have nothing to ask the imap server to
+do we issue the noop command, which does nothing on the server.</strong></p>
+<div align="left">
+
+<pre>
+
+user(13): (noop mb)
+
+nil
+
+user(14): (mailbox-message-count mb)
+
+7</pre>
+</div>
+
+<p align="left"><strong>The server told us that there are now 7 messages in the inbox, one
+more than before. Next we create a new mailbox, copy the messages from the inbox to
+the new mailbox and then delete them from the inbox. Note how we use the :seq form
+to specify a sequence of messages.</strong></p>
+<div align="left">
+
+<pre>
+
+user(15): (create-mailbox mb "tempbox")
+
+t
+
+user(18): (let ((count (mailbox-message-count mb)))
+
+(copy-to-mailbox mb `(:seq 1 ,count) "tempbox")
+
+(delete-letter mb `(:seq 1 ,count)))
+
+(1 1 1 1 1 1 1)
+
+user(19): (mailbox-message-count mb)
+
+0</pre>
+</div>
+
+<p align="left"><strong>When we're done there are 0 messages in the currently selected
+mailbox, which is inbox. We now select the maibox we just created and see that the
+messages are there.</strong></p>
+<div align="left">
+
+<pre>
+
+user(22): (select-mailbox mb "tempbox")
+
+t
+
+user(23): (mailbox-message-count mb)
+
+7</pre>
+</div>
+
+<p align="left"><strong>Finally we shut down the connection. Note that imap
+servers will automatically shut down a connection that's been idle for too long (usually
+around 10 minutes). When that happens, the next time the client tries to use an imap
+function to access the mailbox an error will occur. There is nothing that can
+be done to revive the connection however it is important to call close-imap-connection on
+the lisp side in order to free up the resources still in use for the now dead connection.</strong></p>
+<div align="left">
+
+<pre>
+
+user(24): (close-connection mb)
+
+t
+
+</pre>
+</div>
+
+<p align="left"> </p>
+
+<h1><a name="pop"></a>The Pop interface</h1>
+
+<p>The <strong>pop</strong> protocol is a very simple means for retrieving messages from a
+single mailbox. The functions in the interface are:</p>
+
+<p> </p>
+
+<p align="left"><font face="Courier New">(<strong>make-pop-connection host &key user
+password port timeout)</strong></font></p>
+
+<p align="left">This creates a connection to the <strong>pop</strong> server on machine <strong>host</strong>
+and logs in as <strong>user </strong>with password <strong>password. </strong>The
+<strong>port</strong> argument defaults to 110, which is the port on which the <strong>pop</strong>
+server normally listens. The <strong>timeout</strong> argument defaults
+to 30 (seconds) and this value is used to limit the amount of time this pop interface code
+will wait for a response from the server before giving up. In certain
+circumstances the server may get so busy that you see timeout errors signaled in this
+code. In that case you should specify a larger timeout when connecting. </p>
+
+<p>The value returned by this function is a <strong>mailbox</strong> object. You can
+call <strong>mailbox-message-count</strong> on the <strong>mailbox</strong> object to
+determine how many letters are currently stored in the mailbox.</p>
+
+<p> </p>
+
+<p><font face="Courier New"><strong>(close-connection mb)</strong></font></p>
+
+<p>Disconnect from the pop server. All messages marked for deletion will be deleted.</p>
+
+<p> </p>
+
+<p><strong><font face="Courier New">(delete-letter mb messages)</font></strong></p>
+
+<p>Mark the specified <strong>messages</strong> for deletion. <strong>mb </strong>is
+the mailbox object returned by <strong>make-pop-connection</strong>. The messages
+are only marked for deletion. They are not removed until a <strong>close-connection</strong>
+is done. If the connection to the <strong>pop</strong> server is broken before a <strong>close-connection</strong>
+is done, the messages will <strong>not</strong> be deleted and they will no longer be
+marked for deletion either.</p>
+
+<p><strong>messages</strong> can either be a message number, a list of the form <strong>(:seq
+N M)</strong> meaning messages <strong>N </strong>through <strong>M </strong>or it can be
+a list of message numbers and/or <strong>:seq </strong>specifiers. The
+messages in a mailbox are numbered starting with one. Marking a message for deletion
+does not affect the numbering of other messages in the mailbox.</p>
+
+<p> </p>
+
+<p><font face="Courier New"><strong>(fetch-letter mb message)</strong></font></p>
+
+<p>Fetch from the pop server connection <strong>mb</strong> the letter numbered <strong>message</strong>.
+ The letters in a mailbox are numbered starting with one. The entire
+message, including the headers, is returned as a string. It is an
+error to attempt to fetch a letter marked for deletion.</p>
+
+<p> </p>
+
+<p><font face="Courier New"><strong>(make-envelope-from-text text)</strong></font></p>
+
+<p><strong>text</strong> is a string that is the first part of a mail message, including
+at least all of the headers lines and the blank line following the headers. This
+function parses the header lines and return an <strong>envelope</strong> structure
+containing information from the header. </p>
+
+<p> </p>
+
+<p><font face="Courier New"><strong>(noop mb)</strong></font></p>
+
+<p>This is the no-operation command. It is useful for letting the <strong>pop</strong>
+server know that this connection should be kept alive (<strong>pop </strong>servers tend
+to disconnect after a few minutes of inactivity). In order to make <strong>noop</strong>
+have behavior similar to that of the <strong>imap</strong> version of <strong>noop</strong>,
+we don't send a 'noop' command to the pop server, instead we send a 'stat' command.
+ This means that after this command is completed the <strong>mailbox-message-count</strong>
+will contain the current count of messages in the mailbox.</p>
+
+<p> </p>
+
+<p><font face="Courier New"><strong>(parse-mail-header text)</strong></font></p>
+
+<p><strong>text</strong> is a string that is the first part of a mail message, including
+at least all of the headers lines and the blank line following the headers. This
+function parses the header lines and returns an assoc list where each item has the form <strong>(header
+. value)</strong>. Both the <strong>header</strong> and <strong>value</strong>
+are strings. Note that header names will most likely be mixed case (but this is not
+a requirment) so you'll want to use <strong>:test #'equalp</strong> when searching for a
+particular header with <strong>assoc</strong>. <strong>parse-mail-header</strong>
+returns as a second value a string that is everything after the headers (which is often
+referred to as the body of the message).</p>
+
+<p> </p>
+
+<p><font face="Courier New"><strong>(top-lines mb message line-count)</strong></font></p>
+
+<p>Return a string that contains all the header lines and the first <strong>line-count</strong>
+lines of the body of <strong>message</strong>. To just retrieve the headers a <strong>line-count</strong>
+of zero can be given. See the function <strong>make-envelope-from-text</strong> for
+a means of reading the information in the header.</p>
+
+<p> </p>
+
+<p><font face="Courier New"><strong>(unique-id mb &optional message)</strong></font></p>
+
+<p>Return the unique indentifier for the given message, or for all non-deleted messages if
+<strong>message</strong> is nil. The unique identifier is is a string that is
+different for every message. If the <strong>message</strong> argument is
+not given then this command returns a list of lists where each list contains two items:
+the message number and the unique id.</p>
+
+<h1>Cond<a name="conditions"></a>itions</h1>
+
+<p>When an unexpected event occurs a condition is signaled. This applies to
+both the <strong>imap</strong> and <strong>pop</strong> interfaces. There are two
+classes of conditions signaled by this package:
+
+<ul>
+ <li><strong>po-condition</strong> - this class denotes conditions that need not and in fact
+ should not interrupt program flow. When the mailbox server is responding to a
+ command it sometimes sends informational warning messages and we turn them into
+ conditions. It's important for all messages from the server to be read
+ and processed otherwise the next command issued will see messages in response to the
+ previous command. Therefore the user code should never do a non-local-transfer
+ in response to a <strong>po-condition.</strong></li>
+ <li><strong>po-error - </strong>this class denotes conditions that will prevent execution
+ from continuing. If one of these errors is not caught, the interactive debugger will
+ be entered.</li>
+</ul>
+
+<p>Instances of both of these condition classes have these slots in addition to the
+standard condition slots: </p>
+
+<table border="1" width="100%">
+ <tr>
+ <td width="16%">Name</td>
+ <td width="24%">Accessor</td>
+ <td width="60%">Value</td>
+ </tr>
+ <tr>
+ <td width="16%">identifier</td>
+ <td width="24%">po-condition-identifier</td>
+ <td width="60%">keyword describing the kind of condition being signaled. See the
+ table below for the possible values.</td>
+ </tr>
+ <tr>
+ <td width="16%">server-string</td>
+ <td width="24%">po-condition-server-string</td>
+ <td width="60%">If the condition was created because of a messages sent from the mailbox
+ server then this is that message.</td>
+ </tr>
+</table>
+
+<p>The meaning of the identifier value is as follows</p>
+
+<table border="1" width="100%">
+ <tr>
+ <td width="11%"><strong>Identifier</strong></td>
+ <td width="13%">Kind</td>
+ <td width="76%">Meaning</td>
+ </tr>
+ <tr>
+ <td width="11%"><strong>:problem</strong></td>
+ <td width="13%">po-condition</td>
+ <td width="76%">The server has responded with a warning message. The most
+ likely warning is that the mailbox can only be opened in read-only mode due to another
+ processing using it.</td>
+ </tr>
+ <tr>
+ <td width="11%"><strong>:unknown-ok</strong></td>
+ <td width="13%">po-condition</td>
+ <td width="76%">The server has sent an informative message that we don't understand.
+ It's probably safe to ignore this.</td>
+ </tr>
+ <tr>
+ <td width="11%"><strong>:unknown-untagged</strong></td>
+ <td width="13%">po-condition</td>
+ <td width="76%">The server has sent an informative message that we don't understand.
+ It's probably safe to ignore this.</td>
+ </tr>
+ <tr>
+ <td width="11%"><strong>:error-response</strong></td>
+ <td width="13%">po-error</td>
+ <td width="76%">The server cannot execute the requested command.</td>
+ </tr>
+ <tr>
+ <td width="11%"><strong>:syntax-error</strong></td>
+ <td width="13%">po-error</td>
+ <td width="76%">The arguments to a function in this package are malformed.</td>
+ </tr>
+ <tr>
+ <td width="11%"><strong>:unexpected</strong></td>
+ <td width="13%">po-error</td>
+ <td width="76%">The server has responded a way we don't understand and which prevents us
+ from continuing</td>
+ </tr>
+ <tr>
+ <td width="11%"><strong>:server-shutdown-connection</strong></td>
+ <td width="13%">po-error</td>
+ <td width="76%">The connection to the server has been broken. This usually occurs
+ when the connection has been idle for too long and the server intentionally disconnects.
+ Just before this condition is signaled we close down the socket connection to
+ free up the socket resource on our side. When this condition is signaled the user
+ program should not use the mailbox object again (even to call <strong>close-connection</strong>
+ on it).</td>
+ </tr>
+ <tr>
+ <td width="11%"><strong>:timeout</strong></td>
+ <td width="13%">po-error</td>
+ <td width="76%">The server did not respond quickly enough. The timeout value
+ is set in the call to <strong>make-imap-connection.</strong></td>
+ </tr>
+</table>
+
+<h1><a name="smtp"></a>The smtp interface</h1>
+
+<p>With the smtp interface, a Lisp program can contact a mail server and send electronic
+mail. The contents of the message must be a simple text string. There is
+no provision for encoding binary data and sending it as a Mime attachment.</p>
+
+<p> </p>
+
+<p><font face="Courier New"><strong>(send-letter mail-server from to message &key
+subject reply-to)</strong></font></p>
+
+<p><strong>mail-server</strong> can be a string naming a machine or an integer IP address.
+ The <strong>mail-server</strong> is contacted and asked to send a <strong>message</strong>
+(a string) <strong>from</strong> a given email address <strong>to</strong> a given email
+address or list of addresses. The email addresses must be of the form
+"foo" or <a href="mailto:foo@bar.com">"foo@bar.com"</a>. You can
+<strong>not</strong> use addresses like <a href="mailto:Joe%20%3cfoo@bar.com%3e">"Joe
+<foo@bar.com>"</a> or <a href="mailto:(Joe)%20foo@bar.com">"(Joe)
+foo@bar.com"</a>. </p>
+
+<p>A mail header is built and prepended to the <strong>message</strong> before it is sent.
+ The mail header includes a <strong>From </strong>and <strong>To</strong> line and
+will optionally include a <strong>Subject</strong> and <strong>Reply-To</strong>
+line if those are given in the call to <strong>send-letter.</strong>.</p>
+
+<p>The text of the <strong>message</strong> should be lines separated by #\newline's.
+ The <strong>smtp</strong> interface will automatically insert the necessary
+#\returns's when it transmits the message to the mail server.</p>
+
+<p> </p>
+
+<p> </p>
+
+<p><font face="Courier New"><strong>(send-smtp mail-server from to &rest messages)</strong></font></p>
+
+<p><strong>mail-server</strong> can be a string naming a machine or an integer IP address.
+ The <strong>mail-server</strong> is contacted and asked to send a message <strong>from</strong>
+a given email address <strong>to</strong> a given email address or list of addresses.
+ The email addresses must be of the form "foo" or <a
+href="mailto:foo@bar.com">"foo@bar.com"</a>. You can <strong>not</strong>
+use addresses like <a href="mailto:Joe%20%3cfoo@bar.com%3e">"Joe
+<foo@bar.com>"</a> or <a href="mailto:(Joe)%20foo@bar.com">"(Joe)
+foo@bar.com"</a>. </p>
+
+<p>The message sent is a concatenation of all of the <strong>messages</strong> (which
+should be strings). A header is <strong>not</strong> prepended to the message.
+ This means that the application program can build its own header if it wants to
+include in that header more than <strong>send-letter</strong> supports (e.g. a Mime
+encoded attachment). If no header is provided then some mail servers (e.g. <strong>sendmail</strong>)
+will notice this fact and will automatically create a header.</p>
+
+<p>The text of the <strong>messages</strong> should be lines separated by #\newline's.
+ The <strong>smtp</strong> interface will automatically insert the necessary
+#\returns's when it transmits the message to the mail server.</p>
+
+<p> </p>
+
+<p> </p>
+
+<p> </p>
+
+<p> </p>
+</body>
+</html>
--- /dev/null
+;; -*- mode: common-lisp; package: net.post-office -*-
+;;
+;; smtp.cl
+;;
+;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA
+;;
+;; This code is free software; you can redistribute it and/or
+;; modify it under the terms of the version 2.1 of
+;; the GNU Lesser General Public License as published by
+;; the Free Software Foundation, as clarified by the AllegroServe
+;; prequel found in license-allegroserve.txt.
+;;
+;; This code is distributed in the hope that it will be useful,
+;; but without any warranty; without even the implied warranty of
+;; merchantability or fitness for a particular purpose. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; Version 2.1 of the GNU Lesser General Public License is in the file
+;; license-lgpl.txt that was distributed with this file.
+;; If it is not present, you can access it from
+;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer
+;; version) or write to the Free Software Foundation, Inc., 59 Temple Place,
+;; Suite 330, Boston, MA 02111-1307 USA
+;;
+;;
+;; $Id: smtp.cl,v 1.1 2002/10/09 14:26:11 kevin Exp $
+
+;; Description:
+;; send mail to an smtp server. See rfc821 for the spec.
+
+;;- This code in this file obeys the Lisp Coding Standard found in
+;;- http://www.franz.com/~jkf/coding_standards.html
+;;-
+
+
+(defpackage :net.post-office
+ (:use #:lisp #:excl)
+ (:export
+ #:send-letter
+ #:send-smtp
+ #:test-email-address))
+
+(in-package :net.post-office)
+
+
+;; the exported functions:
+
+;; (send-letter "mail-server" "from" "to" "message"
+;; &key cc bcc subject reply-to headers)
+;;
+;;
+;; sends a message to the mail server (which may be a relay server
+;; or the final destination). "from" is the address to be given
+;; as the sender. "to" can be a string or a list of strings naming
+;; recipients.
+;; "message" is the message to be sent
+;; cc and bcc can be either be a string or a list of strings
+;; naming recipients. All cc's and bcc's are sent the message
+;; but the bcc's aren't included in the header created.
+;; reply-to's value is a string and in cases a Reply-To header
+;; to be created.
+;; headers is a string or list of stings. These are raw header lines
+;; added to the header build to send out.
+;;
+;; This builds a header and inserts the optional cc, bcc,
+;; subject and reply-to lines.
+;;
+;; (send-smtp "mail-server" "from" "to" &rest messages)
+;; this is like send-letter except that it doesn't build a header.
+;; the messages should contain a header (and if not then sendmail
+;; notices this and builds one -- other MTAs may not be that smart).
+;; The messages ia list of strings to be concatenated together
+;; and sent as one message
+;;
+;;
+;; (test-email-address "user@machine.com")
+;; return t is this could be a valid email address on the machine
+;; named. Do this by contacting the mail server and using the VRFY
+;; command from smtp. Since some mail servers don't implement VRFY
+;; we return t if VRFY doesn't work.
+;; nil means that this address is bad (or we can't make contact with
+;; the mail server, which could of course be a transient problem).
+;;
+
+
+
+
+
+(defmacro response-case ((smtp-stream &optional smtp-response response-code) &rest case-clauses)
+ ;; get a response from the smtp server and dispatch in a 'case' like
+ ;; fashion to a clause based on the first digit of the return
+ ;; code of the response.
+ ;; smtp-response, if given, will be bound to string that is
+ ;; the actual response
+ ;;
+ (let ((response-class (gensym)))
+ `(multiple-value-bind (,response-class
+ ,@(if* smtp-response then (list smtp-response))
+ ,@(if* response-code then (list response-code)))
+ (progn (force-output ,smtp-stream)
+ (wait-for-response ,smtp-stream))
+ ;;(declare (ignorable smtp-response))
+ (case ,response-class
+ ,@case-clauses))))
+
+(defvar *smtp-debug* nil)
+
+
+
+(defun send-letter (server from to message
+ &key cc bcc subject reply-to headers)
+ ;;
+ ;; see documentation at the head of this file
+ ;;
+ (let ((header (make-string-output-stream))
+ (tos (if* (stringp to)
+ then (list to)
+ elseif (consp to)
+ then to
+ else (error "to should be a string or list, not ~s" to)))
+ (ccs
+ (if* (null cc)
+ then nil
+ elseif (stringp cc)
+ then (list cc)
+ elseif (consp cc)
+ then cc
+ else (error "cc should be a string or list, not ~s" cc)))
+ (bccs (if* (null bcc)
+ then nil
+ elseif (stringp bcc)
+ then (list bcc)
+ elseif (consp bcc)
+ then bcc
+ else (error "bcc should be a string or list, not ~s" bcc))))
+ (format header "From: ~a~c~cTo: "
+ from
+ #\return
+ #\linefeed)
+ (format header "~{ ~a~^,~}~c~c" tos #\return #\linefeed)
+ (if* ccs
+ then (format header "Cc: ~{ ~a~^,~}~c~c" ccs #\return #\linefeed))
+
+ (if* subject
+ then (format header "Subject: ~a~c~c" subject #\return #\linefeed))
+
+ (if* reply-to
+ then (format header "Reply-To: ~a~c~c" reply-to #\return #\linefeed))
+
+ (if* headers
+ then (if* (stringp headers)
+ then (setq headers (list headers))
+ elseif (consp headers)
+ thenret
+ else (error "Unknown headers format: ~s." headers))
+ (dolist (h headers)
+ (format header "~a~c~c" h #\return #\linefeed)))
+
+ (format header "~c~c" #\return #\linefeed)
+
+ (send-smtp server from (append tos ccs bccs)
+ (get-output-stream-string header)
+ message)))
+
+
+
+
+
+(defun send-smtp (server from to &rest messages)
+ ;; send the effective concatenation of the messages via
+ ;; smtp to the mail server
+ ;; Each message should be a string
+ ;;
+ ;; 'to' can be a single string or a list of strings.
+ ;; each string should be in the official rfc822 format "foo@bar.com"
+ ;;
+
+ (let ((sock (connect-to-mail-server server)))
+
+ (unwind-protect
+ (progn
+
+ (smtp-command sock "MAIL from:<~a>" from)
+ (response-case (sock msg)
+ (2 ;; cool
+ nil
+ )
+ (t (error "Mail from command failed: ~s" msg)))
+
+ (let ((tos (if* (stringp to)
+ then (list to)
+ elseif (consp to)
+ then to
+ else (error "to should be a string or list, not ~s"
+ to))))
+ (dolist (to tos)
+ (smtp-command sock "RCPT to:<~a>" to)
+ (response-case (sock msg)
+ (2 ;; cool
+ nil
+ )
+ (t (error "rcpt to command failed: ~s" msg)))))
+
+ (smtp-command sock "DATA")
+ (response-case (sock msg)
+ (3 ;; cool
+ nil)
+ (t (error "Data command failed: ~s" msg)))
+
+
+
+ (let ((at-bol t)
+ (prev-ch nil))
+ (dolist (message messages)
+ (dotimes (i (length message))
+ (let ((ch (aref message i)))
+ (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)))))
+
+ (write-char #\return sock) (write-char #\linefeed sock)
+ (write-char #\. sock)
+ (write-char #\return sock) (write-char #\linefeed sock)
+
+ (response-case (sock msg)
+ (2 nil ; (format t "Message sent to ~a~%" to)
+ )
+
+ (t (error "message not sent: ~s" msg)))
+
+ (force-output t)
+
+ (smtp-command sock "QUIT")
+ (response-case (sock msg)
+ (2 ;; cool
+ nil)
+ (t (error "quit failed: ~s" msg))))
+ (close sock))))
+
+(defun connect-to-mail-server (server)
+ ;; make that initial connection to the mail server
+ ;; returning a socket connected to it and
+ ;; signaling an error if it can't be made.
+ (let ((ipaddr (determine-mail-server server))
+ (sock)
+ (ok))
+
+ (if* (null ipaddr)
+ then (error "Can't determine ip addres for mail server ~s" server))
+
+ (setq sock (socket:make-socket :remote-host ipaddr
+ :remote-port 25 ; smtp
+ ))
+ (unwind-protect
+ (progn
+ (response-case (sock msg)
+ (2 ;; to the initial connect
+ nil)
+ (t (error "initial connect failed: ~s" msg)))
+
+ ;; now that we're connected we can compute our hostname
+ (let ((hostname (socket:ipaddr-to-hostname
+ (socket:local-host sock))))
+ (if* (null hostname)
+ then (setq hostname
+ (format nil "[~a]" (socket:ipaddr-to-dotted
+ (socket:local-host sock)))))
+ (smtp-command sock "HELO ~a" hostname)
+ (response-case (sock msg)
+ (2 ;; ok
+ nil)
+ (t (error "hello greeting failed: ~s" msg))))
+
+ ; all is good
+ (setq ok t))
+
+ ; cleanup:
+ (if* (null ok)
+ then (close sock :abort t)
+ (setq sock nil)))
+
+ ; return:
+ sock
+ ))
+
+
+
+(defun test-email-address (address)
+ ;; test to see if we can determine if the address is valid
+ ;; return nil if the address is bogus
+ ;; return t if the address may or may not be bogus
+ (if* (or (not (stringp address))
+ (zerop (length address)))
+ then (error "mail address should be a non-empty string: ~s" address))
+
+ ; split on the @ sign
+ (let (name hostname)
+ (let ((pos (position #\@ address)))
+ (if* (null pos)
+ then (setq name address
+ hostname "localhost")
+ elseif (or (eql pos 0)
+ (eql pos (1- (length address))))
+ then ; @ at beginning or end, bogus since we don't do route addrs
+ (return-from test-email-address nil)
+ else (setq name (subseq address 0 pos)
+ hostname (subseq address (1+ pos)))))
+
+ (let ((sock (ignore-errors (connect-to-mail-server hostname))))
+ (if* (null sock) then (return-from test-email-address nil))
+
+ (unwind-protect
+ (progn
+ (smtp-command sock "VRFY ~a" name)
+ (response-case (sock msg code)
+ (5
+ (if* (eq code 550)
+ then ; no such user
+ msg ; to remove unused warning
+ nil
+ else t ; otherwise we don't know
+ ))
+ (t t)))
+ (close sock :abort t)))))
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+(defun wait-for-response (stream)
+ ;; read the response of the smtp server.
+ ;; collect it all in a string.
+ ;; Return two values:
+ ;; response class
+ ;; whole string
+ ;; The string should begin with a decimal digit, and that is converted
+ ;; into a number which is returned as the response class.
+ ;; If the string doesn't begin with a decimal digit then the
+ ;; response class is -1.
+ ;;
+ (flet ((match-chars (string pos1 pos2 count)
+ ;; like strncmp
+ (dotimes (i count t)
+ (if* (not (eq (aref string (+ pos1 i))
+ (aref string (+ pos2 i))))
+ then (return nil)))))
+
+ (let ((res (make-array 20 :element-type 'character
+ :adjustable t
+ :fill-pointer 0)))
+ (if* (null (read-a-line stream res))
+ then ; eof encountered before end of line
+ (return-from wait-for-response (values -1 res)))
+
+ ;; a multi-line response begins with line containing
+ ;; a hyphen in the 4th column:
+ ;; xyz- some text
+ ;;
+ ;; and ends with a line containing the same reply code but no
+ ;; hyphen.
+ ;; xyz some text
+ ;;
+
+ (if* (and (>= (length res) 4) (eq #\- (aref res 3)))
+ then ;; multi line response
+ (let ((old-length (length res))
+ (new-length nil))
+ (loop
+ (if* (null (read-a-line stream res))
+ then ; eof encountered before end of line
+ (return-from wait-for-response (values -1 res)))
+ (setq new-length (length res))
+ ;; see if this is the last line
+ (if* (and (>= (- new-length old-length) 4)
+ (eq (aref res (+ old-length 3)) #\space)
+ (match-chars res 0 old-length 3))
+ then (return))
+
+ (setq old-length new-length))))
+
+ ;; complete response is in res
+ ;; compute class and return the whole thing
+ (let ((class (or (and (> (length res) 0)
+ (digit-char-p (aref res 0)))
+ -1)))
+ (values class res
+ (if* (>= (length res) 3)
+ then ; compute the whole response value
+ (+ (* (or (digit-char-p (aref res 0)) 0) 100)
+ (* (or (digit-char-p (aref res 1)) 0) 10)
+ (or (digit-char-p (aref res 2)) 0))))))))
+
+(defun smtp-command (stream &rest format-args)
+ ;; send a command to the smtp server
+ (let ((command (apply #'format nil format-args)))
+ (if* *smtp-debug*
+ then (format *smtp-debug* "to smtp command: ~s~%" command)
+ (force-output *smtp-debug*))
+ (write-string command stream)
+ (write-char #\return stream)
+ (write-char #\newline stream)
+ (force-output stream)))
+
+(defun read-a-line (stream res)
+ ;; read from stream and put the result in the adjust able array res
+ ;; if line ends in cr-lf, only put a newline in res.
+ ;; If we get an eof before the line finishes, return nil,
+ ;; else return t if all is ok
+ (let (ch last-ch)
+ (loop
+ (setq ch (read-char stream nil nil))
+ (if* (null ch)
+ then ; premature eof
+ (return nil))
+
+ (if* *smtp-debug*
+ then (format *smtp-debug* "~c" ch)
+ (force-output *smtp-debug*)
+ )
+
+ (if* (eq last-ch #\return)
+ then (if* (eq ch #\linefeed)
+ then (vector-push-extend #\newline res)
+ (return t)
+ else (vector-push-extend last-ch res))
+ elseif (eq ch #\linefeed)
+ then ; line ends with just lf, not cr-lf
+ (vector-push-extend #\newline res)
+ (return t)
+ elseif (not (eq ch #\return))
+ then (vector-push-extend ch res))
+
+ (setq last-ch ch))))
+
+
+(defun determine-mail-server (name)
+ ;; return the ipaddress to be used to connect to the
+ ;; the mail server.
+ ;; name is any method for naming a machine:
+ ;; integer ip address
+ ;; string with dotted ip address
+ ;; string naming a machine
+ ;; we can only do the mx lookup for the third case, the rest
+ ;; we just return the ipaddress for what we were given
+ ;;
+ (let (ipaddr)
+ (if* (integerp name)
+ then name
+ elseif (integerp (setq ipaddr
+ (socket:dotted-to-ipaddr name :errorp nil)))
+ then ipaddr
+ else ; do mx lookup if acldns is being used
+ (if* (or (eq socket:*dns-mode* :acldns)
+ (member :acldns socket:*dns-mode* :test #'eq))
+ then (let ((res (socket:dns-query name :type :mx)))
+ (if* (and res (consp res))
+ then (cadr res) ; the ip address
+ else (socket:dns-query name :type :a)))
+ else ; just do a hostname lookup
+ (ignore-errors (socket:lookup-hostname name))))))
+
+
+
+(provide :smtp)
--- /dev/null
+;; -*- mode: common-lisp; package: net.post-office -*-
+;;
+;; smtp.cl
+;;
+;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA
+;;
+;; This code is free software; you can redistribute it and/or
+;; modify it under the terms of the version 2.1 of
+;; the GNU Lesser General Public License as published by
+;; the Free Software Foundation, as clarified by the AllegroServe
+;; prequel found in license-allegroserve.txt.
+;;
+;; This code is distributed in the hope that it will be useful,
+;; but without any warranty; without even the implied warranty of
+;; merchantability or fitness for a particular purpose. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; Version 2.1 of the GNU Lesser General Public License is in the file
+;; license-lgpl.txt that was distributed with this file.
+;; If it is not present, you can access it from
+;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer
+;; version) or write to the Free Software Foundation, Inc., 59 Temple Place,
+;; Suite 330, Boston, MA 02111-1307 USA
+;;
+;;
+;; $Id: smtp.lisp,v 1.1 2002/10/09 14:26:11 kevin Exp $
+
+;; Description:
+;; send mail to an smtp server. See rfc821 for the spec.
+
+;;- This code in this file obeys the Lisp Coding Standard found in
+;;- http://www.franz.com/~jkf/coding_standards.html
+;;-
+
+;;#-allegro (defvar socket:*dns-mode* :clib)
+
+
+
+(defpackage :net.post-office
+ (:use #:lisp #:excl
+ #+allegro #:socket
+ #-allegro #:acl-socket)
+ (:export
+ #:send-letter
+ #:send-smtp
+ #:test-email-address))
+
+(in-package :net.post-office)
+
+
+;; the exported functions:
+
+;; (send-letter "mail-server" "from" "to" "message"
+;; &key cc bcc subject reply-to headers)
+;;
+;;
+;; sends a message to the mail server (which may be a relay server
+;; or the final destination). "from" is the address to be given
+;; as the sender. "to" can be a string or a list of strings naming
+;; recipients.
+;; "message" is the message to be sent
+;; cc and bcc can be either be a string or a list of strings
+;; naming recipients. All cc's and bcc's are sent the message
+;; but the bcc's aren't included in the header created.
+;; reply-to's value is a string and in cases a Reply-To header
+;; to be created.
+;; headers is a string or list of stings. These are raw header lines
+;; added to the header build to send out.
+;;
+;; This builds a header and inserts the optional cc, bcc,
+;; subject and reply-to lines.
+;;
+;; (send-smtp "mail-server" "from" "to" &rest messages)
+;; this is like send-letter except that it doesn't build a header.
+;; the messages should contain a header (and if not then sendmail
+;; notices this and builds one -- other MTAs may not be that smart).
+;; The messages ia list of strings to be concatenated together
+;; and sent as one message
+;;
+;;
+;; (test-email-address "user@machine.com")
+;; return t is this could be a valid email address on the machine
+;; named. Do this by contacting the mail server and using the VRFY
+;; command from smtp. Since some mail servers don't implement VRFY
+;; we return t if VRFY doesn't work.
+;; nil means that this address is bad (or we can't make contact with
+;; the mail server, which could of course be a transient problem).
+;;
+
+
+
+
+
+(defmacro response-case ((smtp-stream &optional smtp-response response-code) &rest case-clauses)
+ ;; get a response from the smtp server and dispatch in a 'case' like
+ ;; fashion to a clause based on the first digit of the return
+ ;; code of the response.
+ ;; smtp-response, if given, will be bound to string that is
+ ;; the actual response
+ ;;
+ (let ((response-class (gensym)))
+ `(multiple-value-bind (,response-class
+ ,@(if* smtp-response then (list smtp-response))
+ ,@(if* response-code then (list response-code)))
+ (progn (force-output ,smtp-stream)
+ (wait-for-response ,smtp-stream))
+ ;;(declare (ignorable smtp-response))
+ (case ,response-class
+ ,@case-clauses))))
+
+(defvar *smtp-debug* nil)
+
+
+
+(defun send-letter (server from to message
+ &key cc bcc subject reply-to headers)
+ ;;
+ ;; see documentation at the head of this file
+ ;;
+ (let ((header (make-string-output-stream))
+ (tos (if* (stringp to)
+ then (list to)
+ elseif (consp to)
+ then to
+ else (error "to should be a string or list, not ~s" to)))
+ (ccs
+ (if* (null cc)
+ then nil
+ elseif (stringp cc)
+ then (list cc)
+ elseif (consp cc)
+ then cc
+ else (error "cc should be a string or list, not ~s" cc)))
+ (bccs (if* (null bcc)
+ then nil
+ elseif (stringp bcc)
+ then (list bcc)
+ elseif (consp bcc)
+ then bcc
+ else (error "bcc should be a string or list, not ~s" bcc))))
+ (format header "From: ~a~c~cTo: "
+ from
+ #\return
+ #\linefeed)
+ (format header "~{ ~a~^,~}~c~c" tos #\return #\linefeed)
+ (if* ccs
+ then (format header "Cc: ~{ ~a~^,~}~c~c" ccs #\return #\linefeed))
+
+ (if* subject
+ then (format header "Subject: ~a~c~c" subject #\return #\linefeed))
+
+ (if* reply-to
+ then (format header "Reply-To: ~a~c~c" reply-to #\return #\linefeed))
+
+ (if* headers
+ then (if* (stringp headers)
+ then (setq headers (list headers))
+ elseif (consp headers)
+ thenret
+ else (error "Unknown headers format: ~s." headers))
+ (dolist (h headers)
+ (format header "~a~c~c" h #\return #\linefeed)))
+
+ (format header "~c~c" #\return #\linefeed)
+
+ (send-smtp server from (append tos ccs bccs)
+ (get-output-stream-string header)
+ message)))
+
+
+
+
+
+(defun send-smtp (server from to &rest messages)
+ ;; send the effective concatenation of the messages via
+ ;; smtp to the mail server
+ ;; Each message should be a string
+ ;;
+ ;; 'to' can be a single string or a list of strings.
+ ;; each string should be in the official rfc822 format "foo@bar.com"
+ ;;
+
+ (let ((sock (connect-to-mail-server server)))
+
+ (unwind-protect
+ (progn
+
+ (smtp-command sock "MAIL from:<~a>" from)
+ (response-case (sock msg)
+ (2 ;; cool
+ nil
+ )
+ (t (error "Mail from command failed: ~s" msg)))
+
+ (let ((tos (if* (stringp to)
+ then (list to)
+ elseif (consp to)
+ then to
+ else (error "to should be a string or list, not ~s"
+ to))))
+ (dolist (to tos)
+ (smtp-command sock "RCPT to:<~a>" to)
+ (response-case (sock msg)
+ (2 ;; cool
+ nil
+ )
+ (t (error "rcpt to command failed: ~s" msg)))))
+
+ (smtp-command sock "DATA")
+ (response-case (sock msg)
+ (3 ;; cool
+ nil)
+ (t (error "Data command failed: ~s" msg)))
+
+
+
+ (let ((at-bol t)
+ (prev-ch nil))
+ (dolist (message messages)
+ (dotimes (i (length message))
+ (let ((ch (aref message i)))
+ (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)))))
+
+ (write-char #\return sock) (write-char #\linefeed sock)
+ (write-char #\. sock)
+ (write-char #\return sock) (write-char #\linefeed sock)
+
+ (response-case (sock msg)
+ (2 nil ; (format t "Message sent to ~a~%" to)
+ )
+
+ (t (error "message not sent: ~s" msg)))
+
+ (force-output t)
+
+ (smtp-command sock "QUIT")
+ (response-case (sock msg)
+ (2 ;; cool
+ nil)
+ (t (error "quit failed: ~s" msg))))
+ (close sock))))
+
+(defun connect-to-mail-server (server)
+ ;; make that initial connection to the mail server
+ ;; returning a socket connected to it and
+ ;; signaling an error if it can't be made.
+ (let ((ipaddr (determine-mail-server server))
+ (sock)
+ (ok))
+
+ (if* (null ipaddr)
+ then (error "Can't determine ip addres for mail server ~s" server))
+
+ (setq sock (make-socket :remote-host ipaddr
+ :remote-port 25 ; smtp
+ ))
+ (unwind-protect
+ (progn
+ (response-case (sock msg)
+ (2 ;; to the initial connect
+ nil)
+ (t (error "initial connect failed: ~s" msg)))
+
+ ;; now that we're connected we can compute our hostname
+ (let ((hostname (ipaddr-to-hostname
+ (local-host sock))))
+ (if* (null hostname)
+ then (setq hostname
+ (format nil "[~a]" (ipaddr-to-dotted
+ (local-host sock)))))
+ (smtp-command sock "HELO ~a" hostname)
+ (response-case (sock msg)
+ (2 ;; ok
+ nil)
+ (t (error "hello greeting failed: ~s" msg))))
+
+ ; all is good
+ (setq ok t))
+
+ ; cleanup:
+ (if* (null ok)
+ then (close sock :abort t)
+ (setq sock nil)))
+
+ ; return:
+ sock
+ ))
+
+
+
+(defun test-email-address (address)
+ ;; test to see if we can determine if the address is valid
+ ;; return nil if the address is bogus
+ ;; return t if the address may or may not be bogus
+ (if* (or (not (stringp address))
+ (zerop (length address)))
+ then (error "mail address should be a non-empty string: ~s" address))
+
+ ; split on the @ sign
+ (let (name hostname)
+ (let ((pos (position #\@ address)))
+ (if* (null pos)
+ then (setq name address
+ hostname "localhost")
+ elseif (or (eql pos 0)
+ (eql pos (1- (length address))))
+ then ; @ at beginning or end, bogus since we don't do route addrs
+ (return-from test-email-address nil)
+ else (setq name (subseq address 0 pos)
+ hostname (subseq address (1+ pos)))))
+
+ (let ((sock (ignore-errors (connect-to-mail-server hostname))))
+ (if* (null sock) then (return-from test-email-address nil))
+
+ (unwind-protect
+ (progn
+ (smtp-command sock "VRFY ~a" name)
+ (response-case (sock msg code)
+ (5
+ (if* (eq code 550)
+ then ; no such user
+ msg ; to remove unused warning
+ nil
+ else t ; otherwise we don't know
+ ))
+ (t t)))
+ (close sock :abort t)))))
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+(defun wait-for-response (stream)
+ ;; read the response of the smtp server.
+ ;; collect it all in a string.
+ ;; Return two values:
+ ;; response class
+ ;; whole string
+ ;; The string should begin with a decimal digit, and that is converted
+ ;; into a number which is returned as the response class.
+ ;; If the string doesn't begin with a decimal digit then the
+ ;; response class is -1.
+ ;;
+ (flet ((match-chars (string pos1 pos2 count)
+ ;; like strncmp
+ (dotimes (i count t)
+ (if* (not (eq (aref string (+ pos1 i))
+ (aref string (+ pos2 i))))
+ then (return nil)))))
+
+ (let ((res (make-array 20 :element-type 'character
+ :adjustable t
+ :fill-pointer 0)))
+ (if* (null (read-a-line stream res))
+ then ; eof encountered before end of line
+ (return-from wait-for-response (values -1 res)))
+
+ ;; a multi-line response begins with line containing
+ ;; a hyphen in the 4th column:
+ ;; xyz- some text
+ ;;
+ ;; and ends with a line containing the same reply code but no
+ ;; hyphen.
+ ;; xyz some text
+ ;;
+
+ (if* (and (>= (length res) 4) (eq #\- (aref res 3)))
+ then ;; multi line response
+ (let ((old-length (length res))
+ (new-length nil))
+ (loop
+ (if* (null (read-a-line stream res))
+ then ; eof encountered before end of line
+ (return-from wait-for-response (values -1 res)))
+ (setq new-length (length res))
+ ;; see if this is the last line
+ (if* (and (>= (- new-length old-length) 4)
+ (eq (aref res (+ old-length 3)) #\space)
+ (match-chars res 0 old-length 3))
+ then (return))
+
+ (setq old-length new-length))))
+
+ ;; complete response is in res
+ ;; compute class and return the whole thing
+ (let ((class (or (and (> (length res) 0)
+ (digit-char-p (aref res 0)))
+ -1)))
+ (values class res
+ (if* (>= (length res) 3)
+ then ; compute the whole response value
+ (+ (* (or (digit-char-p (aref res 0)) 0) 100)
+ (* (or (digit-char-p (aref res 1)) 0) 10)
+ (or (digit-char-p (aref res 2)) 0))))))))
+
+(defun smtp-command (stream &rest format-args)
+ ;; send a command to the smtp server
+ (let ((command (apply #'format nil format-args)))
+ (if* *smtp-debug*
+ then (format *smtp-debug* "to smtp command: ~s~%" command)
+ (force-output *smtp-debug*))
+ (write-string command stream)
+ (write-char #\return stream)
+ (write-char #\newline stream)
+ (force-output stream)))
+
+(defun read-a-line (stream res)
+ ;; read from stream and put the result in the adjust able array res
+ ;; if line ends in cr-lf, only put a newline in res.
+ ;; If we get an eof before the line finishes, return nil,
+ ;; else return t if all is ok
+ (let (ch last-ch)
+ (loop
+ (setq ch (read-char stream nil nil))
+ (if* (null ch)
+ then ; premature eof
+ (return nil))
+
+ (if* *smtp-debug*
+ then (format *smtp-debug* "~c" ch)
+ (force-output *smtp-debug*)
+ )
+
+ (if* (eq last-ch #\return)
+ then (if* (eq ch #\linefeed)
+ then (vector-push-extend #\newline res)
+ (return t)
+ else (vector-push-extend last-ch res))
+ elseif (eq ch #\linefeed)
+ then ; line ends with just lf, not cr-lf
+ (vector-push-extend #\newline res)
+ (return t)
+ elseif (not (eq ch #\return))
+ then (vector-push-extend ch res))
+
+ (setq last-ch ch))))
+
+
+(defun determine-mail-server (name)
+ ;; return the ipaddress to be used to connect to the
+ ;; the mail server.
+ ;; name is any method for naming a machine:
+ ;; integer ip address
+ ;; string with dotted ip address
+ ;; string naming a machine
+ ;; we can only do the mx lookup for the third case, the rest
+ ;; we just return the ipaddress for what we were given
+ ;;
+ (let (ipaddr)
+ (if* (integerp name)
+ then name
+ elseif (integerp (setq ipaddr
+ (dotted-to-ipaddr name :errorp nil)))
+ then ipaddr
+ else ; do mx lookup if acldns is being used
+#|
+ (if* (or (eq *dns-mode* :acldns)
+ (member :acldns *dns-mode* :test #'eq))
+ then (let ((res (dns-query name :type :mx)))
+ (if* (and res (consp res))
+ then (cadr res) ; the ip address
+ else (dns-query name :type :a)))
+ else ; just do a hostname lookup
+|#
+ (ignore-errors (lookup-hostname name)))))
+;; )
+
+
+
+(provide :smtp)
projects / postoffice.git / commitdiff