;;; poe.el --- Portable Outfit for Emacsen
-;; Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc.
+;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003, 2005,
+;; 2008 Free Software Foundation, Inc.
;; Author: MORIOKA Tomohiko <tomo@m17n.org>
;; Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
;;; Commentary:
DEF, if non-nil, is the default value.
Completion ignores case if the ambient value of
- `completion-ignore-case' is non-nil."
+ `completion-ignore-case' is non-nil."
(let ((string (si:completing-read prompt table predicate
require-match init hist)))
(if (and (string= string "") def)
(if (fboundp 'string-to-number)
(fset 'si:string-to-number (symbol-function 'string-to-number))
(fset 'si:string-to-number (symbol-function 'string-to-int))
- ;; XXX: In v18, this causes infinite loop while bytecompiling.
+ ;; XXX: In v18, this causes infinite loop while byte-compiling.
;; (defalias 'string-to-int 'string-to-number)
)
(put 'string-to-number 'defun-maybe t)
(throw 'found (car list))))
(setq list (cdr list)))))
-;; XEmacs 19.13 and later: (remassq KEY LIST)
-(defun-maybe remassq (key list)
- "Delete by side effect any elements of LIST whose car is `eq' to KEY.
-The modified LIST is returned. If the first member of LIST has a car
-that is `eq' to KEY, there is no way to remove it by side effect;
-therefore, write `(setq foo (remassq key foo))' to be sure of changing
-the value of `foo'."
- (if (setq key (assq key list))
- (delq key list)
- list))
-
-;; XEmacs 19.13 and later: (remassoc KEY LIST)
-(defun-maybe remassoc (key list)
- "Delete by side effect any elements of LIST whose car is `equal' to KEY.
-The modified LIST is returned. If the first member of LIST has a car
+;; XEmacs 19.13 and later: (remassoc KEY ALIST)
+(defun-maybe remassoc (key alist)
+ "Delete by side effect any elements of ALIST whose car is `equal' to KEY.
+The modified ALIST is returned. If the first member of ALIST has a car
that is `equal' to KEY, there is no way to remove it by side effect;
therefore, write `(setq foo (remassoc key foo))' to be sure of changing
the value of `foo'."
- (if (setq key (assoc key list))
- (delq key list)
- list))
-
-;; XEmacs 19.13 and later: (remrassq VALUE LIST)
-(defun-maybe remrassq (value list)
- "Delete by side effect any elements of LIST whose cdr is `eq' to VALUE.
-The modified LIST is returned. If the first member of LIST has a car
-that is `eq' to VALUE, there is no way to remove it by side effect;
-therefore, write `(setq foo (remrassq value foo))' to be sure of changing
+ (while (and (consp alist)
+ (or (not (consp (car alist)))
+ (equal (car (car alist)) key)))
+ (setq alist (cdr alist)))
+ (if (consp alist)
+ (let ((prev alist)
+ (tail (cdr alist)))
+ (while (consp tail)
+ (if (and (consp (car alist))
+ (equal (car (car tail)) key))
+ ;; `(setcdr CELL NEWCDR)' returns NEWCDR.
+ (setq tail (setcdr prev (cdr tail)))
+ (setq prev (cdr prev)
+ tail (cdr tail))))))
+ alist)
+
+;; XEmacs 19.13 and later: (remassq KEY ALIST)
+(defun-maybe remassq (key alist)
+ "Delete by side effect any elements of ALIST whose car is `eq' to KEY.
+The modified ALIST is returned. If the first member of ALIST has a car
+that is `eq' to KEY, there is no way to remove it by side effect;
+therefore, write `(setq foo (remassq key foo))' to be sure of changing
the value of `foo'."
- (if (setq value (rassq value list))
- (delq value list)
- list))
-
-;; XEmacs 19.13 and later: (remrassoc VALUE LIST)
-(defun-maybe remrassoc (value list)
- "Delete by side effect any elements of LIST whose cdr is `equal' to VALUE.
-The modified LIST is returned. If the first member of LIST has a car
+ (while (and (consp alist)
+ (or (not (consp (car alist)))
+ (eq (car (car alist)) key)))
+ (setq alist (cdr alist)))
+ (if (consp alist)
+ (let ((prev alist)
+ (tail (cdr alist)))
+ (while (consp tail)
+ (if (and (consp (car tail))
+ (eq (car (car tail)) key))
+ ;; `(setcdr CELL NEWCDR)' returns NEWCDR.
+ (setq tail (setcdr prev (cdr tail)))
+ (setq prev (cdr prev)
+ tail (cdr tail))))))
+ alist)
+
+;; XEmacs 19.13 and later: (remrassoc VALUE ALIST)
+(defun-maybe remrassoc (value alist)
+ "Delete by side effect any elements of ALIST whose cdr is `equal' to VALUE.
+The modified ALIST is returned. If the first member of ALIST has a car
that is `equal' to VALUE, there is no way to remove it by side effect;
therefore, write `(setq foo (remrassoc value foo))' to be sure of changing
the value of `foo'."
- (if (setq value (rassoc value list))
- (delq value list)
- list))
+ (while (and (consp alist)
+ (or (not (consp (car alist)))
+ (equal (cdr (car alist)) value)))
+ (setq alist (cdr alist)))
+ (if (consp alist)
+ (let ((prev alist)
+ (tail (cdr alist)))
+ (while (consp tail)
+ (if (and (consp (car tail))
+ (equal (cdr (car tail)) value))
+ ;; `(setcdr CELL NEWCDR)' returns NEWCDR.
+ (setq tail (setcdr prev (cdr tail)))
+ (setq prev (cdr prev)
+ tail (cdr tail))))))
+ alist)
+
+;; XEmacs 19.13 and later: (remrassq VALUE ALIST)
+(defun-maybe remrassq (value alist)
+ "Delete by side effect any elements of ALIST whose cdr is `eq' to VALUE.
+The modified ALIST is returned. If the first member of ALIST has a car
+that is `eq' to VALUE, there is no way to remove it by side effect;
+therefore, write `(setq foo (remrassq value foo))' to be sure of changing
+the value of `foo'."
+ (while (and (consp alist)
+ (or (not (consp (car alist)))
+ (eq (cdr (car alist)) value)))
+ (setq alist (cdr alist)))
+ (if (consp alist)
+ (let ((prev alist)
+ (tail (cdr alist)))
+ (while (consp tail)
+ (if (and (consp (car tail))
+ (eq (cdr (car tail)) value))
+ ;; `(setcdr CELL NEWCDR)' returns NEWCDR.
+ (setq tail (setcdr prev (cdr tail)))
+ (setq prev (cdr prev)
+ tail (cdr tail))))))
+ alist)
;;; Define `functionp' here because "localhook" uses it.
On those systems, it is automatically local in every buffer.
On other systems, this variable is normally always nil.")
+;; Emacs 20.3 or later.
+(defvar-maybe minor-mode-overriding-map-alist nil
+ "Alist of keymaps to use for minor modes, in current major mode.
+APEL provides this as dummy for compatibility.")
+
;; Emacs 20.1/XEmacs 20.3(?) and later: (save-current-buffer &rest BODY)
;;
;; v20 defines `save-current-buffer' as a C primitive (in src/editfns.c)
(buffer-string)))
(si:replace-match newtext fixedcase literal)))))))))
-;; Emacs 20: (format-time-string)
-;; The the third optional argument universal is yet to be implemented.
+;; Emacs 20: (format-time-string FORMAT &optional TIME UNIVERSAL)
;; Those format constructs are yet to be implemented.
;; %c, %C, %j, %U, %W, %x, %X
;; Not fully compatible especially when invalid format is specified.
Compatibility Note.
-The the third optional argument universal is yet to be implemented.
Those format constructs are yet to be implemented.
%c, %C, %j, %U, %W, %x, %X
Not fully compatible especially when invalid format is specified."
field-result
pad-left change-case
(paren-level 0)
- hour
- (time-string (current-time-string time)))
- (setq hour (string-to-int (substring time-string 11 13)))
+ hour ms ls
+ (tz (car (current-time-zone)))
+ time-string)
+ (if universal
+ (progn
+ (or time
+ (setq time (current-time)))
+ (setq ms (car time)
+ ls (- (nth 1 time) tz))
+ (cond ((< ls 0)
+ (setq ms (1- ms)
+ ls (+ ls 65536)))
+ ((>= ls 65536)
+ (setq ms (1+ ms)
+ ls (- ls 65536))))
+ (setq time (append (list ms ls) (nth 2 time)))))
+ (setq time-string (current-time-string time)
+ hour (string-to-int (substring time-string 11 13)))
(while (< ind fmt-len)
(setq cur-char (aref format ind))
(setq
(cond
((eq cur-char ?%)
"%")
- ;; the abbreviated name of the day of week.
+ ;; the abbreviated name of the day of week.
((eq cur-char ?a)
(substring time-string 0 3))
;; the full name of the day of week
((eq cur-char ?C)
"")
;; the day of month, zero-padded
- ((eq cur-char ?d)
+ ((eq cur-char ?d)
(format "%02d" (string-to-int (substring time-string 8 10))))
;; a synonym for `%m/%d/%y'
((eq cur-char ?D)
(substring time-string 11 13)
(substring time-string 14 16)
(substring time-string 17 19)))
- ;; the week of the year (01-52), assuming that weeks
+ ;; the week of the year (01-52), assuming that weeks
;; start on Sunday (yet to come)
((eq cur-char ?U)
"")
(substring time-string -4))
;; the time zone abbreviation
((eq cur-char ?Z)
- (setq change-case (not change-case))
- (downcase (cadr (current-time-zone))))
+ (if universal
+ "UTC"
+ (setq change-case (not change-case))
+ (downcase (cadr (current-time-zone)))))
+ ((eq cur-char ?z)
+ (if universal
+ "+0000"
+ (if (< tz 0)
+ (format "-%02d%02d"
+ (/ (- tz) 3600) (/ (% (- tz) 3600) 60))
+ (format "+%02d%02d"
+ (/ tz 3600) (/ (% tz 3600) 60)))))
(t
(concat
"%"
(setq current-load-list (cons 'format-time-string current-load-list))
(put 'format-time-string 'defun-maybe t))))
-;; Emacs 20.1/XEmacs 20.3(?) and later: (split-string STRING &optional PATTERN)
-;; Here is a XEmacs version.
-(defun-maybe split-string (string &optional pattern)
- "Return a list of substrings of STRING which are separated by PATTERN.
-If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"."
- (or pattern
- (setq pattern "[ \f\t\n\r\v]+"))
- ;; The FSF version of this function takes care not to cons in case
- ;; of infloop. Maybe we should synch?
- (let (parts (start 0))
- (while (string-match pattern string start)
- (setq parts (cons (substring string start (match-beginning 0)) parts)
- start (match-end 0)))
- (nreverse (cons (substring string start) parts))))
+;; Emacs 19.29-19.34/XEmacs: `format-time-string' neither supports the
+;; format string "%z" nor the third argument `universal'.
+(unless (string-match "\\`[---+][0-9]+\\'"
+ (format-time-string "%z" (current-time)))
+ (defadvice format-time-string
+ (before support-timezone-in-numeric-form-and-3rd-arg
+ (format-string &optional time universal) activate compile)
+ "Advice to support the construct `%z' and the third argument `universal'."
+ (let ((tz (car (current-time-zone)))
+ case-fold-search ms ls)
+ (while (string-match "\\(\\(\\`\\|[^%]\\)\\(%%\\)*\\)%z" format-string)
+ (setq format-string
+ (concat (substring format-string 0 (match-end 1))
+ (if universal
+ "+0000"
+ (if (< tz 0)
+ (format "-%02d%02d"
+ (/ (- tz) 3600) (/ (% (- tz) 3600) 60))
+ (format "+%02d%02d"
+ (/ tz 3600) (/ (% tz 3600) 60))))
+ (substring format-string (match-end 0)))))
+ (if universal
+ (progn
+ (while (string-match "\\(\\(\\`\\|[^%]\\)\\(%%\\)*\\)%Z"
+ format-string)
+ (setq format-string
+ (concat (substring format-string 0 (match-end 1))
+ "UTC"
+ (substring format-string (match-end 0)))))
+ (or time
+ (setq time (current-time)))
+ (setq ms (car time)
+ ls (- (nth 1 time) tz))
+ (cond ((< ls 0)
+ (setq ms (1- ms)
+ ls (+ ls 65536)))
+ ((>= ls 65536)
+ (setq ms (1+ ms)
+ ls (- ls 65536))))
+ (setq time (append (list ms ls) (nth 2 time))))))))
+
+(defconst-maybe split-string-default-separators "[ \f\t\n\r\v]+"
+ "The default value of separators for `split-string'.
+
+A regexp matching strings of whitespace. May be locale-dependent
+\(as yet unimplemented). Should not match non-breaking spaces.
+
+Warning: binding this to a different value and using it as default is
+likely to have undesired semantics.")
+
+;; Here is a Emacs 22 version. OMIT-NULLS
+(defun-maybe split-string (string &optional separators omit-nulls)
+ "Split STRING into substrings bounded by matches for SEPARATORS.
+
+The beginning and end of STRING, and each match for SEPARATORS, are
+splitting points. The substrings matching SEPARATORS are removed, and
+the substrings between the splitting points are collected as a list,
+which is returned.
+
+If SEPARATORS is non-nil, it should be a regular expression matching text
+which separates, but is not part of, the substrings. If nil it defaults to
+`split-string-default-separators', normally \"[ \\f\\t\\n\\r\\v]+\", and
+OMIT-NULLS is forced to t.
+
+If OMIT-NULLS is t, zero-length substrings are omitted from the list \(so
+that for the default value of SEPARATORS leading and trailing whitespace
+are effectively trimmed). If nil, all zero-length substrings are retained,
+which correctly parses CSV format, for example.
+
+Note that the effect of `(split-string STRING)' is the same as
+`(split-string STRING split-string-default-separators t)'). In the rare
+case that you wish to retain zero-length substrings when splitting on
+whitespace, use `(split-string STRING split-string-default-separators)'.
+
+Modifies the match data; use `save-match-data' if necessary."
+ (let ((keep-nulls (not (if separators omit-nulls t)))
+ (rexp (or separators split-string-default-separators))
+ (start 0)
+ notfirst
+ (list nil))
+ (while (and (string-match rexp string
+ (if (and notfirst
+ (= start (match-beginning 0))
+ (< start (length string)))
+ (1+ start) start))
+ (< start (length string)))
+ (setq notfirst t)
+ (if (or keep-nulls (< start (match-beginning 0)))
+ (setq list
+ (cons (substring string start (match-beginning 0))
+ list)))
+ (setq start (match-end 0)))
+ (if (or keep-nulls (< start (length string)))
+ (setq list
+ (cons (substring string start)
+ list)))
+ (nreverse list)))
\f
;;; @ Window commands emulation. (lisp/window.el)
(or (getenv "TMPDIR") (getenv "TMP") (getenv "TEMP") "/tmp"))))
"The directory for writing temporary files.")
+;; Emacs 21 CVS ; nothing to do.
+;; (make-temp-file PREFIX &optional DIR-FLAG SUFFIX)
+;;
+;; Emacs 21.1-21.3 ; replace with CVS version of `make-temp-file'.
+;; (make-temp-file PREFIX &optional DIR-FLAG)
+;;
+;; Emacs 20 and earlier ; install our version of `make-temp-file', for
+;; or XEmacs ; single-user system or for multi-user system.
+(eval-when-compile
+ (cond
+ ((get 'make-temp-file 'defun-maybe)
+ ;; this form is already evaluated during compilation.
+ )
+ ((not (fboundp 'make-temp-file))
+ ;; Emacs 20 and earlier, or XEmacs.
+ (put 'make-temp-file 'defun-maybe 'none))
+ (t
+ (let* ((object (symbol-function 'make-temp-file))
+ (arglist (cond
+ ((byte-code-function-p object)
+ (if (fboundp 'compiled-function-arglist)
+ (compiled-function-arglist object)
+ (aref object 0)))
+ ((eq (car-safe object) 'lambda)
+ (nth 1 object))
+ ;; `make-temp-file' is a built-in.
+ )))
+ ;; arglist: (prefix &optional dir-flag suffix)
+ (cond
+ ((not arglist)
+ ;; `make-temp-file' is a built-in; expects 3-args.
+ (put 'make-temp-file 'defun-maybe '3-args))
+ ((> (length arglist) 3)
+ ;; Emacs 21 CVS.
+ (put 'make-temp-file 'defun-maybe '3-args))
+ (t
+ ;; Emacs 21.1-21.3
+ (put 'make-temp-file 'defun-maybe '2-args)))))))
+
+(static-cond
+ ((eq (get 'make-temp-file 'defun-maybe) '3-args)
+ (put 'make-temp-file 'defun-maybe '3-args))
+ ((eq (get 'make-temp-file 'defun-maybe) '2-args)
+ (put 'make-temp-file 'defun-maybe '2-args)
+ (or (fboundp 'si:make-temp-file)
+ (fset 'si:make-temp-file (symbol-function 'make-temp-file)))
+ (setq current-load-list (cons 'make-temp-file current-load-list))
+ (defun make-temp-file (prefix &optional dir-flag suffix)
+ "\
+Create a temporary file.
+The returned file name (created by appending some random characters at the end
+of PREFIX, and expanding against `temporary-file-directory' if necessary),
+is guaranteed to point to a newly created empty file.
+You can then use `write-region' to write new data into the file.
+
+If DIR-FLAG is non-nil, create a new empty directory instead of a file.
+
+If SUFFIX is non-nil, add that at the end of the file name."
+ (let ((umask (default-file-modes))
+ file)
+ (unwind-protect
+ (progn
+ ;; Create temp files with strict access rights.
+ ;; It's easy toloosen them later, whereas it's impossible
+ ;; to close the time-window of loose permissions otherwise.
+ (set-default-file-modes 448)
+ (while (condition-case ()
+ (progn
+ (setq file
+ (make-temp-name
+ (expand-file-name
+ prefix temporary-file-directory)))
+ (if suffix
+ (setq file (concat file suffix)))
+ (if dir-flag
+ (make-directory file)
+ (write-region "" nil file nil
+ 'silent nil 'excl))
+ nil)
+ (file-already-exists t))
+ ;; the file was somehow created by someone else between
+ ;; `make-temp-name' and `write-region', let's try again.
+ nil)
+ file)
+ ;; Reset the umask.
+ (set-default-file-modes umask)))))
+ ((eq (get 'make-temp-file 'defun-maybe) 'none)
+ (put 'make-temp-file 'defun-maybe 'none)
+ (setq current-load-list (cons 'make-temp-file current-load-list))
+ ;; must be load-time check to share .elc between different systems.
+ (cond
+ ((memq system-type '(windows-nt ms-dos OS/2 emx))
+ ;; for single-user systems.
+ (defun make-temp-file (prefix &optional dir-flag suffix)
+ "Create a temporary file.
+The returned file name (created by appending some random characters at the end
+of PREFIX, and expanding against `temporary-file-directory' if necessary),
+is guaranteed to point to a newly created empty file.
+You can then use `write-region' to write new data into the file.
+
+If DIR-FLAG is non-nil, create a new empty directory instead of a file.
+
+If SUFFIX is non-nil, add that at the end of the file name."
+ (let ((file (make-temp-name
+ (expand-file-name prefix temporary-file-directory))))
+ (if suffix
+ (setq file (concat file suffix)))
+ (if dir-flag
+ (make-directory file)
+ (write-region "" nil file nil 'silent))
+ file)))
+ (t
+ ;; for multi-user systems.
+ (defun make-temp-file (prefix &optional dir-flag suffix)
+ "Create a temporary file.
+The returned file name (created by appending some random characters at the end
+of PREFIX, and expanding against `temporary-file-directory' if necessary),
+is guaranteed to point to a newly created empty file.
+You can then use `write-region' to write new data into the file.
+
+If DIR-FLAG is non-nil, create a new empty directory instead of a file.
+
+If SUFFIX is non-nil, add that at the end of the file name."
+ (let ((prefix (expand-file-name prefix temporary-file-directory)))
+ (if dir-flag
+ ;; Create a new empty directory.
+ (let (dir)
+ (while (condition-case ()
+ (progn
+ (setq dir (make-temp-name prefix))
+ (if suffix
+ (setq dir (concat dir suffix)))
+ ;; `make-directory' returns nil for success,
+ ;; otherwise signals an error.
+ (make-directory dir))
+ ;; the dir was somehow created by someone else
+ ;; between `make-temp-name' and `make-directory',
+ ;; let's try again.
+ (file-already-exists t)))
+ (set-file-modes dir 448)
+ dir)
+ ;; Create a new empty file.
+ (let (tempdir tempfile)
+ (unwind-protect
+ (let (file)
+ ;; First, create a temporary directory.
+ (while (condition-case ()
+ (progn
+ (setq tempdir (make-temp-name
+ (concat
+ (file-name-directory prefix)
+ "DIR")))
+ ;; return nil or signal an error.
+ (make-directory tempdir))
+ ;; let's try again.
+ (file-already-exists t)))
+ (set-file-modes tempdir 448)
+ ;; Second, create a temporary file in the tempdir.
+ ;; There *is* a race condition between `make-temp-name'
+ ;; and `write-region', but we don't care it since we are
+ ;; in a private directory now.
+ (setq tempfile (make-temp-name (concat tempdir "/EMU")))
+ (write-region "" nil tempfile nil 'silent)
+ (set-file-modes tempfile 384)
+ ;; Finally, make a hard-link from the tempfile.
+ (while (condition-case ()
+ (progn
+ (setq file (make-temp-name prefix))
+ (if suffix
+ (setq file (concat file suffix)))
+ ;; return nil or signal an error.
+ (add-name-to-file tempfile file))
+ ;; let's try again.
+ (file-already-exists t)))
+ file)
+ ;; Cleanup the tempfile.
+ (and tempfile
+ (file-exists-p tempfile)
+ (delete-file tempfile))
+ ;; Cleanup the tempdir.
+ (and tempdir
+ (file-directory-p tempdir)
+ (delete-directory tempdir)))))))))))
+
;; Actually, `path-separator' is defined in src/emacs.c and overrided
;; in dos-w32.el.
(defvar-maybe path-separator ":"
((and (fboundp 'read-event)
(subrp (symbol-function 'read-event)))
;; Emacs 19, 20.1 and 20.2.
- (if prompt (message prompt))
+ (if prompt (message "%s" prompt))
(read-event))
(t
- (if prompt (message prompt))
+ (if prompt (message "%s" prompt))
(read-char)))
\f
projects / elisp / apel.git / blobdiff