cgit.sxemacs.org Git - packages/blob - xemacs-packages/mew/mew/mew-env.el

   1 ;;; mew-env.el --- Environment setup for Mew
   2
   3 ;; Author:  Kazu Yamamoto <Kazu@Mew.org>
   4 ;; Created: Mar  6, 1997
   5 ;; Revised: Aug 30, 1999
   6
   7 ;;; Code:
   8
   9 (defconst mew-env-version "mew-env.el version 0.14")
  10
  11 (require 'mew)
  12
  13 (defvar mew-temacs-p nil)
  14 (defvar mew-xemacs-p nil)
  15 (defvar mew-mule-p   nil)
  16 (defvar mew-icon-p   nil)
  17 (defvar mew-mule-ver 0)
  18
  19 (if (featurep 'mule) (setq mew-mule-p t))
  20
  21 (cond
  22  ((featurep 'xemacs)
  23   (setq mew-temacs-p nil)
  24   (setq mew-xemacs-p t)
  25   (if (and (valid-image-instantiator-format-p 'xpm) (featurep 'toolbar))
  26       (setq mew-icon-p t))
  27   (require 'mew-xemacs)
  28   (if (equal emacs-major-version 19)
  29       (require 'mew-mule0)
  30     (if (null mew-mule-p)
  31         (require 'mew-mule0)
  32       (setq mew-mule-ver 3)
  33       (require 'mew-mule3))))
  34  (t
  35   (setq mew-temacs-p t)
  36   (setq mew-xemacs-p nil)
  37   (require 'mew-temacs)
  38   (if (null mew-mule-p)
  39       (require 'mew-mule0)
  40     (if (string< mule-version "3")
  41         (progn
  42           (setq mew-mule-ver 2)
  43           (require 'mew-mule2))
  44       (setq mew-mule-ver 3)
  45       (require 'mew-mule3)))))
  46
  47 (cond
  48  (mew-xemacs-p
  49   (or (find-face 'underline)
  50       (progn (make-face 'underline)
  51              (set-face-underline-p 'underline t)))
  52   (defmacro mew-overlay-p (ovl)
  53     (` (and (extentp (, ovl)) (extent-live-p (, ovl)))))
  54   (defun mew-overlay-make (beg end)
  55     (let ((ovl (make-extent beg end)))
  56       (set-extent-property ovl 'mew t)
  57       ovl))
  58   (defun mew-overlay-move (overlay beg end &optional buffer)
  59     (set-extent-endpoints overlay beg end))
  60   (defun mew-overlay-get (overlay prop)
  61     (extent-property overlay prop))
  62   (defun mew-overlay-put (overlay prop value)
  63     (set-extent-property overlay prop value))
  64   (defun mew-overlay-delete (ovl)
  65     (and (extent-property ovl 'mew) (delete-extent ovl)))
  66   (defun mew-overlay-delete-region (beg end)
  67     (interactive "r")
  68     (mapcar (function mew-overlay-delete)
  69             (extent-list (current-buffer) beg end)))
  70   (defun mew-front-sticky (beg-or-ovl &optional end)
  71     (if (mew-overlay-p beg-or-ovl)
  72         (mew-overlay-put beg-or-ovl 'start-closed t)
  73       (put-text-property beg-or-ovl end 'start-closed t)))
  74   (defun mew-front-nonsticky (beg-or-ovl &optional end)
  75     (if (mew-overlay-p beg-or-ovl)
  76         (mew-overlay-put beg-or-ovl 'start-open t)
  77       (put-text-property beg-or-ovl end 'start-open t)))
  78   (defun mew-rear-sticky (beg-or-ovl &optional end)
  79     (if (mew-overlay-p beg-or-ovl)
  80         (mew-overlay-put beg-or-ovl 'end-open nil)
  81       (put-text-property beg-or-ovl end 'end-open nil)))
  82   (defun mew-rear-nonsticky (beg-or-ovl &optional end)
  83     (if (mew-overlay-p beg-or-ovl)
  84         (mew-overlay-put beg-or-ovl 'end-open t)
  85       (put-text-property beg-or-ovl end 'end-open t)))
  86   (fset 'mew-buffer-substring (symbol-function 'buffer-substring))
  87   (defun mew-mark () (mark t))
  88   (defun mew-pop-to-buffer (buf)
  89     (setq buf (get-buffer-create buf))
  90     (select-window (display-buffer buf nil (selected-frame)))
  91     (set-buffer buf))
  92   (defun mew-timer (min func)
  93     (add-timeout (* min 60) func nil)))
  94  (mew-temacs-p
  95   (if window-system (require 'faces))
  96   (fset 'mew-overlay-p (symbol-function 'overlayp))
  97   (defun mew-overlay-make (beg end)
  98     (let ((ovl (make-overlay beg end)))
  99       (overlay-put ovl 'mew t)
 100       ovl))
 101   (fset 'mew-overlay-move (symbol-function 'move-overlay))
 102   (fset 'mew-overlay-get (symbol-function 'overlay-get))
 103   (fset 'mew-overlay-put (symbol-function 'overlay-put))
 104   (fset 'mew-overlay-delete (symbol-function 'delete-overlay))
 105   (defun mew-overlay-delete (ovl)
 106     (and (overlay-get ovl 'mew) (delete-overlay ovl)))
 107   (if (fboundp 'overlays-in)
 108       (defun mew-overlay-delete-region (beg end)
 109         (interactive "r")
 110         (mapcar (function mew-overlay-delete) (overlays-in beg end)))
 111     (defun mew-overlay-delete-region (beg end)
 112       (interactive "r")
 113       (let ((cur (if (overlays-at beg) beg (next-overlay-change beg))))
 114         (while (and (<= cur end) (overlays-at cur))
 115           (mapcar (function mew-overlay-delete) (overlays-at cur)))
 116         (setq cur (next-overlay-change cur)))))
 117   (defun mew-front-sticky (beg-or-ovl &optional end)
 118     (if (mew-overlay-p beg-or-ovl)
 119         (mew-overlay-put beg-or-ovl 'front-sticky t)
 120       (put-text-property beg-or-ovl end 'front-sticky t)))
 121   (defun mew-front-nonsticky (beg-or-ovl &optional end)
 122     (if (mew-overlay-p beg-or-ovl)
 123         (mew-overlay-put beg-or-ovl 'front-sticky nil)
 124       (put-text-property beg-or-ovl end 'front-sticky nil)))
 125   (defun mew-rear-sticky (beg-or-ovl &optional end)
 126     (if (mew-overlay-p beg-or-ovl)
 127         (mew-overlay-put beg-or-ovl 'rear-nonsticky nil)
 128       (put-text-property beg-or-ovl end 'rear-nonsticky nil)))
 129   (defun mew-rear-nonsticky (beg-or-ovl &optional end)
 130     (if (mew-overlay-p beg-or-ovl)
 131         (mew-overlay-put beg-or-ovl 'rear-nonsticky t)
 132       (put-text-property beg-or-ovl end 'rear-nonsticky t)))
 133   (require 'easymenu)
 134   (if (fboundp 'buffer-substring-no-properties)
 135       (fset 'mew-buffer-substring
 136             (symbol-function 'buffer-substring-no-properties))
 137     (defun mew-buffer-substring (beg end)
 138       "Return the text from BEG to END, without text properties, as a string."
 139       (let ((string (buffer-substring beg end)))
 140         (set-text-properties 0 (length string) nil string)
 141         string)))
 142   (defun mew-mark () (marker-position (mark-marker)))
 143   (fset 'mew-pop-to-buffer (symbol-function 'pop-to-buffer))
 144   (defun mew-timer (min func)
 145     (run-at-time (format "%d min" min) nil func))))
 146
 147 (defun mew-overlay-delete-buffer ()
 148   (save-restriction
 149     (widen)
 150     (mew-overlay-delete-region (point-min) (point-max))))
 151
 152 (if (string< "19.34" emacs-version)
 153     (defvar mew-use-overlay-keymap t)
 154   (defvar mew-use-overlay-keymap nil))
 155
 156 (if (fboundp 'characterp)
 157     (fset 'mew-characterp (symbol-function 'characterp))
 158   (fset 'mew-characterp (symbol-function 'integerp)))
 159
 160 (if (fboundp 'string-width)
 161     (fset 'mew-string-width (symbol-function 'string-width))
 162   (fset 'mew-string-width (symbol-function 'length)))
 163
 164 (if (fboundp 'local-variable-p)
 165     (if mew-xemacs-p
 166         (defmacro mew-local-variable-p (var)
 167           (` (local-variable-p (, var) (current-buffer))))
 168       (fset 'mew-local-variable-p (symbol-function 'local-variable-p)))
 169   (defun mew-local-variable-p (var)
 170     (assoc var (buffer-local-variables))))
 171
 172 (if (fboundp 'set-keymap-parent)        ; for Emacs (or XEmacs)
 173     (defalias 'mew-set-keymap-parent 'set-keymap-parent)
 174   (if (fboundp 'set-keymap-parents)     ; for XEmacs
 175       (defalias 'mew-set-keymap-parent 'set-keymap-parents)
 176     (defun mew-set-keymap-parent (keymap parent) ; for Emacs19
 177       (if (not (keymapp keymap))
 178           (error "ERROR: not keymap, %s" keymap)
 179         (if (and parent (not (keymapp parent)))
 180             (error "ERROR: not keymap, %s" parent)
 181           (catch 'done
 182             (while (cdr keymap)
 183               (if (eq (car (cdr keymap)) 'keymap)
 184                   (throw 'done (setcdr keymap parent)))
 185               (setq keymap (cdr keymap)))
 186             (nconc keymap parent)
 187             parent))))))
 188
 189 ;; to avoid competition with mh-e.el, sigh.
 190 (if (rassq 'mh-letter-mode auto-mode-alist)
 191     (setq auto-mode-alist
 192           (delete (rassq 'mh-letter-mode auto-mode-alist)
 193                   auto-mode-alist)))
 194
 195 ;; tricky way to tell users that subprocess is running
 196 (or (assq 'mew-summary-buffer-process minor-mode-alist)
 197     (setq minor-mode-alist (cons '(mew-summary-buffer-process " Running")
 198                                  minor-mode-alist)))
 199
 200 (defvar mew-connection-type1 nil
 201   "Connection type for many processes. 't' means PTY and 'nil' means PIPE.
 202 PIPE is usually recommended for speed but some OSes such as Linux
 203 requires PTY.")
 204
 205 (defvar mew-connection-type2 t
 206   "Connection type for processes that requires a password. ")
 207
 208 (cond
 209  ((fboundp 'make-symbolic-link)
 210   (defun mew-symbolic-link (filename newname &optional OK-IF-ALREADY-EXISTS)
 211     (if (file-directory-p (file-chase-links filename))
 212         (error "Can't make a symbolic link to directory")
 213       (make-symbolic-link filename newname OK-IF-ALREADY-EXISTS)))
 214   (defun mew-link (filename newname &optional OK-IF-ALREADY-EXISTS)
 215     (if (file-directory-p (file-chase-links filename))
 216         (error "Can't make a link to directory")
 217       (add-name-to-file filename newname OK-IF-ALREADY-EXISTS))))
 218  (t
 219   (defun mew-symbolic-link (filename newname &optional OK-IF-ALREADY-EXISTS)
 220     (if (file-directory-p filename)
 221         (error "Can't make a copy of directory")
 222       (copy-file filename newname OK-IF-ALREADY-EXISTS 'keepdate)))
 223   (defun mew-link (filename newname &optional OK-IF-ALREADY-EXISTS)
 224     (if (file-directory-p filename)
 225         (error "Can't make a copy of directory")
 226       (copy-file filename newname OK-IF-ALREADY-EXISTS 'keepdate)))))
 227
 228 (cond
 229  ((fboundp 'string-to-char-list)
 230   (defalias 'mew-string-to-list 'string-to-char-list))
 231  ((fboundp 'string-to-list)
 232   (defalias 'mew-string-to-list 'string-to-list)))
 233
 234 (if (fboundp 'char-width)
 235     (defalias 'mew-char-width 'char-width)
 236   (defmacro mew-char-width (x) 1))
 237
 238 (provide 'mew-env)
 239
 240 ;;; Copyright Notice:
 241
 242 ;; Copyright (C) 1997, 1998, 1999 Mew developing team.
 243 ;; All rights reserved.
 244
 245 ;; Redistribution and use in source and binary forms, with or without
 246 ;; modification, are permitted provided that the following conditions
 247 ;; are met:
 248 ;;
 249 ;; 1. Redistributions of source code must retain the above copyright
 250 ;;    notice, this list of conditions and the following disclaimer.
 251 ;; 2. Redistributions in binary form must reproduce the above copyright
 252 ;;    notice, this list of conditions and the following disclaimer in the
 253 ;;    documentation and/or other materials provided with the distribution.
 254 ;; 3. Neither the name of the team nor the names of its contributors
 255 ;;    may be used to endorse or promote products derived from this software
 256 ;;    without specific prior written permission.
 257 ;;
 258 ;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' AND
 259 ;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 260 ;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
 261 ;; PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE TEAM OR CONTRIBUTORS BE
 262 ;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 263 ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
 264 ;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
 265 ;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
 266 ;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
 267 ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
 268 ;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 269
 270 ;;; mew-env.el ends here