X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=poe-18.el;h=0dffa0e52aef35a0bf2dd6fea58d5ed71347f0f5;hb=88c8299d6a8a3da16b3054a976ccf2e94ee57fd6;hp=edba3e069877785631ed4d95160d09d68bcc5b92;hpb=49556b1eb338487d82a3c463aa583e9d13fda6b2;p=elisp%2Fapel.git diff --git a/poe-18.el b/poe-18.el index edba3e0..0dffa0e 100644 --- a/poe-18.el +++ b/poe-18.el @@ -22,8 +22,8 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Commentary: @@ -50,15 +50,13 @@ ;;; @ Compilation. ;;; - (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 +226,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' (Emacs 19 emulating function by APEL).") (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' (Emacs 19 emulating function by APEL).") + +(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 +262,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 +357,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 +402,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) @@ -441,13 +452,10 @@ resolution finer than a second." ;;; @@ Floating point numbers. ;;; -(defalias 'numberp 'integerp) - (defun abs (arg) "Return the absolute value of ARG." (if (< arg 0) (- arg) arg)) - ;;; @ Basic lisp subroutines. ;;; @@ -476,16 +484,49 @@ 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. -(defvar buffer-undo-list nil) +;; 18.55 does not have these variables. +(defvar-maybe buffer-undo-list nil + "List of undo entries in current buffer. +APEL provides this as dummy for a compatibility.") + +(defvar-maybe auto-fill-function nil + "Function called (if non-nil) to perform auto-fill. +APEL provides this as dummy for a compatibility.") + +(defvar-maybe unread-command-event nil + "APEL provides this as dummy for a compatibility.") +(defvar-maybe unread-command-events nil + "List of events to be read as the command input. +APEL provides this as dummy for a compatibility.") -(defalias 'buffer-disable-undo 'buffer-flush-undo) +;; (defvar-maybe minibuffer-setup-hook nil +;; "Normal hook run just after entry to minibuffer.") +;; (defvar-maybe minibuffer-exit-hook nil +;; "Normal hook run just after exit from minibuffer.") + +(defvar-maybe minor-mode-map-alist nil + "Alist of keymaps to use for minor modes. +APEL provides this as dummy for a compatibility.") + +(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 +548,98 @@ even if a buffer with that name exists." (defun mark (&optional force) (si:mark)) +(defun-maybe window-minibuffer-p (&optional window) +"Return non-nil if WINDOW is a minibuffer window." + (eq (or window (selected-window)) (minibuffer-window))) + +(defun-maybe window-live-p (obj) + "Returns t if OBJECT is a window which is currently visible." + (and (windowp obj) + (or (eq obj (minibuffer-window)) + (eq obj (get-buffer-window (window-buffer obj)))))) + +;; 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 implementation." + (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 argument 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 argument 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)))) + +(defun buffer-disable-undo (&optional buffer) + "Make BUFFER stop keeping undo information. +No argument or nil as argument means do this for the current buffer." + (buffer-flush-undo (or buffer (current-buffer)))) + + +;;; @@ Frame (Emacs 18 cannot make frame) +;;; +;; The following four are frequently used for manipulating the current frame. +;; frame.el has `screen-width', `screen-height', `set-screen-width' and +;; `set-screen-height' for backward compatibility and declare them as obsolete. +(defun frame-width (&optional frame) + "Return number of columns available for display on FRAME. +If FRAME is omitted, describe the currently selected frame." + (screen-width)) + +(defun frame-height (&optional frame) + "Return number of lines available for display on FRAME. +If FRAME is omitted, describe the currently selected frame." + (screen-height)) + +(defun set-frame-width (frame cols &optional pretend) + "Specify that the frame FRAME has COLS columns. +Optional third arg non-nil means that redisplay should use COLS columns +but that the idea of the actual width of the frame should not be changed." + (set-screen-width cols pretend)) + +(defun set-frame-height (frame lines &optional pretend) + "Specify that the frame FRAME has LINES lines. +Optional third arg non-nil means that redisplay should use LINES lines +but that the idea of the actual height of the frame should not be changed." + (set-screen-height lines pretend)) ;;; @@ Environment variables. ;;; @@ -535,10 +668,17 @@ For a directory, this means you can access files in that directory." (defun make-directory-internal (dirname) "Create a directory. One argument, a file name string." - (let ((dir (expand-file-name dirname))) - (if (file-exists-p dir) - (error "Creating directory: %s is already exist" dir) - (call-process "mkdir" nil nil nil dir)))) + (let ((dir (expand-file-name dirname))) + (if (file-exists-p dir) + (signal 'file-already-exists + (list "Creating directory: %s already exists" dir)) + (let ((exit-status (call-process "mkdir" nil nil nil dir))) + (if (or (and (numberp exit-status) + (not (zerop exit-status))) + (stringp exit-status)) + (error "Create directory %s failed.") + ;; `make-directory' of v19 and later returns nil for success. + ))))) (defun make-directory (dir &optional parents) "Create the directory DIR and any nonexistent parent dirs. @@ -562,6 +702,13 @@ to create parent directories if they don't exist." (setq p p1))) (make-directory-internal dir))) +(defun delete-directory (directory) + "Delete the directory named DIRECTORY. Does not follow symlinks." + (let ((exit-status (call-process "rmdir" nil nil nil directory))) + (when (or (and (numberp exit-status) (not (zerop exit-status))) + (stringp exit-status)) + (error "Delete directory %s failed.")))) + (defun parse-colon-path (cd-path) "Explode a colon-separated list of paths into a string list." (and cd-path @@ -600,6 +747,51 @@ 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)) +(or (fboundp 'si:write-region) + (fset 'si:write-region (symbol-function 'write-region))) +(defun write-region (start end filename &optional append visit) + "Write current region into specified file. +When called from a program, requires three arguments: +START, END and FILENAME. START and END are normally buffer positions +specifying the part of the buffer to write. +If START is nil, that means to use the entire buffer contents. +If START is a string, then output that string to the file +instead of any buffer contents; END is ignored. + +Optional fourth argument APPEND if non-nil means + append to existing file contents (if any). If it is an integer, + seek to that offset in the file before writing. +Optional fifth argument VISIT if t means + set the last-save-file-modtime of buffer to this file's modtime + and mark buffer not modified. +If VISIT is a string, it is a second file name; + the output goes to FILENAME, but the buffer is marked as visiting VISIT. + VISIT is also the file name to lock and unlock for clash detection. +If VISIT is neither t nor nil nor a string, + that means do not display the \"Wrote file\" message." + (cond + ((null start) + (si:write-region (point-min) (point-max) filename append visit)) + ((stringp start) + (with-temp-buffer + (insert start) + (si:write-region (point-min) (point-max) filename append visit))) + (t + (si:write-region start end filename append visit)))) + +;;; @ 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 +805,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 +821,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. ;;;