X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=poe.el;h=2b0e3d412e74b930e103f083884e32ffa51c4cb6;hb=afac0fed5c056349dc2625e6006743506cdbcdb9;hp=115a9faacd5830f92e23ff86137788282fff0797;hpb=7fd5287cb04425b4548fc8e0a99a5d2f5f984b78;p=elisp%2Fapel.git diff --git a/poe.el b/poe.el index 115a9fa..2b0e3d4 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) @@ -689,7 +691,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. @@ -702,6 +704,50 @@ 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)) + (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 +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 +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 +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)) + ;;; Define `functionp' here because "localhook" uses it. ;; Emacs 20.1/XEmacs 20.3 (but first appeared in Epoch?): (functionp OBJECT) @@ -803,6 +849,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) @@ -1061,6 +1112,305 @@ 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. +;; 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. + +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." + (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 + (time-string (current-time-string time))) + (setq 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) + (setq change-case (not change-case)) + (downcase (cadr (current-time-zone)))) + (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 20.1/XEmacs 20.3(?) and later: (split-string STRING &optional PATTERN) ;; Here is a XEmacs version. (defun-maybe split-string (string &optional pattern) @@ -1087,6 +1437,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) @@ -1185,6 +1562,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. ;;;