Merge `deisui-1_14_0-1'.

[elisp/flim.git] / qmtp.el

diff --git a/qmtp.el b/qmtp.el
new file mode 100644 (file)
index 0000000..bbb933b
--- /dev/null
+++ b/qmtp.el
@@ -0,0 +1,142 @@
+;;; qmtp.el --- basic functions to send mail with QMTP server
+
+;; Copyright (C) 2000 Daiki Ueno
+
+;; Author: Daiki Ueno <ueno@unixuser.org>
+;; Keywords: QMTP, qmail
+
+;; This file is part of FLIM (Faithful Library about Internet Message).
+
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2, or (at
+;; your option) any later version.
+
+;; This program 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
+;; General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+
+;;; Commentary:
+
+;; Installation:
+
+;; To send mail using QMTP instead of SMTP, do
+
+;; (fset 'smtp-via-smtp 'qmtp-via-qmtp)
+
+;;; Code:
+
+(require 'poem)
+(require 'pcustom)
+
+(defgroup qmtp nil
+  "QMTP protocol for sending mail."
+  :group 'mail)
+
+(defcustom qmtp-default-server nil
+  "Specify default QMTP server."
+  :type '(choice (const nil) string)
+  :group 'qmtp)
+
+(defvar qmtp-server qmtp-default-server
+  "The name of the host running QMTP server.
+It can also be a function
+called from `qmtp-via-qmtp' with arguments SENDER and RECIPIENTS.")
+
+(defcustom qmtp-service "qmtp"
+  "QMTP service port number.  \"qmtp\" or 209."
+  :type '(choice (integer :tag "209" 209)
+                 (string :tag "qmtp" "qmtp"))
+  :group 'qmtp)
+
+(defcustom qmtp-timeout 30
+  "Timeout for each QMTP session."
+  :type 'integer
+  :group 'qmtp)
+
+(defvar qmtp-open-connection-function (function open-network-stream))
+
+(defvar qmtp-error-response-alist
+  '((?Z "Temporary failure")
+    (?D "Permanent failure")))
+
+(defvar qmtp-read-point nil)
+
+(defun qmtp-encode-netstring-string (string)
+  (format "%d:%s," (length string) string))
+
+(defun qmtp-send-package (process sender recipients buffer)
+  (with-temp-buffer
+    (buffer-disable-undo)
+    (erase-buffer)
+    (set-buffer-multibyte nil)
+    (insert
+     (format "%d:\n"
+            (with-current-buffer buffer
+              (1+ (point-max));; for the "\n"
+              )))
+    (insert-buffer-substring buffer)
+    (insert
+     "\n,"
+     (qmtp-encode-netstring-string sender)
+     (qmtp-encode-netstring-string
+      (mapconcat #'qmtp-encode-netstring-string
+                recipients "")))
+    (process-send-region process (point-min)(point-max)))
+  (goto-char qmtp-read-point)
+  (while (and (memq (process-status process) '(open run))
+             (not (re-search-forward "^[0-9]+:" nil 'noerror)))
+    (unless (accept-process-output process qmtp-timeout)
+      (error "timeout expired: %d" qmtp-timeout))
+    (goto-char qmtp-read-point))
+  (let ((response (char-after (match-end 0))))
+    (unless (eq response ?K)
+      (error (nth 1 (assq response qmtp-error-response-alist))))
+    (setq recipients (cdr recipients))
+    (beginning-of-line 2)
+    (setq qmtp-read-point (point))))
+
+;;;###autoload
+(defun qmtp-via-qmtp (sender recipients buffer)
+  (condition-case nil
+      (progn
+       (qmtp-send-buffer sender recipients buffer)
+       t)
+    (error)))
+
+(make-obsolete 'qmtp-via-qmtp "It's old API.")
+
+;;;###autoload
+(defun qmtp-send-buffer (sender recipients buffer)
+  (save-excursion
+    (set-buffer
+     (get-buffer-create
+      (format "*trace of QMTP session to %s*" qmtp-server)))
+    (buffer-disable-undo)
+    (erase-buffer)
+    (make-local-variable 'qmtp-read-point)
+    (setq qmtp-read-point (point-min))
+    (let (process)
+      (unwind-protect
+         (progn
+           (as-binary-process
+            (setq process
+                  (funcall qmtp-open-connection-function
+                           "QMTP" (current-buffer) qmtp-server qmtp-service)))
+           (qmtp-send-package process sender recipients buffer))
+       (when (and process
+                  (memq (process-status process) '(open run)))
+         ;; QUIT
+         (process-send-eof process)
+         (delete-process process))))))
+
+(provide 'qmtp)
+
+;;; qmtp.el ends here