From 7f12f644a68cb51b4cbbb7148afd1da4f6fcc393 Mon Sep 17 00:00:00 2001 From: shuhei Date: Thu, 8 Mar 2001 13:43:30 +0000 Subject: [PATCH] Sync up to APEL 10.2. --- APEL-CFG | 6 +- ChangeLog | 125 +++++++++++- Makefile | 2 +- apel-ver.el | 5 +- emu.el | 24 +++ mcs-20.el | 1 + pces-om.el | 49 ++++- poe-18.el | 234 +++++++++++++-------- poe-xemacs.el | 44 ++++ poe.el | 634 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++- timezone.el | 13 +- 11 files changed, 1021 insertions(+), 116 deletions(-) diff --git a/APEL-CFG b/APEL-CFG index dc56510..7605343 100644 --- a/APEL-CFG +++ b/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: ;; diff --git a/ChangeLog b/ChangeLog index 5b7666c..66b879b 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,126 @@ +2000-03-01 Yuuichi Teranishi + + * APEL: Version 10.2 released. + +2000-02-29 Yuuichi Teranishi + + * poe-18.el (current-time-string): Fixed leap year's day counting bug. + +2000-02-28 Katsumi Yamaoka + + * 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 + + * emu.el (enriched-encode): Allow the 3rd argument ORIG-BUF for old + Emacsen. + +2000-02-21 Makoto Nakagawa + + * 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 + + * 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 + + * poe.el (replace-match): Redefined to add `STRING' optional + argument. + +2000-02-07 Yuuichi Teranishi + + * 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 + + * mcs-20.el (mime-charset-coding-system-alist): Add + `iso-2022-jp-3'. + +2000-02-04 Katsumi Yamaoka + + * 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 + + * 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 + + * 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 + + * poe-18.el (window-minibuffer-p): New function. + +2000-01-30 Tsukamoto Tetsuo + + * 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 + + * APEL-CFG: Typo. + +2000-01-26 Shuhei KOBAYASHI + + * 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 + + * poe-18.el (byte-code-function-p): Check if the CDR of OBJECT is + a cons cell. + + 2000-01-21 Yuuichi Teranishi * 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 diff --git a/Makefile b/Makefile index 7a7b9ff..571470f 100644 --- a/Makefile +++ b/Makefile @@ -2,7 +2,7 @@ # Makefile for APEL. # -VERSION = 10.1 +VERSION = 10.2 TAR = tar RM = /bin/rm -f diff --git a/apel-ver.el b/apel-ver.el index b8141ab..93d09ca 100644 --- a/apel-ver.el +++ b/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 () diff --git a/emu.el b/emu.el index d610c53..fce2080 100644 --- a/emu.el +++ b/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 ;;; diff --git a/mcs-20.el b/mcs-20.el index 77911a4..aa4743f 100644 --- a/mcs-20.el +++ b/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) diff --git a/pces-om.el b/pces-om.el index 788498e..7b8f99c 100644 --- a/pces-om.el +++ b/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) diff --git a/poe-18.el b/poe-18.el index edba3e0..1f5bc10 100644 --- a/poe-18.el +++ b/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. ;;; diff --git a/poe-xemacs.el b/poe-xemacs.el index 0ab7128..59e0784 100644 --- a/poe-xemacs.el +++ b/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 ;;; diff --git a/poe.el b/poe.el index 70d191a..27f53ee 100644 --- a/poe.el +++ b/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) diff --git a/timezone.el b/timezone.el index 59bb091..333bd90 100644 --- a/timezone.el +++ b/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. ;;; -- 1.7.10.4