X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=poe.el;h=3ad269918e82bfe5419266ae9b6677b565da6241;hb=329b62714dec924ad4ea1e664f4b0e90391bc513;hp=27f53ee33f0365fb1bc690da3496e7b7a2482e18;hpb=065d5e891e96c79ee394a1fd5d4a01f2301f7439;p=elisp%2Fapel.git diff --git a/poe.el b/poe.el index 27f53ee..3ad2699 100644 --- a/poe.el +++ b/poe.el @@ -75,7 +75,6 @@ (or (fboundp 'si:require) (progn (fset 'si:require (symbol-function 'require)) - (put 'require 'defun-maybe t) (defun require (feature &optional filename noerror) "\ If feature FEATURE is not loaded, load it from FILENAME. @@ -90,7 +89,10 @@ Normally the return value is FEATURE." (condition-case nil (si:require feature filename) (file-error)) - (si:require feature filename))))))) + (si:require feature filename))) + ;; for `load-history'. + (setq current-load-list (cons 'require current-load-list)) + (put 'require 'defun-maybe t))))) ;; Emacs 19.29 and later: (plist-get PLIST PROP) ;; (defun-maybe plist-get (plist prop) @@ -265,7 +267,7 @@ HIST, if non-nil, specifies a history list 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) @@ -290,7 +292,7 @@ Completion ignores case if the ambient value of (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) @@ -702,38 +704,97 @@ Elements of LIST that are not conses are ignored." (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)) - (delete 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)) - (delete key 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))) + (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'." + (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)) - (delete 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. @@ -836,6 +897,11 @@ This variable is meaningful on MS-DOG and Windows NT. 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 a 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) @@ -1094,8 +1160,7 @@ which is made by replacing the part of STRING that was matched." (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. @@ -1169,7 +1234,6 @@ For example, to produce full ISO 8601 format, use \"%Y-%m-%dT%T%z\". 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." @@ -1184,9 +1248,24 @@ 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 @@ -1235,7 +1314,7 @@ Not fully compatible especially when invalid format is specified." (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 @@ -1256,14 +1335,14 @@ Not fully compatible especially when invalid format is specified." ((eq cur-char ?C) "") ;; the day of month, zero-padded - ((eq cur-char ?d) - (substring time-string 8 10)) + ((eq cur-char ?d) + (format "%02d" (string-to-int (substring time-string 8 10)))) ;; a synonym for `%m/%d/%y' ((eq cur-char ?D) - (format "%02d/%s/%s" + (format "%02d/%02d/%s" (cddr (assoc (substring time-string 4 7) format-time-month-list)) - (substring time-string 8 10) + (string-to-int (substring time-string 8 10)) (substring time-string -2))) ;; the day of month, blank-padded ((eq cur-char ?e) @@ -1324,7 +1403,7 @@ Not fully compatible especially when invalid format is specified." (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) "") @@ -1350,8 +1429,18 @@ Not fully compatible especially when invalid format is specified." (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 "%" @@ -1393,6 +1482,47 @@ Not fully compatible especially when invalid format is specified." (setq current-load-list (cons 'format-time-string current-load-list)) (put 'format-time-string 'defun-maybe t)))) +;; 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)))))))) + ;; 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) @@ -1465,6 +1595,190 @@ See `walk-windows' for the meaning of MINIBUF and FRAME." (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 ":" @@ -1544,6 +1858,19 @@ The extension, in a file name, is the part that follows the last `.'." filename)))) +;;; @ Miscellanea. + +;; Emacs 19.29 and later: (current-fill-column) +(defun-maybe current-fill-column () + "Return the fill-column to use for this line." + fill-column) + +;; Emacs 19.29 and later: (current-left-margin) +(defun-maybe current-left-margin () + "Return the left margin to use for this line." + left-margin) + + ;;; @ XEmacs emulation. ;;; @@ -1637,10 +1964,10 @@ the echo area while this function is waiting for an event." ((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)))