qmtp.el

   1 ;;; qmtp.el --- basic functions to send mail with QMTP server
   2
   3 ;; Copyright (C) 2000 Daiki Ueno
   4
   5 ;; Author: Daiki Ueno <ueno@unixuser.org>
   6 ;; Keywords: QMTP, qmail
   7
   8 ;; This file is part of FLIM (Faithful Library about Internet Message).
   9
  10 ;; This program is free software; you can redistribute it and/or
  11 ;; modify it under the terms of the GNU General Public License as
  12 ;; published by the Free Software Foundation; either version 2, or (at
  13 ;; your option) any later version.
  14
  15 ;; This program is distributed in the hope that it will be useful, but
  16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18 ;; General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with this program; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25
  26 ;;; Commentary:
  27 ;;
  28
  29 ;;; Code:
  30
  31 (require 'poem)
  32 (require 'pcustom)
  33
  34 (defgroup qmtp nil
  35   "QMTP protocol for sending mail."
  36   :group 'mail)
  37
  38 (defcustom qmtp-default-server nil
  39   "Specify default QMTP server."
  40   :type '(choice (const nil) string)
  41   :group 'qmtp)
  42
  43 (defvar qmtp-server qmtp-default-server
  44   "The name of the host running QMTP server.
  45 It can also be a function
  46 called from `qmtp-via-qmtp' with arguments SENDER and RECIPIENTS.")
  47
  48 (defcustom qmtp-service "qmtp"
  49   "QMTP service port number.  \"qmtp\" or 25."
  50   :type '(choice (integer :tag "25" 25)
  51                  (string :tag "qmtp" "qmtp"))
  52   :group 'qmtp)
  53
  54 (defvar qmtp-open-connection-function (function open-network-stream))
  55
  56 (defvar qmtp-error-response-alist
  57   '((?Z "Temporary failure")
  58     (?D "Permanent failure")))
  59
  60 (defun qmtp-encode-netstring-string (string)
  61   (format "%d:%s," (length string) string))
  62
  63 (defun qmtp-via-qmtp (sender recipients buffer)
  64   (save-excursion
  65     (set-buffer
  66      (get-buffer-create
  67       (format "*trace of QMTP session to %s*" qmtp-server)))
  68     (buffer-disable-undo)
  69     (erase-buffer)
  70     (let (process point response)
  71       (unwind-protect
  72           (progn
  73             (as-binary-process
  74              (setq process
  75                    (funcall qmtp-open-connection-function
  76                             "QMTP" (current-buffer) qmtp-server qmtp-service)))
  77             (with-temp-buffer
  78               (buffer-disable-undo)
  79               (erase-buffer)
  80               (set-buffer-multibyte nil)
  81               (insert
  82                (format "%d:\n"
  83                        (with-current-buffer buffer
  84                          (1+ (point-max));; for the "\n"
  85                          )))
  86               (insert-buffer-substring buffer)
  87               (insert
  88                "\n,"
  89                (qmtp-encode-netstring-string sender)
  90                (qmtp-encode-netstring-string
  91                 (mapconcat #'qmtp-encode-netstring-string
  92                            recipients "")))
  93               (process-send-region process (point-min)(point-max)))
  94             (goto-char (point-min))
  95             (while recipients
  96               (setq point (point))
  97               (while (and
  98                       (memq (process-status process) '(open run))
  99                       (not (re-search-forward "^[0-9]+:" nil 'noerror)))
 100                 (accept-process-output process)
 101                 (goto-char point))
 102               (setq response (char-after (match-end 0)))
 103               (if (eq response ?K)
 104                   (progn
 105                     (setq recipients (cdr recipients))
 106                     (beginning-of-line 2))
 107                 (error
 108                  (nth 1 (assq response qmtp-error-response-alist)))))
 109             t)
 110         (when (and process
 111                    (memq (process-status process) '(open run)))
 112           ;; QUIT
 113           (process-send-eof process)
 114           (delete-process process))))))
 115
 116 (provide 'qmtp)
 117
 118 ;;; qmtp.el ends here