X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=poe.el;h=0c7b4fff9db8aa2c1cdb61cb43e620df939401b2;hb=4426be092c80a2e8c8113ccb1e696743d6210263;hp=b078bdf5812e2d1ab75cb55b6da1ff72bbeb67cd;hpb=41099808ae5031e99f5bc3802765e73e701d200f;p=elisp%2Fapel.git diff --git a/poe.el b/poe.el index b078bdf..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: @@ -75,7 +76,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 +90,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 +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) @@ -290,7 +293,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) @@ -521,6 +524,72 @@ This function does not move point." (save-excursion (end-of-line (or n 1)) (point))) + +;; FSF Emacs 19.29 and later +;; (read-file-name PROMPT &optional DIR DEFAULT-FILENAME MUSTMATCH INITIAL) +;; XEmacs 19.14 and later: +;; (read-file-name (PROMPT &optional DIR DEFAULT MUST-MATCH INITIAL-CONTENTS +;; HISTORY) + +;; In FSF Emacs 19.28 and earlier (except for v18) or XEmacs 19.13 and +;; earlier, this function is incompatible with the other Emacsen. +;; For instance, if DEFAULT-FILENAME is nil, INITIAL is not and user +;; enters a null string, it returns the visited file name of the current +;; buffer if it is non-nil. + +;; It does not assimilate the different numbers of the optional arguments +;; on various Emacsen (yet). +(static-cond + ((and (not (featurep 'xemacs)) + (eq emacs-major-version 19) + (< emacs-minor-version 29)) + (if (fboundp 'si:read-file-name) + nil + (fset 'si:read-file-name (symbol-function 'read-file-name)) + (defun read-file-name (prompt &optional dir default-filename mustmatch + initial) + "Read file name, prompting with PROMPT and completing in directory DIR. +Value is not expanded---you must call `expand-file-name' yourself. +Default name to DEFAULT-FILENAME if user enters a null string. + (If DEFAULT-FILENAME is omitted, the visited file name is used, + except that if INITIAL is specified, that combined with DIR is used.) +Fourth arg MUSTMATCH non-nil means require existing file's name. + Non-nil and non-t means also require confirmation after completion. +Fifth arg INITIAL specifies text to start with. +DIR defaults to current buffer's directory default." + (si:read-file-name prompt dir + (or default-filename + (if initial + (expand-file-name initial dir))) + mustmatch initial)))) + ((and (featurep 'xemacs) + (eq emacs-major-version 19) + (< emacs-minor-version 14)) + (if (fboundp 'si:read-file-name) + nil + (fset 'si:read-file-name (symbol-function 'read-file-name)) + (defun read-file-name (prompt &optional dir default must-match + initial-contents history) + "Read file name, prompting with PROMPT and completing in directory DIR. +This will prompt with a dialog box if appropriate, according to + `should-use-dialog-box-p'. +Value is not expanded---you must call `expand-file-name' yourself. +Value is subject to interpreted by substitute-in-file-name however. +Default name to DEFAULT if user enters a null string. + (If DEFAULT is omitted, the visited file name is used, + except that if INITIAL-CONTENTS is specified, that combined with DIR is + used.) +Fourth arg MUST-MATCH non-nil means require existing file's name. + Non-nil and non-t means also require confirmation after completion. +Fifth arg INITIAL-CONTENTS specifies text to start with. +Sixth arg HISTORY specifies the history list to use. Default is + `file-name-history'. +DIR defaults to current buffer's directory default." + (si:read-file-name prompt dir + (or default + (if initial-contents + (expand-file-name initial-contents dir))) + must-match initial-contents history))))) ;;; @ Basic lisp subroutines emulation. (lisp/subr.el) @@ -623,7 +692,7 @@ If TEST is omitted or nil, `equal' is used." ;; (defun assoc-ignore-case (key alist)) ;; (defun assoc-ignore-representation (key alist)) -;; Emacs 19.29/XEmacs 19.14(?) and later: (rassoc KEY LIST) +;; Emacs 19.29/XEmacs 19.13 and later: (rassoc KEY LIST) ;; Actually, `rassoc' is defined in src/fns.c. (defun-maybe rassoc (key list) "Return non-nil if KEY is `equal' to the cdr of an element of LIST. @@ -636,6 +705,98 @@ Elements of LIST that are not conses are ignored." (throw 'found (car list)))) (setq list (cdr list))))) +;; 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'." + (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'." + (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. ;; Emacs 20.1/XEmacs 20.3 (but first appeared in Epoch?): (functionp OBJECT) @@ -737,6 +898,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 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) @@ -881,20 +1047,539 @@ STRING should be given if the last search was by `string-match' on STRING." (buffer-substring-no-properties (match-beginning num) (match-end num))))) -;; 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.28 and earlier +;; (replace-match NEWTEXT &optional FIXEDCASE LITERAL) +;; Emacs 20.x (?) and later +;; (replace-match NEWTEXT &optional FIXEDCASE LITERAL STRING SUBEXP) +;; XEmacs 21: +;; (replace-match NEWTEXT &optional FIXEDCASE LITERAL STRING STRBUFFER) +;; We support following API. +;; (replace-match NEWTEXT &optional FIXEDCASE LITERAL STRING) +(static-condition-case nil + ;; compile-time check + (progn + (string-match "" "") + (replace-match "" nil nil "") + (if (get 'replace-match 'defun-maybe) + (error "`replace-match' is already defined"))) + (wrong-number-of-arguments ; Emacs 19.28 and earlier + ;; load-time check. + (or (fboundp 'si:replace-match) + (progn + (fset 'si:replace-match (symbol-function 'replace-match)) + (put 'replace-match 'defun-maybe t) + (defun replace-match (newtext &optional fixedcase literal string) + "Replace text matched by last search with NEWTEXT. +If second arg FIXEDCASE is non-nil, do not alter case of replacement text. +Otherwise maybe capitalize the whole text, or maybe just word initials, +based on the replaced text. +If the replaced text has only capital letters +and has at least one multiletter word, convert NEWTEXT to all caps. +If the replaced text has at least one word starting with a capital letter, +then capitalize each word in NEWTEXT. + +If third arg LITERAL is non-nil, insert NEWTEXT literally. +Otherwise treat `\' as special: + `\&' in NEWTEXT means substitute original matched text. + `\N' means substitute what matched the Nth `\(...\)'. + If Nth parens didn't match, substitute nothing. + `\\' means insert one `\'. +FIXEDCASE and LITERAL are optional arguments. +Leaves point at end of replacement text. + +The optional fourth argument STRING can be a string to modify. +In that case, this function creates and returns a new string +which is made by replacing the part of STRING that was matched." + (if string + (with-temp-buffer + (save-match-data + (insert string) + (let* ((matched (match-data)) + (beg (nth 0 matched)) + (end (nth 1 matched))) + (store-match-data + (list + (if (markerp beg) + (move-marker beg (1+ (match-beginning 0))) + (1+ (match-beginning 0))) + (if (markerp end) + (move-marker end (1+ (match-end 0))) + (1+ (match-end 0)))))) + (si:replace-match newtext fixedcase literal) + (buffer-string))) + (si:replace-match newtext fixedcase literal)))))) + (error ; found our definition at compile-time. + ;; load-time check. + (condition-case nil + (progn + (string-match "" "") + (replace-match "" nil nil "")) + (wrong-number-of-arguments ; Emacs 19.28 and earlier + ;; load-time check. + (or (fboundp 'si:replace-match) + (progn + (fset 'si:replace-match (symbol-function 'replace-match)) + (put 'replace-match 'defun-maybe t) + (defun replace-match (newtext &optional fixedcase literal string) + "Replace text matched by last search with NEWTEXT. +If second arg FIXEDCASE is non-nil, do not alter case of replacement text. +Otherwise maybe capitalize the whole text, or maybe just word initials, +based on the replaced text. +If the replaced text has only capital letters +and has at least one multiletter word, convert NEWTEXT to all caps. +If the replaced text has at least one word starting with a capital letter, +then capitalize each word in NEWTEXT. + +If third arg LITERAL is non-nil, insert NEWTEXT literally. +Otherwise treat `\' as special: + `\&' in NEWTEXT means substitute original matched text. + `\N' means substitute what matched the Nth `\(...\)'. + If Nth parens didn't match, substitute nothing. + `\\' means insert one `\'. +FIXEDCASE and LITERAL are optional arguments. +Leaves point at end of replacement text. + +The optional fourth argument STRING can be a string to modify. +In that case, this function creates and returns a new string +which is made by replacing the part of STRING that was matched." + (if string + (with-temp-buffer + (save-match-data + (insert string) + (let* ((matched (match-data)) + (beg (nth 0 matched)) + (end (nth 1 matched))) + (store-match-data + (list + (if (markerp beg) + (move-marker beg (1+ (match-beginning 0))) + (1+ (match-beginning 0))) + (if (markerp end) + (move-marker end (1+ (match-end 0))) + (1+ (match-end 0)))))) + (si:replace-match newtext fixedcase literal) + (buffer-string))) + (si:replace-match newtext fixedcase literal))))))))) + +;; 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. +(static-unless (and (fboundp 'format-time-string) + (not (get 'format-time-string 'defun-maybe))) + (or (fboundp 'format-time-string) + (progn + (defconst format-time-month-list + '(( "Zero" . ("Zero" . 0)) + ("Jan" . ("January" . 1)) ("Feb" . ("February" . 2)) + ("Mar" . ("March" . 3)) ("Apr" . ("April" . 4)) ("May" . ("May" . 5)) + ("Jun" . ("June" . 6))("Jul" . ("July" . 7)) ("Aug" . ("August" . 8)) + ("Sep" . ("September" . 9)) ("Oct" . ("October" . 10)) + ("Nov" . ("November" . 11)) ("Dec" . ("December" . 12))) + "Alist of months and their number.") + + (defconst format-time-week-list + '(("Sun" . ("Sunday" . 0)) ("Mon" . ("Monday" . 1)) + ("Tue" . ("Tuesday" . 2)) ("Wed" . ("Wednesday" . 3)) + ("Thu" . ("Thursday" . 4)) ("Fri" . ("Friday" . 5)) + ("Sat" . ("Saturday" . 6))) + "Alist of weeks and their number.") + + (defun format-time-string (format &optional time universal) + "Use FORMAT-STRING to format the time TIME, or now if omitted. +TIME is specified as (HIGH LOW . IGNORED) or (HIGH . LOW), as returned by +`current-time' or `file-attributes'. +The third, optional, argument UNIVERSAL, if non-nil, means describe TIME +as Universal Time; nil means describe TIME in the local time zone. +The value is a copy of FORMAT-STRING, but with certain constructs replaced +by text that describes the specified date and time in TIME: + +%Y is the year, %y within the century, %C the century. +%G is the year corresponding to the ISO week, %g within the century. +%m is the numeric month. +%b and %h are the locale's abbreviated month name, %B the full name. +%d is the day of the month, zero-padded, %e is blank-padded. +%u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6. +%a is the locale's abbreviated name of the day of week, %A the full name. +%U is the week number starting on Sunday, %W starting on Monday, + %V according to ISO 8601. +%j is the day of the year. + +%H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H + only blank-padded, %l is like %I blank-padded. +%p is the locale's equivalent of either AM or PM. +%M is the minute. +%S is the second. +%Z is the time zone name, %z is the numeric form. +%s is the number of seconds since 1970-01-01 00:00:00 +0000. + +%c is the locale's date and time format. +%x is the locale's \"preferred\" date format. +%D is like \"%m/%d/%y\". + +%R is like \"%H:%M\", %T is like \"%H:%M:%S\", %r is like \"%I:%M:%S %p\". +%X is the locale's \"preferred\" time format. + +Finally, %n is a newline, %t is a tab, %% is a literal %. + +Certain flags and modifiers are available with some format controls. +The flags are `_' and `-'. For certain characters X, %_X is like %X, +but padded with blanks; %-X is like %X, but without padding. +%NX (where N stands for an integer) is like %X, +but takes up at least N (a number) positions. +The modifiers are `E' and `O'. For certain characters X, +%EX is a locale's alternative version of %X; +%OX is like %X, but uses the locale's number symbols. + +For example, to produce full ISO 8601 format, use \"%Y-%m-%dT%T%z\". + +Compatibility Note. + +Those format constructs are yet to be implemented. + %c, %C, %j, %U, %W, %x, %X +Not fully compatible especially when invalid format is specified." + (let ((fmt-len (length format)) + (ind 0) + prev-ind + cur-char + (prev-char nil) + strings-so-far + (result "") + field-width + field-result + pad-left change-case + (paren-level 0) + 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 + result + (concat result + (cond + ((eq cur-char ?%) + ;; eat any additional args to allow for future expansion, not!! + (setq pad-left nil change-case nil field-width "" prev-ind ind + strings-so-far "") +; (catch 'invalid + (while (progn + (setq ind (1+ ind)) + (setq cur-char (if (< ind fmt-len) + (aref format ind) + ?\0)) + (or (eq ?- cur-char) ; pad on left + (eq ?# cur-char) ; case change + (if (and (string-equal field-width "") + (<= ?0 cur-char) (>= ?9 cur-char)) + ;; get format width + (let ((field-index ind)) + (while (progn + (setq ind (1+ ind)) + (setq cur-char (if (< ind fmt-len) + (aref format ind) + ?\0)) + (and (<= ?0 cur-char) (>= ?9 cur-char)))) + (setq field-width + (substring format field-index ind)) + (setq ind (1- ind) + cur-char nil) + t)))) + (setq prev-char cur-char + strings-so-far (concat strings-so-far + (if cur-char + (char-to-string cur-char) + field-width))) + ;; characters we actually use + (cond ((eq cur-char ?-) + ;; padding to left must be specified before field-width + (setq pad-left (string-equal field-width ""))) + ((eq cur-char ?#) + (setq change-case t)))) + (setq field-result + (cond + ((eq cur-char ?%) + "%") + ;; 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 ?A) + (cadr (assoc (substring time-string 0 3) + format-time-week-list))) + ;; the abbreviated name of the month + ((eq cur-char ?b) + (substring time-string 4 7)) + ;; the full name of the month + ((eq cur-char ?B) + (cadr (assoc (substring time-string 4 7) + format-time-month-list))) + ;; a synonym for `%x %X' (yet to come) + ((eq cur-char ?c) + "") + ;; locale specific (yet to come) + ((eq cur-char ?C) + "") + ;; the day of month, zero-padded + ((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/%02d/%s" + (cddr (assoc (substring time-string 4 7) + format-time-month-list)) + (string-to-int (substring time-string 8 10)) + (substring time-string -2))) + ;; the day of month, blank-padded + ((eq cur-char ?e) + (format "%2d" (string-to-int (substring time-string 8 10)))) + ;; a synonym for `%b' + ((eq cur-char ?h) + (substring time-string 4 7)) + ;; the hour (00-23) + ((eq cur-char ?H) + (substring time-string 11 13)) + ;; the hour (00-12) + ((eq cur-char ?I) + (format "%02d" (if (> hour 12) (- hour 12) hour))) + ;; the day of the year (001-366) (yet to come) + ((eq cur-char ?j) + "") + ;; the hour (0-23), blank padded + ((eq cur-char ?k) + (format "%2d" hour)) + ;; the hour (1-12), blank padded + ((eq cur-char ?l) + (format "%2d" (if (> hour 12) (- hour 12) hour))) + ;; the month (01-12) + ((eq cur-char ?m) + (format "%02d" (cddr (assoc (substring time-string 4 7) + format-time-month-list)))) + ;; the minute (00-59) + ((eq cur-char ?M) + (substring time-string 14 16)) + ;; a newline + ((eq cur-char ?n) + "\n") + ;; `AM' or `PM', as appropriate + ((eq cur-char ?p) + (setq change-case (not change-case)) + (if (> hour 12) "pm" "am")) + ;; a synonym for `%I:%M:%S %p' + ((eq cur-char ?r) + (format "%02d:%s:%s %s" + (if (> hour 12) (- hour 12) hour) + (substring time-string 14 16) + (substring time-string 17 19) + (if (> hour 12) "PM" "AM"))) + ;; a synonym for `%H:%M' + ((eq cur-char ?R) + (format "%s:%s" + (substring time-string 11 13) + (substring time-string 14 16))) + ;; the seconds (00-60) + ((eq cur-char ?S) + (substring time-string 17 19)) + ;; a tab character + ((eq cur-char ?t) + "\t") + ;; a synonym for `%H:%M:%S' + ((eq cur-char ?T) + (format "%s:%s:%s" + (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 + ;; start on Sunday (yet to come) + ((eq cur-char ?U) + "") + ;; the numeric day of week (0-6). Sunday is day 0 + ((eq cur-char ?w) + (format "%d" (cddr (assoc (substring time-string 0 3) + format-time-week-list)))) + ;; the week of the year (01-52), assuming that weeks + ;; start on Monday (yet to come) + ((eq cur-char ?W) + "") + ;; locale specific (yet to come) + ((eq cur-char ?x) + "") + ;; locale specific (yet to come) + ((eq cur-char ?X) + "") + ;; the year without century (00-99) + ((eq cur-char ?y) + (substring time-string -2)) + ;; the year with century + ((eq cur-char ?Y) + (substring time-string -4)) + ;; the time zone abbreviation + ((eq cur-char ?Z) + (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 + "%" + strings-so-far + (char-to-string cur-char))))) +; (setq ind prev-ind) +; (throw 'invalid "%")))) + (if (string-equal field-width "") + (if change-case (upcase field-result) field-result) + (let ((padded-result + (format (format "%%%s%s%c" + "" ; pad on left is ignored +; (if pad-left "-" "") + field-width + ?s) + (or field-result "")))) + (let ((initial-length (length padded-result)) + (desired-length (string-to-int field-width))) + (when (and (string-match "^0" field-width) + (string-match "^ +" padded-result)) + (setq padded-result + (replace-match + (make-string + (length (match-string 0 padded-result)) ?0) + nil nil padded-result))) + (if (> initial-length desired-length) + ;; truncate strings on right, years on left + (if (stringp field-result) + (substring padded-result 0 desired-length) + (if (eq cur-char ?y) + (substring padded-result (- desired-length)) + padded-result))) ;non-year numbers don't truncate + (if change-case (upcase padded-result) padded-result))))) ;) + (t + (char-to-string cur-char))))) + (setq ind (1+ ind))) + result)) + ;; for `load-history'. + (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)))))))) + +(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) @@ -907,6 +1592,33 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." (list 'unwind-protect (cons 'progn body) (list 'select-window 'save-selected-window-window)))) + +;; Emacs 19.31 and later: +;; (get-buffer-window-list &optional BUFFER MINIBUF FRAME) +(defun-maybe get-buffer-window-list (buffer &optional minibuf frame) + "Return windows currently displaying BUFFER, or nil if none. +See `walk-windows' for the meaning of MINIBUF and FRAME." + (let ((buffer (if (bufferp buffer) buffer (get-buffer buffer))) windows) + (walk-windows + (function (lambda (window) + (if (eq (window-buffer window) buffer) + (setq windows (cons window windows))))) + minibuf frame) + windows)) + + +;;; @ Frame commands emulation. (lisp/frame.el) +;;; + +;; XEmacs 21.0 and later: +;; (save-selected-frame &rest BODY) +(defmacro-maybe save-selected-frame (&rest body) + "Execute forms in BODY, then restore the selected frame." + (list 'let + '((save-selected-frame-frame (selected-frame))) + (list 'unwind-protect + (cons 'progn body) + (list 'select-frame 'save-selected-frame-frame)))) ;;; @ Basic editing commands emulation. (lisp/simple.el) @@ -926,6 +1638,190 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." (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 ":" @@ -1005,6 +1901,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. ;;; @@ -1098,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)))