Skip to content
Browse files

Sync up to APEL 10.2.

  • Loading branch information...
1 parent b4d553a commit 785df92ab7ae790e00e0546c7ea1d20deb4fb9f9 shuhei committed
Showing with 1,021 additions and 116 deletions.
  1. +3 −3 APEL-CFG
  2. +124 −1 ChangeLog
  3. +1 −1 Makefile
  4. +3 −2 apel-ver.el
  5. +24 −0 emu.el
  6. +1 −0 mcs-20.el
  7. +38 −11 pces-om.el
  8. +149 −85 poe-18.el
  9. +44 −0 poe-xemacs.el
  10. +633 −1 poe.el
  11. +1 −12 timezone.el
View
6 APEL-CFG
@@ -24,10 +24,10 @@
;; make subdirectory.
;;
;; APEL_DIR: The directory where APEL modules will be installed.
-;; Generated from LISPDIR and APEL_DIR if it is not set.
+;; Generated from LISPDIR and APEL_PREFIX if it is not set.
;; EMU_DIR: The directory where EMU modules will be installed.
-;; Generated from VERSION_SPECIFIC_LISPDIR and EMU_DIR if
-;; it is not set.
+;; Generated from VERSION_SPECIFIC_LISPDIR and EMU_PREFIX
+;; if it is not set.
;;
;; For XEmacs with package system:
;;
View
125 ChangeLog
@@ -1,3 +1,126 @@
+2000-03-01 Yuuichi Teranishi <teranisi@gohome.org>
+
+ * APEL: Version 10.2 released.
+
+2000-02-29 Yuuichi Teranishi <teranisi@gohome.org>
+
+ * poe-18.el (current-time-string): Fixed leap year's day counting bug.
+
+2000-02-28 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * emu.el (enriched-encode): Do nothing for it if FSF Emacs 19.28
+ and earlier or XEmacs 19.13 and earlier is used.
+
+2000-02-25 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * emu.el (enriched-encode): Allow the 3rd argument ORIG-BUF for old
+ Emacsen.
+
+2000-02-21 Makoto Nakagawa <Makoto.Nakagawa@jp.compaq.com>
+
+ * poe.el (format-time-string): New function for Emacs 19.28 and
+ earlier.
+ (format-time-month-list): New constant for `format-time-string'.
+ (format-time-week-list): New constant for `format-time-string'.
+
+2000-02-21 Daiki Ueno <ueno@ueda.info.waseda.ac.jp>
+
+ * poe-18.el (walk-windows): New function.
+
+ * poe-xemacs.el
+ (set-extent-properties): New function.
+ (run-at-time): New function.
+ (cancel-timer): New function.
+ (with-timeout-handler): New function.
+ (with-timeout): New function.
+
+ * poe.el (remassq): New function.
+ (remassoc): New function.
+ (remrassoc): New function.
+ (get-buffer-window-list): New function.
+ (save-selected-frame): New macro.
+
+2000-02-10 Yuuichi Teranishi <teranisi@gohome.org>
+
+ * poe.el (replace-match): Redefined to add `STRING' optional
+ argument.
+
+2000-02-07 Yuuichi Teranishi <teranisi@gohome.org>
+
+ * poe-18.el (mod): Define as an alias for `%'.
+ (overlayp, move-overlay, delete-overlay, overlay-start,
+ overlay-end, overlay-buffer, overlay-properties, overlays-at,
+ overlays-in, next-overlay-change, previous-overlay-change,
+ overlay-lists, overlay-recenter, overlay-get):
+ Define as null function.
+
+2000-02-05 MORIOKA Tomohiko <tomo@m17n.org>
+
+ * mcs-20.el (mime-charset-coding-system-alist): Add
+ `iso-2022-jp-3'.
+
+2000-02-04 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * poe.el (read-file-name): Replacement for Emacs 19.28 and earlier
+ (except for Emacs 18) or XEmacs 19.13 and earlier, for
+ compatibility.
+
+2000-02-04 Yuuichi Teranishi <teranisi@gohome.org>
+
+ * timezone.el (timezone-floor): Eliminated.
+ (timezone-fix-time-2): Use `floor' instead of `timezone-floor'.
+
+ * poe-18.el (current-time): Fixed leap year count bug.
+ (set-time-zone-rule): New function.
+ (current-time-zone): Use `set-time-zone-rule'.
+ (floor): New function.
+ (window-live-p): New function.
+ (read-from-minibuffer): Redefined to add `HIST' optional argument.
+ (accept-process-output): Redefined to add `TIMEOUT' and
+ `TIMEOUT-MSECS' optional arguments.
+ (get-buffer-window): Redefined to add `FRAME' optional argument.
+
+ * poe.el (completing-read): Redefined to adjust optional arguments
+ for some emacsen.
+
+2000-01-31 Mikio Nakajima <minakaji@osaka.email.ne.jp>
+
+ * poe-18.el (auto-fill-function): Declare with defvar-maybe.
+ (unread-command-event): Ditto.
+ (unread-command-events): Ditto.
+ (insert-and-inherit): Define with defalias.
+ (insert-before-markers-and-inherit): Ditto.
+ (number-to-string): Ditto.
+
+2000-01-30 Mikio Nakajima <minakaji@osaka.email.ne.jp>
+
+ * poe-18.el (window-minibuffer-p): New function.
+
+2000-01-30 Tsukamoto Tetsuo <czkmt@remus.dti.ne.jp>
+
+ * pces-om.el (insert-file-contents-as-coding-system): Ignore BEG,
+ END and REPLACE under Emacs 18, or Mule 1.1 or earlier.
+ (insert-file-contents-as-binary): Ditto.
+
+2000-01-27 Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
+
+ * APEL-CFG: Typo.
+
+2000-01-26 Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
+
+ * poe-18.el (set-match-data): New alias for `store-match-data'.
+ (save-match-data-internal): New variable.
+ (save-match-data): New macro; use above.
+
+ (defalias): Docstring sync.
+ (put-text-property): Typo.
+
+2000-01-23 Tsukamoto Tetsuo <czkmt@remus.dti.ne.jp>
+
+ * poe-18.el (byte-code-function-p): Check if the CDR of OBJECT is
+ a cons cell.
+
+
2000-01-21 Yuuichi Teranishi <teranisi@gohome.org>
* APEL: Version 10.1 released.
@@ -2473,7 +2596,7 @@
* APEL: Version 8.4 was released.
- * EMU-ELS: Don't use HIRAGANA LETTER A ($(B$"(B) to detect character
+ * EMU-ELS: Don't use HIRAGANA LETTER A ($B$"(B) to detect character
indexing (Emacs 20.3 or later).
1998-04-20 MORIOKA Tomohiko <morioka@jaist.ac.jp>
View
2 Makefile
@@ -2,7 +2,7 @@
# Makefile for APEL.
#
-VERSION = 10.1
+VERSION = 10.2
TAR = tar
RM = /bin/rm -f
View
5 apel-ver.el
@@ -38,8 +38,9 @@
(product-provide 'apel-ver
;; (product-define "APEL" nil '(9 23)) ; comment.
;; (product-define "APEL" nil '(10 0)) ; Released 24 December 1999
- (product-define "APEL" nil '(10 1)) ; Released 20 January 2000
- ;; (product-define "APEL" nil '(10 2)) ;
+ ;; (product-define "APEL" nil '(10 1)) ; Released 20 January 2000
+ (product-define "APEL" nil '(10 2)) ; Released 01 March 2000
+ ;; (product-define "APEL" nil '(10 3))
)
(defun apel-version ()
View
24 emu.el
@@ -223,6 +223,30 @@ find-file-hooks, etc.
(autoload 'enriched-decode "tinyrich")
))
+(if (or (and (eq emacs-major-version 19)
+ (>= emacs-minor-version (if (featurep 'xemacs) 14 29)))
+ (and (eq emacs-major-version 20)
+ (< emacs-minor-version (if (featurep 'xemacs) 3 1))))
+ (eval-after-load "enriched"
+ '(if (fboundp 'si:enriched-encode)
+ nil
+ (fset 'si:enriched-encode (symbol-function 'enriched-encode))
+ (defun enriched-encode (from to &optional orig-buf)
+ (let* ((si:enriched-initial-annotation enriched-initial-annotation)
+ (enriched-initial-annotation
+ (if (stringp si:enriched-initial-annotation)
+ si:enriched-initial-annotation
+ (function
+ (lambda ()
+ (save-excursion
+ ;; Eval this in the buffer we are annotating. This
+ ;; fixes a bug which was saving incorrect File-Width
+ ;; information, since we were looking at local
+ ;; variables in the wrong buffer.
+ (if orig-buf (set-buffer orig-buf))
+ (funcall si:enriched-initial-annotation)))))))
+ (si::enriched-encode from to))))))
+
;;; @ end
;;;
View
1 mcs-20.el
@@ -43,6 +43,7 @@
(gb2312 . cn-gb-2312)
(cn-gb . cn-gb-2312)
(iso-2022-jp-2 . iso-2022-7bit-ss2)
+ (iso-2022-jp-3 . iso-2022-7bit-ss2)
(tis-620 . tis620)
(windows-874 . tis-620)
(cp874 . tis-620)
View
49 pces-om.el
@@ -160,12 +160,23 @@
;;; @ with code-conversion
;;;
-(defun insert-file-contents-as-coding-system
- (coding-system filename &optional visit beg end replace)
- "Like `insert-file-contents', q.v., but CODING-SYSTEM the first arg will
+(cond
+ ((and (>= emacs-major-version 19) (>= emacs-minor-version 23))
+ ;; Mule 2.0 or later.
+ (defun insert-file-contents-as-coding-system
+ (coding-system filename &optional visit beg end replace)
+ "Like `insert-file-contents', q.v., but CODING-SYSTEM the first arg will
+be applied to `file-coding-system-for-read'."
+ (let ((file-coding-system-for-read coding-system))
+ (insert-file-contents filename visit beg end replace))))
+ (t
+ ;; Mule 1.1 or earlier.
+ (defun insert-file-contents-as-coding-system
+ (coding-system filename &optional visit beg end replace)
+ "Like `insert-file-contents', q.v., but CODING-SYSTEM the first arg will
be applied to `file-coding-system-for-read'."
- (let ((file-coding-system-for-read coding-system))
- (insert-file-contents filename visit beg end replace)))
+ (let ((file-coding-system-for-read coding-system))
+ (insert-file-contents filename visit)))))
(cond
((and (>= emacs-major-version 19) (>= emacs-minor-version 29))
@@ -237,17 +248,33 @@ applied to `coding-system-for-write'."
(defalias 'set-process-input-coding-system 'set-process-coding-system)
-(defun insert-file-contents-as-binary (filename
- &optional visit beg end replace)
- "Like `insert-file-contents', q.v., but don't code and format conversion.
+(cond
+ ((and (>= emacs-major-version 19) (>= emacs-minor-version 23))
+ ;; Mule 2.0 or later.
+ (defun insert-file-contents-as-binary (filename
+ &optional visit beg end replace)
+ "Like `insert-file-contents', q.v., but don't code and format conversion.
+Like `insert-file-contents-literary', but it allows find-file-hooks,
+automatic uncompression, etc.
+
+Namely this function ensures that only format decoding and character
+code conversion will not take place."
+ (as-binary-input-file
+ ;; Returns list absolute file name and length of data inserted.
+ (insert-file-contents filename visit beg end replace))))
+ (t
+ ;; Mule 1.1 or earlier.
+ (defun insert-file-contents-as-binary (filename
+ &optional visit beg end replace)
+ "Like `insert-file-contents', q.v., but don't code and format conversion.
Like `insert-file-contents-literary', but it allows find-file-hooks,
automatic uncompression, etc.
Namely this function ensures that only format decoding and character
code conversion will not take place."
- (as-binary-input-file
- ;; Returns list absolute file name and length of data inserted.
- (insert-file-contents filename visit beg end replace)))
+ (as-binary-input-file
+ ;; Returns list absolute file name and length of data inserted.
+ (insert-file-contents filename visit)))))
(defun insert-file-contents-as-raw-text (filename
&optional visit beg end replace)
View
234 poe-18.el
@@ -52,13 +52,12 @@
;;;
(defun defalias (sym newdef)
- "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.
-Associates the function with the current load file, if any."
+ "Set SYMBOL's function definition to NEWVAL, and return NEWVAL."
(fset sym newdef))
(defun byte-code-function-p (object)
"Return t if OBJECT is a byte-compiled function object."
- (and (consp object)
+ (and (consp object) (consp (cdr object))
(let ((rest (cdr (cdr object)))
elt)
(if (stringp (car rest))
@@ -228,11 +227,31 @@ for this variable."
("GMT-8" . -800)("GMT-9" . -900)("GMT-10" . -1000)
("GMT-11" . -1100) ("GMT-12" . -1200))
"Time differentials of timezone from GMT in +-HHMM form.
-Used in `current-time-zone' (Emacs 19 emulating function in poe-18.el).")
+Used in `current-time-zone'.")
(defvar current-time-local-timezone nil
"*Local timezone name.
-Used in `current-time-zone' (Emacs 19 emulating function in poe-18.el).")
+Used in `current-time-zone'.")
+
+(defun set-time-zone-rule (tz)
+ "Set the local time zone using TZ, a string specifying a time zone rule.
+If TZ is nil, use implementation-defined default time zone information.
+If TZ is t, use Universal Time."
+ (cond
+ ((stringp tz)
+ (setq current-time-local-timezone tz))
+ (tz
+ (setq current-time-local-timezone "GMT"))
+ (t
+ (setq current-time-local-timezone
+ (with-temp-buffer
+ ;; We use `date' command to get timezone information.
+ (call-process "date" nil (current-buffer) t)
+ (goto-char (point-min))
+ (if (looking-at
+ "^.*\\([A-Z][A-Z][A-Z]\\([^ \n\t]*\\)\\).*$")
+ (buffer-substring (match-beginning 1)
+ (match-end 1))))))))
(defun current-time-zone (&optional specified-time)
"Return the offset and name for the local time zone.
@@ -244,16 +263,10 @@ Optional argument SPECIFIED-TIME is ignored in this implementation.
Some operating systems cannot provide all this information to Emacs;
in this case, `current-time-zone' returns a list containing nil for
the data it can't find."
- (let ((local-timezone
- (or current-time-local-timezone
- (setq current-time-local-timezone
- (with-temp-buffer
- (call-process "date" nil (current-buffer) t)
- (goto-char (point-min))
- (if (looking-at
- "^.*\\([A-Z][A-Z][A-Z]\\([^ \n\t]*\\)\\).*$")
- (buffer-substring (match-beginning 1)
- (match-end 1)))))))
+ (let ((local-timezone (or current-time-local-timezone
+ (progn
+ (set-time-zone-rule nil)
+ current-time-local-timezone)))
timezone abszone seconds)
(setq timezone
(or (cdr (assoc (upcase local-timezone)
@@ -345,10 +358,8 @@ and from `file-attributes'."
(setq lyear (and (zerop (% yyyy 4))
(or (not (zerop (% yyyy 100)))
(zerop (% yyyy 400)))))
- (while (> (- dd (nth mm mdays)) 0)
- (if (and (= mm 1) lyear)
- (setq dd (- dd 29))
- (setq dd (- dd (nth mm mdays))))
+ (while (> (- dd (if (and lyear (= mm 1)) 29 (nth mm mdays))) 0)
+ (setq dd (- dd (if (and lyear (= mm 1)) 29 (nth mm mdays))))
(setq mm (1+ mm)))
(setq HH (/ low 3600)
low (% low 3600)
@@ -392,8 +403,9 @@ resolution finer than a second."
(while (> ct2 65535)
(setq ct1 (1+ ct1)
ct2 (- ct2 65536))))
- (setq uru (- (+ (- (/ yyyy 4) (/ yyyy 100))
- (/ yyyy 400)) 477))
+ (setq year (- yyyy 1))
+ (setq uru (- (+ (- (/ year 4) (/ year 100))
+ (/ year 400)) 477))
(while (> uru 0)
(setq uru (1- uru)
i1 (1+ i1)
@@ -447,6 +459,16 @@ resolution finer than a second."
"Return the absolute value of ARG."
(if (< arg 0) (- arg) arg))
+(defun floor (arg &optional divisor)
+ "Return the largest integer no grater than ARG.
+With optional DIVISOR, return the largest integer no greater than ARG/DIVISOR."
+ (if (null divisor)
+ (setq divisor 1))
+ (if (< arg 0)
+ (- (/ (- divisor 1 arg) divisor))
+ (/ arg divisor)))
+
+(defalias 'mod '%)
;;; @ Basic lisp subroutines.
;;;
@@ -476,16 +498,32 @@ With optional non-nil ALL, force redisplay of all mode-lines."
(if all (save-excursion (set-buffer (other-buffer))))
(set-buffer-modified-p (buffer-modified-p)))
-;; (defalias 'save-match-data 'store-match-data)
+(defalias 'set-match-data 'store-match-data)
+
+(defvar save-match-data-internal)
+
+;; We use save-match-data-internal as the local variable because
+;; that works ok in practice (people should not use that variable elsewhere).
+(defmacro save-match-data (&rest body)
+ "Execute the BODY forms, restoring the global value of the match data."
+ (` (let ((save-match-data-internal (match-data)))
+ (unwind-protect (progn (,@ body))
+ (set-match-data save-match-data-internal)))))
;;; @ Basic editing commands.
;;;
-;; 18.55 does not have this variable.
+;; 18.55 does not have these variables.
(defvar buffer-undo-list nil)
+(defvar auto-fill-function nil)
+(defvar unread-command-event nil)
+(defvar unread-command-events nil)
(defalias 'buffer-disable-undo 'buffer-flush-undo)
+(defalias 'insert-and-inherit 'insert)
+(defalias 'insert-before-markers-and-inherit 'insert-before-markers)
+(defalias 'number-to-string 'int-to-string)
(defun generate-new-buffer-name (name &optional ignore)
"Return a string that is the name of no existing buffer based on NAME.
@@ -507,6 +545,65 @@ even if a buffer with that name exists."
(defun mark (&optional force)
(si:mark))
+(defun window-minibuffer-p (&optional window)
+"Return non-nil if WINDOW is a minibuffer window."
+ (eq (or window (selected-window)) (minibuffer-window)))
+
+(defun window-live-p (object)
+ "Returns t if OBJECT is a window which is currently visible."
+ (and (windowp object)
+ (or (eq object (minibuffer-window))
+ (eq object (get-buffer-window (window-buffer object))))))
+
+;; Add optinal argument `hist'
+(or (fboundp 'si:read-from-minibuffer)
+ (progn
+ (fset 'si:read-from-minibuffer (symbol-function 'read-from-minibuffer))
+ (defun read-from-minibuffer (prompt &optional
+ initial-contents keymap read hist)
+
+ "Read a string from the minibuffer, prompting with string PROMPT.
+If optional second arg INITIAL-CONTENTS is non-nil, it is a string
+to be inserted into the minibuffer before reading input.
+If INITIAL-CONTENTS is (STRING . POSITION), the initial input
+is STRING, but point is placed at position POSITION in the minibuffer.
+Third arg KEYMAP is a keymap to use whilst reading;
+if omitted or nil, the default is `minibuffer-local-map'.
+If fourth arg READ is non-nil, then interpret the result as a lisp object
+and return that object:
+in other words, do `(car (read-from-string INPUT-STRING))'
+Fifth arg HIST is ignored in this implementatin."
+ (si:read-from-minibuffer prompt initial-contents keymap read))))
+
+;; Add optional argument `frame'.
+(or (fboundp 'si:get-buffer-window)
+ (progn
+ (fset 'si:get-buffer-window (symbol-function 'get-buffer-window))
+ (defun get-buffer-window (buffer &optional frame)
+ "Return a window currently displaying BUFFER, or nil if none.
+Optional argunemt FRAME is ignored in this implementation."
+ (si:get-buffer-window buffer))))
+
+(defun-maybe walk-windows (proc &optional minibuf all-frames)
+ "Cycle through all visible windows, calling PROC for each one.
+PROC is called with a window as argument.
+
+Optional second arg MINIBUF t means count the minibuffer window even
+if not active. MINIBUF nil or omitted means count the minibuffer iff
+it is active. MINIBUF neither t nor nil means not to count the
+minibuffer even if it is active.
+Optional third argunemt ALL-FRAMES is ignored in this implementation."
+ (if (window-minibuffer-p (selected-window))
+ (setq minibuf t))
+ (let* ((walk-windows-start (selected-window))
+ (walk-windows-current walk-windows-start))
+ (unwind-protect
+ (while (progn
+ (setq walk-windows-current
+ (next-window walk-windows-current minibuf))
+ (funcall proc walk-windows-current)
+ (not (eq walk-windows-current walk-windows-start))))
+ (select-window walk-windows-start))))
;;; @@ Environment variables.
;;;
@@ -600,6 +697,19 @@ If MATCH is non-nil, mention only file names that match the regexp MATCH.
If NOSORT is dummy for compatibility."
(si:directory-files directory full match))
+;;; @ Process.
+;;;
+(or (fboundp 'si:accept-process-output)
+ (progn
+ (fset 'si:accept-process-output (symbol-function 'accept-process-output))
+ (defun accept-process-output (&optional process timeout timeout-msecs)
+ "Allow any pending output from subprocesses to be read by Emacs.
+It is read into the process' buffers or given to their filter functions.
+Non-nil arg PROCESS means do not return until some output has been received
+ from PROCESS. Nil arg PROCESS means do not return until some output has
+ been received from any process.
+TIMEOUT and TIMEOUT-MSECS are ignored in this implementation."
+ (si:accept-process-output process))))
;;; @ Text property.
;;;
@@ -613,7 +723,7 @@ If NOSORT is dummy for compatibility."
(defun previous-property-change (position &optional object limit))
(defun previous-single-property-change (position prop &optional object limit))
(defun add-text-properties (start end properties &optional object))
-(defun put-text-properties (start end property &optional object))
+(defun put-text-property (start end property value &optional object))
(defun set-text-properties (start end properties &optional object))
(defun remove-text-properties (start end properties &optional object))
(defun text-property-any (start end property value &optional object))
@@ -629,68 +739,22 @@ If NOSORT is dummy for compatibility."
;;; @ Overlay.
;;;
-(cond
- ((boundp 'NEMACS)
- (defvar emu:available-face-attribute-alist
- '(
- ;;(bold . inversed-region)
- (italic . underlined-region)
- (underline . underlined-region)))
-
- ;; by YAMATE Keiichirou 1994/10/28
- (defun attribute-add-narrow-attribute (attr from to)
- (or (consp (symbol-value attr))
- (set attr (list 1)))
- (let* ((attr-value (symbol-value attr))
- (len (car attr-value))
- (posfrom 1)
- posto)
- (while (and (< posfrom len)
- (> from (nth posfrom attr-value)))
- (setq posfrom (1+ posfrom)))
- (setq posto posfrom)
- (while (and (< posto len)
- (> to (nth posto attr-value)))
- (setq posto (1+ posto)))
- (if (= posto posfrom)
- (if (= (% posto 2) 1)
- (if (and (< to len)
- (= to (nth posto attr-value)))
- (set-marker (nth posto attr-value) from)
- (setcdr (nthcdr (1- posfrom) attr-value)
- (cons (set-marker-type (set-marker (make-marker)
- from)
- 'point-type)
- (cons (set-marker-type
- (set-marker (make-marker)
- to)
- nil)
- (nthcdr posto attr-value))))
- (setcar attr-value (+ len 2))))
- (if (= (% posfrom 2) 0)
- (setq posfrom (1- posfrom))
- (set-marker (nth posfrom attr-value) from))
- (if (= (% posto 2) 0)
- nil
- (setq posto (1- posto))
- (set-marker (nth posto attr-value) to))
- (setcdr (nthcdr posfrom attr-value)
- (nthcdr posto attr-value)))))
-
- (defalias 'make-overlay 'cons)
-
- (defun overlay-put (overlay prop value)
- (let ((ret (and (eq prop 'face)
- (assq value emu:available-face-attribute-alist))))
- (if ret
- (attribute-add-narrow-attribute (cdr ret)
- (car overlay)(cdr overlay))))))
- (t
- (defun make-overlay (beg end &optional buffer type))
- (defun overlay-put (overlay prop value))))
-
+(defun overlayp (object))
+(defun make-overlay (beg end &optional buffer front-advance rear-advance))
+(defun move-overlay (overlay beg end &optional buffer))
+(defun delete-overlay (overlay))
+(defun overlay-start (overlay))
+(defun overlay-end (overlay))
(defun overlay-buffer (overlay))
-
+(defun overlay-properties (overlay))
+(defun overlays-at (pos))
+(defun overlays-in (beg end))
+(defun next-overlay-change (pos))
+(defun previous-overlay-change (pos))
+(defun overlay-lists ())
+(defun overlay-recenter (pos))
+(defun overlay-get (overlay prop))
+(defun overlay-put (overlay prop value))
;;; @ End.
;;;
View
44 poe-xemacs.el
@@ -78,6 +78,39 @@ When called interactively, prompt for the name of the color to use."
(switch-to-buffer-other-frame (dired-noselect dirname switches)))
+;;; @ timer
+;;;
+
+(condition-case nil
+ (require 'timer)
+ (error
+ (require 'itimer)
+ (defun-maybe run-at-time (time repeat function &rest args)
+ (start-itimer (make-temp-name "rat")
+ `(lambda ()
+ (,function ,@args))
+ time repeat))
+ (defalias 'cancel-timer 'delete-itimer)
+ (defun with-timeout-handler (tag)
+ (throw tag 'timeout))
+ (defmacro-maybe with-timeout (list &rest body)
+ (let ((seconds (car list))
+ (timeout-forms (cdr list)))
+ `(let ((with-timeout-tag (cons nil nil))
+ with-timeout-value with-timeout-timer)
+ (if (catch with-timeout-tag
+ (progn
+ (setq with-timeout-timer
+ (run-at-time ,seconds nil
+ 'with-timeout-handler
+ with-timeout-tag))
+ (setq with-timeout-value (progn . ,body))
+ nil))
+ (progn . ,timeout-forms)
+ (cancel-timer with-timeout-timer)
+ with-timeout-value))))))
+
+
;;; @ to avoid bug of XEmacs 19.14
;;;
@@ -105,6 +138,17 @@ When called interactively, prompt for the name of the color to use."
(defalias-maybe 'line-beginning-position 'point-at-bol)
(defalias-maybe 'line-end-position 'point-at-eol)
+;;; @ XEmacs 21 emulation
+;;;
+
+;; XEmacs 20.5 and later: (set-extent-properties EXTENT PLIST)
+(defun-maybe set-extent-properties (extent plist)
+ "Change some properties of EXTENT.
+PLIST is a property list.
+For a list of built-in properties, see `set-extent-property'."
+ (while plist
+ (set-extent-property extent (car plist) (cadr plist))
+ (setq plist (cddr plist))))
;;; @ end
;;;
View
634 poe.el
@@ -178,6 +178,99 @@ The third arg HISTORY, is dummy for compatibility.
See `read-from-minibuffer' for details of HISTORY argument."
(si:read-string prompt initial-input)))))
+;; (completing-read prompt table &optional
+;; FSF Emacs
+;; --19.7 : predicate require-match init
+;; 19.7 --19.34 : predicate require-match init hist
+;; 20.1 -- : predicate require-match init hist def inherit-input-method
+;; XEmacs
+;; --19.(?): predicate require-match init
+;; --21.2 : predicate require-match init hist
+;; 21.2 -- : predicate require-match init hist def
+;; )
+
+;; We support following API.
+;; (completing-read prompt table
+;; &optional predicate require-match init hist def)
+(static-cond
+ ;; add 'hist' and 'def' argument.
+ ((< emacs-major-version 19)
+ (or (fboundp 'si:completing-read)
+ (progn
+ (fset 'si:completing-read (symbol-function 'completing-read))
+ (defun completing-read
+ (prompt table &optional predicate require-match init
+ hist def)
+ "Read a string in the minibuffer, with completion.
+PROMPT is a string to prompt with; normally it ends in a colon and a space.
+TABLE is an alist whose elements' cars are strings, or an obarray.
+PREDICATE limits completion to a subset of TABLE.
+See `try-completion' and `all-completions' for more details
+ on completion, TABLE, and PREDICATE.
+
+If REQUIRE-MATCH is non-nil, the user is not allowed to exit unless
+ the input is (or completes to) an element of TABLE or is null.
+ If it is also not t, Return does not exit if it does non-null completion.
+If the input is null, `completing-read' returns an empty string,
+ regardless of the value of REQUIRE-MATCH.
+
+If INIT is non-nil, insert it in the minibuffer initially.
+ If it is (STRING . POSITION), the initial input
+ is STRING, but point is placed POSITION characters into the string.
+HIST is ignored in this implementation.
+DEF, if non-nil, is the default value.
+
+Completion ignores case if the ambient value of
+ `completion-ignore-case' is non-nil."
+ (let ((string (si:completing-read prompt table predicate
+ require-match init)))
+ (if (and (string= string "") def)
+ def string))))))
+ ;; add 'def' argument.
+ ((or (and (featurep 'xemacs)
+ (or (and (eq emacs-major-version 21)
+ (< emacs-minor-version 2))
+ (< emacs-major-version 21)))
+ (< emacs-major-version 20))
+ (or (fboundp 'si:completing-read)
+ (progn
+ (fset 'si:completing-read (symbol-function 'completing-read))
+ (defun completing-read
+ (prompt table &optional predicate require-match init
+ hist def)
+ "Read a string in the minibuffer, with completion.
+PROMPT is a string to prompt with; normally it ends in a colon and a space.
+TABLE is an alist whose elements' cars are strings, or an obarray.
+PREDICATE limits completion to a subset of TABLE.
+See `try-completion' and `all-completions' for more details
+ on completion, TABLE, and PREDICATE.
+
+If REQUIRE-MATCH is non-nil, the user is not allowed to exit unless
+ the input is (or completes to) an element of TABLE or is null.
+ If it is also not t, Return does not exit if it does non-null completion.
+If the input is null, `completing-read' returns an empty string,
+ regardless of the value of REQUIRE-MATCH.
+
+If INIT is non-nil, insert it in the minibuffer initially.
+ If it is (STRING . POSITION), the initial input
+ is STRING, but point is placed POSITION characters into the string.
+HIST, if non-nil, specifies a history list
+ and optionally the initial position in the list.
+ It can be a symbol, which is the history list variable to use,
+ or it can be a cons cell (HISTVAR . HISTPOS).
+ In that case, HISTVAR is the history list variable to use,
+ and HISTPOS is the initial position (the position in the list
+ which INIT corresponds to).
+ Positions are counted starting from 1 at the beginning of the list.
+DEF, if non-nil, is the default value.
+
+Completion ignores case if the ambient value of
+ `completion-ignore-case' is non-nil."
+ (let ((string (si:completing-read prompt table predicate
+ require-match init hist)))
+ (if (and (string= string "") def)
+ def string)))))))
+
;; v18: (string-to-int STRING)
;; v19: (string-to-number STRING)
;; v20: (string-to-number STRING &optional BASE)
@@ -428,6 +521,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)
@@ -530,7 +689,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.
@@ -543,6 +702,39 @@ 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
+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
+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))
+
;;; Define `functionp' here because "localhook" uses it.
;; Emacs 20.1/XEmacs 20.3 (but first appeared in Epoch?): (functionp OBJECT)
@@ -788,6 +980,419 @@ 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 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)
+;; 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)
+ (substring time-string 8 10))
+ ;; a synonym for `%m/%d/%y'
+ ((eq cur-char ?D)
+ (format "%02d/%s/%s"
+ (cddr (assoc (substring time-string 4 7)
+ format-time-month-list))
+ (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)
@@ -814,6 +1419,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)
View
13 timezone.el
@@ -409,7 +409,7 @@ If TIMEZONE is nil, use the local time zone."
(diff (- (timezone-zone-to-minute timezone)
(timezone-zone-to-minute local)))
(minute (+ minute diff))
- (hour-fix (timezone-floor minute 60)))
+ (hour-fix (floor minute 60)))
(setq hour (+ hour hour-fix))
(setq minute (- minute (* 60 hour-fix)))
;; HOUR may be larger than 24 or smaller than 0.
@@ -487,17 +487,6 @@ The Gregorian date Sunday, December 31, 1 BC is imaginary."
(- (/ (1- year) 100));; - century years
(/ (1- year) 400)));; + Gregorian leap years
-(defun timezone-floor (n &optional divisor)
- "Return the largest integer no grater than N.
-With optional DIVISOR, return the largest integer no greater than ARG/DIVISOR."
- (if (fboundp 'floor)
- (floor n divisor)
- (if (null divisor)
- (setq divisor 1))
- (if (< n 0)
- (- (/ (- divisor 1 n) divisor))
- (/ n divisor))))
-
;;; @ End.
;;;

0 comments on commit 785df92

Please sign in to comment.
Something went wrong with that request. Please try again.