poe.el

   1 ;;; poe.el --- Portable Outfit for Emacsen
   2
   3 ;; Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc.
   4
   5 ;; Author: MORIOKA Tomohiko <tomo@m17n.org>
   6 ;;      Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
   7 ;; Keywords: emulation, compatibility, Nemacs, MULE, Emacs/mule, XEmacs
   8
   9 ;; This file is part of APEL (A Portable Emacs Library).
  10
  11 ;; This program is free software; you can redistribute it and/or
  12 ;; modify it under the terms of the GNU General Public License as
  13 ;; published by the Free Software Foundation; either version 2, or (at
  14 ;; your option) any later version.
  15
  16 ;; This program is distributed in the hope that it will be useful, but
  17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 ;; General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Commentary:
  27
  28 ;;; Code:
  29
  30 (require 'product)
  31 (product-provide (provide 'poe) (require 'apel-ver))
  32
  33 (require 'pym)
  34
  35
  36 ;;; @ Version information.
  37 ;;;
  38
  39 (static-when (= emacs-major-version 18)
  40   (require 'poe-18))
  41
  42 ;; Some ancient version of XEmacs did not provide 'xemacs.
  43 (static-when (string-match "XEmacs" emacs-version)
  44   (provide 'xemacs))
  45
  46 ;; `file-coding' was appeared in the spring of 1998, just before XEmacs
  47 ;; 21.0. Therefore it is not provided in XEmacs with MULE versions 20.4
  48 ;; or earlier.
  49 (static-when (featurep 'xemacs)
  50   ;; must be load-time check to share .elc between w/ MULE and w/o MULE.
  51   (when (featurep 'mule)
  52     (provide 'file-coding)))
  53
  54 (static-when (featurep 'xemacs)
  55   (require 'poe-xemacs))
  56
  57 ;; must be load-time check to share .elc between different systems.
  58 (or (fboundp 'open-network-stream)
  59     (require 'tcp))
  60 \f
  61
  62 ;;; @ C primitives emulation.
  63 ;;;
  64
  65 ;; Emacs 20.3 and earlier: (require FEATURE &optional FILENAME)
  66 ;; Emacs 20.4 and later: (require FEATURE &optional FILENAME NOERROR)
  67 (static-condition-case nil
  68     ;; compile-time check.
  69     (progn
  70       (require 'nofeature "nofile" 'noerror)
  71       (if (get 'require 'defun-maybe)
  72           (error "`require' is already redefined")))
  73   (error
  74    ;; load-time check.
  75    (or (fboundp 'si:require)
  76        (progn
  77          (fset 'si:require (symbol-function 'require))
  78          (defun require (feature &optional filename noerror)
  79            "\
  80 If feature FEATURE is not loaded, load it from FILENAME.
  81 If FEATURE is not a member of the list `features', then the feature
  82 is not loaded; so load the file FILENAME.
  83 If FILENAME is omitted, the printname of FEATURE is used as the file name,
  84 but in this case `load' insists on adding the suffix `.el' or `.elc'.
  85 If the optional third argument NOERROR is non-nil,
  86 then return nil if the file is not found.
  87 Normally the return value is FEATURE."
  88            (if noerror
  89                (condition-case nil
  90                    (si:require feature filename)
  91                  (file-error))
  92              (si:require feature filename)))
  93          ;; for `load-history'.
  94          (setq current-load-list (cons 'require current-load-list))
  95          (put 'require 'defun-maybe t)))))
  96
  97 ;; Emacs 19.29 and later: (plist-get PLIST PROP)
  98 ;; (defun-maybe plist-get (plist prop)
  99 ;;   (while (and plist
 100 ;;               (not (eq (car plist) prop)))
 101 ;;     (setq plist (cdr (cdr plist))))
 102 ;;   (car (cdr plist)))
 103 (static-unless (and (fboundp 'plist-get)
 104                     (not (get 'plist-get 'defun-maybe)))
 105   (or (fboundp 'plist-get)
 106       (progn
 107         (defvar plist-get-internal-symbol)
 108         (defun plist-get (plist prop)
 109           "\
 110 Extract a value from a property list.
 111 PLIST is a property list, which is a list of the form
 112 \(PROP1 VALUE1 PROP2 VALUE2...\).  This function returns the value
 113 corresponding to the given PROP, or nil if PROP is not
 114 one of the properties on the list."
 115           (setplist 'plist-get-internal-symbol plist)
 116           (get 'plist-get-internal-symbol prop))
 117         ;; for `load-history'.
 118         (setq current-load-list (cons 'plist-get current-load-list))
 119         (put 'plist-get 'defun-maybe t))))
 120
 121 ;; Emacs 19.29 and later: (plist-put PLIST PROP VAL)
 122 ;; (defun-maybe plist-put (plist prop val)
 123 ;;   (catch 'found
 124 ;;     (let ((tail plist)
 125 ;;           (prev nil))
 126 ;;       (while (and tail (cdr tail))
 127 ;;         (if (eq (car tail) prop)
 128 ;;             (progn
 129 ;;               (setcar (cdr tail) val)
 130 ;;               (throw 'found plist))
 131 ;;           (setq prev tail
 132 ;;                 tail (cdr (cdr tail)))))
 133 ;;       (if prev
 134 ;;           (progn
 135 ;;             (setcdr (cdr prev) (list prop val))
 136 ;;             plist)
 137 ;;         (list prop val)))))
 138 (static-unless (and (fboundp 'plist-put)
 139                     (not (get 'plist-put 'defun-maybe)))
 140   (or (fboundp 'plist-put)
 141       (progn
 142         (defvar plist-put-internal-symbol)
 143         (defun plist-put (plist prop val)
 144           "\
 145 Change value in PLIST of PROP to VAL.
 146 PLIST is a property list, which is a list of the form
 147 \(PROP1 VALUE1 PROP2 VALUE2 ...\).  PROP is a symbol and VAL is any object.
 148 If PROP is already a property on the list, its value is set to VAL,
 149 otherwise the new PROP VAL pair is added.  The new plist is returned;
 150 use `\(setq x \(plist-put x prop val\)\)' to be sure to use the new value.
 151 The PLIST is modified by side effects."
 152           (setplist 'plist-put-internal-symbol plist)
 153           (put 'plist-put-internal-symbol prop val)
 154           (symbol-plist 'plist-put-internal-symbol))
 155         ;; for `load-history'.
 156         (setq current-load-list (cons 'plist-put current-load-list))
 157         (put 'plist-put 'defun-maybe t))))
 158
 159 ;; Emacs 19.23 and later: (minibuffer-prompt-width)
 160 (defun-maybe minibuffer-prompt-width ()
 161   "Return the display width of the minibuffer prompt."
 162   (save-excursion
 163     (set-buffer (window-buffer (minibuffer-window)))
 164     (current-column)))
 165
 166 ;; (read-string PROMPT &optional INITIAL-INPUT HISTORY)
 167 ;; Emacs 19.29/XEmacs 19.14(?) and later takes optional 3rd arg HISTORY.
 168 (static-unless (or (featurep 'xemacs)
 169                    (>= emacs-major-version 20)
 170                    (and (= emacs-major-version 19)
 171                         (>= emacs-minor-version 29)))
 172   (or (fboundp 'si:read-string)
 173       (progn
 174         (fset 'si:read-string (symbol-function 'read-string))
 175         (defun read-string (prompt &optional initial-input history)
 176           "\
 177 Read a string from the minibuffer, prompting with string PROMPT.
 178 If non-nil, second arg INITIAL-INPUT is a string to insert before reading.
 179 The third arg HISTORY, is dummy for compatibility.
 180 See `read-from-minibuffer' for details of HISTORY argument."
 181           (si:read-string prompt initial-input)))))
 182
 183 ;; (completing-read prompt table &optional
 184 ;; FSF Emacs
 185 ;;      --19.7  : predicate require-match init
 186 ;; 19.7 --19.34 : predicate require-match init hist
 187 ;; 20.1 --      : predicate require-match init hist def inherit-input-method
 188 ;; XEmacs
 189 ;;      --19.(?): predicate require-match init
 190 ;;      --21.2  : predicate require-match init hist
 191 ;; 21.2 --      : predicate require-match init hist def
 192 ;; )
 193
 194 ;; We support following API.
 195 ;; (completing-read prompt table
 196 ;;                  &optional predicate require-match init hist def)
 197 (static-cond
 198  ;; add 'hist' and 'def' argument.
 199  ((< emacs-major-version 19)
 200   (or (fboundp 'si:completing-read)
 201       (progn
 202         (fset 'si:completing-read (symbol-function 'completing-read))
 203         (defun completing-read
 204           (prompt table &optional predicate require-match init
 205                                   hist def)
 206         "Read a string in the minibuffer, with completion.
 207 PROMPT is a string to prompt with; normally it ends in a colon and a space.
 208 TABLE is an alist whose elements' cars are strings, or an obarray.
 209 PREDICATE limits completion to a subset of TABLE.
 210 See `try-completion' and `all-completions' for more details
 211  on completion, TABLE, and PREDICATE.
 212
 213 If REQUIRE-MATCH is non-nil, the user is not allowed to exit unless
 214  the input is (or completes to) an element of TABLE or is null.
 215  If it is also not t, Return does not exit if it does non-null completion.
 216 If the input is null, `completing-read' returns an empty string,
 217  regardless of the value of REQUIRE-MATCH.
 218
 219 If INIT is non-nil, insert it in the minibuffer initially.
 220   If it is (STRING . POSITION), the initial input
 221   is STRING, but point is placed POSITION characters into the string.
 222 HIST is ignored in this implementation.
 223 DEF, if non-nil, is the default value.
 224
 225 Completion ignores case if the ambient value of
 226   `completion-ignore-case' is non-nil."
 227         (let ((string (si:completing-read prompt table predicate
 228                                           require-match init)))
 229           (if (and (string= string "") def)
 230               def string))))))
 231  ;; add 'def' argument.
 232  ((or (and (featurep 'xemacs)
 233            (or (and (eq emacs-major-version 21)
 234                     (< emacs-minor-version 2))
 235                (< emacs-major-version 21)))
 236       (< emacs-major-version 20))
 237   (or (fboundp 'si:completing-read)
 238       (progn
 239         (fset 'si:completing-read (symbol-function 'completing-read))
 240         (defun completing-read
 241           (prompt table &optional predicate require-match init
 242                                   hist def)
 243         "Read a string in the minibuffer, with completion.
 244 PROMPT is a string to prompt with; normally it ends in a colon and a space.
 245 TABLE is an alist whose elements' cars are strings, or an obarray.
 246 PREDICATE limits completion to a subset of TABLE.
 247 See `try-completion' and `all-completions' for more details
 248  on completion, TABLE, and PREDICATE.
 249
 250 If REQUIRE-MATCH is non-nil, the user is not allowed to exit unless
 251  the input is (or completes to) an element of TABLE or is null.
 252  If it is also not t, Return does not exit if it does non-null completion.
 253 If the input is null, `completing-read' returns an empty string,
 254  regardless of the value of REQUIRE-MATCH.
 255
 256 If INIT is non-nil, insert it in the minibuffer initially.
 257   If it is (STRING . POSITION), the initial input
 258   is STRING, but point is placed POSITION characters into the string.
 259 HIST, if non-nil, specifies a history list
 260   and optionally the initial position in the list.
 261   It can be a symbol, which is the history list variable to use,
 262   or it can be a cons cell (HISTVAR . HISTPOS).
 263   In that case, HISTVAR is the history list variable to use,
 264   and HISTPOS is the initial position (the position in the list
 265   which INIT corresponds to).
 266   Positions are counted starting from 1 at the beginning of the list.
 267 DEF, if non-nil, is the default value.
 268
 269 Completion ignores case if the ambient value of
 270   `completion-ignore-case' is non-nil."
 271         (let ((string (si:completing-read prompt table predicate
 272                                           require-match init hist)))
 273           (if (and (string= string "") def)
 274               def string)))))))
 275
 276 ;; v18: (string-to-int STRING)
 277 ;; v19: (string-to-number STRING)
 278 ;; v20: (string-to-number STRING &optional BASE)
 279 ;;
 280 ;; XXX: `string-to-number' of Emacs 20.3 and earlier is broken.
 281 ;;      (string-to-number "1e1" 16) => 10.0, should be 481.
 282 (static-condition-case nil
 283     ;; compile-time check.
 284     (if (= (string-to-number "1e1" 16) 481)
 285         (if (get 'string-to-number 'defun-maybe)
 286             (error "`string-to-number' is already redefined"))
 287       (error "`string-to-number' is broken"))
 288   (error
 289    ;; load-time check.
 290    (or (fboundp 'si:string-to-number)
 291        (progn
 292          (if (fboundp 'string-to-number)
 293              (fset 'si:string-to-number (symbol-function 'string-to-number))
 294            (fset 'si:string-to-number (symbol-function 'string-to-int))
 295            ;; XXX: In v18, this causes infinite loop while byte-compiling.
 296            ;; (defalias 'string-to-int 'string-to-number)
 297            )
 298          (put 'string-to-number 'defun-maybe t)
 299          (defun string-to-number (string &optional base)
 300            "\
 301 Convert STRING to a number by parsing it as a decimal number.
 302 This parses both integers and floating point numbers.
 303 It ignores leading spaces and tabs.
 304
 305 If BASE, interpret STRING as a number in that base.  If BASE isn't
 306 present, base 10 is used.  BASE must be between 2 and 16 (inclusive).
 307 If the base used is not 10, floating point is not recognized."
 308            (if (or (null base) (= base 10))
 309                (si:string-to-number string)
 310              (if (or (< base 2)(> base 16))
 311                  (signal 'args-out-of-range (cons base nil)))
 312              (let ((len (length string))
 313                    (pos 0))
 314                ;; skip leading whitespace.
 315                (while (and (< pos len)
 316                            (memq (aref string pos) '(?\  ?\t)))
 317                  (setq pos (1+ pos)))
 318                (if (= pos len)
 319                    0
 320                  (let ((number 0)(negative 1)
 321                        chr num)
 322                    (if (eq (aref string pos) ?-)
 323                        (setq negative -1
 324                              pos (1+ pos))
 325                      (if (eq (aref string pos) ?+)
 326                          (setq pos (1+ pos))))
 327                    (while (and (< pos len)
 328                                (setq chr (aref string pos)
 329                                      num (cond
 330                                           ((and (<= ?0 chr)(<= chr ?9))
 331                                            (- chr ?0))
 332                                           ((and (<= ?A chr)(<= chr ?F))
 333                                            (+ (- chr ?A) 10))
 334                                           ((and (<= ?a chr)(<= chr ?f))
 335                                            (+ (- chr ?a) 10))
 336                                           (t nil)))
 337                                (< num base))
 338                      (setq number (+ (* number base) num)
 339                            pos (1+ pos)))
 340                    (* negative number))))))))))
 341
 342 ;; Emacs 20.1 and 20.2: (concat-chars &rest CHARS)
 343 ;; Emacs 20.3/XEmacs 21.0 and later: (string &rest CHARS)
 344 (static-cond
 345  ((and (fboundp 'string)
 346        (subrp (symbol-function 'string)))
 347   ;; Emacs 20.3/XEmacs 21.0 and later.
 348   )
 349  ((and (fboundp 'concat-chars)
 350        (subrp (symbol-function 'concat-chars)))
 351   ;; Emacs 20.1 and 20.2.
 352   (defalias 'string 'concat-chars))
 353  (t
 354   ;; Use `defun-maybe' to update `load-history'.
 355   (defun-maybe string (&rest chars)
 356     "Concatenate all the argument characters and make the result a string."
 357     ;; We cannot use (apply 'concat chars) here because `concat' does not
 358     ;; work with multibyte chars on Mule 1.* and 2.*.
 359     (mapconcat (function char-to-string) chars ""))))
 360
 361 ;; Mule: (char-before POS)
 362 ;; v20: (char-before &optional POS)
 363 (static-condition-case nil
 364     ;; compile-time check.
 365     (progn
 366       (char-before)
 367       (if (get 'char-before 'defun-maybe)
 368           (error "`char-before' is already defined")))
 369   (wrong-number-of-arguments            ; Mule.
 370    ;; load-time check.
 371    (or (fboundp 'si:char-before)
 372        (progn
 373          (fset 'si:char-before (symbol-function 'char-before))
 374          (put 'char-before 'defun-maybe t)
 375          ;; takes IGNORED for backward compatibility.
 376          (defun char-before (&optional pos ignored)
 377            "\
 378 Return character in current buffer preceding position POS.
 379 POS is an integer or a buffer pointer.
 380 If POS is out of range, the value is nil."
 381            (si:char-before (or pos (point)))))))
 382   (void-function                        ; non-Mule.
 383    ;; load-time check.
 384    (defun-maybe char-before (&optional pos)
 385      "\
 386 Return character in current buffer preceding position POS.
 387 POS is an integer or a buffer pointer.
 388 If POS is out of range, the value is nil."
 389      (if pos
 390          (save-excursion
 391            (and (= (goto-char pos) (point))
 392                 (not (bobp))
 393                 (preceding-char)))
 394        (and (not (bobp))
 395             (preceding-char)))))
 396   (error                                ; found our definition at compile-time.
 397    ;; load-time check.
 398    (condition-case nil
 399        (char-before)
 400      (wrong-number-of-arguments         ; Mule.
 401       (or (fboundp 'si:char-before)
 402           (progn
 403             (fset 'si:char-before (symbol-function 'char-before))
 404             (put 'char-before 'defun-maybe t)
 405             ;; takes IGNORED for backward compatibility.
 406             (defun char-before (&optional pos ignored)
 407               "\
 408 Return character in current buffer preceding position POS.
 409 POS is an integer or a buffer pointer.
 410 If POS is out of range, the value is nil."
 411               (si:char-before (or pos (point)))))))
 412      (void-function                     ; non-Mule.
 413       (defun-maybe char-before (&optional pos)
 414         "\
 415 Return character in current buffer preceding position POS.
 416 POS is an integer or a buffer pointer.
 417 If POS is out of range, the value is nil."
 418         (if pos
 419             (save-excursion
 420               (and (= (goto-char pos) (point))
 421                    (not (bobp))
 422                    (preceding-char)))
 423           (and (not (bobp))
 424                (preceding-char))))))))
 425
 426 ;; v18, v19: (char-after POS)
 427 ;; v20: (char-after &optional POS)
 428 (static-condition-case nil
 429     ;; compile-time check.
 430     (progn
 431       (char-after)
 432       (if (get 'char-after 'defun-maybe)
 433           (error "`char-after' is already redefined")))
 434   (wrong-number-of-arguments            ; v18, v19
 435    ;; load-time check.
 436    (or (fboundp 'si:char-after)
 437        (progn
 438          (fset 'si:char-after (symbol-function 'char-after))
 439          (put 'char-after 'defun-maybe t)
 440          (defun char-after (&optional pos)
 441            "\
 442 Return character in current buffer at position POS.
 443 POS is an integer or a buffer pointer.
 444 If POS is out of range, the value is nil."
 445            (si:char-after (or pos (point)))))))
 446   (void-function                        ; NEVER happen?
 447    ;; load-time check.
 448    (defun-maybe char-after (&optional pos)
 449      "\
 450 Return character in current buffer at position POS.
 451 POS is an integer or a buffer pointer.
 452 If POS is out of range, the value is nil."
 453      (if pos
 454          (save-excursion
 455            (and (= (goto-char pos) (point))
 456                 (not (eobp))
 457                 (following-char)))
 458        (and (not (eobp))
 459             (following-char)))))
 460   (error                                ; found our definition at compile-time.
 461    ;; load-time check.
 462    (condition-case nil
 463        (char-after)
 464      (wrong-number-of-arguments         ; v18, v19
 465       (or (fboundp 'si:char-after)
 466           (progn
 467             (fset 'si:char-after (symbol-function 'char-after))
 468             (put 'char-after 'defun-maybe t)
 469             (defun char-after (&optional pos)
 470               "\
 471 Return character in current buffer at position POS.
 472 POS is an integer or a buffer pointer.
 473 If POS is out of range, the value is nil."
 474               (si:char-after (or pos (point)))))))
 475      (void-function                     ; NEVER happen?
 476       (defun-maybe char-after (&optional pos)
 477         "\
 478 Return character in current buffer at position POS.
 479 POS is an integer or a buffer pointer.
 480 If POS is out of range, the value is nil."
 481         (if pos
 482             (save-excursion
 483               (and (= (goto-char pos) (point))
 484                    (not (eobp))
 485                    (following-char)))
 486           (and (not (eobp))
 487                (following-char))))))))
 488
 489 ;; Emacs 19.29 and later: (buffer-substring-no-properties START END)
 490 (defun-maybe buffer-substring-no-properties (start end)
 491   "Return the characters of part of the buffer, without the text properties.
 492 The two arguments START and END are character positions;
 493 they can be in either order."
 494   (let ((string (buffer-substring start end)))
 495     (set-text-properties 0 (length string) nil string)
 496     string))
 497
 498 ;; Emacs 19.31 and later: (buffer-live-p OBJECT)
 499 (defun-maybe buffer-live-p (object)
 500   "Return non-nil if OBJECT is a buffer which has not been killed.
 501 Value is nil if OBJECT is not a buffer or if it has been killed."
 502   (and object
 503        (get-buffer object)
 504        (buffer-name (get-buffer object))
 505        t))
 506
 507 ;; Emacs 20: (line-beginning-position &optional N)
 508 (defun-maybe line-beginning-position (&optional n)
 509   "Return the character position of the first character on the current line.
 510 With argument N not nil or 1, move forward N - 1 lines first.
 511 If scan reaches end of buffer, return that position.
 512 This function does not move point."
 513   (save-excursion
 514     (forward-line (1- (or n 1)))
 515     (point)))
 516
 517 ;; Emacs 20: (line-end-position &optional N)
 518 (defun-maybe line-end-position (&optional n)
 519   "Return the character position of the last character on the current line.
 520 With argument N not nil or 1, move forward N - 1 lines first.
 521 If scan reaches end of buffer, return that position.
 522 This function does not move point."
 523   (save-excursion
 524     (end-of-line (or n 1))
 525     (point)))
 526
 527 ;; FSF Emacs 19.29 and later
 528 ;; (read-file-name PROMPT &optional DIR DEFAULT-FILENAME MUSTMATCH INITIAL)
 529 ;; XEmacs 19.14 and later:
 530 ;; (read-file-name (PROMPT &optional DIR DEFAULT MUST-MATCH INITIAL-CONTENTS
 531 ;;                         HISTORY)
 532
 533 ;; In FSF Emacs 19.28 and earlier (except for v18) or XEmacs 19.13 and
 534 ;; earlier, this function is incompatible with the other Emacsen.
 535 ;; For instance, if DEFAULT-FILENAME is nil, INITIAL is not and user
 536 ;; enters a null string, it returns the visited file name of the current
 537 ;; buffer if it is non-nil.
 538
 539 ;; It does not assimilate the different numbers of the optional arguments
 540 ;; on various Emacsen (yet).
 541 (static-cond
 542  ((and (not (featurep 'xemacs))
 543        (eq emacs-major-version 19)
 544        (< emacs-minor-version 29))
 545   (if (fboundp 'si:read-file-name)
 546       nil
 547     (fset 'si:read-file-name (symbol-function 'read-file-name))
 548     (defun read-file-name (prompt &optional dir default-filename mustmatch
 549                                   initial)
 550       "Read file name, prompting with PROMPT and completing in directory DIR.
 551 Value is not expanded---you must call `expand-file-name' yourself.
 552 Default name to DEFAULT-FILENAME if user enters a null string.
 553  (If DEFAULT-FILENAME is omitted, the visited file name is used,
 554   except that if INITIAL is specified, that combined with DIR is used.)
 555 Fourth arg MUSTMATCH non-nil means require existing file's name.
 556  Non-nil and non-t means also require confirmation after completion.
 557 Fifth arg INITIAL specifies text to start with.
 558 DIR defaults to current buffer's directory default."
 559       (si:read-file-name prompt dir
 560                          (or default-filename
 561                              (if initial
 562                                  (expand-file-name initial dir)))
 563                          mustmatch initial))))
 564  ((and (featurep 'xemacs)
 565        (eq emacs-major-version 19)
 566        (< emacs-minor-version 14))
 567   (if (fboundp 'si:read-file-name)
 568       nil
 569     (fset 'si:read-file-name (symbol-function 'read-file-name))
 570     (defun read-file-name (prompt &optional dir default must-match
 571                                   initial-contents history)
 572       "Read file name, prompting with PROMPT and completing in directory DIR.
 573 This will prompt with a dialog box if appropriate, according to
 574  `should-use-dialog-box-p'.
 575 Value is not expanded---you must call `expand-file-name' yourself.
 576 Value is subject to interpreted by substitute-in-file-name however.
 577 Default name to DEFAULT if user enters a null string.
 578  (If DEFAULT is omitted, the visited file name is used,
 579   except that if INITIAL-CONTENTS is specified, that combined with DIR is
 580   used.)
 581 Fourth arg MUST-MATCH non-nil means require existing file's name.
 582  Non-nil and non-t means also require confirmation after completion.
 583 Fifth arg INITIAL-CONTENTS specifies text to start with.
 584 Sixth arg HISTORY specifies the history list to use.  Default is
 585  `file-name-history'.
 586 DIR defaults to current buffer's directory default."
 587       (si:read-file-name prompt dir
 588                          (or default
 589                              (if initial-contents
 590                                  (expand-file-name initial-contents dir)))
 591                          must-match initial-contents history)))))
 592 \f
 593
 594 ;;; @ Basic lisp subroutines emulation. (lisp/subr.el)
 595 ;;;
 596
 597 ;;; @@ Lisp language features.
 598
 599 (defmacro-maybe push (newelt listname)
 600   "Add NEWELT to the list stored in the symbol LISTNAME.
 601 This is equivalent to (setq LISTNAME (cons NEWELT LISTNAME)).
 602 LISTNAME must be a symbol."
 603   (list 'setq listname
 604         (list 'cons newelt listname)))
 605
 606 (defmacro-maybe pop (listname)
 607   "Return the first element of LISTNAME's value, and remove it from the list.
 608 LISTNAME must be a symbol whose value is a list.
 609 If the value is nil, `pop' returns nil but does not actually
 610 change the list."
 611   (list 'prog1 (list 'car listname)
 612         (list 'setq listname (list 'cdr listname))))
 613
 614 (defmacro-maybe when (cond &rest body)
 615   "If COND yields non-nil, do BODY, else return nil."
 616   (list 'if cond (cons 'progn body)))
 617 ;; (def-edebug-spec when (&rest form))
 618
 619 (defmacro-maybe unless (cond &rest body)
 620   "If COND yields nil, do BODY, else return nil."
 621   (cons 'if (cons cond (cons nil body))))
 622 ;; (def-edebug-spec unless (&rest form))
 623
 624 (defsubst-maybe caar (x)
 625   "Return the car of the car of X."
 626   (car (car x)))
 627
 628 (defsubst-maybe cadr (x)
 629   "Return the car of the cdr of X."
 630   (car (cdr x)))
 631
 632 (defsubst-maybe cdar (x)
 633   "Return the cdr of the car of X."
 634   (cdr (car x)))
 635
 636 (defsubst-maybe cddr (x)
 637   "Return the cdr of the cdr of X."
 638   (cdr (cdr x)))
 639
 640 (defun-maybe last (x &optional n)
 641   "Return the last link of the list X.  Its car is the last element.
 642 If X is nil, return nil.
 643 If N is non-nil, return the Nth-to-last link of X.
 644 If N is bigger than the length of X, return X."
 645   (if n
 646       (let ((m 0) (p x))
 647         (while (consp p)
 648           (setq m (1+ m) p (cdr p)))
 649         (if (<= n 0) p
 650           (if (< n m) (nthcdr (- m n) x) x)))
 651     (while (cdr x)
 652       (setq x (cdr x)))
 653     x))
 654
 655 ;; Actually, `butlast' and `nbutlast' are defined in lisp/cl.el.
 656 (defun-maybe butlast (x &optional n)
 657   "Returns a copy of LIST with the last N elements removed."
 658   (if (and n (<= n 0)) x
 659     (nbutlast (copy-sequence x) n)))
 660
 661 (defun-maybe nbutlast (x &optional n)
 662   "Modifies LIST to remove the last N elements."
 663   (let ((m (length x)))
 664     (or n (setq n 1))
 665     (and (< n m)
 666          (progn
 667            (if (> n 0) (setcdr (nthcdr (- (1- m) n) x) nil))
 668            x))))
 669
 670 ;; Emacs 20.3 and later: (assoc-default KEY ALIST &optional TEST DEFAULT)
 671 (defun-maybe assoc-default (key alist &optional test default)
 672   "Find object KEY in a pseudo-alist ALIST.
 673 ALIST is a list of conses or objects.  Each element (or the element's car,
 674 if it is a cons) is compared with KEY by evaluating (TEST (car elt) KEY).
 675 If that is non-nil, the element matches;
 676 then `assoc-default' returns the element's cdr, if it is a cons,
 677 or DEFAULT if the element is not a cons.
 678
 679 If no element matches, the value is nil.
 680 If TEST is omitted or nil, `equal' is used."
 681   (let (found (tail alist) value)
 682     (while (and tail (not found))
 683       (let ((elt (car tail)))
 684         (when (funcall (or test 'equal) (if (consp elt) (car elt) elt) key)
 685           (setq found t value (if (consp elt) (cdr elt) default))))
 686       (setq tail (cdr tail)))
 687     value))
 688
 689 ;; The following two function use `compare-strings', which we don't
 690 ;; support yet.
 691 ;; (defun assoc-ignore-case (key alist))
 692 ;; (defun assoc-ignore-representation (key alist))
 693
 694 ;; Emacs 19.29/XEmacs 19.13 and later: (rassoc KEY LIST)
 695 ;; Actually, `rassoc' is defined in src/fns.c.
 696 (defun-maybe rassoc (key list)
 697   "Return non-nil if KEY is `equal' to the cdr of an element of LIST.
 698 The value is actually the element of LIST whose cdr equals KEY.
 699 Elements of LIST that are not conses are ignored."
 700   (catch 'found
 701     (while list
 702       (cond ((not (consp (car list))))
 703             ((equal (cdr (car list)) key)
 704              (throw 'found (car list))))
 705       (setq list (cdr list)))))
 706
 707 ;; XEmacs 19.13 and later: (remassoc KEY ALIST)
 708 (defun-maybe remassoc (key alist)
 709   "Delete by side effect any elements of ALIST whose car is `equal' to KEY.
 710 The modified ALIST is returned.  If the first member of ALIST has a car
 711 that is `equal' to KEY, there is no way to remove it by side effect;
 712 therefore, write `(setq foo (remassoc key foo))' to be sure of changing
 713 the value of `foo'."
 714   (while (and (consp alist)
 715               (or (not (consp (car alist)))
 716                   (equal (car (car alist)) key)))
 717     (setq alist (cdr alist)))
 718   (if (consp alist)
 719       (let ((prev alist)
 720             (tail (cdr alist)))
 721         (while (consp tail)
 722           (if (and (consp (car alist))
 723                    (equal (car (car tail)) key))
 724               ;; `(setcdr CELL NEWCDR)' returns NEWCDR.
 725               (setq tail (setcdr prev (cdr tail)))
 726             (setq prev (cdr prev)
 727                   tail (cdr tail))))))
 728   alist)
 729
 730 ;; XEmacs 19.13 and later: (remassq KEY ALIST)
 731 (defun-maybe remassq (key alist)
 732   "Delete by side effect any elements of ALIST whose car is `eq' to KEY.
 733 The modified ALIST is returned.  If the first member of ALIST has a car
 734 that is `eq' to KEY, there is no way to remove it by side effect;
 735 therefore, write `(setq foo (remassq key foo))' to be sure of changing
 736 the value of `foo'."
 737   (while (and (consp alist)
 738               (or (not (consp (car alist)))
 739                   (eq (car (car alist)) key)))
 740     (setq alist (cdr alist)))
 741   (if (consp alist)
 742       (let ((prev alist)
 743             (tail (cdr alist)))
 744         (while (consp tail)
 745           (if (and (consp (car tail))
 746                    (eq (car (car tail)) key))
 747               ;; `(setcdr CELL NEWCDR)' returns NEWCDR.
 748               (setq tail (setcdr prev (cdr tail)))
 749             (setq prev (cdr prev)
 750                   tail (cdr tail))))))
 751   alist)
 752
 753 ;; XEmacs 19.13 and later: (remrassoc VALUE ALIST)
 754 (defun-maybe remrassoc (value alist)
 755   "Delete by side effect any elements of ALIST whose cdr is `equal' to VALUE.
 756 The modified ALIST is returned.  If the first member of ALIST has a car
 757 that is `equal' to VALUE, there is no way to remove it by side effect;
 758 therefore, write `(setq foo (remrassoc value foo))' to be sure of changing
 759 the value of `foo'."
 760   (while (and (consp alist)
 761               (or (not (consp (car alist)))
 762                   (equal (cdr (car alist)) value)))
 763     (setq alist (cdr alist)))
 764   (if (consp alist)
 765       (let ((prev alist)
 766             (tail (cdr alist)))
 767         (while (consp tail)
 768           (if (and (consp (car tail))
 769                    (equal (cdr (car tail)) value))
 770               ;; `(setcdr CELL NEWCDR)' returns NEWCDR.
 771               (setq tail (setcdr prev (cdr tail)))
 772             (setq prev (cdr prev)
 773                   tail (cdr tail))))))
 774   alist)
 775
 776 ;; XEmacs 19.13 and later: (remrassq VALUE ALIST)
 777 (defun-maybe remrassq (value alist)
 778   "Delete by side effect any elements of ALIST whose cdr is `eq' to VALUE.
 779 The modified ALIST is returned.  If the first member of ALIST has a car
 780 that is `eq' to VALUE, there is no way to remove it by side effect;
 781 therefore, write `(setq foo (remrassq value foo))' to be sure of changing
 782 the value of `foo'."
 783   (while (and (consp alist)
 784               (or (not (consp (car alist)))
 785                   (eq (cdr (car alist)) value)))
 786     (setq alist (cdr alist)))
 787   (if (consp alist)
 788       (let ((prev alist)
 789             (tail (cdr alist)))
 790         (while (consp tail)
 791           (if (and (consp (car tail))
 792                    (eq (cdr (car tail)) value))
 793               ;; `(setcdr CELL NEWCDR)' returns NEWCDR.
 794               (setq tail (setcdr prev (cdr tail)))
 795             (setq prev (cdr prev)
 796                   tail (cdr tail))))))
 797   alist)
 798
 799 ;;; Define `functionp' here because "localhook" uses it.
 800
 801 ;; Emacs 20.1/XEmacs 20.3 (but first appeared in Epoch?): (functionp OBJECT)
 802 (defun-maybe functionp (object)
 803   "Non-nil if OBJECT is a type of object that can be called as a function."
 804   (or (subrp object) (byte-code-function-p object)
 805       (eq (car-safe object) 'lambda)
 806       (and (symbolp object) (fboundp object))))
 807
 808 ;;; @@ Hook manipulation functions.
 809
 810 ;; "localhook" package is written for Emacs 19.28 and earlier.
 811 ;; `run-hooks' was a lisp function in Emacs 19.29 and earlier.
 812 ;; So, in Emacs 19.29, `run-hooks' and others will be overrided.
 813 ;; But, who cares it?
 814 (static-unless (subrp (symbol-function 'run-hooks))
 815   (require 'localhook))
 816
 817 ;; Emacs 19.29/XEmacs 19.14(?) and later: (add-to-list LIST-VAR ELEMENT)
 818 (defun-maybe add-to-list (list-var element)
 819   "Add to the value of LIST-VAR the element ELEMENT if it isn't there yet.
 820 The test for presence of ELEMENT is done with `equal'.
 821 If you want to use `add-to-list' on a variable that is not defined
 822 until a certain package is loaded, you should put the call to `add-to-list'
 823 into a hook function that will be run only after loading the package.
 824 `eval-after-load' provides one way to do this.  In some cases
 825 other hooks, such as major mode hooks, can do the job."
 826   (or (member element (symbol-value list-var))
 827       (set list-var (cons element (symbol-value list-var)))))
 828
 829 ;; (eval-after-load FILE FORM)
 830 ;; Emacs 19.28 and earlier do not evaluate FORM if FILE is already loaded.
 831 ;; XEmacs 20.2 and earlier have `after-load-alist', but refuse to support
 832 ;; `eval-after-load'. (see comments in XEmacs/lisp/subr.el.)
 833 (static-cond
 834  ((featurep 'xemacs)
 835   ;; for XEmacs 20.2 and earlier.
 836   (defun-maybe eval-after-load (file form)
 837     "Arrange that, if FILE is ever loaded, FORM will be run at that time.
 838 This makes or adds to an entry on `after-load-alist'.
 839 If FILE is already loaded, evaluate FORM right now.
 840 It does nothing if FORM is already on the list for FILE.
 841 FILE should be the name of a library, with no directory name."
 842     ;; Make sure there is an element for FILE.
 843     (or (assoc file after-load-alist)
 844         (setq after-load-alist (cons (list file) after-load-alist)))
 845     ;; Add FORM to the element if it isn't there.
 846     (let ((elt (assoc file after-load-alist)))
 847       (or (member form (cdr elt))
 848           (progn
 849             (nconc elt (list form))
 850             ;; If the file has been loaded already, run FORM right away.
 851             (and (assoc file load-history)
 852                  (eval form)))))
 853     form))
 854  ((>= emacs-major-version 20))
 855  ((and (= emacs-major-version 19)
 856        (< emacs-minor-version 29))
 857   ;; for Emacs 19.28 and earlier.
 858   (defun eval-after-load (file form)
 859     "Arrange that, if FILE is ever loaded, FORM will be run at that time.
 860 This makes or adds to an entry on `after-load-alist'.
 861 If FILE is already loaded, evaluate FORM right now.
 862 It does nothing if FORM is already on the list for FILE.
 863 FILE should be the name of a library, with no directory name."
 864     ;; Make sure there is an element for FILE.
 865     (or (assoc file after-load-alist)
 866         (setq after-load-alist (cons (list file) after-load-alist)))
 867     ;; Add FORM to the element if it isn't there.
 868     (let ((elt (assoc file after-load-alist)))
 869       (or (member form (cdr elt))
 870           (progn
 871             (nconc elt (list form))
 872             ;; If the file has been loaded already, run FORM right away.
 873             (and (assoc file load-history)
 874                  (eval form)))))
 875     form))
 876  (t
 877   ;; should emulate for v18?
 878   ))
 879
 880 (defun-maybe eval-next-after-load (file)
 881   "Read the following input sexp, and run it whenever FILE is loaded.
 882 This makes or adds to an entry on `after-load-alist'.
 883 FILE should be the name of a library, with no directory name."
 884   (eval-after-load file (read)))
 885
 886 ;;; @@ Input and display facilities.
 887
 888 ;; XXX: (defun read-passwd (prompt &optional confirm default))
 889
 890 ;;; @@ Miscellanea.
 891
 892 ;; Avoid compiler warnings about this variable,
 893 ;; which has a special meaning on certain system types.
 894 (defvar-maybe buffer-file-type nil
 895   "Non-nil if the visited file is a binary file.
 896 This variable is meaningful on MS-DOG and Windows NT.
 897 On those systems, it is automatically local in every buffer.
 898 On other systems, this variable is normally always nil.")
 899
 900 ;; Emacs 20.3 or later.
 901 (defvar-maybe minor-mode-overriding-map-alist nil
 902   "Alist of keymaps to use for minor modes, in current major mode.
 903 APEL provides this as dummy for a compatibility.")
 904
 905 ;; Emacs 20.1/XEmacs 20.3(?) and later: (save-current-buffer &rest BODY)
 906 ;;
 907 ;; v20 defines `save-current-buffer' as a C primitive (in src/editfns.c)
 908 ;; and introduces a new bytecode Bsave_current_buffer(_1), replacing an
 909 ;; obsolete bytecode Bread_char.  To make things worse, Emacs 20.1 and
 910 ;; 20.2 have a bug that it will restore the current buffer without
 911 ;; confirming that it is alive.
 912 ;;
 913 ;; This is a source of incompatibility of .elc between v18/v19 and v20.
 914 ;; (XEmacs compiler takes care of it if compatibility mode is enabled.)
 915 (defmacro-maybe save-current-buffer (&rest body)
 916   "Save the current buffer; execute BODY; restore the current buffer.
 917 Executes BODY just like `progn'."
 918   (` (let ((orig-buffer (current-buffer)))
 919        (unwind-protect
 920            (progn (,@ body))
 921          (if (buffer-live-p orig-buffer)
 922              (set-buffer orig-buffer))))))
 923
 924 ;; Emacs 20.1/XEmacs 20.3(?) and later: (with-current-buffer BUFFER &rest BODY)
 925 (defmacro-maybe with-current-buffer (buffer &rest body)
 926   "Execute the forms in BODY with BUFFER as the current buffer.
 927 The value returned is the value of the last form in BODY.
 928 See also `with-temp-buffer'."
 929   (` (save-current-buffer
 930        (set-buffer (, buffer))
 931        (,@ body))))
 932
 933 ;; Emacs 20.1/XEmacs 20.3(?) and later: (with-temp-file FILE &rest FORMS)
 934 (defmacro-maybe with-temp-file (file &rest forms)
 935   "Create a new buffer, evaluate FORMS there, and write the buffer to FILE.
 936 The value of the last form in FORMS is returned, like `progn'.
 937 See also `with-temp-buffer'."
 938   (let ((temp-file (make-symbol "temp-file"))
 939         (temp-buffer (make-symbol "temp-buffer")))
 940     (` (let (((, temp-file) (, file))
 941              ((, temp-buffer)
 942               (get-buffer-create (generate-new-buffer-name " *temp file*"))))
 943          (unwind-protect
 944              (prog1
 945                  (with-current-buffer (, temp-buffer)
 946                    (,@ forms))
 947                (with-current-buffer (, temp-buffer)
 948                  (widen)
 949                  (write-region (point-min) (point-max) (, temp-file) nil 0)))
 950            (and (buffer-name (, temp-buffer))
 951                 (kill-buffer (, temp-buffer))))))))
 952
 953 ;; Emacs 20.4 and later: (with-temp-message MESSAGE &rest BODY)
 954 ;; This macro uses `current-message', which appears in v20.
 955 (static-when (and (fboundp 'current-message)
 956                   (subrp (symbol-function 'current-message)))
 957   (defmacro-maybe with-temp-message (message &rest body)
 958     "\
 959 Display MESSAGE temporarily if non-nil while BODY is evaluated.
 960 The original message is restored to the echo area after BODY has finished.
 961 The value returned is the value of the last form in BODY.
 962 MESSAGE is written to the message log buffer if `message-log-max' is non-nil.
 963 If MESSAGE is nil, the echo area and message log buffer are unchanged.
 964 Use a MESSAGE of \"\" to temporarily clear the echo area."
 965     (let ((current-message (make-symbol "current-message"))
 966           (temp-message (make-symbol "with-temp-message")))
 967       (` (let (((, temp-message) (, message))
 968                ((, current-message)))
 969            (unwind-protect
 970                (progn
 971                  (when (, temp-message)
 972                    (setq (, current-message) (current-message))
 973                    (message "%s" (, temp-message))
 974                    (,@ body))
 975                  (and (, temp-message) (, current-message)
 976                       (message "%s" (, current-message))))))))))
 977
 978 ;; Emacs 20.1/XEmacs 20.3(?) and later: (with-temp-buffer &rest FORMS)
 979 (defmacro-maybe with-temp-buffer (&rest forms)
 980   "Create a temporary buffer, and evaluate FORMS there like `progn'.
 981 See also `with-temp-file' and `with-output-to-string'."
 982   (let ((temp-buffer (make-symbol "temp-buffer")))
 983     (` (let (((, temp-buffer)
 984               (get-buffer-create (generate-new-buffer-name " *temp*"))))
 985          (unwind-protect
 986              (with-current-buffer (, temp-buffer)
 987                (,@ forms))
 988            (and (buffer-name (, temp-buffer))
 989                 (kill-buffer (, temp-buffer))))))))
 990
 991 ;; Emacs 20.1/XEmacs 20.3(?) and later: (with-output-to-string &rest BODY)
 992 (defmacro-maybe with-output-to-string (&rest body)
 993   "Execute BODY, return the text it sent to `standard-output', as a string."
 994   (` (let ((standard-output
 995             (get-buffer-create (generate-new-buffer-name " *string-output*"))))
 996        (let ((standard-output standard-output))
 997          (,@ body))
 998        (with-current-buffer standard-output
 999          (prog1
1000              (buffer-string)
1001            (kill-buffer nil))))))
1002
1003 ;; Emacs 20.1 and later: (combine-after-change-calls &rest BODY)
1004 (defmacro-maybe combine-after-change-calls (&rest body)
1005   "Execute BODY, but don't call the after-change functions till the end.
1006 If BODY makes changes in the buffer, they are recorded
1007 and the functions on `after-change-functions' are called several times
1008 when BODY is finished.
1009 The return value is the value of the last form in BODY.
1010
1011 If `before-change-functions' is non-nil, then calls to the after-change
1012 functions can't be deferred, so in that case this macro has no effect.
1013
1014 Do not alter `after-change-functions' or `before-change-functions'
1015 in BODY.
1016
1017 This emulating macro does not support after-change functions at all,
1018 just execute BODY."
1019   (cons 'progn body))
1020
1021 ;; Emacs 19.29/XEmacs 19.14(?) and later: (match-string NUM &optional STRING)
1022 (defun-maybe match-string (num &optional string)
1023   "Return string of text matched by last search.
1024 NUM specifies which parenthesized expression in the last regexp.
1025  Value is nil if NUMth pair didn't match, or there were less than NUM pairs.
1026 Zero means the entire text matched by the whole regexp or whole string.
1027 STRING should be given if the last search was by `string-match' on STRING."
1028   (if (match-beginning num)
1029       (if string
1030           (substring string (match-beginning num) (match-end num))
1031         (buffer-substring (match-beginning num) (match-end num)))))
1032
1033 ;; Emacs 20.3 and later: (match-string-no-properties NUM &optional STRING)
1034 (defun-maybe match-string-no-properties (num &optional string)
1035   "Return string of text matched by last search, without text properties.
1036 NUM specifies which parenthesized expression in the last regexp.
1037  Value is nil if NUMth pair didn't match, or there were less than NUM pairs.
1038 Zero means the entire text matched by the whole regexp or whole string.
1039 STRING should be given if the last search was by `string-match' on STRING."
1040   (if (match-beginning num)
1041       (if string
1042           (let ((result
1043                  (substring string (match-beginning num) (match-end num))))
1044             (set-text-properties 0 (length result) nil result)
1045             result)
1046         (buffer-substring-no-properties (match-beginning num)
1047                                         (match-end num)))))
1048
1049 ;; Emacs 19.28 and earlier
1050 ;;  (replace-match NEWTEXT &optional FIXEDCASE LITERAL)
1051 ;; Emacs 20.x (?) and later
1052 ;;  (replace-match NEWTEXT &optional FIXEDCASE LITERAL STRING SUBEXP)
1053 ;; XEmacs 21:
1054 ;;  (replace-match NEWTEXT &optional FIXEDCASE LITERAL STRING STRBUFFER)
1055 ;; We support following API.
1056 ;;  (replace-match NEWTEXT &optional FIXEDCASE LITERAL STRING)
1057 (static-condition-case nil
1058     ;; compile-time check
1059     (progn
1060       (string-match "" "")
1061       (replace-match "" nil nil "")
1062       (if (get 'replace-match 'defun-maybe)
1063           (error "`replace-match' is already defined")))
1064   (wrong-number-of-arguments ; Emacs 19.28 and earlier
1065    ;; load-time check.
1066    (or (fboundp 'si:replace-match)
1067        (progn
1068          (fset 'si:replace-match (symbol-function 'replace-match))
1069          (put 'replace-match 'defun-maybe t)
1070          (defun replace-match (newtext &optional fixedcase literal string)
1071            "Replace text matched by last search with NEWTEXT.
1072 If second arg FIXEDCASE is non-nil, do not alter case of replacement text.
1073 Otherwise maybe capitalize the whole text, or maybe just word initials,
1074 based on the replaced text.
1075 If the replaced text has only capital letters
1076 and has at least one multiletter word, convert NEWTEXT to all caps.
1077 If the replaced text has at least one word starting with a capital letter,
1078 then capitalize each word in NEWTEXT.
1079
1080 If third arg LITERAL is non-nil, insert NEWTEXT literally.
1081 Otherwise treat `\' as special:
1082   `\&' in NEWTEXT means substitute original matched text.
1083   `\N' means substitute what matched the Nth `\(...\)'.
1084        If Nth parens didn't match, substitute nothing.
1085   `\\' means insert one `\'.
1086 FIXEDCASE and LITERAL are optional arguments.
1087 Leaves point at end of replacement text.
1088
1089 The optional fourth argument STRING can be a string to modify.
1090 In that case, this function creates and returns a new string
1091 which is made by replacing the part of STRING that was matched."
1092            (if string
1093                (with-temp-buffer
1094                 (save-match-data
1095                   (insert string)
1096                   (let* ((matched (match-data))
1097                          (beg (nth 0 matched))
1098                          (end (nth 1 matched)))
1099                     (store-match-data
1100                      (list
1101                       (if (markerp beg)
1102                           (move-marker beg (1+ (match-beginning 0)))
1103                         (1+ (match-beginning 0)))
1104                       (if (markerp end)
1105                           (move-marker end (1+ (match-end 0)))
1106                         (1+ (match-end 0))))))
1107                   (si:replace-match newtext fixedcase literal)
1108                   (buffer-string)))
1109              (si:replace-match newtext fixedcase literal))))))
1110   (error ; found our definition at compile-time.
1111    ;; load-time check.
1112    (condition-case nil
1113     (progn
1114       (string-match "" "")
1115       (replace-match "" nil nil ""))
1116     (wrong-number-of-arguments ; Emacs 19.28 and earlier
1117      ;; load-time check.
1118      (or (fboundp 'si:replace-match)
1119          (progn
1120            (fset 'si:replace-match (symbol-function 'replace-match))
1121            (put 'replace-match 'defun-maybe t)
1122            (defun replace-match (newtext &optional fixedcase literal string)
1123              "Replace text matched by last search with NEWTEXT.
1124 If second arg FIXEDCASE is non-nil, do not alter case of replacement text.
1125 Otherwise maybe capitalize the whole text, or maybe just word initials,
1126 based on the replaced text.
1127 If the replaced text has only capital letters
1128 and has at least one multiletter word, convert NEWTEXT to all caps.
1129 If the replaced text has at least one word starting with a capital letter,
1130 then capitalize each word in NEWTEXT.
1131
1132 If third arg LITERAL is non-nil, insert NEWTEXT literally.
1133 Otherwise treat `\' as special:
1134   `\&' in NEWTEXT means substitute original matched text.
1135   `\N' means substitute what matched the Nth `\(...\)'.
1136        If Nth parens didn't match, substitute nothing.
1137   `\\' means insert one `\'.
1138 FIXEDCASE and LITERAL are optional arguments.
1139 Leaves point at end of replacement text.
1140
1141 The optional fourth argument STRING can be a string to modify.
1142 In that case, this function creates and returns a new string
1143 which is made by replacing the part of STRING that was matched."
1144              (if string
1145                  (with-temp-buffer
1146                   (save-match-data
1147                     (insert string)
1148                     (let* ((matched (match-data))
1149                            (beg (nth 0 matched))
1150                            (end (nth 1 matched)))
1151                       (store-match-data
1152                        (list
1153                         (if (markerp beg)
1154                             (move-marker beg (1+ (match-beginning 0)))
1155                           (1+ (match-beginning 0)))
1156                         (if (markerp end)
1157                             (move-marker end (1+ (match-end 0)))
1158                           (1+ (match-end 0))))))
1159                     (si:replace-match newtext fixedcase literal)
1160                     (buffer-string)))
1161                (si:replace-match newtext fixedcase literal)))))))))
1162
1163 ;; Emacs 20: (format-time-string)
1164 ;; The the third optional argument universal is yet to be implemented.
1165 ;; Those format constructs are yet to be implemented.
1166 ;;   %c, %C, %j, %U, %W, %x, %X
1167 ;; Not fully compatible especially when invalid format is specified.
1168 (static-unless (and (fboundp 'format-time-string)
1169                     (not (get 'format-time-string 'defun-maybe)))
1170   (or (fboundp 'format-time-string)
1171   (progn
1172   (defconst format-time-month-list
1173     '(( "Zero" . ("Zero" . 0))
1174       ("Jan" . ("January" . 1)) ("Feb" . ("February" . 2))
1175       ("Mar" . ("March" . 3)) ("Apr" . ("April" . 4)) ("May" . ("May" . 5))
1176       ("Jun" . ("June" . 6))("Jul" . ("July" . 7)) ("Aug" . ("August" . 8))
1177       ("Sep" . ("September" . 9)) ("Oct" . ("October" . 10))
1178       ("Nov" . ("November" . 11)) ("Dec" . ("December" . 12)))
1179     "Alist of months and their number.")
1180
1181   (defconst format-time-week-list
1182     '(("Sun" . ("Sunday" . 0)) ("Mon" . ("Monday" . 1))
1183       ("Tue" . ("Tuesday" . 2)) ("Wed" . ("Wednesday" . 3))
1184       ("Thu" . ("Thursday" . 4)) ("Fri" . ("Friday" . 5))
1185       ("Sat" . ("Saturday" . 6)))
1186     "Alist of weeks and their number.")
1187
1188   (defun format-time-string (format &optional time universal)
1189     "Use FORMAT-STRING to format the time TIME, or now if omitted.
1190 TIME is specified as (HIGH LOW . IGNORED) or (HIGH . LOW), as returned by
1191 `current-time' or `file-attributes'.
1192 The third, optional, argument UNIVERSAL, if non-nil, means describe TIME
1193 as Universal Time; nil means describe TIME in the local time zone.
1194 The value is a copy of FORMAT-STRING, but with certain constructs replaced
1195 by text that describes the specified date and time in TIME:
1196
1197 %Y is the year, %y within the century, %C the century.
1198 %G is the year corresponding to the ISO week, %g within the century.
1199 %m is the numeric month.
1200 %b and %h are the locale's abbreviated month name, %B the full name.
1201 %d is the day of the month, zero-padded, %e is blank-padded.
1202 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
1203 %a is the locale's abbreviated name of the day of week, %A the full name.
1204 %U is the week number starting on Sunday, %W starting on Monday,
1205  %V according to ISO 8601.
1206 %j is the day of the year.
1207
1208 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
1209  only blank-padded, %l is like %I blank-padded.
1210 %p is the locale's equivalent of either AM or PM.
1211 %M is the minute.
1212 %S is the second.
1213 %Z is the time zone name, %z is the numeric form.
1214 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
1215
1216 %c is the locale's date and time format.
1217 %x is the locale's \"preferred\" date format.
1218 %D is like \"%m/%d/%y\".
1219
1220 %R is like \"%H:%M\", %T is like \"%H:%M:%S\", %r is like \"%I:%M:%S %p\".
1221 %X is the locale's \"preferred\" time format.
1222
1223 Finally, %n is a newline, %t is a tab, %% is a literal %.
1224
1225 Certain flags and modifiers are available with some format controls.
1226 The flags are `_' and `-'.  For certain characters X, %_X is like %X,
1227 but padded with blanks; %-X is like %X, but without padding.
1228 %NX (where N stands for an integer) is like %X,
1229 but takes up at least N (a number) positions.
1230 The modifiers are `E' and `O'.  For certain characters X,
1231 %EX is a locale's alternative version of %X;
1232 %OX is like %X, but uses the locale's number symbols.
1233
1234 For example, to produce full ISO 8601 format, use \"%Y-%m-%dT%T%z\".
1235
1236 Compatibility Note.
1237
1238 The the third optional argument universal is yet to be implemented.
1239 Those format constructs are yet to be implemented.
1240   %c, %C, %j, %U, %W, %x, %X
1241 Not fully compatible especially when invalid format is specified."
1242     (let ((fmt-len (length format))
1243           (ind 0)
1244           prev-ind
1245           cur-char
1246           (prev-char nil)
1247           strings-so-far
1248           (result "")
1249           field-width
1250           field-result
1251           pad-left change-case
1252           (paren-level 0)
1253           hour
1254           (time-string (current-time-string time)))
1255       (setq hour (string-to-int (substring time-string 11 13)))
1256       (while (< ind fmt-len)
1257         (setq cur-char (aref format ind))
1258         (setq
1259          result
1260          (concat result
1261         (cond
1262          ((eq cur-char ?%)
1263           ;; eat any additional args to allow for future expansion, not!!
1264           (setq pad-left nil change-case nil field-width "" prev-ind ind
1265                 strings-so-far "")
1266 ;         (catch 'invalid
1267           (while (progn
1268                    (setq ind (1+ ind))
1269                    (setq cur-char (if (< ind fmt-len)
1270                                       (aref format ind)
1271                                     ?\0))
1272                    (or (eq ?- cur-char) ; pad on left
1273                        (eq ?# cur-char) ; case change
1274                        (if (and (string-equal field-width "")
1275                                 (<= ?0 cur-char) (>= ?9 cur-char))
1276                            ;; get format width
1277                            (let ((field-index ind))
1278                              (while (progn
1279                                       (setq ind (1+ ind))
1280                                       (setq cur-char (if (< ind fmt-len)
1281                                                          (aref format ind)
1282                                                        ?\0))
1283                                       (and (<= ?0 cur-char) (>= ?9 cur-char))))
1284                              (setq field-width
1285                                    (substring format field-index ind))
1286                              (setq ind (1- ind)
1287                                    cur-char nil)
1288                              t))))
1289             (setq prev-char cur-char
1290                   strings-so-far (concat strings-so-far
1291                                          (if cur-char
1292                                              (char-to-string cur-char)
1293                                            field-width)))
1294             ;; characters we actually use
1295             (cond ((eq cur-char ?-)
1296                    ;; padding to left must be specified before field-width
1297                    (setq pad-left (string-equal field-width "")))
1298                   ((eq cur-char ?#)
1299                    (setq change-case t))))
1300           (setq field-result
1301                 (cond
1302                  ((eq cur-char ?%)
1303                   "%")
1304                  ;; the abbreviated name of the day of week.
1305                  ((eq cur-char ?a)
1306                   (substring time-string 0 3))
1307                  ;; the full name of the day of week
1308                  ((eq cur-char ?A)
1309                   (cadr (assoc (substring time-string 0 3)
1310                                format-time-week-list)))
1311                  ;; the abbreviated name of the month
1312                  ((eq cur-char ?b)
1313                   (substring time-string 4 7))
1314                  ;; the full name of the month
1315                  ((eq cur-char ?B)
1316                   (cadr (assoc (substring time-string 4 7)
1317                                format-time-month-list)))
1318                  ;; a synonym for `%x %X' (yet to come)
1319                  ((eq cur-char ?c)
1320                   "")
1321                  ;; locale specific (yet to come)
1322                  ((eq cur-char ?C)
1323                   "")
1324                  ;; the day of month, zero-padded
1325                  ((eq cur-char ?d)
1326                   (format "%02d" (string-to-int (substring time-string 8 10))))
1327                  ;; a synonym for `%m/%d/%y'
1328                  ((eq cur-char ?D)
1329                   (format "%02d/%02d/%s"
1330                           (cddr (assoc (substring time-string 4 7)
1331                                        format-time-month-list))
1332                           (string-to-int (substring time-string 8 10))
1333                           (substring time-string -2)))
1334                  ;; the day of month, blank-padded
1335                  ((eq cur-char ?e)
1336                   (format "%2d" (string-to-int (substring time-string 8 10))))
1337                  ;; a synonym for `%b'
1338                  ((eq cur-char ?h)
1339                   (substring time-string 4 7))
1340                  ;; the hour (00-23)
1341                  ((eq cur-char ?H)
1342                   (substring time-string 11 13))
1343                  ;; the hour (00-12)
1344                  ((eq cur-char ?I)
1345                   (format "%02d" (if (> hour 12) (- hour 12) hour)))
1346                  ;; the day of the year (001-366) (yet to come)
1347                  ((eq cur-char ?j)
1348                   "")
1349                  ;; the hour (0-23), blank padded
1350                  ((eq cur-char ?k)
1351                   (format "%2d" hour))
1352                  ;; the hour (1-12), blank padded
1353                  ((eq cur-char ?l)
1354                   (format "%2d" (if (> hour 12) (- hour 12) hour)))
1355                  ;; the month (01-12)
1356                  ((eq cur-char ?m)
1357                   (format "%02d" (cddr (assoc (substring time-string 4 7)
1358                                               format-time-month-list))))
1359                  ;; the minute (00-59)
1360                  ((eq cur-char ?M)
1361                   (substring time-string 14 16))
1362                  ;; a newline
1363                  ((eq cur-char ?n)
1364                   "\n")
1365                  ;; `AM' or `PM', as appropriate
1366                  ((eq cur-char ?p)
1367                   (setq change-case (not change-case))
1368                   (if (> hour 12) "pm" "am"))
1369                  ;; a synonym for `%I:%M:%S %p'
1370                  ((eq cur-char ?r)
1371                   (format "%02d:%s:%s %s"
1372                           (if (> hour 12) (- hour 12) hour)
1373                           (substring time-string 14 16)
1374                           (substring time-string 17 19)
1375                           (if (> hour 12) "PM" "AM")))
1376                  ;; a synonym for `%H:%M'
1377                  ((eq cur-char ?R)
1378                   (format "%s:%s"
1379                           (substring time-string 11 13)
1380                           (substring time-string 14 16)))
1381                  ;; the seconds (00-60)
1382                  ((eq cur-char ?S)
1383                   (substring time-string 17 19))
1384                  ;; a tab character
1385                  ((eq cur-char ?t)
1386                   "\t")
1387                  ;; a synonym for `%H:%M:%S'
1388                  ((eq cur-char ?T)
1389                   (format "%s:%s:%s"
1390                           (substring time-string 11 13)
1391                           (substring time-string 14 16)
1392                           (substring time-string 17 19)))
1393                  ;; the week of the year (01-52), assuming that weeks
1394                  ;; start on Sunday (yet to come)
1395                  ((eq cur-char ?U)
1396                   "")
1397                  ;; the numeric day of week (0-6).  Sunday is day 0
1398                  ((eq cur-char ?w)
1399                   (format "%d" (cddr (assoc (substring time-string 0 3)
1400                                             format-time-week-list))))
1401                  ;; the week of the year (01-52), assuming that weeks
1402                  ;; start on Monday (yet to come)
1403                  ((eq cur-char ?W)
1404                   "")
1405                  ;; locale specific (yet to come)
1406                  ((eq cur-char ?x)
1407                   "")
1408                  ;; locale specific (yet to come)
1409                  ((eq cur-char ?X)
1410                   "")
1411                  ;; the year without century (00-99)
1412                  ((eq cur-char ?y)
1413                   (substring time-string -2))
1414                  ;; the year with century
1415                  ((eq cur-char ?Y)
1416                   (substring time-string -4))
1417                  ;; the time zone abbreviation
1418                  ((eq cur-char ?Z)
1419                   (setq change-case (not change-case))
1420                   (downcase (cadr (current-time-zone))))
1421                  ((eq cur-char ?z)
1422                   (let ((tz (car (current-time-zone))))
1423                     (if (< tz 0)
1424                         (format "-%02d%02d" (/ (- tz) 3600) (/ (% (- tz) 3600) 60))
1425                       (format "+%02d%02d" (/ tz 3600) (/ (% tz 3600) 60)))))
1426                  (t
1427                   (concat
1428                    "%"
1429                    strings-so-far
1430                    (char-to-string cur-char)))))
1431 ;                 (setq ind prev-ind)
1432 ;                 (throw 'invalid "%"))))
1433           (if (string-equal field-width "")
1434               (if change-case (upcase field-result) field-result)
1435             (let ((padded-result
1436                    (format (format "%%%s%s%c"
1437                                    ""   ; pad on left is ignored
1438 ;                                  (if pad-left "-" "")
1439                                    field-width
1440                                    ?s)
1441                            (or field-result ""))))
1442               (let ((initial-length (length padded-result))
1443                     (desired-length (string-to-int field-width)))
1444                 (when (and (string-match "^0" field-width)
1445                            (string-match "^ +" padded-result))
1446                   (setq padded-result
1447                         (replace-match
1448                          (make-string
1449                           (length (match-string 0 padded-result)) ?0)
1450                          nil nil padded-result)))
1451                 (if (> initial-length desired-length)
1452                     ;; truncate strings on right, years on left
1453                     (if (stringp field-result)
1454                         (substring padded-result 0 desired-length)
1455                       (if (eq cur-char ?y)
1456                           (substring padded-result (- desired-length))
1457                         padded-result))) ;non-year numbers don't truncate
1458                 (if change-case (upcase padded-result) padded-result))))) ;)
1459          (t
1460           (char-to-string cur-char)))))
1461         (setq ind (1+ ind)))
1462       result))
1463   ;; for `load-history'.
1464   (setq current-load-list (cons 'format-time-string current-load-list))
1465   (put 'format-time-string 'defun-maybe t))))
1466
1467 ;; Emacs 19.29-19.34/XEmacs: `format-time-string' neither supports the
1468 ;; format string "%z" nor the third argument `universal'.
1469 (unless (string-match "\\`[\\-\\+][0-9]+\\'"
1470                       (format-time-string "%z" (current-time)))
1471   (defadvice format-time-string
1472     (before support-timezone-in-numeric-form-and-3rd-arg
1473             (format-string &optional time universal) activate compile)
1474     "Advice to support the construct `%z' and the third argument `universal'."
1475     (let ((tz (car (current-time-zone)))
1476           case-fold-search ms ls)
1477       (while (string-match "\\(\\(\\`\\|[^%]\\)\\(%%\\)*\\)%z" format-string)
1478         (setq format-string
1479               (concat (substring format-string 0 (match-end 1))
1480                       (if universal
1481                           "+0000"
1482                         (if (< tz 0)
1483                             (format "-%02d%02d"
1484                                     (/ (- tz) 3600) (/ (% (- tz) 3600) 60))
1485                           (format "+%02d%02d"
1486                                   (/ tz 3600) (/ (% tz 3600) 60))))
1487                       (substring format-string (match-end 0)))))
1488       (if universal
1489           (progn
1490             (while (string-match "\\(\\(\\`\\|[^%]\\)\\(%%\\)*\\)%Z"
1491                                  format-string)
1492               (setq format-string
1493                     (concat (substring format-string 0 (match-end 1))
1494                             "UTC"
1495                             (substring format-string (match-end 0)))))
1496             (or time
1497                 (setq time (current-time)))
1498             (setq ms (car time)
1499                   ls (- (nth 1 time) tz))
1500             (cond ((< ls 0)
1501                    (setq ms (1- ms)
1502                          ls (+ ls 65536)))
1503                   ((>= ls 65536)
1504                    (setq ms (1+ ms)
1505                          ls (- ls 65536))))
1506             (setq time (append (list ms ls) (nth 2 time))))))))
1507
1508 ;; Emacs 20.1/XEmacs 20.3(?) and later: (split-string STRING &optional PATTERN)
1509 ;; Here is a XEmacs version.
1510 (defun-maybe split-string (string &optional pattern)
1511   "Return a list of substrings of STRING which are separated by PATTERN.
1512 If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"."
1513   (or pattern
1514       (setq pattern "[ \f\t\n\r\v]+"))
1515   ;; The FSF version of this function takes care not to cons in case
1516   ;; of infloop.  Maybe we should synch?
1517   (let (parts (start 0))
1518     (while (string-match pattern string start)
1519       (setq parts (cons (substring string start (match-beginning 0)) parts)
1520             start (match-end 0)))
1521     (nreverse (cons (substring string start) parts))))
1522 \f
1523
1524 ;;; @ Window commands emulation. (lisp/window.el)
1525 ;;;
1526
1527 (defmacro-maybe save-selected-window (&rest body)
1528   "Execute BODY, then select the window that was selected before BODY."
1529   (list 'let
1530         '((save-selected-window-window (selected-window)))
1531         (list 'unwind-protect
1532               (cons 'progn body)
1533               (list 'select-window 'save-selected-window-window))))
1534
1535 ;; Emacs 19.31 and later:
1536 ;;  (get-buffer-window-list &optional BUFFER MINIBUF FRAME)
1537 (defun-maybe get-buffer-window-list (buffer &optional minibuf frame)
1538   "Return windows currently displaying BUFFER, or nil if none.
1539 See `walk-windows' for the meaning of MINIBUF and FRAME."
1540   (let ((buffer (if (bufferp buffer) buffer (get-buffer buffer))) windows)
1541     (walk-windows
1542      (function (lambda (window)
1543                  (if (eq (window-buffer window) buffer)
1544                      (setq windows (cons window windows)))))
1545      minibuf frame)
1546     windows))
1547 \f
1548
1549 ;;; @ Frame commands emulation. (lisp/frame.el)
1550 ;;;
1551
1552 ;; XEmacs 21.0 and later:
1553 ;;  (save-selected-frame &rest BODY)
1554 (defmacro-maybe save-selected-frame (&rest body)
1555   "Execute forms in BODY, then restore the selected frame."
1556   (list 'let
1557         '((save-selected-frame-frame (selected-frame)))
1558         (list 'unwind-protect
1559               (cons 'progn body)
1560               (list 'select-frame 'save-selected-frame-frame))))
1561 \f
1562
1563 ;;; @ Basic editing commands emulation. (lisp/simple.el)
1564 ;;;
1565 \f
1566
1567 ;;; @ File input and output commands emulation. (lisp/files.el)
1568 ;;;
1569
1570 (defvar-maybe temporary-file-directory
1571   (file-name-as-directory
1572    (cond ((memq system-type '(ms-dos windows-nt))
1573           (or (getenv "TEMP") (getenv "TMPDIR") (getenv "TMP") "c:/temp"))
1574          ((memq system-type '(vax-vms axp-vms))
1575           (or (getenv "TMPDIR") (getenv "TMP") (getenv "TEMP") "SYS$SCRATCH:"))
1576          (t
1577           (or (getenv "TMPDIR") (getenv "TMP") (getenv "TEMP") "/tmp"))))
1578   "The directory for writing temporary files.")
1579
1580 ;; Actually, `path-separator' is defined in src/emacs.c and overrided
1581 ;; in dos-w32.el.
1582 (defvar-maybe path-separator ":"
1583   "The directory separator in search paths, as a string.")
1584
1585 ;; `convert-standard-filename' is defined in lisp/files.el and overrided
1586 ;; in lisp/dos-fns.el and lisp/w32-fns.el for each environment.
1587 (cond
1588  ;; must be load-time check to share .elc between different systems.
1589  ((fboundp 'convert-standard-filename))
1590  ((memq system-type '(windows-nt ms-dos))
1591   ;; should we do (require 'filename) at load-time ?
1592   ;; (require 'filename)
1593   ;; filename.el requires many modules, so we do not want to load it
1594   ;; at compile-time. Instead, suppress warnings by these autoloads.
1595   (eval-when-compile
1596     (autoload 'filename-maybe-truncate-by-size "filename")
1597     (autoload 'filename-special-filter "filename"))
1598   (defun convert-standard-filename (filename)
1599     "Convert a standard file's name to something suitable for the current OS.
1600 This function's standard definition is trivial; it just returns the argument.
1601 However, on some systems, the function is redefined
1602 with a definition that really does change some file names.
1603 Under `windows-nt' or `ms-dos', it refers `filename-replacement-alist' and
1604 `filename-limit-length' for the basic filename and each parent directory name."
1605     (require 'filename)
1606     (let* ((names (split-string filename "/"))
1607            (drive-name (car names))
1608            (filter (function
1609                     (lambda (string)
1610                       (filename-maybe-truncate-by-size
1611                        (filename-special-filter string))))))
1612       (cond
1613        ((eq 1 (length names))
1614         (funcall filter drive-name))
1615        ((string-match "^[^/]:$" drive-name)
1616         (concat drive-name "/" (mapconcat filter (cdr names) "/")))
1617        (t
1618         (mapconcat filter names "/"))))))
1619  (t
1620   (defun convert-standard-filename (filename)
1621     "Convert a standard file's name to something suitable for the current OS.
1622 This function's standard definition is trivial; it just returns the argument.
1623 However, on some systems, the function is redefined
1624 with a definition that really does change some file names.
1625 Under `windows-nt' or `ms-dos', it refers `filename-replacement-alist' and
1626 `filename-limit-length' for the basic filename and each parent directory name."
1627     filename)))
1628
1629 (static-cond
1630  ((fboundp 'insert-file-contents-literally))
1631  ((boundp 'file-name-handler-alist)
1632   ;; Use `defun-maybe' to update `load-history'.
1633   (defun-maybe insert-file-contents-literally (filename &optional visit
1634                                                         beg end replace)
1635     "Like `insert-file-contents', q.v., but only reads in the file.
1636 A buffer may be modified in several ways after reading into the buffer due
1637 to advanced Emacs features, such as file-name-handlers, format decoding,
1638 find-file-hooks, etc.
1639   This function ensures that none of these modifications will take place."
1640     (let (file-name-handler-alist)
1641       (insert-file-contents filename visit beg end replace))))
1642  (t
1643   (defalias 'insert-file-contents-literally 'insert-file-contents)))
1644
1645 (defun-maybe file-name-sans-extension (filename)
1646   "Return FILENAME sans final \"extension\".
1647 The extension, in a file name, is the part that follows the last `.'."
1648   (save-match-data
1649     (let ((file (file-name-sans-versions (file-name-nondirectory filename)))
1650           directory)
1651       (if (string-match "\\.[^.]*\\'" file)
1652           (if (setq directory (file-name-directory filename))
1653               (expand-file-name (substring file 0 (match-beginning 0))
1654                                 directory)
1655             (substring file 0 (match-beginning 0)))
1656         filename))))
1657 \f
1658
1659 ;;; @ Miscellanea.
1660
1661 ;; Emacs 19.29 and later: (current-fill-column)
1662 (defun-maybe current-fill-column ()
1663   "Return the fill-column to use for this line."
1664   fill-column)
1665
1666 ;; Emacs 19.29 and later: (current-left-margin)
1667 (defun-maybe current-left-margin ()
1668   "Return the left margin to use for this line."
1669   left-margin)
1670 \f
1671
1672 ;;; @ XEmacs emulation.
1673 ;;;
1674
1675 (defun-maybe find-face (face-or-name)
1676   "Retrieve the face of the given name.
1677 If FACE-OR-NAME is a face object, it is simply returned.
1678 Otherwise, FACE-OR-NAME should be a symbol.  If there is no such face,
1679 nil is returned.  Otherwise the associated face object is returned."
1680   (car (memq face-or-name (face-list))))
1681
1682 ;; Emacs 21.1 defines this as an alias for `line-beginning-position'.
1683 ;; Therefore, optional 2nd arg BUFFER is not portable.
1684 (defun-maybe point-at-bol (&optional n buffer)
1685   "Return the character position of the first character on the current line.
1686 With argument N not nil or 1, move forward N - 1 lines first.
1687 If scan reaches end of buffer, return that position.
1688 This function does not move point."
1689   (save-excursion
1690     (if buffer (set-buffer buffer))
1691     (forward-line (1- (or n 1)))
1692     (point)))
1693
1694 ;; Emacs 21.1 defines this as an alias for `line-end-position'.
1695 ;; Therefore, optional 2nd arg BUFFER is not portable.
1696 (defun-maybe point-at-eol (&optional n buffer)
1697   "Return the character position of the last character on the current line.
1698 With argument N not nil or 1, move forward N - 1 lines first.
1699 If scan reaches end of buffer, return that position.
1700 This function does not move point."
1701   (save-excursion
1702     (if buffer (set-buffer buffer))
1703     (end-of-line (or n 1))
1704     (point)))
1705
1706 (defsubst-maybe define-obsolete-function-alias (oldfun newfun)
1707   "Define OLDFUN as an obsolete alias for function NEWFUN.
1708 This makes calling OLDFUN equivalent to calling NEWFUN and marks OLDFUN
1709 as obsolete."
1710   (defalias oldfun newfun)
1711   (make-obsolete oldfun newfun))
1712
1713 ;; XEmacs 21: (character-to-event CH &optional EVENT DEVICE)
1714 (defun-maybe character-to-event (ch)
1715   "Convert keystroke CH into an event structure, replete with bucky bits.
1716 Note that CH (the keystroke specifier) can be an integer, a character
1717 or a symbol such as 'clear."
1718   ch)
1719
1720 ;; XEmacs 21: (event-to-character EVENT
1721 ;;             &optional ALLOW-EXTRA-MODIFIERS ALLOW-META ALLOW-NON-ASCII)
1722 (defun-maybe-cond event-to-character (event)
1723   "Return the character approximation to the given event object.
1724 If the event isn't a keypress, this returns nil."
1725   ((and (fboundp 'read-event)
1726         (subrp (symbol-function 'read-event)))
1727    ;; Emacs 19 and later.
1728    (cond
1729     ((symbolp event)
1730      ;; mask is (BASE-TYPE MODIFIER-BITS) or nil.
1731      (let ((mask (get event 'event-symbol-element-mask)))
1732        (if mask
1733            (let ((base (get (car mask) 'ascii-character)))
1734              (if base
1735                  (logior base (car (cdr mask))))))))
1736     ((integerp event) event)))
1737   (t
1738    ;; v18. Is this correct?
1739    event))
1740
1741 ;; v18: no event; (read-char)
1742 ;; Emacs 19, 20.1 and 20.2: (read-event)
1743 ;; Emacs 20.3: (read-event &optional PROMPT SUPPRESS-INPUT-METHOD)
1744 ;; Emacs 20.4: (read-event &optional PROMPT INHERIT-INPUT-METHOD)
1745 ;; XEmacs: (next-event &optional EVENT PROMPT),
1746 ;;         (next-command-event &optional EVENT PROMPT)
1747 (defun-maybe-cond next-command-event (&optional event prompt)
1748   "Read an event object from the input stream.
1749 If EVENT is non-nil, it should be an event object and will be filled
1750 in and returned; otherwise a new event object will be created and
1751 returned.
1752 If PROMPT is non-nil, it should be a string and will be displayed in
1753 the echo area while this function is waiting for an event."
1754   ((and (>= emacs-major-version 20)
1755         (>= emacs-minor-version 4))
1756    ;; Emacs 20.4 and later.
1757    (read-event prompt))                 ; should specify 2nd arg?
1758   ((and (= emacs-major-version 20)
1759         (= emacs-minor-version 3))
1760    ;; Emacs 20.3.
1761    (read-event prompt))                 ; should specify 2nd arg?
1762   ((and (fboundp 'read-event)
1763         (subrp (symbol-function 'read-event)))
1764    ;; Emacs 19, 20.1 and 20.2.
1765    (if prompt (message prompt))
1766    (read-event))
1767   (t
1768    (if prompt (message prompt))
1769    (read-char)))
1770 \f
1771
1772 ;;; @ MULE 2 emulation.
1773 ;;;
1774
1775 (defun-maybe-cond cancel-undo-boundary ()
1776   "Cancel undo boundary."
1777   ((boundp 'buffer-undo-list)
1778    ;; for Emacs 19 and later.
1779    (if (and (consp buffer-undo-list)
1780             (null (car buffer-undo-list)))
1781        (setq buffer-undo-list (cdr buffer-undo-list)))))
1782 \f
1783
1784 ;;; @ End.
1785 ;;;
1786
1787 ;;; poe.el ends here