git.chise.org Git - elisp/gnus.git-/blob - lisp/canlock-om.el

   1 ;;; canlock-om.el --- Mule 2 specific functions for canlock
   2 ;; Copyright (C) 2001 Katsumi Yamaoka
   3
   4 ;; Author: Katsumi Yamaoka <yamaoka@jpl.org>
   5 ;; Keywords: mule, cancel-lock
   6
   7 ;; This program is free software; you can redistribute it and/or modify
   8 ;; it under the terms of the GNU General Public License as published by
   9 ;; the Free Software Foundation; either version 2, or (at your option)
  10 ;; any later version.
  11
  12 ;; This program is distributed in the hope that it will be useful,
  13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;; GNU General Public License for more details.
  16
  17 ;; You should have received a copy of the GNU General Public License
  18 ;; along with this program; see the file COPYING.  If not, write to the
  19 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  20 ;; Boston, MA 02111-1307, USA.
  21
  22 ;;; Commentary:
  23
  24 ;; This program is used to make canlock.el work with Mule 2.3 based on
  25 ;; Emacs 19.34.  See README.ja in the canlock distribution for details.
  26
  27 ;;; Code:
  28
  29 (eval-and-compile
  30   (cond ((and (boundp 'emacs-major-version)
  31               (> emacs-major-version 19))
  32          (error "\
  33 Error: You should never use canlock-om.el(c) for this environment"))
  34         ((and (boundp 'MULE)
  35               (boundp 'emacs-major-version)
  36               (= emacs-major-version 19)
  37               (>= emacs-minor-version 29)))
  38         (t
  39          (error "Error: Canlock does not support this version of Emacs"))))
  40
  41 (eval-when-compile
  42   (require 'cl))
  43
  44 (require 'custom)
  45 (eval-and-compile
  46   (unless (fboundp 'custom-declare-variable)
  47     (error "Error: Canlock requires new custom")))
  48
  49 (eval-when-compile
  50   (unless (fboundp 'byte-compile-file-form-custom-declare-variable)
  51     (defun byte-compile-file-form-custom-declare-variable (form)
  52       ;; Bind defcustom'ed variables.
  53       (if (memq 'free-vars byte-compile-warnings)
  54           (setq byte-compile-bound-variables
  55                 (cons (nth 1 (nth 1 form)) byte-compile-bound-variables)))
  56       (if (memq ':version (nthcdr 4 form))
  57           ;; Make the variable uncustomizable.
  58           `(defvar ,(nth 1 (nth 1 form)) ,(nth 1 (nth 2 form))
  59              ,(substring (nth 3 form)
  60                          (if (string-match "^[\t *]+" (nth 3 form))
  61                              (match-end 0)
  62                            0)))
  63         ;; Ignore unsupported keyword(s).
  64         (if (memq ':set-after (nthcdr 4 form))
  65             (let ((newform (list (car form) (nth 1 form)
  66                                  (nth 2 form) (nth 3 form)))
  67                   (args (nthcdr 4 form)))
  68               (while args
  69                 (or (eq (car args) ':set-after)
  70                     (setq newform (nconc newform (list (car args)
  71                                                        (car (cdr args))))))
  72                 (setq args (cdr (cdr args))))
  73               newform)
  74           form)))
  75     (put 'custom-declare-variable 'byte-hunk-handler
  76          'byte-compile-file-form-custom-declare-variable))
  77
  78   (define-compiler-macro with-temp-buffer (&whole form &rest forms)
  79     (let ((def (if (fboundp 'with-temp-buffer)
  80                    (symbol-function 'with-temp-buffer))))
  81       (if (and def
  82                (consp def)
  83                (or (eq (car def) 'macro)
  84                    (and (eq (car def) 'autoload)
  85                         (memq (nth 4 def) '(macro t)))))
  86           form
  87         ;; The function definition is imported from APEL.
  88         `(let ((obuffer (current-buffer))
  89                (buffer (generate-new-buffer " *temp*")))
  90            (unwind-protect
  91                (progn
  92                  (set-buffer buffer)
  93                  ,@forms)
  94              (if (buffer-name buffer)
  95                  (kill-buffer buffer))
  96              (if (buffer-live-p obuffer)
  97                  (set-buffer obuffer))))))))
  98
  99 (autoload 'base64-encode "base64")
 100
 101 (defcustom canlock-base64-encode-function 'base64-encode-string
 102   "Function to call to base64 encode a string."
 103   :type '(radio (function-item base64-encode-string)
 104                 (function-item base64-encode)
 105                 (function-item canlock-base64-encode-string-with-mmencode)
 106                 (function :tag "Other"))
 107   :group 'canlock)
 108
 109 (defcustom canlock-mmencode-program "mmencode"
 110   "Name of mmencode program."
 111   :type 'string
 112   :group 'canlock)
 113
 114 (defcustom canlock-mmencode-args-for-encoding nil
 115   "Arguments passed to mmencode program for encoding."
 116   :type 'sexp
 117   :group 'canlock)
 118
 119 (defun canlock-base64-encode-string-with-mmencode (string)
 120   "Base64 encode a string using mmencode."
 121   (with-temp-buffer
 122     (setq mc-flag nil)
 123     (insert string)
 124     (let ((default-process-coding-system (cons *iso-2022-jp*dos *noconv*))
 125           program-coding-system-alist selective-display)
 126       (apply 'call-process-region (point-min) (point-max)
 127              canlock-mmencode-program t t nil
 128              canlock-mmencode-args-for-encoding))
 129     (goto-char (point-max))
 130     (skip-chars-backward "\n")
 131     (buffer-substring (point-min) (point))))
 132
 133 ;; The following macros will only be used to byte-compile canlock.el.
 134 (eval-when-compile
 135   (define-compiler-macro base64-encode-string
 136     (&whole form string &optional no-line-break)
 137     (if (and (string-equal (buffer-name) " *Compiler Input*")
 138              (string-equal ";;; canlock.el"
 139                            (buffer-substring (point-min)
 140                                              (min (+ (point-min) 14)
 141                                                   (point-max)))))
 142         (if no-line-break
 143             `(let ((string ,string))
 144                (if ,no-line-break
 145                    (with-temp-buffer
 146                      (insert (funcall canlock-base64-encode-function string))
 147                      (goto-char (point-min))
 148                      (while (search-forward "\n" nil t)
 149                        (delete-char -1))
 150                      (buffer-string))
 151                  (funcall canlock-base64-encode-function string)))
 152           `(funcall canlock-base64-encode-function ,string))
 153       form))
 154
 155   (define-compiler-macro split-string (&whole form string &optional pattern)
 156     (if (and (string-equal (buffer-name) " *Compiler Input*")
 157              (string-equal ";;; canlock.el"
 158                            (buffer-substring (point-min)
 159                                              (min (+ (point-min) 14)
 160                                                   (point-max)))))
 161         ;; The function definition is imported from APEL.
 162         (if pattern
 163             `(let ((string ,string)
 164                    (pattern ,pattern)
 165                    (start 0)
 166                    parts)
 167                (while (string-match pattern string start)
 168                  (setq parts (cons (substring string
 169                                               start (match-beginning 0))
 170                                    parts)
 171                        start (match-end 0)))
 172                (nreverse (cons (substring string start) parts)))
 173           `(let ((string ,string)
 174                  (start 0)
 175                  parts)
 176              (while (string-match "[ \f\t\n\r\v]+" string start)
 177                (setq parts (cons (substring string
 178                                             start (match-beginning 0))
 179                                  parts)
 180                      start (match-end 0)))
 181              (nreverse (cons (substring string start) parts))))
 182       form)))
 183
 184 ;; The following variables might not be bound if the old version of
 185 ;; canlock.el(c) exists.
 186 (eval-when-compile
 187   (defvar canlock-openssl-args)
 188   (defvar canlock-openssl-program))
 189
 190 (defun canlock-om-sha1-with-openssl (message)
 191   "Make a SHA-1 digest of MESSAGE using OpenSSL."
 192   (with-temp-buffer
 193     (setq mc-flag nil)
 194     (insert message)
 195     (let ((default-process-coding-system (cons *iso-2022-jp*dos *noconv*))
 196           program-coding-system-alist selective-display)
 197       (apply 'call-process-region (point-min) (point-max)
 198              canlock-openssl-program t t nil canlock-openssl-args))
 199     (goto-char (point-min))
 200     (insert "\"")
 201     (while (re-search-forward "\\([0-9A-Fa-f][0-9A-Fa-f]\\)" nil t)
 202       (replace-match "\\\\x\\1"))
 203     (insert "\"")
 204     (goto-char (point-min))
 205     (read (current-buffer))))
 206
 207 ;; Override the original function.
 208 (eval-after-load "canlock"
 209   '(defalias 'canlock-sha1-with-openssl 'canlock-om-sha1-with-openssl))
 210
 211 (provide 'canlock-om)
 212
 213 (require 'canlock)
 214
 215 ;;; canlock-om.el ends here