poe.el

   1 ;;; poe.el --- Portable Outfit for Emacsen; -*-byte-compile-dynamic: t;-*-
   2
   3 ;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
   4
   5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   6 ;; Keywords: emulation, compatibility, NEmacs, MULE, Emacs/mule, XEmacs
   7
   8 ;; This file is part of APEL (A Portable Emacs Library).
   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 GNU Emacs; 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 ;;; Commentary:
  26
  27 ;; This modules does not includes MULE related features.  MULE related
  28 ;; features are supported by `poem'.
  29
  30 ;;; Code:
  31
  32 (provide 'poe)
  33
  34 (defmacro defun-maybe (name &rest everything-else)
  35   (or (and (fboundp name)
  36            (not (get name 'defun-maybe)))
  37       (` (or (fboundp (quote (, name)))
  38              (progn
  39                (defun (, name) (,@ everything-else))
  40                (put (quote (, name)) 'defun-maybe t)
  41                ))
  42          )))
  43
  44 (defmacro defmacro-maybe (name &rest everything-else)
  45   (or (and (fboundp name)
  46            (not (get name 'defmacro-maybe)))
  47       (` (or (fboundp (quote (, name)))
  48              (progn
  49                (defmacro (, name) (,@ everything-else))
  50                (put (quote (, name)) 'defmacro-maybe t)
  51                ))
  52          )))
  53
  54 (defmacro-maybe defsubst (name arglist &rest body)
  55   "Define an inline function.  The syntax is just like that of `defun'."
  56   (cons 'defun (cons name (cons arglist body)))
  57   )
  58
  59 (defmacro defsubst-maybe (name &rest everything-else)
  60   (or (and (fboundp name)
  61            (not (get name 'defsubst-maybe)))
  62       (` (or (fboundp (quote (, name)))
  63              (progn
  64                (defsubst (, name) (,@ everything-else))
  65                (put (quote (, name)) 'defsubst-maybe t)
  66                ))
  67          )))
  68
  69 (defmacro defalias-maybe (symbol definition)
  70   (setq symbol (eval symbol))
  71   (or (and (fboundp symbol)
  72            (not (get symbol 'defalias-maybe)))
  73       (` (or (fboundp (quote (, symbol)))
  74              (progn
  75                (defalias (quote (, symbol)) (, definition))
  76                (put (quote (, symbol)) 'defalias-maybe t)
  77                ))
  78          )))
  79
  80 (put 'defun-maybe 'lisp-indent-function 'defun)
  81 (put 'defsubst-maybe 'lisp-indent-function 'defun)
  82 (put 'defmacro-maybe 'lisp-indent-function 'defun)
  83
  84 (defmacro defvar-maybe (name &rest everything-else)
  85   (or (and (boundp name)
  86            (not (get name 'defvar-maybe)))
  87       (` (or (boundp (quote (, name)))
  88              (progn
  89                (defvar (, name) (,@ everything-else))
  90                (put (quote (, name)) 'defvar-maybe t)
  91                ))
  92          )))
  93
  94 (defmacro defconst-maybe (name &rest everything-else)
  95   (or (and (boundp name)
  96            (not (get name 'defconst-maybe))
  97            )
  98       (` (or (boundp (quote (, name)))
  99              (progn
 100                (defconst (, name) (,@ everything-else))
 101                (put (quote (, name)) 'defconst-maybe t)
 102                ))
 103          )))
 104
 105 (defmacro defun-maybe-cond (name args &optional doc &rest everything-else)
 106   (or (stringp doc)
 107       (setq everything-else (cons doc everything-else)
 108             doc nil)
 109       )
 110   (or (and (fboundp name)
 111            (not (get name 'defun-maybe)))
 112       (` (or (fboundp (quote (, name)))
 113              (progn
 114                (cond (,@ (mapcar (function
 115                                   (lambda (case)
 116                                     (list (car case)
 117                                           (if doc
 118                                               (` (defun (, name) (, args)
 119                                                    (, doc)
 120                                                    (,@ (cdr case))))
 121                                             (` (defun (, name) (, args)
 122                                                  (,@ (cdr case))))
 123                                             ))))
 124                                  everything-else)))
 125                (put (quote (, name)) 'defun-maybe t)
 126                )))))
 127
 128 (defsubst subr-fboundp (symbol)
 129   "Return t if SYMBOL's function definition is a built-in function."
 130   (and (fboundp symbol)
 131        (subrp (symbol-function symbol))))
 132
 133 (defconst-maybe emacs-major-version (string-to-int emacs-version))
 134 (defconst-maybe emacs-minor-version
 135   (string-to-int
 136    (substring emacs-version
 137               (string-match (format "%d\\." emacs-major-version)
 138                             emacs-version))))
 139
 140 (cond ((featurep 'xemacs)
 141        (require 'poe-xemacs)
 142        )
 143       ((string-match "XEmacs" emacs-version)
 144        (provide 'xemacs)
 145        (require 'poe-xemacs)
 146        )
 147       ((> emacs-major-version 20))
 148       ((= emacs-major-version 20)
 149        (cond ((subr-fboundp 'string)
 150               ;; Emacs 20.3 or later
 151               )
 152              ((subr-fboundp 'concat-chars)
 153               ;; Emacs 20.1 or later
 154               (defalias 'string 'concat-chars)
 155               ))
 156        )
 157       ((= emacs-major-version 19))
 158       (t
 159        (require 'poe-18)
 160        ))
 161
 162 ;;; @ Emacs 19.23 emulation
 163 ;;;
 164
 165 (defun-maybe minibuffer-prompt-width ()
 166   "Return the display width of the minibuffer prompt."
 167   (save-excursion
 168     (set-buffer (window-buffer (minibuffer-window)))
 169     (current-column)))
 170
 171
 172 ;;; @ Emacs 19.29 emulation
 173 ;;;
 174
 175 (defvar-maybe path-separator ":"
 176   "Character used to separate concatenated paths.")
 177
 178 (defun-maybe buffer-substring-no-properties (start end)
 179   "Return the characters of part of the buffer, without the text properties.
 180 The two arguments START and END are character positions;
 181 they can be in either order. [Emacs 19.29 emulating function]"
 182   (let ((string (buffer-substring start end)))
 183     (set-text-properties 0 (length string) nil string)
 184     string))
 185
 186 (defun-maybe match-string (num &optional string)
 187   "Return string of text matched by last search.
 188 NUM specifies which parenthesized expression in the last regexp.
 189  Value is nil if NUMth pair didn't match, or there were less than NUM pairs.
 190 Zero means the entire text matched by the whole regexp or whole string.
 191 STRING should be given if the last search was by `string-match' on STRING.
 192 \[Emacs 19.29 emulating function]"
 193   (if (match-beginning num)
 194       (if string
 195           (substring string (match-beginning num) (match-end num))
 196         (buffer-substring (match-beginning num) (match-end num)))))
 197
 198 (or (featurep 'xemacs)
 199     (>= emacs-major-version 20)
 200     (and (= emacs-major-version 19)
 201          (>= emacs-minor-version 29))
 202     ;; for Emacs 19.28 or earlier
 203     (fboundp 'si:read-string)
 204     (eval-and-compile
 205       (fset 'si:read-string (symbol-function 'read-string))
 206       (defun read-string (prompt &optional initial-input history)
 207         "Read a string from the minibuffer, prompting with string PROMPT.
 208 If non-nil, second arg INITIAL-INPUT is a string to insert before reading.
 209 The third arg HISTORY, is dummy for compatibility.
 210 See `read-from-minibuffer' for details of HISTORY argument."
 211         (si:read-string prompt initial-input))
 212       ))
 213
 214 (defun-maybe rassoc (key list)
 215   "Return non-nil if KEY is `equal' to the cdr of an element of LIST.
 216 The value is actually the element of LIST whose cdr equals KEY."
 217   (catch 'found
 218     (while list
 219       (if (equal (cdr (car list)) key)
 220           (throw 'found (car list))
 221         )
 222       (setq list (cdr list)))
 223     ))
 224
 225 (defun-maybe file-name-sans-extension (filename)
 226   "Return FILENAME sans final \"extension\".
 227 The extension, in a file name, is the part that follows the last `.'."
 228   (save-match-data
 229     (let ((file (file-name-sans-versions (file-name-nondirectory filename)))
 230           directory)
 231       (if (string-match "\\.[^.]*\\'" file)
 232           (if (setq directory (file-name-directory filename))
 233               (expand-file-name (substring file 0 (match-beginning 0))
 234                                 directory)
 235             (substring file 0 (match-beginning 0)))
 236         filename))))
 237
 238 ;; They are not Emacs features
 239
 240 (defmacro-maybe add-local-hook (hook function &optional append)
 241   (if (fboundp 'make-local-hook)
 242       (list 'add-hook hook function append t)
 243     (list 'add-hook hook function append)
 244     ))
 245
 246 (defmacro-maybe remove-local-hook (hook function)
 247   (if (fboundp 'make-local-hook)
 248       (list 'remove-hook hook function t)
 249     (list 'remove-hook hook function)
 250     ))
 251
 252 (defmacro-maybe make-local-hook (hook))
 253
 254
 255 ;;; @ Emacs 19.30 emulation
 256 ;;;
 257
 258 ;; imported from Emacs 19.30.
 259 (defun-maybe add-to-list (list-var element)
 260   "Add to the value of LIST-VAR the element ELEMENT if it isn't there yet.
 261 If you want to use `add-to-list' on a variable that is not defined
 262 until a certain package is loaded, you should put the call to `add-to-list'
 263 into a hook function that will be run only after loading the package.
 264 \[Emacs 19.30 emulating function]"
 265   (or (member element (symbol-value list-var))
 266       (set list-var (cons element (symbol-value list-var)))))
 267
 268 (cond ((fboundp 'insert-file-contents-literally))
 269       ((boundp 'file-name-handler-alist)
 270        (defun insert-file-contents-literally
 271          (filename &optional visit beg end replace)
 272          "Like `insert-file-contents', q.v., but only reads in the file.
 273 A buffer may be modified in several ways after reading into the buffer due
 274 to advanced Emacs features, such as file-name-handlers, format decoding,
 275 find-file-hooks, etc.
 276   This function ensures that none of these modifications will take place.
 277 \[Emacs 19.30 emulating function]"
 278          (let (file-name-handler-alist)
 279            (insert-file-contents filename visit beg end replace)))
 280        )
 281       (t
 282        (defalias 'insert-file-contents-literally 'insert-file-contents)
 283        ))
 284
 285
 286 ;;; @ Emacs 19.31 emulation
 287 ;;;
 288
 289 (defun-maybe buffer-live-p (object)
 290   "Return non-nil if OBJECT is a buffer which has not been killed.
 291 Value is nil if OBJECT is not a buffer or if it has been killed.
 292 \[Emacs 19.31 emulating function]"
 293   (and object
 294        (get-buffer object)
 295        (buffer-name (get-buffer object))))
 296
 297 ;; imported from Emacs 19.33.
 298 (defmacro-maybe save-selected-window (&rest body)
 299   "Execute BODY, then select the window that was selected before BODY.
 300 \[Emacs 19.31 emulating function]"
 301   (list 'let
 302         '((save-selected-window-window (selected-window)))
 303         (list 'unwind-protect
 304               (cons 'progn body)
 305               (list 'select-window 'save-selected-window-window))))
 306
 307
 308 ;;; @ Emacs 20.1 emulation
 309 ;;;
 310
 311 ;; imported from Emacs 20.2.
 312 (defmacro-maybe when (cond &rest body)
 313   "(when COND BODY...): if COND yields non-nil, do BODY, else return nil."
 314   (list 'if cond (cons 'progn body)))
 315
 316 ;; imported from Emacs 20.3.
 317 (defmacro-maybe unless (cond &rest body)
 318   "(unless COND BODY...): if COND yields nil, do BODY, else return nil."
 319   (cons 'if (cons cond (cons nil body))))
 320
 321 ;; imported from Emacs 20.3.
 322 (defun-maybe last (x &optional n)
 323   "Return the last link of the list X.  Its car is the last element.
 324 If X is nil, return nil.
 325 If N is non-nil, return the Nth-to-last link of X.
 326 If N is bigger than the length of X, return X."
 327   (if n
 328       (let ((m 0) (p x))
 329         (while (consp p)
 330           (setq m (1+ m) p (cdr p)))
 331         (if (<= n 0) p
 332           (if (< n m) (nthcdr (- m n) x) x)))
 333     (while (cdr x)
 334       (setq x (cdr x)))
 335     x))
 336
 337 (defmacro-maybe save-current-buffer (&rest body)
 338   "Save the current buffer; execute BODY; restore the current buffer.
 339 Executes BODY just like `progn'."
 340   (` (let ((orig-buffer (current-buffer)))
 341        (unwind-protect
 342            (progn (,@ body))
 343          (set-buffer orig-buffer)))))
 344
 345 ;; imported from Emacs 20.2.
 346 (defmacro-maybe with-current-buffer (buffer &rest body)
 347   "Execute the forms in BODY with BUFFER as the current buffer.
 348 The value returned is the value of the last form in BODY.
 349 See also `with-temp-buffer'."
 350   (` (save-current-buffer
 351        (set-buffer (, buffer))
 352        (,@ body))))
 353
 354 ;; imported from Emacs 20.2.
 355 (defmacro-maybe with-temp-file (file &rest forms)
 356   "Create a new buffer, evaluate FORMS there, and write the buffer to FILE.
 357 The value of the last form in FORMS is returned, like `progn'.
 358 See also `with-temp-buffer'."
 359   (let ((temp-file (make-symbol "temp-file"))
 360         (temp-buffer (make-symbol "temp-buffer")))
 361     (` (let (((, temp-file) (, file))
 362              ((, temp-buffer)
 363               (get-buffer-create (generate-new-buffer-name " *temp file*"))))
 364          (unwind-protect
 365              (prog1
 366                  (with-current-buffer (, temp-buffer)
 367                    (,@ forms))
 368                (with-current-buffer (, temp-buffer)
 369                  (widen)
 370                  (write-region (point-min) (point-max) (, temp-file) nil 0)))
 371            (and (buffer-name (, temp-buffer))
 372                 (kill-buffer (, temp-buffer))))))))
 373
 374 ;; imported from Emacs 20.2.
 375 (defmacro-maybe with-temp-buffer (&rest forms)
 376   "Create a temporary buffer, and evaluate FORMS there like `progn'.
 377 See also `with-temp-file' and `with-output-to-string'."
 378   (let ((temp-buffer (make-symbol "temp-buffer")))
 379     (` (let (((, temp-buffer)
 380               (get-buffer-create (generate-new-buffer-name " *temp*"))))
 381          (unwind-protect
 382              (with-current-buffer (, temp-buffer)
 383                (,@ forms))
 384            (and (buffer-name (, temp-buffer))
 385                 (kill-buffer (, temp-buffer))))))))
 386
 387 (defmacro-maybe combine-after-change-calls (&rest body)
 388   "Execute BODY."
 389   (cons 'progn body))
 390
 391 ;; imported from Emacs 20.3. (cl function)
 392 (defun-maybe butlast (x &optional n)
 393   "Returns a copy of LIST with the last N elements removed."
 394   (if (and n (<= n 0)) x
 395     (nbutlast (copy-sequence x) n)))
 396
 397 ;; imported from Emacs 20.3. (cl function)
 398 (defun-maybe nbutlast (x &optional n)
 399   "Modifies LIST to remove the last N elements."
 400   (let ((m (length x)))
 401     (or n (setq n 1))
 402     (and (< n m)
 403          (progn
 404            (if (> n 0) (setcdr (nthcdr (- (1- m) n) x) nil))
 405            x))))
 406
 407 ;; imported from XEmacs 21.
 408 (defun-maybe split-string (string &optional pattern)
 409   "Return a list of substrings of STRING which are separated by PATTERN.
 410 If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"."
 411   (or pattern
 412       (setq pattern "[ \f\t\n\r\v]+"))
 413   ;; The FSF version of this function takes care not to cons in case
 414   ;; of infloop.  Maybe we should synch?
 415   (let (parts (start 0))
 416     (while (string-match pattern string start)
 417       (setq parts (cons (substring string start (match-beginning 0)) parts)
 418             start (match-end 0)))
 419     (nreverse (cons (substring string start) parts))))
 420
 421
 422 ;;; @ Emacs 20.3 emulation
 423 ;;;
 424
 425 ;; imported from Emacs 20.3.91.
 426 (defvar-maybe temporary-file-directory
 427   (file-name-as-directory
 428    (cond ((memq system-type '(ms-dos windows-nt))
 429           (or (getenv "TEMP") (getenv "TMPDIR") (getenv "TMP") "c:/temp"))
 430          ((memq system-type '(vax-vms axp-vms))
 431           (or (getenv "TMPDIR") (getenv "TMP") (getenv "TEMP") "SYS$SCRATCH:"))
 432          (t
 433           (or (getenv "TMPDIR") (getenv "TMP") (getenv "TEMP") "/tmp"))))
 434   "The directory for writing temporary files.")
 435
 436 (defun-maybe line-beginning-position (&optional n)
 437   "Return the character position of the first character on the current line.
 438 With argument N not nil or 1, move forward N - 1 lines first.
 439 If scan reaches end of buffer, return that position.
 440 This function does not move point."
 441   (save-excursion
 442     (if n
 443         (forward-line (1- n))
 444       )
 445     (beginning-of-line)
 446     (point)))
 447
 448 (defun-maybe line-end-position (&optional n)
 449   "Return the character position of the last character on the current line.
 450 With argument N not nil or 1, move forward N - 1 lines first.
 451 If scan reaches end of buffer, return that position.
 452 This function does not move point."
 453   (save-excursion
 454     (if n
 455         (forward-line (1- n))
 456       )
 457     (end-of-line)
 458     (point)))
 459
 460 (defun-maybe string (&rest chars)
 461   "Concatenate all the argument characters and make the result a string."
 462   (mapconcat (function char-to-string) chars "")
 463   )
 464
 465
 466 ;;; @ XEmacs emulation
 467 ;;;
 468
 469 (defun-maybe find-face (face-or-name)
 470   "Retrieve the face of the given name.
 471 If FACE-OR-NAME is a face object, it is simply returned.
 472 Otherwise, FACE-OR-NAME should be a symbol.  If there is no such face,
 473 nil is returned.  Otherwise the associated face object is returned.
 474 \[XEmacs emulating function]"
 475   (car (memq face-or-name (face-list)))
 476   )
 477
 478 (defun-maybe point-at-bol (&optional n buffer)
 479   "Return the character position of the first character on the current line.
 480 With argument N not nil or 1, move forward N - 1 lines first.
 481 If scan reaches end of buffer, return that position.
 482 This function does not move point. [XEmacs emulating function]"
 483   (save-excursion
 484     (if buffer
 485         (set-buffer buffer)
 486       )
 487     (line-beginning-position n)
 488     ))
 489
 490 (defun-maybe point-at-eol (&optional n buffer)
 491   "Return the character position of the last character on the current line.
 492 With argument N not nil or 1, move forward N - 1 lines first.
 493 If scan reaches end of buffer, return that position.
 494 This function does not move point. [XEmacs emulating function]"
 495   (save-excursion
 496     (if buffer
 497         (set-buffer buffer)
 498       )
 499     (line-end-position n)
 500     ))
 501
 502 (defun-maybe functionp (obj)
 503   "Returns t if OBJ is a function, nil otherwise.
 504 \[XEmacs emulating function]"
 505   (or (subrp obj)
 506       (byte-code-function-p obj)
 507       (and (symbolp obj)(fboundp obj))
 508       (and (consp obj)(eq (car obj) 'lambda))
 509       ))
 510
 511 (defsubst-maybe define-obsolete-function-alias (oldfun newfun)
 512   "Define OLDFUN as an obsolete alias for function NEWFUN.
 513 This makes calling OLDFUN equivalent to calling NEWFUN and marks OLDFUN
 514 as obsolete. [XEmacs emulating function]"
 515   (defalias oldfun newfun)
 516   (make-obsolete oldfun newfun)
 517   )
 518
 519 (when (subr-fboundp 'read-event)
 520   ;; for Emacs 19 or later
 521
 522   (defun-maybe-cond next-command-event (&optional event prompt)
 523     "Read an event object from the input stream.
 524 If EVENT is non-nil, it should be an event object and will be filled
 525 in and returned; otherwise a new event object will be created and
 526 returned.
 527 If PROMPT is non-nil, it should be a string and will be displayed in
 528 the echo area while this function is waiting for an event.
 529 \[XEmacs emulating function]"
 530     ((subr-fboundp 'string)
 531      ;; for Emacs 20.3 or later
 532      (read-event prompt t)
 533      )
 534     (t
 535      (if prompt (message prompt))
 536      (read-event)
 537      ))
 538
 539   (defsubst-maybe character-to-event (ch)
 540     "Convert keystroke CH into an event structure, replete with bucky bits.
 541 Note that CH (the keystroke specifier) can be an integer, a character
 542 or a symbol such as 'clear. [XEmacs emulating function]"
 543     ch)
 544
 545   (defun-maybe event-to-character (event)
 546     "Return the character approximation to the given event object.
 547 If the event isn't a keypress, this returns nil.
 548 \[XEmacs emulating function]"
 549     (cond ((symbolp event)
 550            ;; mask is (BASE-TYPE MODIFIER-BITS) or nil.
 551            (let ((mask (get event 'event-symbol-element-mask)))
 552              (if mask
 553                  (let ((base (get (car mask) 'ascii-character)))
 554                    (if base
 555                        (logior base (car (cdr mask)))
 556                      )))))
 557           ((integerp event) event)
 558           ))
 559   )
 560
 561
 562 ;;; @ MULE 2 emulation
 563 ;;;
 564
 565 (defun-maybe-cond cancel-undo-boundary ()
 566   "Cancel undo boundary. [MULE 2.3 emulating function]"
 567   ((boundp 'buffer-undo-list)
 568    ;; for Emacs 19.7 or later
 569    (if (and (consp buffer-undo-list)
 570             ;; if car is nil.
 571             (null (car buffer-undo-list)))
 572        (setq buffer-undo-list (cdr buffer-undo-list))
 573      ))
 574   (t
 575    ;; for anything older than Emacs 19.7.
 576    ))
 577
 578
 579 ;;; @ end
 580 ;;;
 581
 582 ;;; poe.el ends here