1 | ;;; poe.el --- Portable Outfit for Emacsen |
---|
2 | |
---|
3 | ;; Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc. |
---|
4 | |
---|
5 | ;; Author: MORIOKA Tomohiko <tomo@m17n.org> |
---|
6 | ;; Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp> |
---|
7 | ;; Keywords: emulation, compatibility, Nemacs, MULE, Emacs/mule, XEmacs |
---|
8 | |
---|
9 | ;; This file is part of APEL (A Portable Emacs Library). |
---|
10 | |
---|
11 | ;; This program is free software; you can redistribute it and/or |
---|
12 | ;; modify it under the terms of the GNU General Public License as |
---|
13 | ;; published by the Free Software Foundation; either version 2, or (at |
---|
14 | ;; your option) any later version. |
---|
15 | |
---|
16 | ;; This program is distributed in the hope that it will be useful, but |
---|
17 | ;; WITHOUT ANY WARRANTY; without even the implied warranty of |
---|
18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
---|
19 | ;; General Public License for more details. |
---|
20 | |
---|
21 | ;; You should have received a copy of the GNU General Public License |
---|
22 | ;; along with GNU Emacs; see the file COPYING. If not, write to the |
---|
23 | ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, |
---|
24 | ;; Boston, MA 02111-1307, USA. |
---|
25 | |
---|
26 | ;;; Commentary: |
---|
27 | |
---|
28 | ;;; Code: |
---|
29 | |
---|
30 | (require 'product) |
---|
31 | (product-provide (provide 'poe) (require 'apel-ver)) |
---|
32 | |
---|
33 | (require 'pym) |
---|
34 | |
---|
35 | |
---|
36 | ;;; @ Version information. |
---|
37 | ;;; |
---|
38 | |
---|
39 | (static-when (= emacs-major-version 18) |
---|
40 | (require 'poe-18)) |
---|
41 | |
---|
42 | ;; Some ancient version of XEmacs did not provide 'xemacs. |
---|
43 | (static-when (string-match "XEmacs" emacs-version) |
---|
44 | (provide 'xemacs)) |
---|
45 | |
---|
46 | ;; `file-coding' was appeared in the spring of 1998, just before XEmacs |
---|
47 | ;; 21.0. Therefore it is not provided in XEmacs with MULE versions 20.4 |
---|
48 | ;; or earlier. |
---|
49 | (static-when (featurep 'xemacs) |
---|
50 | ;; must be load-time check to share .elc between w/ MULE and w/o MULE. |
---|
51 | (when (featurep 'mule) |
---|
52 | (provide 'file-coding))) |
---|
53 | |
---|
54 | (static-when (featurep 'xemacs) |
---|
55 | (require 'poe-xemacs)) |
---|
56 | |
---|
57 | ;; must be load-time check to share .elc between different systems. |
---|
58 | (or (fboundp 'open-network-stream) |
---|
59 | (require 'tcp)) |
---|
60 | |
---|
61 | |
---|
62 | ;;; @ C primitives emulation. |
---|
63 | ;;; |
---|
64 | |
---|
65 | ;; Emacs 20.3 and earlier: (require FEATURE &optional FILENAME) |
---|
66 | ;; Emacs 20.4 and later: (require FEATURE &optional FILENAME NOERROR) |
---|
67 | (static-condition-case nil |
---|
68 | ;; compile-time check. |
---|
69 | (progn |
---|
70 | (require 'nofeature "nofile" 'noerror) |
---|
71 | (if (get 'require 'defun-maybe) |
---|
72 | (error "`require' is already redefined"))) |
---|
73 | (error |
---|
74 | ;; load-time check. |
---|
75 | (or (fboundp 'si:require) |
---|
76 | (progn |
---|
77 | (fset 'si:require (symbol-function 'require)) |
---|
78 | (defun require (feature &optional filename noerror) |
---|
79 | "\ |
---|
80 | If feature FEATURE is not loaded, load it from FILENAME. |
---|
81 | If FEATURE is not a member of the list `features', then the feature |
---|
82 | is not loaded; so load the file FILENAME. |
---|
83 | If FILENAME is omitted, the printname of FEATURE is used as the file name, |
---|
84 | but in this case `load' insists on adding the suffix `.el' or `.elc'. |
---|
85 | If the optional third argument NOERROR is non-nil, |
---|
86 | then return nil if the file is not found. |
---|
87 | Normally the return value is FEATURE." |
---|
88 | (if noerror |
---|
89 | (condition-case nil |
---|
90 | (si:require feature filename) |
---|
91 | (file-error)) |
---|
92 | (si:require feature filename))) |
---|
93 | ;; for `load-history'. |
---|
94 | (setq current-load-list (cons 'require current-load-list)) |
---|
95 | (put 'require 'defun-maybe t))))) |
---|
96 | |
---|
97 | ;; Emacs 19.29 and later: (plist-get PLIST PROP) |
---|
98 | ;; (defun-maybe plist-get (plist prop) |
---|
99 | ;; (while (and plist |
---|
100 | ;; (not (eq (car plist) prop))) |
---|
101 | ;; (setq plist (cdr (cdr plist)))) |
---|
102 | ;; (car (cdr plist))) |
---|
103 | (static-unless (and (fboundp 'plist-get) |
---|
104 | (not (get 'plist-get 'defun-maybe))) |
---|
105 | (or (fboundp 'plist-get) |
---|
106 | (progn |
---|
107 | (defvar plist-get-internal-symbol) |
---|
108 | (defun plist-get (plist prop) |
---|
109 | "\ |
---|
110 | Extract a value from a property list. |
---|
111 | PLIST is a property list, which is a list of the form |
---|
112 | \(PROP1 VALUE1 PROP2 VALUE2...\). This function returns the value |
---|
113 | corresponding to the given PROP, or nil if PROP is not |
---|
114 | one of the properties on the list." |
---|
115 | (setplist 'plist-get-internal-symbol plist) |
---|
116 | (get 'plist-get-internal-symbol prop)) |
---|
117 | ;; for `load-history'. |
---|
118 | (setq current-load-list (cons 'plist-get current-load-list)) |
---|
119 | (put 'plist-get 'defun-maybe t)))) |
---|
120 | |
---|
121 | ;; Emacs 19.29 and later: (plist-put PLIST PROP VAL) |
---|
122 | ;; (defun-maybe plist-put (plist prop val) |
---|
123 | ;; (catch 'found |
---|
124 | ;; (let ((tail plist) |
---|
125 | ;; (prev nil)) |
---|
126 | ;; (while (and tail (cdr tail)) |
---|
127 | ;; (if (eq (car tail) prop) |
---|
128 | ;; (progn |
---|
129 | ;; (setcar (cdr tail) val) |
---|
130 | ;; (throw 'found plist)) |
---|
131 | ;; (setq prev tail |
---|
132 | ;; tail (cdr (cdr tail))))) |
---|
133 | ;; (if prev |
---|
134 | ;; (progn |
---|
135 | ;; (setcdr (cdr prev) (list prop val)) |
---|
136 | ;; plist) |
---|
137 | ;; (list prop val))))) |
---|
138 | (static-unless (and (fboundp 'plist-put) |
---|
139 | (not (get 'plist-put 'defun-maybe))) |
---|
140 | (or (fboundp 'plist-put) |
---|
141 | (progn |
---|
142 | (defvar plist-put-internal-symbol) |
---|
143 | (defun plist-put (plist prop val) |
---|
144 | "\ |
---|
145 | Change value in PLIST of PROP to VAL. |
---|
146 | PLIST is a property list, which is a list of the form |
---|
147 | \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol and VAL is any object. |
---|
148 | If PROP is already a property on the list, its value is set to VAL, |
---|
149 | otherwise the new PROP VAL pair is added. The new plist is returned; |
---|
150 | use `\(setq x \(plist-put x prop val\)\)' to be sure to use the new value. |
---|
151 | The PLIST is modified by side effects." |
---|
152 | (setplist 'plist-put-internal-symbol plist) |
---|
153 | (put 'plist-put-internal-symbol prop val) |
---|
154 | (symbol-plist 'plist-put-internal-symbol)) |
---|
155 | ;; for `load-history'. |
---|
156 | (setq current-load-list (cons 'plist-put current-load-list)) |
---|
157 | (put 'plist-put 'defun-maybe t)))) |
---|
158 | |
---|
159 | ;; Emacs 19.23 and later: (minibuffer-prompt-width) |
---|
160 | (defun-maybe minibuffer-prompt-width () |
---|
161 | "Return the display width of the minibuffer prompt." |
---|
162 | (save-excursion |
---|
163 | (set-buffer (window-buffer (minibuffer-window))) |
---|
164 | (current-column))) |
---|
165 | |
---|
166 | ;; (read-string PROMPT &optional INITIAL-INPUT HISTORY) |
---|
167 | ;; Emacs 19.29/XEmacs 19.14(?) and later takes optional 3rd arg HISTORY. |
---|
168 | (static-unless (or (featurep 'xemacs) |
---|
169 | (>= emacs-major-version 20) |
---|
170 | (and (= emacs-major-version 19) |
---|
171 | (>= emacs-minor-version 29))) |
---|
172 | (or (fboundp 'si:read-string) |
---|
173 | (progn |
---|
174 | (fset 'si:read-string (symbol-function 'read-string)) |
---|
175 | (defun read-string (prompt &optional initial-input history) |
---|
176 | "\ |
---|
177 | Read a string from the minibuffer, prompting with string PROMPT. |
---|
178 | If non-nil, second arg INITIAL-INPUT is a string to insert before reading. |
---|
179 | The third arg HISTORY, is dummy for compatibility. |
---|
180 | See `read-from-minibuffer' for details of HISTORY argument." |
---|
181 | (si:read-string prompt initial-input))))) |
---|
182 | |
---|
183 | ;; (completing-read prompt table &optional |
---|
184 | ;; FSF Emacs |
---|
185 | ;; --19.7 : predicate require-match init |
---|
186 | ;; 19.7 --19.34 : predicate require-match init hist |
---|
187 | ;; 20.1 -- : predicate require-match init hist def inherit-input-method |
---|
188 | ;; XEmacs |
---|
189 | ;; --19.(?): predicate require-match init |
---|
190 | ;; --21.2 : predicate require-match init hist |
---|
191 | ;; 21.2 -- : predicate require-match init hist def |
---|
192 | ;; ) |
---|
193 | |
---|
194 | ;; We support following API. |
---|
195 | ;; (completing-read prompt table |
---|
196 | ;; &optional predicate require-match init hist def) |
---|
197 | (static-cond |
---|
198 | ;; add 'hist' and 'def' argument. |
---|
199 | ((< emacs-major-version 19) |
---|
200 | (or (fboundp 'si:completing-read) |
---|
201 | (progn |
---|
202 | (fset 'si:completing-read (symbol-function 'completing-read)) |
---|
203 | (defun completing-read |
---|
204 | (prompt table &optional predicate require-match init |
---|
205 | hist def) |
---|
206 | "Read a string in the minibuffer, with completion. |
---|
207 | PROMPT is a string to prompt with; normally it ends in a colon and a space. |
---|
208 | TABLE is an alist whose elements' cars are strings, or an obarray. |
---|
209 | PREDICATE limits completion to a subset of TABLE. |
---|
210 | See `try-completion' and `all-completions' for more details |
---|
211 | on completion, TABLE, and PREDICATE. |
---|
212 | |
---|
213 | If REQUIRE-MATCH is non-nil, the user is not allowed to exit unless |
---|
214 | the input is (or completes to) an element of TABLE or is null. |
---|
215 | If it is also not t, Return does not exit if it does non-null completion. |
---|
216 | If the input is null, `completing-read' returns an empty string, |
---|
217 | regardless of the value of REQUIRE-MATCH. |
---|
218 | |
---|
219 | If INIT is non-nil, insert it in the minibuffer initially. |
---|
220 | If it is (STRING . POSITION), the initial input |
---|
221 | is STRING, but point is placed POSITION characters into the string. |
---|
222 | HIST is ignored in this implementation. |
---|
223 | DEF, if non-nil, is the default value. |
---|
224 | |
---|
225 | Completion ignores case if the ambient value of |
---|
226 | `completion-ignore-case' is non-nil." |
---|
227 | (let ((string (si:completing-read prompt table predicate |
---|
228 | require-match init))) |
---|
229 | (if (and (string= string "") def) |
---|
230 | def string)))))) |
---|
231 | ;; add 'def' argument. |
---|
232 | ((or (and (featurep 'xemacs) |
---|
233 | (or (and (eq emacs-major-version 21) |
---|
234 | (< emacs-minor-version 2)) |
---|
235 | (< emacs-major-version 21))) |
---|
236 | (< emacs-major-version 20)) |
---|
237 | (or (fboundp 'si:completing-read) |
---|
238 | (progn |
---|
239 | (fset 'si:completing-read (symbol-function 'completing-read)) |
---|
240 | (defun completing-read |
---|
241 | (prompt table &optional predicate require-match init |
---|
242 | hist def) |
---|
243 | "Read a string in the minibuffer, with completion. |
---|
244 | PROMPT is a string to prompt with; normally it ends in a colon and a space. |
---|
245 | TABLE is an alist whose elements' cars are strings, or an obarray. |
---|
246 | PREDICATE limits completion to a subset of TABLE. |
---|
247 | See `try-completion' and `all-completions' for more details |
---|
248 | on completion, TABLE, and PREDICATE. |
---|
249 | |
---|
250 | If REQUIRE-MATCH is non-nil, the user is not allowed to exit unless |
---|
251 | the input is (or completes to) an element of TABLE or is null. |
---|
252 | If it is also not t, Return does not exit if it does non-null completion. |
---|
253 | If the input is null, `completing-read' returns an empty string, |
---|
254 | regardless of the value of REQUIRE-MATCH. |
---|
255 | |
---|
256 | If INIT is non-nil, insert it in the minibuffer initially. |
---|
257 | If it is (STRING . POSITION), the initial input |
---|
258 | is STRING, but point is placed POSITION characters into the string. |
---|
259 | HIST, if non-nil, specifies a history list |
---|
260 | and optionally the initial position in the list. |
---|
261 | It can be a symbol, which is the history list variable to use, |
---|
262 | or it can be a cons cell (HISTVAR . HISTPOS). |
---|
263 | In that case, HISTVAR is the history list variable to use, |
---|
264 | and HISTPOS is the initial position (the position in the list |
---|
265 | which INIT corresponds to). |
---|
266 | Positions are counted starting from 1 at the beginning of the list. |
---|
267 | DEF, if non-nil, is the default value. |
---|
268 | |
---|
269 | Completion ignores case if the ambient value of |
---|
270 | `completion-ignore-case' is non-nil." |
---|
271 | (let ((string (si:completing-read prompt table predicate |
---|
272 | require-match init hist))) |
---|
273 | (if (and (string= string "") def) |
---|
274 | def string))))))) |
---|
275 | |
---|
276 | ;; v18: (string-to-int STRING) |
---|
277 | ;; v19: (string-to-number STRING) |
---|
278 | ;; v20: (string-to-number STRING &optional BASE) |
---|
279 | ;; |
---|
280 | ;; XXX: `string-to-number' of Emacs 20.3 and earlier is broken. |
---|
281 | ;; (string-to-number "1e1" 16) => 10.0, should be 481. |
---|
282 | (static-condition-case nil |
---|
283 | ;; compile-time check. |
---|
284 | (if (= (string-to-number "1e1" 16) 481) |
---|
285 | (if (get 'string-to-number 'defun-maybe) |
---|
286 | (error "`string-to-number' is already redefined")) |
---|
287 | (error "`string-to-number' is broken")) |
---|
288 | (error |
---|
289 | ;; load-time check. |
---|
290 | (or (fboundp 'si:string-to-number) |
---|
291 | (progn |
---|
292 | (if (fboundp 'string-to-number) |
---|
293 | (fset 'si:string-to-number (symbol-function 'string-to-number)) |
---|
294 | (fset 'si:string-to-number (symbol-function 'string-to-int)) |
---|
295 | ;; XXX: In v18, this causes infinite loop while bytecompiling. |
---|
296 | ;; (defalias 'string-to-int 'string-to-number) |
---|
297 | ) |
---|
298 | (put 'string-to-number 'defun-maybe t) |
---|
299 | (defun string-to-number (string &optional base) |
---|
300 | "\ |
---|
301 | Convert STRING to a number by parsing it as a decimal number. |
---|
302 | This parses both integers and floating point numbers. |
---|
303 | It ignores leading spaces and tabs. |
---|
304 | |
---|
305 | If BASE, interpret STRING as a number in that base. If BASE isn't |
---|
306 | present, base 10 is used. BASE must be between 2 and 16 (inclusive). |
---|
307 | If the base used is not 10, floating point is not recognized." |
---|
308 | (if (or (null base) (= base 10)) |
---|
309 | (si:string-to-number string) |
---|
310 | (if (or (< base 2)(> base 16)) |
---|
311 | (signal 'args-out-of-range (cons base nil))) |
---|
312 | (let ((len (length string)) |
---|
313 | (pos 0)) |
---|
314 | ;; skip leading whitespace. |
---|
315 | (while (and (< pos len) |
---|
316 | (memq (aref string pos) '(?\ ?\t))) |
---|
317 | (setq pos (1+ pos))) |
---|
318 | (if (= pos len) |
---|
319 | 0 |
---|
320 | (let ((number 0)(negative 1) |
---|
321 | chr num) |
---|
322 | (if (eq (aref string pos) ?-) |
---|
323 | (setq negative -1 |
---|
324 | pos (1+ pos)) |
---|
325 | (if (eq (aref string pos) ?+) |
---|
326 | (setq pos (1+ pos)))) |
---|
327 | (while (and (< pos len) |
---|
328 | (setq chr (aref string pos) |
---|
329 | num (cond |
---|
330 | ((and (<= ?0 chr)(<= chr ?9)) |
---|
331 | (- chr ?0)) |
---|
332 | ((and (<= ?A chr)(<= chr ?F)) |
---|
333 | (+ (- chr ?A) 10)) |
---|
334 | ((and (<= ?a chr)(<= chr ?f)) |
---|
335 | (+ (- chr ?a) 10)) |
---|
336 | (t nil))) |
---|
337 | (< num base)) |
---|
338 | (setq number (+ (* number base) num) |
---|
339 | pos (1+ pos))) |
---|
340 | (* negative number)))))))))) |
---|
341 | |
---|
342 | ;; Emacs 20.1 and 20.2: (concat-chars &rest CHARS) |
---|
343 | ;; Emacs 20.3/XEmacs 21.0 and later: (string &rest CHARS) |
---|
344 | (static-cond |
---|
345 | ((and (fboundp 'string) |
---|
346 | (subrp (symbol-function 'string))) |
---|
347 | ;; Emacs 20.3/XEmacs 21.0 and later. |
---|
348 | ) |
---|
349 | ((and (fboundp 'concat-chars) |
---|
350 | (subrp (symbol-function 'concat-chars))) |
---|
351 | ;; Emacs 20.1 and 20.2. |
---|
352 | (defalias 'string 'concat-chars)) |
---|
353 | (t |
---|
354 | ;; Use `defun-maybe' to update `load-history'. |
---|
355 | (defun-maybe string (&rest chars) |
---|
356 | "Concatenate all the argument characters and make the result a string." |
---|
357 | ;; We cannot use (apply 'concat chars) here because `concat' does not |
---|
358 | ;; work with multibyte chars on Mule 1.* and 2.*. |
---|
359 | (mapconcat (function char-to-string) chars "")))) |
---|
360 | |
---|
361 | ;; Mule: (char-before POS) |
---|
362 | ;; v20: (char-before &optional POS) |
---|
363 | (static-condition-case nil |
---|
364 | ;; compile-time check. |
---|
365 | (progn |
---|
366 | (char-before) |
---|
367 | (if (get 'char-before 'defun-maybe) |
---|
368 | (error "`char-before' is already defined"))) |
---|
369 | (wrong-number-of-arguments ; Mule. |
---|
370 | ;; load-time check. |
---|
371 | (or (fboundp 'si:char-before) |
---|
372 | (progn |
---|
373 | (fset 'si:char-before (symbol-function 'char-before)) |
---|
374 | (put 'char-before 'defun-maybe t) |
---|
375 | ;; takes IGNORED for backward compatibility. |
---|
376 | (defun char-before (&optional pos ignored) |
---|
377 | "\ |
---|
378 | Return character in current buffer preceding position POS. |
---|
379 | POS is an integer or a buffer pointer. |
---|
380 | If POS is out of range, the value is nil." |
---|
381 | (si:char-before (or pos (point))))))) |
---|
382 | (void-function ; non-Mule. |
---|
383 | ;; load-time check. |
---|
384 | (defun-maybe char-before (&optional pos) |
---|
385 | "\ |
---|
386 | Return character in current buffer preceding position POS. |
---|
387 | POS is an integer or a buffer pointer. |
---|
388 | If POS is out of range, the value is nil." |
---|
389 | (if pos |
---|
390 | (save-excursion |
---|
391 | (and (= (goto-char pos) (point)) |
---|
392 | (not (bobp)) |
---|
393 | (preceding-char))) |
---|
394 | (and (not (bobp)) |
---|
395 | (preceding-char))))) |
---|
396 | (error ; found our definition at compile-time. |
---|
397 | ;; load-time check. |
---|
398 | (condition-case nil |
---|
399 | (char-before) |
---|
400 | (wrong-number-of-arguments ; Mule. |
---|
401 | (or (fboundp 'si:char-before) |
---|
402 | (progn |
---|
403 | (fset 'si:char-before (symbol-function 'char-before)) |
---|
404 | (put 'char-before 'defun-maybe t) |
---|
405 | ;; takes IGNORED for backward compatibility. |
---|
406 | (defun char-before (&optional pos ignored) |
---|
407 | "\ |
---|
408 | Return character in current buffer preceding position POS. |
---|
409 | POS is an integer or a buffer pointer. |
---|
410 | If POS is out of range, the value is nil." |
---|
411 | (si:char-before (or pos (point))))))) |
---|
412 | (void-function ; non-Mule. |
---|
413 | (defun-maybe char-before (&optional pos) |
---|
414 | "\ |
---|
415 | Return character in current buffer preceding position POS. |
---|
416 | POS is an integer or a buffer pointer. |
---|
417 | If POS is out of range, the value is nil." |
---|
418 | (if pos |
---|
419 | (save-excursion |
---|
420 | (and (= (goto-char pos) (point)) |
---|
421 | (not (bobp)) |
---|
422 | (preceding-char))) |
---|
423 | (and (not (bobp)) |
---|
424 | (preceding-char)))))))) |
---|
425 | |
---|
426 | ;; v18, v19: (char-after POS) |
---|
427 | ;; v20: (char-after &optional POS) |
---|
428 | (static-condition-case nil |
---|
429 | ;; compile-time check. |
---|
430 | (progn |
---|
431 | (char-after) |
---|
432 | (if (get 'char-after 'defun-maybe) |
---|
433 | (error "`char-after' is already redefined"))) |
---|
434 | (wrong-number-of-arguments ; v18, v19 |
---|
435 | ;; load-time check. |
---|
436 | (or (fboundp 'si:char-after) |
---|
437 | (progn |
---|
438 | (fset 'si:char-after (symbol-function 'char-after)) |
---|
439 | (put 'char-after 'defun-maybe t) |
---|
440 | (defun char-after (&optional pos) |
---|
441 | "\ |
---|
442 | Return character in current buffer at position POS. |
---|
443 | POS is an integer or a buffer pointer. |
---|
444 | If POS is out of range, the value is nil." |
---|
445 | (si:char-after (or pos (point))))))) |
---|
446 | (void-function ; NEVER happen? |
---|
447 | ;; load-time check. |
---|
448 | (defun-maybe char-after (&optional pos) |
---|
449 | "\ |
---|
450 | Return character in current buffer at position POS. |
---|
451 | POS is an integer or a buffer pointer. |
---|
452 | If POS is out of range, the value is nil." |
---|
453 | (if pos |
---|
454 | (save-excursion |
---|
455 | (and (= (goto-char pos) (point)) |
---|
456 | (not (eobp)) |
---|
457 | (following-char))) |
---|
458 | (and (not (eobp)) |
---|
459 | (following-char))))) |
---|
460 | (error ; found our definition at compile-time. |
---|
461 | ;; load-time check. |
---|
462 | (condition-case nil |
---|
463 | (char-after) |
---|
464 | (wrong-number-of-arguments ; v18, v19 |
---|
465 | (or (fboundp 'si:char-after) |
---|
466 | (progn |
---|
467 | (fset 'si:char-after (symbol-function 'char-after)) |
---|
468 | (put 'char-after 'defun-maybe t) |
---|
469 | (defun char-after (&optional pos) |
---|
470 | "\ |
---|
471 | Return character in current buffer at position POS. |
---|
472 | POS is an integer or a buffer pointer. |
---|
473 | If POS is out of range, the value is nil." |
---|
474 | (si:char-after (or pos (point))))))) |
---|
475 | (void-function ; NEVER happen? |
---|
476 | (defun-maybe char-after (&optional pos) |
---|
477 | "\ |
---|
478 | Return character in current buffer at position POS. |
---|
479 | POS is an integer or a buffer pointer. |
---|
480 | If POS is out of range, the value is nil." |
---|
481 | (if pos |
---|
482 | (save-excursion |
---|
483 | (and (= (goto-char pos) (point)) |
---|
484 | (not (eobp)) |
---|
485 | (following-char))) |
---|
486 | (and (not (eobp)) |
---|
487 | (following-char)))))))) |
---|
488 | |
---|
489 | ;; Emacs 19.29 and later: (buffer-substring-no-properties START END) |
---|
490 | (defun-maybe buffer-substring-no-properties (start end) |
---|
491 | "Return the characters of part of the buffer, without the text properties. |
---|
492 | The two arguments START and END are character positions; |
---|
493 | they can be in either order." |
---|
494 | (let ((string (buffer-substring start end))) |
---|
495 | (set-text-properties 0 (length string) nil string) |
---|
496 | string)) |
---|
497 | |
---|
498 | ;; Emacs 19.31 and later: (buffer-live-p OBJECT) |
---|
499 | (defun-maybe buffer-live-p (object) |
---|
500 | "Return non-nil if OBJECT is a buffer which has not been killed. |
---|
501 | Value is nil if OBJECT is not a buffer or if it has been killed." |
---|
502 | (and object |
---|
503 | (get-buffer object) |
---|
504 | (buffer-name (get-buffer object)) |
---|
505 | t)) |
---|
506 | |
---|
507 | ;; Emacs 20: (line-beginning-position &optional N) |
---|
508 | (defun-maybe line-beginning-position (&optional n) |
---|
509 | "Return the character position of the first character on the current line. |
---|
510 | With argument N not nil or 1, move forward N - 1 lines first. |
---|
511 | If scan reaches end of buffer, return that position. |
---|
512 | This function does not move point." |
---|
513 | (save-excursion |
---|
514 | (forward-line (1- (or n 1))) |
---|
515 | (point))) |
---|
516 | |
---|
517 | ;; Emacs 20: (line-end-position &optional N) |
---|
518 | (defun-maybe line-end-position (&optional n) |
---|
519 | "Return the character position of the last character on the current line. |
---|
520 | With argument N not nil or 1, move forward N - 1 lines first. |
---|
521 | If scan reaches end of buffer, return that position. |
---|
522 | This function does not move point." |
---|
523 | (save-excursion |
---|
524 | (end-of-line (or n 1)) |
---|
525 | (point))) |
---|
526 | |
---|
527 | ;; FSF Emacs 19.29 and later |
---|
528 | ;; (read-file-name PROMPT &optional DIR DEFAULT-FILENAME MUSTMATCH INITIAL) |
---|
529 | ;; XEmacs 19.14 and later: |
---|
530 | ;; (read-file-name (PROMPT &optional DIR DEFAULT MUST-MATCH INITIAL-CONTENTS |
---|
531 | ;; HISTORY) |
---|
532 | |
---|
533 | ;; In FSF Emacs 19.28 and earlier (except for v18) or XEmacs 19.13 and |
---|
534 | ;; earlier, this function is incompatible with the other Emacsen. |
---|
535 | ;; For instance, if DEFAULT-FILENAME is nil, INITIAL is not and user |
---|
536 | ;; enters a null string, it returns the visited file name of the current |
---|
537 | ;; buffer if it is non-nil. |
---|
538 | |
---|
539 | ;; It does not assimilate the different numbers of the optional arguments |
---|
540 | ;; on various Emacsen (yet). |
---|
541 | (static-cond |
---|
542 | ((and (not (featurep 'xemacs)) |
---|
543 | (eq emacs-major-version 19) |
---|
544 | (< emacs-minor-version 29)) |
---|
545 | (if (fboundp 'si:read-file-name) |
---|
546 | nil |
---|
547 | (fset 'si:read-file-name (symbol-function 'read-file-name)) |
---|
548 | (defun read-file-name (prompt &optional dir default-filename mustmatch |
---|
549 | initial) |
---|
550 | "Read file name, prompting with PROMPT and completing in directory DIR. |
---|
551 | Value is not expanded---you must call `expand-file-name' yourself. |
---|
552 | Default name to DEFAULT-FILENAME if user enters a null string. |
---|
553 | (If DEFAULT-FILENAME is omitted, the visited file name is used, |
---|
554 | except that if INITIAL is specified, that combined with DIR is used.) |
---|
555 | Fourth arg MUSTMATCH non-nil means require existing file's name. |
---|
556 | Non-nil and non-t means also require confirmation after completion. |
---|
557 | Fifth arg INITIAL specifies text to start with. |
---|
558 | DIR defaults to current buffer's directory default." |
---|
559 | (si:read-file-name prompt dir |
---|
560 | (or default-filename |
---|
561 | (if initial |
---|
562 | (expand-file-name initial dir))) |
---|
563 | mustmatch initial)))) |
---|
564 | ((and (featurep 'xemacs) |
---|
565 | (eq emacs-major-version 19) |
---|
566 | (< emacs-minor-version 14)) |
---|
567 | (if (fboundp 'si:read-file-name) |
---|
568 | nil |
---|
569 | (fset 'si:read-file-name (symbol-function 'read-file-name)) |
---|
570 | (defun read-file-name (prompt &optional dir default must-match |
---|
571 | initial-contents history) |
---|
572 | "Read file name, prompting with PROMPT and completing in directory DIR. |
---|
573 | This will prompt with a dialog box if appropriate, according to |
---|
574 | `should-use-dialog-box-p'. |
---|
575 | Value is not expanded---you must call `expand-file-name' yourself. |
---|
576 | Value is subject to interpreted by substitute-in-file-name however. |
---|
577 | Default name to DEFAULT if user enters a null string. |
---|
578 | (If DEFAULT is omitted, the visited file name is used, |
---|
579 | except that if INITIAL-CONTENTS is specified, that combined with DIR is |
---|
580 | used.) |
---|
581 | Fourth arg MUST-MATCH non-nil means require existing file's name. |
---|
582 | Non-nil and non-t means also require confirmation after completion. |
---|
583 | Fifth arg INITIAL-CONTENTS specifies text to start with. |
---|
584 | Sixth arg HISTORY specifies the history list to use. Default is |
---|
585 | `file-name-history'. |
---|
586 | DIR defaults to current buffer's directory default." |
---|
587 | (si:read-file-name prompt dir |
---|
588 | (or default |
---|
589 | (if initial-contents |
---|
590 | (expand-file-name initial-contents dir))) |
---|
591 | must-match initial-contents history))))) |
---|
592 | |
---|
593 | |
---|
594 | ;;; @ Basic lisp subroutines emulation. (lisp/subr.el) |
---|
595 | ;;; |
---|
596 | |
---|
597 | ;;; @@ Lisp language features. |
---|
598 | |
---|
599 | (defmacro-maybe push (newelt listname) |
---|
600 | "Add NEWELT to the list stored in the symbol LISTNAME. |
---|
601 | This is equivalent to (setq LISTNAME (cons NEWELT LISTNAME)). |
---|
602 | LISTNAME must be a symbol." |
---|
603 | (list 'setq listname |
---|
604 | (list 'cons newelt listname))) |
---|
605 | |
---|
606 | (defmacro-maybe pop (listname) |
---|
607 | "Return the first element of LISTNAME's value, and remove it from the list. |
---|
608 | LISTNAME must be a symbol whose value is a list. |
---|
609 | If the value is nil, `pop' returns nil but does not actually |
---|
610 | change the list." |
---|
611 | (list 'prog1 (list 'car listname) |
---|
612 | (list 'setq listname (list 'cdr listname)))) |
---|
613 | |
---|
614 | (defmacro-maybe when (cond &rest body) |
---|
615 | "If COND yields non-nil, do BODY, else return nil." |
---|
616 | (list 'if cond (cons 'progn body))) |
---|
617 | ;; (def-edebug-spec when (&rest form)) |
---|
618 | |
---|
619 | (defmacro-maybe unless (cond &rest body) |
---|
620 | "If COND yields nil, do BODY, else return nil." |
---|
621 | (cons 'if (cons cond (cons nil body)))) |
---|
622 | ;; (def-edebug-spec unless (&rest form)) |
---|
623 | |
---|
624 | (defsubst-maybe caar (x) |
---|
625 | "Return the car of the car of X." |
---|
626 | (car (car x))) |
---|
627 | |
---|
628 | (defsubst-maybe cadr (x) |
---|
629 | "Return the car of the cdr of X." |
---|
630 | (car (cdr x))) |
---|
631 | |
---|
632 | (defsubst-maybe cdar (x) |
---|
633 | "Return the cdr of the car of X." |
---|
634 | (cdr (car x))) |
---|
635 | |
---|
636 | (defsubst-maybe cddr (x) |
---|
637 | "Return the cdr of the cdr of X." |
---|
638 | (cdr (cdr x))) |
---|
639 | |
---|
640 | (defun-maybe last (x &optional n) |
---|
641 | "Return the last link of the list X. Its car is the last element. |
---|
642 | If X is nil, return nil. |
---|
643 | If N is non-nil, return the Nth-to-last link of X. |
---|
644 | If N is bigger than the length of X, return X." |
---|
645 | (if n |
---|
646 | (let ((m 0) (p x)) |
---|
647 | (while (consp p) |
---|
648 | (setq m (1+ m) p (cdr p))) |
---|
649 | (if (<= n 0) p |
---|
650 | (if (< n m) (nthcdr (- m n) x) x))) |
---|
651 | (while (cdr x) |
---|
652 | (setq x (cdr x))) |
---|
653 | x)) |
---|
654 | |
---|
655 | ;; Actually, `butlast' and `nbutlast' are defined in lisp/cl.el. |
---|
656 | (defun-maybe butlast (x &optional n) |
---|
657 | "Returns a copy of LIST with the last N elements removed." |
---|
658 | (if (and n (<= n 0)) x |
---|
659 | (nbutlast (copy-sequence x) n))) |
---|
660 | |
---|
661 | (defun-maybe nbutlast (x &optional n) |
---|
662 | "Modifies LIST to remove the last N elements." |
---|
663 | (let ((m (length x))) |
---|
664 | (or n (setq n 1)) |
---|
665 | (and (< n m) |
---|
666 | (progn |
---|
667 | (if (> n 0) (setcdr (nthcdr (- (1- m) n) x) nil)) |
---|
668 | x)))) |
---|
669 | |
---|
670 | ;; Emacs 20.3 and later: (assoc-default KEY ALIST &optional TEST DEFAULT) |
---|
671 | (defun-maybe assoc-default (key alist &optional test default) |
---|
672 | "Find object KEY in a pseudo-alist ALIST. |
---|
673 | ALIST is a list of conses or objects. Each element (or the element's car, |
---|
674 | if it is a cons) is compared with KEY by evaluating (TEST (car elt) KEY). |
---|
675 | If that is non-nil, the element matches; |
---|
676 | then `assoc-default' returns the element's cdr, if it is a cons, |
---|
677 | or DEFAULT if the element is not a cons. |
---|
678 | |
---|
679 | If no element matches, the value is nil. |
---|
680 | If TEST is omitted or nil, `equal' is used." |
---|
681 | (let (found (tail alist) value) |
---|
682 | (while (and tail (not found)) |
---|
683 | (let ((elt (car tail))) |
---|
684 | (when (funcall (or test 'equal) (if (consp elt) (car elt) elt) key) |
---|
685 | (setq found t value (if (consp elt) (cdr elt) default)))) |
---|
686 | (setq tail (cdr tail))) |
---|
687 | value)) |
---|
688 | |
---|
689 | ;; The following two function use `compare-strings', which we don't |
---|
690 | ;; support yet. |
---|
691 | ;; (defun assoc-ignore-case (key alist)) |
---|
692 | ;; (defun assoc-ignore-representation (key alist)) |
---|
693 | |
---|
694 | ;; Emacs 19.29/XEmacs 19.13 and later: (rassoc KEY LIST) |
---|
695 | ;; Actually, `rassoc' is defined in src/fns.c. |
---|
696 | (defun-maybe rassoc (key list) |
---|
697 | "Return non-nil if KEY is `equal' to the cdr of an element of LIST. |
---|
698 | The value is actually the element of LIST whose cdr equals KEY. |
---|
699 | Elements of LIST that are not conses are ignored." |
---|
700 | (catch 'found |
---|
701 | (while list |
---|
702 | (cond ((not (consp (car list)))) |
---|
703 | ((equal (cdr (car list)) key) |
---|
704 | (throw 'found (car list)))) |
---|
705 | (setq list (cdr list))))) |
---|
706 | |
---|
707 | ;; XEmacs 19.13 and later: (remassq KEY LIST) |
---|
708 | (defun-maybe remassq (key list) |
---|
709 | "Delete by side effect any elements of LIST whose car is `eq' to KEY. |
---|
710 | The modified LIST is returned. If the first member of LIST has a car |
---|
711 | that is `eq' to KEY, there is no way to remove it by side effect; |
---|
712 | therefore, write `(setq foo (remassq key foo))' to be sure of changing |
---|
713 | the value of `foo'." |
---|
714 | (if (setq key (assq key list)) |
---|
715 | (delq key list) |
---|
716 | list)) |
---|
717 | |
---|
718 | ;; XEmacs 19.13 and later: (remassoc KEY LIST) |
---|
719 | (defun-maybe remassoc (key list) |
---|
720 | "Delete by side effect any elements of LIST whose car is `equal' to KEY. |
---|
721 | The modified LIST is returned. If the first member of LIST has a car |
---|
722 | that is `equal' to KEY, there is no way to remove it by side effect; |
---|
723 | therefore, write `(setq foo (remassoc key foo))' to be sure of changing |
---|
724 | the value of `foo'." |
---|
725 | (if (setq key (assoc key list)) |
---|
726 | (delq key list) |
---|
727 | list)) |
---|
728 | |
---|
729 | ;; XEmacs 19.13 and later: (remrassq VALUE LIST) |
---|
730 | (defun-maybe remrassq (value list) |
---|
731 | "Delete by side effect any elements of LIST whose cdr is `eq' to VALUE. |
---|
732 | The modified LIST is returned. If the first member of LIST has a car |
---|
733 | that is `eq' to VALUE, there is no way to remove it by side effect; |
---|
734 | therefore, write `(setq foo (remrassq value foo))' to be sure of changing |
---|
735 | the value of `foo'." |
---|
736 | (if (setq value (rassq value list)) |
---|
737 | (delq value list) |
---|
738 | list)) |
---|
739 | |
---|
740 | ;; XEmacs 19.13 and later: (remrassoc VALUE LIST) |
---|
741 | (defun-maybe remrassoc (value list) |
---|
742 | "Delete by side effect any elements of LIST whose cdr is `equal' to VALUE. |
---|
743 | The modified LIST is returned. If the first member of LIST has a car |
---|
744 | that is `equal' to VALUE, there is no way to remove it by side effect; |
---|
745 | therefore, write `(setq foo (remrassoc value foo))' to be sure of changing |
---|
746 | the value of `foo'." |
---|
747 | (if (setq value (rassoc value list)) |
---|
748 | (delq value list) |
---|
749 | list)) |
---|
750 | |
---|
751 | ;;; Define `functionp' here because "localhook" uses it. |
---|
752 | |
---|
753 | ;; Emacs 20.1/XEmacs 20.3 (but first appeared in Epoch?): (functionp OBJECT) |
---|
754 | (defun-maybe functionp (object) |
---|
755 | "Non-nil if OBJECT is a type of object that can be called as a function." |
---|
756 | (or (subrp object) (byte-code-function-p object) |
---|
757 | (eq (car-safe object) 'lambda) |
---|
758 | (and (symbolp object) (fboundp object)))) |
---|
759 | |
---|
760 | ;;; @@ Hook manipulation functions. |
---|
761 | |
---|
762 | ;; "localhook" package is written for Emacs 19.28 and earlier. |
---|
763 | ;; `run-hooks' was a lisp function in Emacs 19.29 and earlier. |
---|
764 | ;; So, in Emacs 19.29, `run-hooks' and others will be overrided. |
---|
765 | ;; But, who cares it? |
---|
766 | (static-unless (subrp (symbol-function 'run-hooks)) |
---|
767 | (require 'localhook)) |
---|
768 | |
---|
769 | ;; Emacs 19.29/XEmacs 19.14(?) and later: (add-to-list LIST-VAR ELEMENT) |
---|
770 | (defun-maybe add-to-list (list-var element) |
---|
771 | "Add to the value of LIST-VAR the element ELEMENT if it isn't there yet. |
---|
772 | The test for presence of ELEMENT is done with `equal'. |
---|
773 | If you want to use `add-to-list' on a variable that is not defined |
---|
774 | until a certain package is loaded, you should put the call to `add-to-list' |
---|
775 | into a hook function that will be run only after loading the package. |
---|
776 | `eval-after-load' provides one way to do this. In some cases |
---|
777 | other hooks, such as major mode hooks, can do the job." |
---|
778 | (or (member element (symbol-value list-var)) |
---|
779 | (set list-var (cons element (symbol-value list-var))))) |
---|
780 | |
---|
781 | ;; (eval-after-load FILE FORM) |
---|
782 | ;; Emacs 19.28 and earlier do not evaluate FORM if FILE is already loaded. |
---|
783 | ;; XEmacs 20.2 and earlier have `after-load-alist', but refuse to support |
---|
784 | ;; `eval-after-load'. (see comments in XEmacs/lisp/subr.el.) |
---|
785 | (static-cond |
---|
786 | ((featurep 'xemacs) |
---|
787 | ;; for XEmacs 20.2 and earlier. |
---|
788 | (defun-maybe eval-after-load (file form) |
---|
789 | "Arrange that, if FILE is ever loaded, FORM will be run at that time. |
---|
790 | This makes or adds to an entry on `after-load-alist'. |
---|
791 | If FILE is already loaded, evaluate FORM right now. |
---|
792 | It does nothing if FORM is already on the list for FILE. |
---|
793 | FILE should be the name of a library, with no directory name." |
---|
794 | ;; Make sure there is an element for FILE. |
---|
795 | (or (assoc file after-load-alist) |
---|
796 | (setq after-load-alist (cons (list file) after-load-alist))) |
---|
797 | ;; Add FORM to the element if it isn't there. |
---|
798 | (let ((elt (assoc file after-load-alist))) |
---|
799 | (or (member form (cdr elt)) |
---|
800 | (progn |
---|
801 | (nconc elt (list form)) |
---|
802 | ;; If the file has been loaded already, run FORM right away. |
---|
803 | (and (assoc file load-history) |
---|
804 | (eval form))))) |
---|
805 | form)) |
---|
806 | ((>= emacs-major-version 20)) |
---|
807 | ((and (= emacs-major-version 19) |
---|
808 | (< emacs-minor-version 29)) |
---|
809 | ;; for Emacs 19.28 and earlier. |
---|
810 | (defun eval-after-load (file form) |
---|
811 | "Arrange that, if FILE is ever loaded, FORM will be run at that time. |
---|
812 | This makes or adds to an entry on `after-load-alist'. |
---|
813 | If FILE is already loaded, evaluate FORM right now. |
---|
814 | It does nothing if FORM is already on the list for FILE. |
---|
815 | FILE should be the name of a library, with no directory name." |
---|
816 | ;; Make sure there is an element for FILE. |
---|
817 | (or (assoc file after-load-alist) |
---|
818 | (setq after-load-alist (cons (list file) after-load-alist))) |
---|
819 | ;; Add FORM to the element if it isn't there. |
---|
820 | (let ((elt (assoc file after-load-alist))) |
---|
821 | (or (member form (cdr elt)) |
---|
822 | (progn |
---|
823 | (nconc elt (list form)) |
---|
824 | ;; If the file has been loaded already, run FORM right away. |
---|
825 | (and (assoc file load-history) |
---|
826 | (eval form))))) |
---|
827 | form)) |
---|
828 | (t |
---|
829 | ;; should emulate for v18? |
---|
830 | )) |
---|
831 | |
---|
832 | (defun-maybe eval-next-after-load (file) |
---|
833 | "Read the following input sexp, and run it whenever FILE is loaded. |
---|
834 | This makes or adds to an entry on `after-load-alist'. |
---|
835 | FILE should be the name of a library, with no directory name." |
---|
836 | (eval-after-load file (read))) |
---|
837 | |
---|
838 | ;;; @@ Input and display facilities. |
---|
839 | |
---|
840 | ;; XXX: (defun read-passwd (prompt &optional confirm default)) |
---|
841 | |
---|
842 | ;;; @@ Miscellanea. |
---|
843 | |
---|
844 | ;; Avoid compiler warnings about this variable, |
---|
845 | ;; which has a special meaning on certain system types. |
---|
846 | (defvar-maybe buffer-file-type nil |
---|
847 | "Non-nil if the visited file is a binary file. |
---|
848 | This variable is meaningful on MS-DOG and Windows NT. |
---|
849 | On those systems, it is automatically local in every buffer. |
---|
850 | On other systems, this variable is normally always nil.") |
---|
851 | |
---|
852 | ;; Emacs 20.3 or later. |
---|
853 | (defvar-maybe minor-mode-overriding-map-alist nil |
---|
854 | "Alist of keymaps to use for minor modes, in current major mode. |
---|
855 | APEL provides this as dummy for a compatibility.") |
---|
856 | |
---|
857 | ;; Emacs 20.1/XEmacs 20.3(?) and later: (save-current-buffer &rest BODY) |
---|
858 | ;; |
---|
859 | ;; v20 defines `save-current-buffer' as a C primitive (in src/editfns.c) |
---|
860 | ;; and introduces a new bytecode Bsave_current_buffer(_1), replacing an |
---|
861 | ;; obsolete bytecode Bread_char. To make things worse, Emacs 20.1 and |
---|
862 | ;; 20.2 have a bug that it will restore the current buffer without |
---|
863 | ;; confirming that it is alive. |
---|
864 | ;; |
---|
865 | ;; This is a source of incompatibility of .elc between v18/v19 and v20. |
---|
866 | ;; (XEmacs compiler takes care of it if compatibility mode is enabled.) |
---|
867 | (defmacro-maybe save-current-buffer (&rest body) |
---|
868 | "Save the current buffer; execute BODY; restore the current buffer. |
---|
869 | Executes BODY just like `progn'." |
---|
870 | (` (let ((orig-buffer (current-buffer))) |
---|
871 | (unwind-protect |
---|
872 | (progn (,@ body)) |
---|
873 | (if (buffer-live-p orig-buffer) |
---|
874 | (set-buffer orig-buffer)))))) |
---|
875 | |
---|
876 | ;; Emacs 20.1/XEmacs 20.3(?) and later: (with-current-buffer BUFFER &rest BODY) |
---|
877 | (defmacro-maybe with-current-buffer (buffer &rest body) |
---|
878 | "Execute the forms in BODY with BUFFER as the current buffer. |
---|
879 | The value returned is the value of the last form in BODY. |
---|
880 | See also `with-temp-buffer'." |
---|
881 | (` (save-current-buffer |
---|
882 | (set-buffer (, buffer)) |
---|
883 | (,@ body)))) |
---|
884 | |
---|
885 | ;; Emacs 20.1/XEmacs 20.3(?) and later: (with-temp-file FILE &rest FORMS) |
---|
886 | (defmacro-maybe with-temp-file (file &rest forms) |
---|
887 | "Create a new buffer, evaluate FORMS there, and write the buffer to FILE. |
---|
888 | The value of the last form in FORMS is returned, like `progn'. |
---|
889 | See also `with-temp-buffer'." |
---|
890 | (let ((temp-file (make-symbol "temp-file")) |
---|
891 | (temp-buffer (make-symbol "temp-buffer"))) |
---|
892 | (` (let (((, temp-file) (, file)) |
---|
893 | ((, temp-buffer) |
---|
894 | (get-buffer-create (generate-new-buffer-name " *temp file*")))) |
---|
895 | (unwind-protect |
---|
896 | (prog1 |
---|
897 | (with-current-buffer (, temp-buffer) |
---|
898 | (,@ forms)) |
---|
899 | (with-current-buffer (, temp-buffer) |
---|
900 | (widen) |
---|
901 | (write-region (point-min) (point-max) (, temp-file) nil 0))) |
---|
902 | (and (buffer-name (, temp-buffer)) |
---|
903 | (kill-buffer (, temp-buffer)))))))) |
---|
904 | |
---|
905 | ;; Emacs 20.4 and later: (with-temp-message MESSAGE &rest BODY) |
---|
906 | ;; This macro uses `current-message', which appears in v20. |
---|
907 | (static-when (and (fboundp 'current-message) |
---|
908 | (subrp (symbol-function 'current-message))) |
---|
909 | (defmacro-maybe with-temp-message (message &rest body) |
---|
910 | "\ |
---|
911 | Display MESSAGE temporarily if non-nil while BODY is evaluated. |
---|
912 | The original message is restored to the echo area after BODY has finished. |
---|
913 | The value returned is the value of the last form in BODY. |
---|
914 | MESSAGE is written to the message log buffer if `message-log-max' is non-nil. |
---|
915 | If MESSAGE is nil, the echo area and message log buffer are unchanged. |
---|
916 | Use a MESSAGE of \"\" to temporarily clear the echo area." |
---|
917 | (let ((current-message (make-symbol "current-message")) |
---|
918 | (temp-message (make-symbol "with-temp-message"))) |
---|
919 | (` (let (((, temp-message) (, message)) |
---|
920 | ((, current-message))) |
---|
921 | (unwind-protect |
---|
922 | (progn |
---|
923 | (when (, temp-message) |
---|
924 | (setq (, current-message) (current-message)) |
---|
925 | (message "%s" (, temp-message)) |
---|
926 | (,@ body)) |
---|
927 | (and (, temp-message) (, current-message) |
---|
928 | (message "%s" (, current-message)))))))))) |
---|
929 | |
---|
930 | ;; Emacs 20.1/XEmacs 20.3(?) and later: (with-temp-buffer &rest FORMS) |
---|
931 | (defmacro-maybe with-temp-buffer (&rest forms) |
---|
932 | "Create a temporary buffer, and evaluate FORMS there like `progn'. |
---|
933 | See also `with-temp-file' and `with-output-to-string'." |
---|
934 | (let ((temp-buffer (make-symbol "temp-buffer"))) |
---|
935 | (` (let (((, temp-buffer) |
---|
936 | (get-buffer-create (generate-new-buffer-name " *temp*")))) |
---|
937 | (unwind-protect |
---|
938 | (with-current-buffer (, temp-buffer) |
---|
939 | (,@ forms)) |
---|
940 | (and (buffer-name (, temp-buffer)) |
---|
941 | (kill-buffer (, temp-buffer)))))))) |
---|
942 | |
---|
943 | ;; Emacs 20.1/XEmacs 20.3(?) and later: (with-output-to-string &rest BODY) |
---|
944 | (defmacro-maybe with-output-to-string (&rest body) |
---|
945 | "Execute BODY, return the text it sent to `standard-output', as a string." |
---|
946 | (` (let ((standard-output |
---|
947 | (get-buffer-create (generate-new-buffer-name " *string-output*")))) |
---|
948 | (let ((standard-output standard-output)) |
---|
949 | (,@ body)) |
---|
950 | (with-current-buffer standard-output |
---|
951 | (prog1 |
---|
952 | (buffer-string) |
---|
953 | (kill-buffer nil)))))) |
---|
954 | |
---|
955 | ;; Emacs 20.1 and later: (combine-after-change-calls &rest BODY) |
---|
956 | (defmacro-maybe combine-after-change-calls (&rest body) |
---|
957 | "Execute BODY, but don't call the after-change functions till the end. |
---|
958 | If BODY makes changes in the buffer, they are recorded |
---|
959 | and the functions on `after-change-functions' are called several times |
---|
960 | when BODY is finished. |
---|
961 | The return value is the value of the last form in BODY. |
---|
962 | |
---|
963 | If `before-change-functions' is non-nil, then calls to the after-change |
---|
964 | functions can't be deferred, so in that case this macro has no effect. |
---|
965 | |
---|
966 | Do not alter `after-change-functions' or `before-change-functions' |
---|
967 | in BODY. |
---|
968 | |
---|
969 | This emulating macro does not support after-change functions at all, |
---|
970 | just execute BODY." |
---|
971 | (cons 'progn body)) |
---|
972 | |
---|
973 | ;; Emacs 19.29/XEmacs 19.14(?) and later: (match-string NUM &optional STRING) |
---|
974 | (defun-maybe match-string (num &optional string) |
---|
975 | "Return string of text matched by last search. |
---|
976 | NUM specifies which parenthesized expression in the last regexp. |
---|
977 | Value is nil if NUMth pair didn't match, or there were less than NUM pairs. |
---|
978 | Zero means the entire text matched by the whole regexp or whole string. |
---|
979 | STRING should be given if the last search was by `string-match' on STRING." |
---|
980 | (if (match-beginning num) |
---|
981 | (if string |
---|
982 | (substring string (match-beginning num) (match-end num)) |
---|
983 | (buffer-substring (match-beginning num) (match-end num))))) |
---|
984 | |
---|
985 | ;; Emacs 20.3 and later: (match-string-no-properties NUM &optional STRING) |
---|
986 | (defun-maybe match-string-no-properties (num &optional string) |
---|
987 | "Return string of text matched by last search, without text properties. |
---|
988 | NUM specifies which parenthesized expression in the last regexp. |
---|
989 | Value is nil if NUMth pair didn't match, or there were less than NUM pairs. |
---|
990 | Zero means the entire text matched by the whole regexp or whole string. |
---|
991 | STRING should be given if the last search was by `string-match' on STRING." |
---|
992 | (if (match-beginning num) |
---|
993 | (if string |
---|
994 | (let ((result |
---|
995 | (substring string (match-beginning num) (match-end num)))) |
---|
996 | (set-text-properties 0 (length result) nil result) |
---|
997 | result) |
---|
998 | (buffer-substring-no-properties (match-beginning num) |
---|
999 | (match-end num))))) |
---|
1000 | |
---|
1001 | ;; Emacs 19.28 and earlier |
---|
1002 | ;; (replace-match NEWTEXT &optional FIXEDCASE LITERAL) |
---|
1003 | ;; Emacs 20.x (?) and later |
---|
1004 | ;; (replace-match NEWTEXT &optional FIXEDCASE LITERAL STRING SUBEXP) |
---|
1005 | ;; XEmacs 21: |
---|
1006 | ;; (replace-match NEWTEXT &optional FIXEDCASE LITERAL STRING STRBUFFER) |
---|
1007 | ;; We support following API. |
---|
1008 | ;; (replace-match NEWTEXT &optional FIXEDCASE LITERAL STRING) |
---|
1009 | (static-condition-case nil |
---|
1010 | ;; compile-time check |
---|
1011 | (progn |
---|
1012 | (string-match "" "") |
---|
1013 | (replace-match "" nil nil "") |
---|
1014 | (if (get 'replace-match 'defun-maybe) |
---|
1015 | (error "`replace-match' is already defined"))) |
---|
1016 | (wrong-number-of-arguments ; Emacs 19.28 and earlier |
---|
1017 | ;; load-time check. |
---|
1018 | (or (fboundp 'si:replace-match) |
---|
1019 | (progn |
---|
1020 | (fset 'si:replace-match (symbol-function 'replace-match)) |
---|
1021 | (put 'replace-match 'defun-maybe t) |
---|
1022 | (defun replace-match (newtext &optional fixedcase literal string) |
---|
1023 | "Replace text matched by last search with NEWTEXT. |
---|
1024 | If second arg FIXEDCASE is non-nil, do not alter case of replacement text. |
---|
1025 | Otherwise maybe capitalize the whole text, or maybe just word initials, |
---|
1026 | based on the replaced text. |
---|
1027 | If the replaced text has only capital letters |
---|
1028 | and has at least one multiletter word, convert NEWTEXT to all caps. |
---|
1029 | If the replaced text has at least one word starting with a capital letter, |
---|
1030 | then capitalize each word in NEWTEXT. |
---|
1031 | |
---|
1032 | If third arg LITERAL is non-nil, insert NEWTEXT literally. |
---|
1033 | Otherwise treat `\' as special: |
---|
1034 | `\&' in NEWTEXT means substitute original matched text. |
---|
1035 | `\N' means substitute what matched the Nth `\(...\)'. |
---|
1036 | If Nth parens didn't match, substitute nothing. |
---|
1037 | `\\' means insert one `\'. |
---|
1038 | FIXEDCASE and LITERAL are optional arguments. |
---|
1039 | Leaves point at end of replacement text. |
---|
1040 | |
---|
1041 | The optional fourth argument STRING can be a string to modify. |
---|
1042 | In that case, this function creates and returns a new string |
---|
1043 | which is made by replacing the part of STRING that was matched." |
---|
1044 | (if string |
---|
1045 | (with-temp-buffer |
---|
1046 | (save-match-data |
---|
1047 | (insert string) |
---|
1048 | (let* ((matched (match-data)) |
---|
1049 | (beg (nth 0 matched)) |
---|
1050 | (end (nth 1 matched))) |
---|
1051 | (store-match-data |
---|
1052 | (list |
---|
1053 | (if (markerp beg) |
---|
1054 | (move-marker beg (1+ (match-beginning 0))) |
---|
1055 | (1+ (match-beginning 0))) |
---|
1056 | (if (markerp end) |
---|
1057 | (move-marker end (1+ (match-end 0))) |
---|
1058 | (1+ (match-end 0)))))) |
---|
1059 | (si:replace-match newtext fixedcase literal) |
---|
1060 | (buffer-string))) |
---|
1061 | (si:replace-match newtext fixedcase literal)))))) |
---|
1062 | (error ; found our definition at compile-time. |
---|
1063 | ;; load-time check. |
---|
1064 | (condition-case nil |
---|
1065 | (progn |
---|
1066 | (string-match "" "") |
---|
1067 | (replace-match "" nil nil "")) |
---|
1068 | (wrong-number-of-arguments ; Emacs 19.28 and earlier |
---|
1069 | ;; load-time check. |
---|
1070 | (or (fboundp 'si:replace-match) |
---|
1071 | (progn |
---|
1072 | (fset 'si:replace-match (symbol-function 'replace-match)) |
---|
1073 | (put 'replace-match 'defun-maybe t) |
---|
1074 | (defun replace-match (newtext &optional fixedcase literal string) |
---|
1075 | "Replace text matched by last search with NEWTEXT. |
---|
1076 | If second arg FIXEDCASE is non-nil, do not alter case of replacement text. |
---|
1077 | Otherwise maybe capitalize the whole text, or maybe just word initials, |
---|
1078 | based on the replaced text. |
---|
1079 | If the replaced text has only capital letters |
---|
1080 | and has at least one multiletter word, convert NEWTEXT to all caps. |
---|
1081 | If the replaced text has at least one word starting with a capital letter, |
---|
1082 | then capitalize each word in NEWTEXT. |
---|
1083 | |
---|
1084 | If third arg LITERAL is non-nil, insert NEWTEXT literally. |
---|
1085 | Otherwise treat `\' as special: |
---|
1086 | `\&' in NEWTEXT means substitute original matched text. |
---|
1087 | `\N' means substitute what matched the Nth `\(...\)'. |
---|
1088 | If Nth parens didn't match, substitute nothing. |
---|
1089 | `\\' means insert one `\'. |
---|
1090 | FIXEDCASE and LITERAL are optional arguments. |
---|
1091 | Leaves point at end of replacement text. |
---|
1092 | |
---|
1093 | The optional fourth argument STRING can be a string to modify. |
---|
1094 | In that case, this function creates and returns a new string |
---|
1095 | which is made by replacing the part of STRING that was matched." |
---|
1096 | (if string |
---|
1097 | (with-temp-buffer |
---|
1098 | (save-match-data |
---|
1099 | (insert string) |
---|
1100 | (let* ((matched (match-data)) |
---|
1101 | (beg (nth 0 matched)) |
---|
1102 | (end (nth 1 matched))) |
---|
1103 | (store-match-data |
---|
1104 | (list |
---|
1105 | (if (markerp beg) |
---|
1106 | (move-marker beg (1+ (match-beginning 0))) |
---|
1107 | (1+ (match-beginning 0))) |
---|
1108 | (if (markerp end) |
---|
1109 | (move-marker end (1+ (match-end 0))) |
---|
1110 | (1+ (match-end 0)))))) |
---|
1111 | (si:replace-match newtext fixedcase literal) |
---|
1112 | (buffer-string))) |
---|
1113 | (si:replace-match newtext fixedcase literal))))))))) |
---|
1114 | |
---|
1115 | ;; Emacs 20: (format-time-string) |
---|
1116 | ;; The the third optional argument universal is yet to be implemented. |
---|
1117 | ;; Those format constructs are yet to be implemented. |
---|
1118 | ;; %c, %C, %j, %U, %W, %x, %X |
---|
1119 | ;; Not fully compatible especially when invalid format is specified. |
---|
1120 | (static-unless (and (fboundp 'format-time-string) |
---|
1121 | (not (get 'format-time-string 'defun-maybe))) |
---|
1122 | (or (fboundp 'format-time-string) |
---|
1123 | (progn |
---|
1124 | (defconst format-time-month-list |
---|
1125 | '(( "Zero" . ("Zero" . 0)) |
---|
1126 | ("Jan" . ("January" . 1)) ("Feb" . ("February" . 2)) |
---|
1127 | ("Mar" . ("March" . 3)) ("Apr" . ("April" . 4)) ("May" . ("May" . 5)) |
---|
1128 | ("Jun" . ("June" . 6))("Jul" . ("July" . 7)) ("Aug" . ("August" . 8)) |
---|
1129 | ("Sep" . ("September" . 9)) ("Oct" . ("October" . 10)) |
---|
1130 | ("Nov" . ("November" . 11)) ("Dec" . ("December" . 12))) |
---|
1131 | "Alist of months and their number.") |
---|
1132 | |
---|
1133 | (defconst format-time-week-list |
---|
1134 | '(("Sun" . ("Sunday" . 0)) ("Mon" . ("Monday" . 1)) |
---|
1135 | ("Tue" . ("Tuesday" . 2)) ("Wed" . ("Wednesday" . 3)) |
---|
1136 | ("Thu" . ("Thursday" . 4)) ("Fri" . ("Friday" . 5)) |
---|
1137 | ("Sat" . ("Saturday" . 6))) |
---|
1138 | "Alist of weeks and their number.") |
---|
1139 | |
---|
1140 | (defun format-time-string (format &optional time universal) |
---|
1141 | "Use FORMAT-STRING to format the time TIME, or now if omitted. |
---|
1142 | TIME is specified as (HIGH LOW . IGNORED) or (HIGH . LOW), as returned by |
---|
1143 | `current-time' or `file-attributes'. |
---|
1144 | The third, optional, argument UNIVERSAL, if non-nil, means describe TIME |
---|
1145 | as Universal Time; nil means describe TIME in the local time zone. |
---|
1146 | The value is a copy of FORMAT-STRING, but with certain constructs replaced |
---|
1147 | by text that describes the specified date and time in TIME: |
---|
1148 | |
---|
1149 | %Y is the year, %y within the century, %C the century. |
---|
1150 | %G is the year corresponding to the ISO week, %g within the century. |
---|
1151 | %m is the numeric month. |
---|
1152 | %b and %h are the locale's abbreviated month name, %B the full name. |
---|
1153 | %d is the day of the month, zero-padded, %e is blank-padded. |
---|
1154 | %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6. |
---|
1155 | %a is the locale's abbreviated name of the day of week, %A the full name. |
---|
1156 | %U is the week number starting on Sunday, %W starting on Monday, |
---|
1157 | %V according to ISO 8601. |
---|
1158 | %j is the day of the year. |
---|
1159 | |
---|
1160 | %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H |
---|
1161 | only blank-padded, %l is like %I blank-padded. |
---|
1162 | %p is the locale's equivalent of either AM or PM. |
---|
1163 | %M is the minute. |
---|
1164 | %S is the second. |
---|
1165 | %Z is the time zone name, %z is the numeric form. |
---|
1166 | %s is the number of seconds since 1970-01-01 00:00:00 +0000. |
---|
1167 | |
---|
1168 | %c is the locale's date and time format. |
---|
1169 | %x is the locale's \"preferred\" date format. |
---|
1170 | %D is like \"%m/%d/%y\". |
---|
1171 | |
---|
1172 | %R is like \"%H:%M\", %T is like \"%H:%M:%S\", %r is like \"%I:%M:%S %p\". |
---|
1173 | %X is the locale's \"preferred\" time format. |
---|
1174 | |
---|
1175 | Finally, %n is a newline, %t is a tab, %% is a literal %. |
---|
1176 | |
---|
1177 | Certain flags and modifiers are available with some format controls. |
---|
1178 | The flags are `_' and `-'. For certain characters X, %_X is like %X, |
---|
1179 | but padded with blanks; %-X is like %X, but without padding. |
---|
1180 | %NX (where N stands for an integer) is like %X, |
---|
1181 | but takes up at least N (a number) positions. |
---|
1182 | The modifiers are `E' and `O'. For certain characters X, |
---|
1183 | %EX is a locale's alternative version of %X; |
---|
1184 | %OX is like %X, but uses the locale's number symbols. |
---|
1185 | |
---|
1186 | For example, to produce full ISO 8601 format, use \"%Y-%m-%dT%T%z\". |
---|
1187 | |
---|
1188 | Compatibility Note. |
---|
1189 | |
---|
1190 | The the third optional argument universal is yet to be implemented. |
---|
1191 | Those format constructs are yet to be implemented. |
---|
1192 | %c, %C, %j, %U, %W, %x, %X |
---|
1193 | Not fully compatible especially when invalid format is specified." |
---|
1194 | (let ((fmt-len (length format)) |
---|
1195 | (ind 0) |
---|
1196 | prev-ind |
---|
1197 | cur-char |
---|
1198 | (prev-char nil) |
---|
1199 | strings-so-far |
---|
1200 | (result "") |
---|
1201 | field-width |
---|
1202 | field-result |
---|
1203 | pad-left change-case |
---|
1204 | (paren-level 0) |
---|
1205 | hour |
---|
1206 | (time-string (current-time-string time))) |
---|
1207 | (setq hour (string-to-int (substring time-string 11 13))) |
---|
1208 | (while (< ind fmt-len) |
---|
1209 | (setq cur-char (aref format ind)) |
---|
1210 | (setq |
---|
1211 | result |
---|
1212 | (concat result |
---|
1213 | (cond |
---|
1214 | ((eq cur-char ?%) |
---|
1215 | ;; eat any additional args to allow for future expansion, not!! |
---|
1216 | (setq pad-left nil change-case nil field-width "" prev-ind ind |
---|
1217 | strings-so-far "") |
---|
1218 | ; (catch 'invalid |
---|
1219 | (while (progn |
---|
1220 | (setq ind (1+ ind)) |
---|
1221 | (setq cur-char (if (< ind fmt-len) |
---|
1222 | (aref format ind) |
---|
1223 | ?\0)) |
---|
1224 | (or (eq ?- cur-char) ; pad on left |
---|
1225 | (eq ?# cur-char) ; case change |
---|
1226 | (if (and (string-equal field-width "") |
---|
1227 | (<= ?0 cur-char) (>= ?9 cur-char)) |
---|
1228 | ;; get format width |
---|
1229 | (let ((field-index ind)) |
---|
1230 | (while (progn |
---|
1231 | (setq ind (1+ ind)) |
---|
1232 | (setq cur-char (if (< ind fmt-len) |
---|
1233 | (aref format ind) |
---|
1234 | ?\0)) |
---|
1235 | (and (<= ?0 cur-char) (>= ?9 cur-char)))) |
---|
1236 | (setq field-width |
---|
1237 | (substring format field-index ind)) |
---|
1238 | (setq ind (1- ind) |
---|
1239 | cur-char nil) |
---|
1240 | t)))) |
---|
1241 | (setq prev-char cur-char |
---|
1242 | strings-so-far (concat strings-so-far |
---|
1243 | (if cur-char |
---|
1244 | (char-to-string cur-char) |
---|
1245 | field-width))) |
---|
1246 | ;; characters we actually use |
---|
1247 | (cond ((eq cur-char ?-) |
---|
1248 | ;; padding to left must be specified before field-width |
---|
1249 | (setq pad-left (string-equal field-width ""))) |
---|
1250 | ((eq cur-char ?#) |
---|
1251 | (setq change-case t)))) |
---|
1252 | (setq field-result |
---|
1253 | (cond |
---|
1254 | ((eq cur-char ?%) |
---|
1255 | "%") |
---|
1256 | ;; the abbreviated name of the day of week. |
---|
1257 | ((eq cur-char ?a) |
---|
1258 | (substring time-string 0 3)) |
---|
1259 | ;; the full name of the day of week |
---|
1260 | ((eq cur-char ?A) |
---|
1261 | (cadr (assoc (substring time-string 0 3) |
---|
1262 | format-time-week-list))) |
---|
1263 | ;; the abbreviated name of the month |
---|
1264 | ((eq cur-char ?b) |
---|
1265 | (substring time-string 4 7)) |
---|
1266 | ;; the full name of the month |
---|
1267 | ((eq cur-char ?B) |
---|
1268 | (cadr (assoc (substring time-string 4 7) |
---|
1269 | format-time-month-list))) |
---|
1270 | ;; a synonym for `%x %X' (yet to come) |
---|
1271 | ((eq cur-char ?c) |
---|
1272 | "") |
---|
1273 | ;; locale specific (yet to come) |
---|
1274 | ((eq cur-char ?C) |
---|
1275 | "") |
---|
1276 | ;; the day of month, zero-padded |
---|
1277 | ((eq cur-char ?d) |
---|
1278 | (format "%02d" (string-to-int (substring time-string 8 10)))) |
---|
1279 | ;; a synonym for `%m/%d/%y' |
---|
1280 | ((eq cur-char ?D) |
---|
1281 | (format "%02d/%02d/%s" |
---|
1282 | (cddr (assoc (substring time-string 4 7) |
---|
1283 | format-time-month-list)) |
---|
1284 | (string-to-int (substring time-string 8 10)) |
---|
1285 | (substring time-string -2))) |
---|
1286 | ;; the day of month, blank-padded |
---|
1287 | ((eq cur-char ?e) |
---|
1288 | (format "%2d" (string-to-int (substring time-string 8 10)))) |
---|
1289 | ;; a synonym for `%b' |
---|
1290 | ((eq cur-char ?h) |
---|
1291 | (substring time-string 4 7)) |
---|
1292 | ;; the hour (00-23) |
---|
1293 | ((eq cur-char ?H) |
---|
1294 | (substring time-string 11 13)) |
---|
1295 | ;; the hour (00-12) |
---|
1296 | ((eq cur-char ?I) |
---|
1297 | (format "%02d" (if (> hour 12) (- hour 12) hour))) |
---|
1298 | ;; the day of the year (001-366) (yet to come) |
---|
1299 | ((eq cur-char ?j) |
---|
1300 | "") |
---|
1301 | ;; the hour (0-23), blank padded |
---|
1302 | ((eq cur-char ?k) |
---|
1303 | (format "%2d" hour)) |
---|
1304 | ;; the hour (1-12), blank padded |
---|
1305 | ((eq cur-char ?l) |
---|
1306 | (format "%2d" (if (> hour 12) (- hour 12) hour))) |
---|
1307 | ;; the month (01-12) |
---|
1308 | ((eq cur-char ?m) |
---|
1309 | (format "%02d" (cddr (assoc (substring time-string 4 7) |
---|
1310 | format-time-month-list)))) |
---|
1311 | ;; the minute (00-59) |
---|
1312 | ((eq cur-char ?M) |
---|
1313 | (substring time-string 14 16)) |
---|
1314 | ;; a newline |
---|
1315 | ((eq cur-char ?n) |
---|
1316 | "\n") |
---|
1317 | ;; `AM' or `PM', as appropriate |
---|
1318 | ((eq cur-char ?p) |
---|
1319 | (setq change-case (not change-case)) |
---|
1320 | (if (> hour 12) "pm" "am")) |
---|
1321 | ;; a synonym for `%I:%M:%S %p' |
---|
1322 | ((eq cur-char ?r) |
---|
1323 | (format "%02d:%s:%s %s" |
---|
1324 | (if (> hour 12) (- hour 12) hour) |
---|
1325 | (substring time-string 14 16) |
---|
1326 | (substring time-string 17 19) |
---|
1327 | (if (> hour 12) "PM" "AM"))) |
---|
1328 | ;; a synonym for `%H:%M' |
---|
1329 | ((eq cur-char ?R) |
---|
1330 | (format "%s:%s" |
---|
1331 | (substring time-string 11 13) |
---|
1332 | (substring time-string 14 16))) |
---|
1333 | ;; the seconds (00-60) |
---|
1334 | ((eq cur-char ?S) |
---|
1335 | (substring time-string 17 19)) |
---|
1336 | ;; a tab character |
---|
1337 | ((eq cur-char ?t) |
---|
1338 | "\t") |
---|
1339 | ;; a synonym for `%H:%M:%S' |
---|
1340 | ((eq cur-char ?T) |
---|
1341 | (format "%s:%s:%s" |
---|
1342 | (substring time-string 11 13) |
---|
1343 | (substring time-string 14 16) |
---|
1344 | (substring time-string 17 19))) |
---|
1345 | ;; the week of the year (01-52), assuming that weeks |
---|
1346 | ;; start on Sunday (yet to come) |
---|
1347 | ((eq cur-char ?U) |
---|
1348 | "") |
---|
1349 | ;; the numeric day of week (0-6). Sunday is day 0 |
---|
1350 | ((eq cur-char ?w) |
---|
1351 | (format "%d" (cddr (assoc (substring time-string 0 3) |
---|
1352 | format-time-week-list)))) |
---|
1353 | ;; the week of the year (01-52), assuming that weeks |
---|
1354 | ;; start on Monday (yet to come) |
---|
1355 | ((eq cur-char ?W) |
---|
1356 | "") |
---|
1357 | ;; locale specific (yet to come) |
---|
1358 | ((eq cur-char ?x) |
---|
1359 | "") |
---|
1360 | ;; locale specific (yet to come) |
---|
1361 | ((eq cur-char ?X) |
---|
1362 | "") |
---|
1363 | ;; the year without century (00-99) |
---|
1364 | ((eq cur-char ?y) |
---|
1365 | (substring time-string -2)) |
---|
1366 | ;; the year with century |
---|
1367 | ((eq cur-char ?Y) |
---|
1368 | (substring time-string -4)) |
---|
1369 | ;; the time zone abbreviation |
---|
1370 | ((eq cur-char ?Z) |
---|
1371 | (setq change-case (not change-case)) |
---|
1372 | (downcase (cadr (current-time-zone)))) |
---|
1373 | (t |
---|
1374 | (concat |
---|
1375 | "%" |
---|
1376 | strings-so-far |
---|
1377 | (char-to-string cur-char))))) |
---|
1378 | ; (setq ind prev-ind) |
---|
1379 | ; (throw 'invalid "%")))) |
---|
1380 | (if (string-equal field-width "") |
---|
1381 | (if change-case (upcase field-result) field-result) |
---|
1382 | (let ((padded-result |
---|
1383 | (format (format "%%%s%s%c" |
---|
1384 | "" ; pad on left is ignored |
---|
1385 | ; (if pad-left "-" "") |
---|
1386 | field-width |
---|
1387 | ?s) |
---|
1388 | (or field-result "")))) |
---|
1389 | (let ((initial-length (length padded-result)) |
---|
1390 | (desired-length (string-to-int field-width))) |
---|
1391 | (when (and (string-match "^0" field-width) |
---|
1392 | (string-match "^ +" padded-result)) |
---|
1393 | (setq padded-result |
---|
1394 | (replace-match |
---|
1395 | (make-string |
---|
1396 | (length (match-string 0 padded-result)) ?0) |
---|
1397 | nil nil padded-result))) |
---|
1398 | (if (> initial-length desired-length) |
---|
1399 | ;; truncate strings on right, years on left |
---|
1400 | (if (stringp field-result) |
---|
1401 | (substring padded-result 0 desired-length) |
---|
1402 | (if (eq cur-char ?y) |
---|
1403 | (substring padded-result (- desired-length)) |
---|
1404 | padded-result))) ;non-year numbers don't truncate |
---|
1405 | (if change-case (upcase padded-result) padded-result))))) ;) |
---|
1406 | (t |
---|
1407 | (char-to-string cur-char))))) |
---|
1408 | (setq ind (1+ ind))) |
---|
1409 | result)) |
---|
1410 | ;; for `load-history'. |
---|
1411 | (setq current-load-list (cons 'format-time-string current-load-list)) |
---|
1412 | (put 'format-time-string 'defun-maybe t)))) |
---|
1413 | |
---|
1414 | ;; Emacs 20.1/XEmacs 20.3(?) and later: (split-string STRING &optional PATTERN) |
---|
1415 | ;; Here is a XEmacs version. |
---|
1416 | (defun-maybe split-string (string &optional pattern) |
---|
1417 | "Return a list of substrings of STRING which are separated by PATTERN. |
---|
1418 | If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." |
---|
1419 | (or pattern |
---|
1420 | (setq pattern "[ \f\t\n\r\v]+")) |
---|
1421 | ;; The FSF version of this function takes care not to cons in case |
---|
1422 | ;; of infloop. Maybe we should synch? |
---|
1423 | (let (parts (start 0)) |
---|
1424 | (while (string-match pattern string start) |
---|
1425 | (setq parts (cons (substring string start (match-beginning 0)) parts) |
---|
1426 | start (match-end 0))) |
---|
1427 | (nreverse (cons (substring string start) parts)))) |
---|
1428 | |
---|
1429 | |
---|
1430 | ;;; @ Window commands emulation. (lisp/window.el) |
---|
1431 | ;;; |
---|
1432 | |
---|
1433 | (defmacro-maybe save-selected-window (&rest body) |
---|
1434 | "Execute BODY, then select the window that was selected before BODY." |
---|
1435 | (list 'let |
---|
1436 | '((save-selected-window-window (selected-window))) |
---|
1437 | (list 'unwind-protect |
---|
1438 | (cons 'progn body) |
---|
1439 | (list 'select-window 'save-selected-window-window)))) |
---|
1440 | |
---|
1441 | ;; Emacs 19.31 and later: |
---|
1442 | ;; (get-buffer-window-list &optional BUFFER MINIBUF FRAME) |
---|
1443 | (defun-maybe get-buffer-window-list (buffer &optional minibuf frame) |
---|
1444 | "Return windows currently displaying BUFFER, or nil if none. |
---|
1445 | See `walk-windows' for the meaning of MINIBUF and FRAME." |
---|
1446 | (let ((buffer (if (bufferp buffer) buffer (get-buffer buffer))) windows) |
---|
1447 | (walk-windows |
---|
1448 | (function (lambda (window) |
---|
1449 | (if (eq (window-buffer window) buffer) |
---|
1450 | (setq windows (cons window windows))))) |
---|
1451 | minibuf frame) |
---|
1452 | windows)) |
---|
1453 | |
---|
1454 | |
---|
1455 | ;;; @ Frame commands emulation. (lisp/frame.el) |
---|
1456 | ;;; |
---|
1457 | |
---|
1458 | ;; XEmacs 21.0 and later: |
---|
1459 | ;; (save-selected-frame &rest BODY) |
---|
1460 | (defmacro-maybe save-selected-frame (&rest body) |
---|
1461 | "Execute forms in BODY, then restore the selected frame." |
---|
1462 | (list 'let |
---|
1463 | '((save-selected-frame-frame (selected-frame))) |
---|
1464 | (list 'unwind-protect |
---|
1465 | (cons 'progn body) |
---|
1466 | (list 'select-frame 'save-selected-frame-frame)))) |
---|
1467 | |
---|
1468 | |
---|
1469 | ;;; @ Basic editing commands emulation. (lisp/simple.el) |
---|
1470 | ;;; |
---|
1471 | |
---|
1472 | |
---|
1473 | ;;; @ File input and output commands emulation. (lisp/files.el) |
---|
1474 | ;;; |
---|
1475 | |
---|
1476 | (defvar-maybe temporary-file-directory |
---|
1477 | (file-name-as-directory |
---|
1478 | (cond ((memq system-type '(ms-dos windows-nt)) |
---|
1479 | (or (getenv "TEMP") (getenv "TMPDIR") (getenv "TMP") "c:/temp")) |
---|
1480 | ((memq system-type '(vax-vms axp-vms)) |
---|
1481 | (or (getenv "TMPDIR") (getenv "TMP") (getenv "TEMP") "SYS$SCRATCH:")) |
---|
1482 | (t |
---|
1483 | (or (getenv "TMPDIR") (getenv "TMP") (getenv "TEMP") "/tmp")))) |
---|
1484 | "The directory for writing temporary files.") |
---|
1485 | |
---|
1486 | ;; Actually, `path-separator' is defined in src/emacs.c and overrided |
---|
1487 | ;; in dos-w32.el. |
---|
1488 | (defvar-maybe path-separator ":" |
---|
1489 | "The directory separator in search paths, as a string.") |
---|
1490 | |
---|
1491 | ;; `convert-standard-filename' is defined in lisp/files.el and overrided |
---|
1492 | ;; in lisp/dos-fns.el and lisp/w32-fns.el for each environment. |
---|
1493 | (cond |
---|
1494 | ;; must be load-time check to share .elc between different systems. |
---|
1495 | ((fboundp 'convert-standard-filename)) |
---|
1496 | ((memq system-type '(windows-nt ms-dos)) |
---|
1497 | ;; should we do (require 'filename) at load-time ? |
---|
1498 | ;; (require 'filename) |
---|
1499 | ;; filename.el requires many modules, so we do not want to load it |
---|
1500 | ;; at compile-time. Instead, suppress warnings by these autoloads. |
---|
1501 | (eval-when-compile |
---|
1502 | (autoload 'filename-maybe-truncate-by-size "filename") |
---|
1503 | (autoload 'filename-special-filter "filename")) |
---|
1504 | (defun convert-standard-filename (filename) |
---|
1505 | "Convert a standard file's name to something suitable for the current OS. |
---|
1506 | This function's standard definition is trivial; it just returns the argument. |
---|
1507 | However, on some systems, the function is redefined |
---|
1508 | with a definition that really does change some file names. |
---|
1509 | Under `windows-nt' or `ms-dos', it refers `filename-replacement-alist' and |
---|
1510 | `filename-limit-length' for the basic filename and each parent directory name." |
---|
1511 | (require 'filename) |
---|
1512 | (let* ((names (split-string filename "/")) |
---|
1513 | (drive-name (car names)) |
---|
1514 | (filter (function |
---|
1515 | (lambda (string) |
---|
1516 | (filename-maybe-truncate-by-size |
---|
1517 | (filename-special-filter string)))))) |
---|
1518 | (cond |
---|
1519 | ((eq 1 (length names)) |
---|
1520 | (funcall filter drive-name)) |
---|
1521 | ((string-match "^[^/]:$" drive-name) |
---|
1522 | (concat drive-name "/" (mapconcat filter (cdr names) "/"))) |
---|
1523 | (t |
---|
1524 | (mapconcat filter names "/")))))) |
---|
1525 | (t |
---|
1526 | (defun convert-standard-filename (filename) |
---|
1527 | "Convert a standard file's name to something suitable for the current OS. |
---|
1528 | This function's standard definition is trivial; it just returns the argument. |
---|
1529 | However, on some systems, the function is redefined |
---|
1530 | with a definition that really does change some file names. |
---|
1531 | Under `windows-nt' or `ms-dos', it refers `filename-replacement-alist' and |
---|
1532 | `filename-limit-length' for the basic filename and each parent directory name." |
---|
1533 | filename))) |
---|
1534 | |
---|
1535 | (static-cond |
---|
1536 | ((fboundp 'insert-file-contents-literally)) |
---|
1537 | ((boundp 'file-name-handler-alist) |
---|
1538 | ;; Use `defun-maybe' to update `load-history'. |
---|
1539 | (defun-maybe insert-file-contents-literally (filename &optional visit |
---|
1540 | beg end replace) |
---|
1541 | "Like `insert-file-contents', q.v., but only reads in the file. |
---|
1542 | A buffer may be modified in several ways after reading into the buffer due |
---|
1543 | to advanced Emacs features, such as file-name-handlers, format decoding, |
---|
1544 | find-file-hooks, etc. |
---|
1545 | This function ensures that none of these modifications will take place." |
---|
1546 | (let (file-name-handler-alist) |
---|
1547 | (insert-file-contents filename visit beg end replace)))) |
---|
1548 | (t |
---|
1549 | (defalias 'insert-file-contents-literally 'insert-file-contents))) |
---|
1550 | |
---|
1551 | (defun-maybe file-name-sans-extension (filename) |
---|
1552 | "Return FILENAME sans final \"extension\". |
---|
1553 | The extension, in a file name, is the part that follows the last `.'." |
---|
1554 | (save-match-data |
---|
1555 | (let ((file (file-name-sans-versions (file-name-nondirectory filename))) |
---|
1556 | directory) |
---|
1557 | (if (string-match "\\.[^.]*\\'" file) |
---|
1558 | (if (setq directory (file-name-directory filename)) |
---|
1559 | (expand-file-name (substring file 0 (match-beginning 0)) |
---|
1560 | directory) |
---|
1561 | (substring file 0 (match-beginning 0))) |
---|
1562 | filename)))) |
---|
1563 | |
---|
1564 | |
---|
1565 | ;;; @ Miscellanea. |
---|
1566 | |
---|
1567 | ;; Emacs 19.29 and later: (current-fill-column) |
---|
1568 | (defun-maybe current-fill-column () |
---|
1569 | "Return the fill-column to use for this line." |
---|
1570 | fill-column) |
---|
1571 | |
---|
1572 | ;; Emacs 19.29 and later: (current-left-margin) |
---|
1573 | (defun-maybe current-left-margin () |
---|
1574 | "Return the left margin to use for this line." |
---|
1575 | left-margin) |
---|
1576 | |
---|
1577 | |
---|
1578 | ;;; @ XEmacs emulation. |
---|
1579 | ;;; |
---|
1580 | |
---|
1581 | (defun-maybe find-face (face-or-name) |
---|
1582 | "Retrieve the face of the given name. |
---|
1583 | If FACE-OR-NAME is a face object, it is simply returned. |
---|
1584 | Otherwise, FACE-OR-NAME should be a symbol. If there is no such face, |
---|
1585 | nil is returned. Otherwise the associated face object is returned." |
---|
1586 | (car (memq face-or-name (face-list)))) |
---|
1587 | |
---|
1588 | ;; Emacs 21.1 defines this as an alias for `line-beginning-position'. |
---|
1589 | ;; Therefore, optional 2nd arg BUFFER is not portable. |
---|
1590 | (defun-maybe point-at-bol (&optional n buffer) |
---|
1591 | "Return the character position of the first character on the current line. |
---|
1592 | With argument N not nil or 1, move forward N - 1 lines first. |
---|
1593 | If scan reaches end of buffer, return that position. |
---|
1594 | This function does not move point." |
---|
1595 | (save-excursion |
---|
1596 | (if buffer (set-buffer buffer)) |
---|
1597 | (forward-line (1- (or n 1))) |
---|
1598 | (point))) |
---|
1599 | |
---|
1600 | ;; Emacs 21.1 defines this as an alias for `line-end-position'. |
---|
1601 | ;; Therefore, optional 2nd arg BUFFER is not portable. |
---|
1602 | (defun-maybe point-at-eol (&optional n buffer) |
---|
1603 | "Return the character position of the last character on the current line. |
---|
1604 | With argument N not nil or 1, move forward N - 1 lines first. |
---|
1605 | If scan reaches end of buffer, return that position. |
---|
1606 | This function does not move point." |
---|
1607 | (save-excursion |
---|
1608 | (if buffer (set-buffer buffer)) |
---|
1609 | (end-of-line (or n 1)) |
---|
1610 | (point))) |
---|
1611 | |
---|
1612 | (defsubst-maybe define-obsolete-function-alias (oldfun newfun) |
---|
1613 | "Define OLDFUN as an obsolete alias for function NEWFUN. |
---|
1614 | This makes calling OLDFUN equivalent to calling NEWFUN and marks OLDFUN |
---|
1615 | as obsolete." |
---|
1616 | (defalias oldfun newfun) |
---|
1617 | (make-obsolete oldfun newfun)) |
---|
1618 | |
---|
1619 | ;; XEmacs 21: (character-to-event CH &optional EVENT DEVICE) |
---|
1620 | (defun-maybe character-to-event (ch) |
---|
1621 | "Convert keystroke CH into an event structure, replete with bucky bits. |
---|
1622 | Note that CH (the keystroke specifier) can be an integer, a character |
---|
1623 | or a symbol such as 'clear." |
---|
1624 | ch) |
---|
1625 | |
---|
1626 | ;; XEmacs 21: (event-to-character EVENT |
---|
1627 | ;; &optional ALLOW-EXTRA-MODIFIERS ALLOW-META ALLOW-NON-ASCII) |
---|
1628 | (defun-maybe-cond event-to-character (event) |
---|
1629 | "Return the character approximation to the given event object. |
---|
1630 | If the event isn't a keypress, this returns nil." |
---|
1631 | ((and (fboundp 'read-event) |
---|
1632 | (subrp (symbol-function 'read-event))) |
---|
1633 | ;; Emacs 19 and later. |
---|
1634 | (cond |
---|
1635 | ((symbolp event) |
---|
1636 | ;; mask is (BASE-TYPE MODIFIER-BITS) or nil. |
---|
1637 | (let ((mask (get event 'event-symbol-element-mask))) |
---|
1638 | (if mask |
---|
1639 | (let ((base (get (car mask) 'ascii-character))) |
---|
1640 | (if base |
---|
1641 | (logior base (car (cdr mask)))))))) |
---|
1642 | ((integerp event) event))) |
---|
1643 | (t |
---|
1644 | ;; v18. Is this correct? |
---|
1645 | event)) |
---|
1646 | |
---|
1647 | ;; v18: no event; (read-char) |
---|
1648 | ;; Emacs 19, 20.1 and 20.2: (read-event) |
---|
1649 | ;; Emacs 20.3: (read-event &optional PROMPT SUPPRESS-INPUT-METHOD) |
---|
1650 | ;; Emacs 20.4: (read-event &optional PROMPT INHERIT-INPUT-METHOD) |
---|
1651 | ;; XEmacs: (next-event &optional EVENT PROMPT), |
---|
1652 | ;; (next-command-event &optional EVENT PROMPT) |
---|
1653 | (defun-maybe-cond next-command-event (&optional event prompt) |
---|
1654 | "Read an event object from the input stream. |
---|
1655 | If EVENT is non-nil, it should be an event object and will be filled |
---|
1656 | in and returned; otherwise a new event object will be created and |
---|
1657 | returned. |
---|
1658 | If PROMPT is non-nil, it should be a string and will be displayed in |
---|
1659 | the echo area while this function is waiting for an event." |
---|
1660 | ((and (>= emacs-major-version 20) |
---|
1661 | (>= emacs-minor-version 4)) |
---|
1662 | ;; Emacs 20.4 and later. |
---|
1663 | (read-event prompt)) ; should specify 2nd arg? |
---|
1664 | ((and (= emacs-major-version 20) |
---|
1665 | (= emacs-minor-version 3)) |
---|
1666 | ;; Emacs 20.3. |
---|
1667 | (read-event prompt)) ; should specify 2nd arg? |
---|
1668 | ((and (fboundp 'read-event) |
---|
1669 | (subrp (symbol-function 'read-event))) |
---|
1670 | ;; Emacs 19, 20.1 and 20.2. |
---|
1671 | (if prompt (message prompt)) |
---|
1672 | (read-event)) |
---|
1673 | (t |
---|
1674 | (if prompt (message prompt)) |
---|
1675 | (read-char))) |
---|
1676 | |
---|
1677 | |
---|
1678 | ;;; @ MULE 2 emulation. |
---|
1679 | ;;; |
---|
1680 | |
---|
1681 | (defun-maybe-cond cancel-undo-boundary () |
---|
1682 | "Cancel undo boundary." |
---|
1683 | ((boundp 'buffer-undo-list) |
---|
1684 | ;; for Emacs 19 and later. |
---|
1685 | (if (and (consp buffer-undo-list) |
---|
1686 | (null (car buffer-undo-list))) |
---|
1687 | (setq buffer-undo-list (cdr buffer-undo-list))))) |
---|
1688 | |
---|
1689 | |
---|
1690 | ;;; @ End. |
---|
1691 | ;;; |
---|
1692 | |
---|
1693 | ;;; poe.el ends here |
---|