X-Git-Url: http://git.chise.org/gitweb/?p=elisp%2Fapel.git;a=blobdiff_plain;f=poe.el;h=0c7b4fff9db8aa2c1cdb61cb43e620df939401b2;hp=d2a9309a7be7cda9ad8ac84c74cb40d7b1d92dae;hb=8b0dbe5092ae30b5092d7abf96649f96635d1060;hpb=97f5ef85b0cd85a26a41e05fbd61e78692c288d6 diff --git a/poe.el b/poe.el index d2a9309..0c7b4ff 100644 --- a/poe.el +++ b/poe.el @@ -1,6 +1,7 @@ ;;; 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 ;; Shuhei KOBAYASHI @@ -20,8 +21,8 @@ ;; 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: @@ -267,7 +268,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) @@ -900,7 +901,7 @@ 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.") +APEL provides this as dummy for compatibility.") ;; Emacs 20.1/XEmacs 20.3(?) and later: (save-current-buffer &rest BODY) ;; @@ -1160,8 +1161,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. @@ -1235,7 +1235,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." @@ -1250,9 +1249,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 @@ -1301,7 +1315,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 @@ -1322,7 +1336,7 @@ Not fully compatible especially when invalid format is specified." ((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) @@ -1390,7 +1404,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) "") @@ -1416,13 +1430,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) - (let ((tz (car (current-time-zone)))) + (if universal + "+0000" (if (< tz 0) - (format "-%02d%02d" (/ (- tz) 3600) (/ (% (- tz) 3600) 60)) - (format "+%02d%02d" (/ tz 3600) (/ (% tz 3600) 60))))) + (format "-%02d%02d" + (/ (- tz) 3600) (/ (% (- tz) 3600) 60)) + (format "+%02d%02d" + (/ tz 3600) (/ (% tz 3600) 60))))) (t (concat "%" @@ -1464,38 +1483,103 @@ 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() doesn't support `%z'. -(unless (string-match "\\`[\\-\\+][0-9]+\\'" +;; 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 activate compile) - "Advice to support the construct `%z'." - (if (let ((case-fold-search nil)) - (string-match "\\(\\(\\`\\|[^%]\\)\\(%%\\)*\\)%z" (ad-get-arg 0))) - (ad-set-arg - 0 - (concat - (substring (ad-get-arg 0) 0 (match-end 1)) - (let ((tz (car (current-time-zone)))) - (if (< tz 0) - (format "-%02d%02d" (/ (- tz) 3600) (/ (% (- tz) 3600) 60)) - (format "+%02d%02d" (/ tz 3600) (/ (% tz 3600) 60)))) - (substring (ad-get-arg 0) (match-end 0))))))) - -;; 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)))) + (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))) ;;; @ Window commands emulation. (lisp/window.el) @@ -1554,6 +1638,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 ":" @@ -1739,10 +2007,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)))