cgit.sxemacs.org Git - packages/blob - mule-packages/lookup/lisp/evi.el

   1 ;;; evi.el --- Emacs version integrator
   2 ;; Copyright (C) 1999 Lookup Development Team <lookup@ring.gr.jp>
   3
   4 ;; Author: Keisuke Nishida <kei@psn.net>
   5 ;; Version: $Id: evi.el,v 1.3 1999/05/24 02:44:14 yoshimi Exp $
   6
   7 ;; This file is part of `evi'.
   8
   9 ;; This program is free software; you can redistribute it and/or
  10 ;; modify it under the terms of the GNU General Public License
  11 ;; as published by the Free Software Foundation; either version 2
  12 ;; of the License, or (at your option) any later version.
  13
  14 ;; This program is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with this program; if not, write to the Free Software Foundation,
  21 ;; Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  22
  23 ;;; Code:
  24
  25 (or (fboundp 'when)
  26     (defmacro when (cond &rest body) (` (if (, cond) (progn (,@ body))))))
  27 (or (fboundp 'unless)
  28     (defmacro unless (cond &rest body) (` (if (, cond) nil (,@ body)))))
  29
  30 (or (fboundp 'caar) (defun caar (obj) (car (car obj))))
  31 (or (fboundp 'cadr) (defun cadr (obj) (car (cdr obj))))
  32 (or (fboundp 'cdar) (defun cdar (obj) (cdr (car obj))))
  33 (or (fboundp 'cddr) (defun cddr (obj) (cdr (cdr obj))))
  34
  35 (or (fboundp 'defgroup)
  36     (defmacro defgroup (symbol members doc &rest rest) nil))
  37 (or (fboundp 'defcustom)
  38     (defmacro defcustom (symbol value doc &rest rest)
  39       (list 'defvar symbol value doc)))
  40 (or (fboundp 'defface)
  41     (defmacro defface (face spec doc &rest rest)
  42       (let ((list (cadr (assq t (eval spec))))
  43             (symbol (list 'quote face))
  44             key value exp)
  45         (while list
  46           (setq key (car list) value (cadr list))
  47           (setq exp (cons (cond ((eq key ':bold)
  48                                  (list 'set-face-bold-p symbol value))
  49                                 ((eq key ':underline)
  50                                  (list 'set-face-underline-p symbol value))
  51                                 ((eq key ':foreground)
  52                                  (list 'set-face-foreground symbol value)))
  53                           exp))
  54           (setq list (cddr list)))
  55         (cons 'progn (cons (list 'setq face (list 'make-face symbol)) exp)))))
  56
  57 (or (fboundp 'plist-get)
  58     (defun plist-get (plist prop)
  59       (catch 'value
  60         (while plist
  61           (if (eq (car plist) prop)
  62               (throw 'value (cadr plist))
  63             (setq plist (cddr plist)))))))
  64
  65 (or (fboundp 'plist-put)
  66     (defun plist-put (plist prop val)
  67       (catch 'new-list
  68         (let ((list plist))
  69           (while list
  70             (when (eq (car list) prop)
  71               (setcar (cdr list) val)
  72               (throw 'new-list plist))
  73             (setq list (cddr list)))
  74           (cons prop (cons val plist))))))
  75
  76 (or (fboundp 'save-current-buffer)
  77     (defmacro save-current-buffer (&rest body)
  78       (` (let ((evi-orig-buffer (current-buffer)))
  79            (unwind-protect
  80                (progn (,@ body))
  81              (set-buffer evi-orig-buffer))))))
  82
  83 (or (fboundp 'save-selected-window)
  84     (defmacro save-selected-window (&rest body)
  85       (` (let ((save-selected-window-window (selected-window)))
  86            (unwind-protect
  87                (progn (,@ body))
  88              (select-window save-selected-window-window))))))
  89
  90 (or (fboundp 'with-current-buffer)
  91     (defmacro with-current-buffer (buffer &rest body)
  92       (` (save-current-buffer
  93            (set-buffer (, buffer))
  94            (,@ body)))))
  95
  96 (or (fboundp 'with-temp-buffer)
  97     (defmacro with-temp-buffer (&rest forms)
  98       (let ((temp-buffer (make-symbol "temp-buffer")))
  99         (` (let (((, temp-buffer)
 100                   (get-buffer-create (generate-new-buffer-name " *temp*"))))
 101              (unwind-protect
 102                  (with-current-buffer (, temp-buffer)
 103                    (,@ forms))
 104                (and (buffer-name (, temp-buffer))
 105                     (kill-buffer (, temp-buffer)))))))))
 106
 107 (or (fboundp 'with-temp-file)
 108     (defmacro with-temp-file (file &rest forms)
 109       (let ((temp-file (make-symbol "temp-file"))
 110             (temp-buffer (make-symbol "temp-buffer")))
 111         (` (let (((, temp-file) (, file))
 112                  ((, temp-buffer) (get-buffer-create
 113                                    (generate-new-buffer-name " *temp file*"))))
 114              (unwind-protect
 115                  (prog1 (with-current-buffer (, temp-buffer) (,@ forms))
 116                    (with-current-buffer (, temp-buffer)
 117                      (widen)
 118                      (write-region (point-min) (point-max)
 119                                    (, temp-file) nil 0)))
 120                (and (buffer-name (, temp-buffer))
 121                     (kill-buffer (, temp-buffer)))))))))
 122
 123 (or (fboundp 'add-to-list)
 124     (defun add-to-list (symbol element)
 125       (or (member element (symbol-value symbol))
 126           (set symbol (cons element (symbol-value symbol))))))
 127
 128 (or (fboundp 'match-string)
 129     (defun match-string (num &optional string)
 130       (if (match-beginning num)
 131           (if string
 132               (substring string (match-beginning num) (match-end num))
 133             (buffer-substring (match-beginning num) (match-end num))))))
 134
 135 (or (fboundp 'buffer-substring-no-properties)
 136     (defun buffer-substring-no-properties (start end)
 137       (format "%s" (buffer-substring start end))))
 138
 139 (or (fboundp 'file-name-sans-extension)
 140     (defun file-name-sans-extension (filename)
 141       (if (string-match "\\.[^./]*$" filename)
 142           (substring filename 0 (match-beginning 0))
 143         filename)))
 144
 145 (or (fboundp 'string-width) (defalias 'string-width 'length))
 146 (or (fboundp 'string-to-list) (defalias 'string-to-list 'string-to-char-list))
 147 (or (fboundp 'make-char) (defalias 'make-char 'make-character))
 148 (or (fboundp 'buffer-live-p) (defalias 'buffer-live-p 'buffer-name))
 149
 150 (or (fboundp 'frame-first-window)
 151     (defalias 'frame-first-window 'frame-highest-window))
 152
 153 (or (fboundp 'make-variable-frame-local)
 154     (defalias 'make-variable-frame-local 'make-variable-buffer-local))
 155
 156 (or (fboundp 'frame-parameter)
 157     (if (fboundp 'frame-property)
 158         (defalias 'frame-parameter 'frame-property)
 159       (defun frame-parameter (frame parameter)
 160         (cdr (assq parameter (frame-parameters frame))))))
 161
 162 (when (string< emacs-version "20")
 163   (defvar evi-orig-char-after (symbol-function 'char-after))
 164   (defun char-after (&optional pos)
 165     (funcall evi-orig-char-after (or pos (point))))
 166
 167   (defvar evi-orig-replace-match (symbol-function 'replace-match))
 168   (defun replace-match (newtext &optional fixedcase literal string)
 169     (if (not string)
 170         (funcall evi-orig-replace-match newtext fixedcase literal)
 171       (with-temp-buffer
 172         (insert string)
 173         (set-match-data (mapcar '1+ (match-data)))
 174         (funcall evi-orig-replace-match newtext fixedcase literal)
 175         (buffer-substring (point-min) (point-max)))))
 176   )
 177
 178
 179 (when (or (string< emacs-version "20") (featurep 'xemacs))
 180   (defvar evi-orig-read-string (symbol-function 'read-string))
 181   (defun read-string (prompt &optional initial history default inherit)
 182     (let ((input (funcall evi-orig-read-string prompt initial)))
 183       (if (and default (equal input ""))
 184           default
 185         input)))
 186
 187   (defvar evi-orig-completing-read (symbol-function 'completing-read))
 188   (defun completing-read (prompt table &optional predicate require-match
 189                                  initial histry default inherit)
 190     (let ((input (funcall evi-orig-completing-read prompt table predicate
 191                           require-match initial histry)))
 192       (if (and default (equal input ""))
 193           default
 194         input)))
 195
 196   (when (string< emacs-version "20.3")
 197     (defvar evi-orig-string-to-number (symbol-function 'string-to-number))
 198     (defun string-to-number (string &optional base)
 199       (if (not base)
 200           (funcall evi-orig-string-to-number string)
 201         (let ((len (length string))
 202               (number 0) (i 0) c)
 203           (if (or (< base 2) (< 16 base))
 204               (error "Args out of range: %d" base)
 205             (while (< i len)
 206               (setq number (* number base))
 207               (setq c (aref string i))
 208               (cond
 209                ((and (<= ?0 c) (<= c ?9)) (setq number (+ number (- c ?0))))
 210                ((and (<= ?a c) (<= c ?f)) (setq number (+ number (- c ?a -10))))
 211                ((and (<= ?A c) (<= c ?F)) (setq number (+ number (- c ?A -10))))
 212                (t (setq i len)))
 213               (setq i (1+ i)))
 214             number)))))
 215   )
 216
 217 (if (featurep 'mule) (require 'evi-mule))
 218
 219 (provide 'evi)
 220
 221 ;;; evi.el ends here