Index: /branches/ide-1.0/ccl/hemlock/src/archive/bit-display.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/archive/bit-display.lisp (revision 6567) +++ /branches/ide-1.0/ccl/hemlock/src/archive/bit-display.lisp (revision 6567) @@ -0,0 +1,292 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Written by Rob MacLachlan +;;; Modified by Bill Chiles to run under X on IBM RT's. +;;; + +(in-package :hemlock-internals) + + + +;;; prepare-window-for-redisplay -- Internal +;;; +;;; Called by make-window to do whatever redisplay wants to set up +;;; a new window. +;;; +(defun prepare-window-for-redisplay (window) + (setf (window-old-lines window) 0)) + + + + +;;;; Dumb window redisplay. + +;;; DUMB-WINDOW-REDISPLAY redraws an entire window using dumb-line-redisplay. +;;; This assumes the cursor has been lifted if necessary. +;;; +(defun dumb-window-redisplay (window) + (let* ((hunk (window-hunk window)) + (first (window-first-line window))) + (hunk-reset hunk) + (do ((i 0 (1+ i)) + (dl (cdr first) (cdr dl))) + ((eq dl *the-sentinel*) + (setf (window-old-lines window) (1- i))) + (dumb-line-redisplay hunk (car dl))) + (setf (window-first-changed window) *the-sentinel* + (window-last-changed window) first) + (when (window-modeline-buffer window) + (hunk-replace-modeline hunk) + (setf (dis-line-flags (window-modeline-dis-line window)) + unaltered-bits)) + (setf (bitmap-hunk-start hunk) (cdr (window-first-line window))))) + + +;;; DUMB-LINE-REDISPLAY is used when the line is known to be cleared already. +;;; +(defun dumb-line-redisplay (hunk dl) + (hunk-write-line hunk dl) + (setf (dis-line-flags dl) unaltered-bits (dis-line-delta dl) 0)) + + + + +;;;; Smart window redisplay. + +;;; We scan through the changed dis-lines, and condense the information +;;; obtained into five categories: Unchanged lines moved down, unchanged +;;; lines moved up, lines that need to be cleared, lines that are in the +;;; same place (but changed), and new or moved-and-changed lines to write. +;;; Each such instance of a thing that needs to be done is remembered be +;;; throwing needed information on a stack specific to the thing to be +;;; done. We cannot do any of these things right away because each may +;;; confict with the previous. +;;; +;;; Each stack is represented by a simple-vector big enough to hold the +;;; worst-case number of entries and a pointer to the next free entry. The +;;; pointers are local variables returned from COMPUTE-CHANGES and used by +;;; SMART-WINDOW-REDISPLAY. Note that the order specified in these tuples +;;; is the order in which they were pushed. +;;; +(defvar *display-down-move-stack* (make-array (* hunk-height-limit 2)) + "This is the vector that we stash info about which lines moved down in + as (Start, End, Count) triples.") +(defvar *display-up-move-stack* (make-array (* hunk-height-limit 2)) + "This is the vector that we stash info about which lines moved up in + as (Start, End, Count) triples.") +(defvar *display-erase-stack* (make-array hunk-height-limit) + "This is the vector that we stash info about which lines need to be erased + as (Start, Count) pairs.") +(defvar *display-write-stack* (make-array hunk-height-limit) + "This is the vector that we stash dis-lines in that need to be written.") +(defvar *display-rewrite-stack* (make-array hunk-height-limit) + "This is the vector that we stash dis-lines in that need to be written. + with clear-to-end.") + +;;; Accessor macros to push and pop on the stacks: +;;; +(eval-when (:compile-toplevel :execute) + +(defmacro spush (thing stack stack-pointer) + `(progn + (setf (svref ,stack ,stack-pointer) ,thing) + (incf ,stack-pointer))) + +(defmacro spop (stack stack-pointer) + `(svref ,stack (decf ,stack-pointer))) + +(defmacro snext (stack stack-pointer) + `(prog1 (svref ,stack ,stack-pointer) (incf ,stack-pointer))) + +); eval-when + + +;;; SMART-WINDOW-REDISPLAY only re-writes lines which may have been changed, +;;; and updates them with smart-line-redisplay if not very much has changed. +;;; Lines which have moved are copied. We must be careful not to redisplay +;;; the window with the cursor down since it is not guaranteed to be out of +;;; the way just because we are in redisplay; LIFT-CURSOR is called just before +;;; the screen may be altered, and it takes care to know whether the cursor +;;; is lifted already or not. At the end, if the cursor had been down, +;;; DROP-CURSOR puts it back; it doesn't matter if LIFT-CURSOR was never called +;;; since it does nothing if the cursor is already down. +;;; +(defun smart-window-redisplay (window) + ;; This isn't actually called --GB + (let* ((hunk (window-hunk window)) + (liftp (and (eq *cursor-hunk* hunk) *cursor-dropped*))) + (when (bitmap-hunk-trashed hunk) + (when liftp (lift-cursor)) + (dumb-window-redisplay window) + (when liftp (drop-cursor)) + (return-from smart-window-redisplay nil)) + (let ((first-changed (window-first-changed window)) + (last-changed (window-last-changed window))) + ;; Is there anything to do? + (unless (eq first-changed *the-sentinel*) + (when liftp (lift-cursor)) + (if (and (eq first-changed last-changed) + (zerop (dis-line-delta (car first-changed)))) + ;; One line changed. + (smart-line-redisplay hunk (car first-changed)) + ;; More than one line changed. + (multiple-value-bind (up down erase write rewrite) + (compute-changes first-changed last-changed) + (do-down-moves hunk down) + (do-up-moves hunk up) + (do-erases hunk erase) + (do-writes hunk write) + (do-rewrites hunk rewrite))) + ;; Set the bounds so we know we displayed... + (setf (window-first-changed window) *the-sentinel* + (window-last-changed window) (window-first-line window)))) + ;; + ;; Clear any extra lines at the end of the window. + (let ((pos (dis-line-position (car (window-last-line window))))) + (when (< pos (window-old-lines window)) + (when liftp (lift-cursor)) + (hunk-clear-lines hunk (1+ pos) (- (window-height window) pos 1))) + (setf (window-old-lines window) pos)) + ;; + ;; Update the modeline if needed. + (when (window-modeline-buffer window) + (when (/= (dis-line-flags (window-modeline-dis-line window)) + unaltered-bits) + (hunk-replace-modeline hunk) + (setf (dis-line-flags (window-modeline-dis-line window)) + unaltered-bits))) + ;; + (setf (bitmap-hunk-start hunk) (cdr (window-first-line window))) + (when liftp (drop-cursor)))) + +;;; COMPUTE-CHANGES is used once in smart-window-redisplay, and it scans +;;; through the changed dis-lines in a window, computes the changes needed +;;; to bring the screen into corespondence, and throws the information +;;; needed to do the change onto the apropriate stack. The pointers into +;;; the stacks (up, down, erase, write, and rewrite) are returned. +;;; +;;; The algorithm is as follows: +;;; 1] If the line is moved-and-changed or new then throw the line on +;;; the write stack and increment the clear count. Repeat until no more +;;; such lines are found. +;;; 2] If the line is moved then flush any pending clear, find how many +;;; consecutive lines are moved the same amount, and put the numbers +;;; on the correct move stack. +;;; 3] If the line is changed and unmoved throw it on a write stack. +;;; If a clear is pending throw it in the write stack and bump the clear +;;; count, otherwise throw it on the rewrite stack. +;;; 4] The line is unchanged, do nothing. +;;; +(defun compute-changes (first-changed last-changed) + (let* ((dl first-changed) + (flags (dis-line-flags (car dl))) + (up 0) (down 0) (erase 0) (write 0) (rewrite 0) ;return values. + (clear-count 0) + prev clear-start) + (declare (fixnum up down erase write rewrite clear-count)) + (loop + (cond + ;; Line moved-and-changed or new. + ((> flags moved-bit) + (when (zerop clear-count) + (setq clear-start (dis-line-position (car dl)))) + (loop + (setf (dis-line-delta (car dl)) 0) + (spush (car dl) *display-write-stack* write) + (incf clear-count) + (setq prev dl dl (cdr dl) flags (dis-line-flags (car dl))) + (when (<= flags moved-bit) (return nil)))) + ;; Line moved, unchanged. + ((= flags moved-bit) + (unless (zerop clear-count) + (spush clear-count *display-erase-stack* erase) + (spush clear-start *display-erase-stack* erase) + (setq clear-count 0)) + (do ((delta (dis-line-delta (car dl))) + (end (dis-line-position (car dl))) + (count 1 (1+ count))) + (()) + (setf (dis-line-delta (car dl)) 0 + (dis-line-flags (car dl)) unaltered-bits) + (setq prev dl dl (cdr dl) flags (dis-line-flags (car dl))) + (when (or (/= (dis-line-delta (car dl)) delta) (/= flags moved-bit)) + ;; We push in different order because we pop in different order. + (cond + ((minusp delta) + (spush (- end delta) *display-up-move-stack* up) + (spush end *display-up-move-stack* up) + (spush count *display-up-move-stack* up)) + (t + (spush count *display-down-move-stack* down) + (spush end *display-down-move-stack* down) + (spush (- end delta) *display-down-move-stack* down))) + (return nil)))) + ;; Line changed, unmoved. + ((= flags changed-bit) + (cond ((zerop clear-count) + (spush (car dl) *display-rewrite-stack* rewrite)) + (t + (spush (car dl) *display-write-stack* write) + (incf clear-count))) + (setq prev dl dl (cdr dl) flags (dis-line-flags (car dl)))) + ;; Line unmoved, unchanged. + (t + (unless (zerop clear-count) + (spush clear-count *display-erase-stack* erase) + (spush clear-start *display-erase-stack* erase) + (setq clear-count 0)) + (setq prev dl dl (cdr dl) flags (dis-line-flags (car dl))))) + + (when (eq prev last-changed) + ;; If done flush any pending clear. + (unless (zerop clear-count) + (spush clear-count *display-erase-stack* erase) + (spush clear-start *display-erase-stack* erase)) + (return (values up down erase write rewrite)))))) + +(defun do-up-moves (hunk up) + (do ((i 0)) + ((= i up)) + (hunk-copy-lines hunk (snext *display-up-move-stack* i) + (snext *display-up-move-stack* i) + (snext *display-up-move-stack* i)))) + +(defun do-down-moves (hunk down) + (do () + ((zerop down)) + (hunk-copy-lines hunk (spop *display-down-move-stack* down) + (spop *display-down-move-stack* down) + (spop *display-down-move-stack* down)))) + +(defun do-erases (hunk erase) + (do () + ((zerop erase)) + (hunk-clear-lines hunk (spop *display-erase-stack* erase) + (spop *display-erase-stack* erase)))) + +(defun do-writes (hunk write) + (do ((i 0)) + ((= i write)) + (dumb-line-redisplay hunk (snext *display-write-stack* i)))) + +(defun do-rewrites (hunk rewrite) + (do () + ((zerop rewrite)) + (smart-line-redisplay hunk (spop *display-rewrite-stack* rewrite)))) + + +;;; SMART-LINE-REDISPLAY is called when the screen is mostly the same, +;;; clear to eol after we write it to avoid annoying flicker. +;;; +(defun smart-line-redisplay (hunk dl) + (hunk-replace-line hunk dl) + (setf (dis-line-flags dl) unaltered-bits (dis-line-delta dl) 0)) Index: /branches/ide-1.0/ccl/hemlock/src/archive/bit-screen.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/archive/bit-screen.lisp (revision 6567) +++ /branches/ide-1.0/ccl/hemlock/src/archive/bit-screen.lisp (revision 6567) @@ -0,0 +1,1873 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Screen allocation functions. +;;; +;;; This is the screen management and event handlers for Hemlock under X. +;;; +;;; Written by Bill Chiles, Rob MacLachlan, and Blaine Burks. +;;; + +(in-package :hemlock-internals) + +(declaim (special *echo-area-window*)) + +;;; We have an internal notion of window groups on bitmap devices. Every +;;; Hemlock window has a hunk slot which holds a structure with information +;;; about physical real-estate on some device. Bitmap-hunks have an X window +;;; and a window-group. The X window is a child of the window-group's window. +;;; The echo area, pop-up display window, and the initial window are all in +;;; their own group. +;;; +;;; MAKE-WINDOW splits the current window which is some child window in a group. +;;; If the user supplied an X window, it becomes the parent window of some new +;;; group, and we make a child for the Hemlock window. If the user supplies +;;; ask-user, we prompt for a group/parent window. We link the hunks for +;;; NEXT-WINDOW and PREVIOUS-WINDOW only within a group, so the group maintains +;;; a stack of windows that always fill the entire group window. +;;; + +;;; This is the object set for Hemlock windows. All types of incoming +;;; X events on standard editing windows have the same handlers via this set. +;;; We also include the group/parent windows in here, but they only handle +;;; :configure-notify events. +;;; +(defvar *hemlock-windows* + #+clx + (hemlock-ext:make-object-set "Hemlock Windows" #'hemlock-ext:default-clx-event-handler)) + + + + +;;;; Some window making parameters. + +;;; These could be parameters, but they have to be set after the display is +;;; opened. These are set in INIT-BITMAP-SCREEN-MANAGER. + +(defvar *default-background-pixel* nil + "Default background color. It defaults to white.") + +(defvar *default-foreground-pixel* nil + "Default foreground color. It defaults to black.") + +(defvar *foreground-background-xor* nil + "The LOGXOR of *default-background-pixel* and *default-foreground-pixel*.") + +(defvar *default-border-pixmap* nil + "This is the default color of X window borders. It defaults to a + grey pattern.") + +(defvar *highlight-border-pixmap* nil + "This is the color of the border of the current window when the mouse + cursor is over any Hemlock window.") + + + + +;;;; Exposed region handling. + +;;; :exposure events are sent because we selected them. :graphics-exposure +;;; events are generated because of a slot in our graphics contexts. These are +;;; generated from using XLIB:COPY-AREA when the source could not be generated. +;;; Also, :no-exposure events are sent when a :graphics-exposure event could +;;; have been sent but wasn't. +;;; +#| +;;; This is an old handler that doesn't do anything clever about multiple +;;; exposures. +(defun hunk-exposed-region (hunk &key y height &allow-other-keys) + (if (bitmap-hunk-lock hunk) + (setf (bitmap-hunk-trashed hunk) t) + (let ((liftp (and (eq *cursor-hunk* hunk) *cursor-dropped*))) + (when liftp (lift-cursor)) + ;; (hunk-draw-top-border hunk) + (let* ((font-family (bitmap-hunk-font-family hunk)) + (font-height (font-family-height font-family)) + (co (font-family-cursor-y-offset font-family)) + (start (truncate (- y hunk-top-border) font-height)) + (end (ceiling (- (+ y height) hunk-top-border) font-height)) + (start-bit (+ (* start font-height) co hunk-top-border)) + (nheight (- (* (- end start) font-height) co)) + (end-line (bitmap-hunk-end hunk))) + (declare (fixnum font-height co start end start-bit nheight)) + (xlib:clear-area (bitmap-hunk-xwindow hunk) :x 0 :y start-bit + :width (bitmap-hunk-width hunk) :height nheight) + (do ((dl (bitmap-hunk-start hunk) (cdr dl)) + (i 0 (1+ i))) + ((or (eq dl end-line) (= i start)) + (do ((i i (1+ i)) + (dl dl (cdr dl))) + ((or (eq dl end-line) (= i end))) + (declare (fixnum i)) + (hunk-write-line hunk (car dl) i))) + (declare (fixnum i))) + (when (and (bitmap-hunk-modeline-pos hunk) + (>= (the fixnum (+ nheight start-bit)) + (the fixnum (bitmap-hunk-modeline-pos hunk)))) + (hunk-replace-modeline hunk))) + (when liftp (drop-cursor))))) +|# + +;;; HUNK-EXPOSED-REGION redisplays the appropriate rectangle from the hunk +;;; dis-lines. Don't do anything if the hunk is trashed since redisplay is +;;; probably about to fix everything; specifically, this keeps new windows +;;; from getting drawn twice (once for the exposure and once for being trashed). +;;; +;;; Exposure and graphics-exposure events pass in a different number of +;;; arguments, with some the same but in a different order, so we just bind +;;; and ignore foo, bar, baz, and quux. +;;; +#+clx +(defun hunk-exposed-region (hunk event-key event-window x y width height + foo bar &optional baz quux) + (declare (ignore event-key event-window x width foo bar baz quux)) + (unless (bitmap-hunk-trashed hunk) + (let ((liftp (and (eq *cursor-hunk* hunk) *cursor-dropped*)) + (display (bitmap-device-display (device-hunk-device hunk)))) + (when liftp (lift-cursor)) + (multiple-value-bind (y-peek height-peek) + (exposed-region-peek-event display + (bitmap-hunk-xwindow hunk)) + (if y-peek + (let ((n (coelesce-exposed-regions hunk display + y height y-peek height-peek))) + (write-n-exposed-regions hunk n)) + (write-one-exposed-region hunk y height))) + (xlib:display-force-output display) + (when liftp (drop-cursor))))) +;;; +#+clx (hemlock-ext:serve-exposure *hemlock-windows* #'hunk-exposed-region) +#+clx (hemlock-ext:serve-graphics-exposure *hemlock-windows* #'hunk-exposed-region) + + +;;; HUNK-NO-EXPOSURE handles this bullshit event that gets sent without its +;;; being requested. +;;; +(defun hunk-no-exposure (hunk event-key event-window major minor send-event-p) + (declare (ignore hunk event-key event-window major minor send-event-p)) + t) +;;; +#+clx (hemlock-ext:serve-no-exposure *hemlock-windows* #'hunk-no-exposure) + + +;;; EXPOSED-REGION-PEEK-EVENT returns the position and height of an :exposure +;;; or :graphics-exposure event on win if one exists. If there are none, then +;;; nil and nil are returned. +;;; +#+clx +(defun exposed-region-peek-event (display win) + (xlib:display-finish-output display) + (let ((result-y nil) + (result-height nil)) + (xlib:process-event + display :timeout 0 + :handler #'(lambda (&key event-key event-window window y height + &allow-other-keys) + (cond ((and (or (eq event-key :exposure) + (eq event-key :graphics-exposure)) + (or (eq event-window win) (eq window win))) + (setf result-y y) + (setf result-height height) + t) + (t nil)))) + (values result-y result-height))) + +;;; COELESCE-EXPOSED-REGIONS insert sorts exposed region events from the X +;;; input queue into *coelesce-buffer*. Then the regions are merged into the +;;; same number or fewer regions that are vertically distinct +;;; (non-overlapping). When this function is called, one event has already +;;; been popped from the queue, the first event that caused HUNK-EXPOSED-REGION +;;; to be called. That information is passed in as y1 and height1. There is +;;; a second event that also has already been popped from the queue, the +;;; event resulting from peeking for multiple "exposure" events. That info +;;; is passed in as y2 and height2. +;;; +(defun coelesce-exposed-regions (hunk display y1 height1 y2 height2) + (let ((len 0)) + (declare (fixnum len)) + ;; + ;; Insert sort the exposeevents as we pick them off the event queue. + (let* ((font-family (bitmap-hunk-font-family hunk)) + (font-height (font-family-height font-family)) + (co (font-family-cursor-y-offset font-family)) + (xwindow (bitmap-hunk-xwindow hunk))) + ;; + ;; Insert the region the exposedregion handler was called on. + (multiple-value-bind (start-line start-bit end-line expanded-height) + (exposed-region-bounds y1 height1 co font-height) + (setf len + (coelesce-buffer-insert start-bit start-line + expanded-height end-line len))) + ;; + ;; Peek for exposedregion events on xwindow, inserting them into + ;; the buffer. + (let ((y y2) + (height height2)) + (loop + (multiple-value-bind (start-line start-bit end-line expanded-height) + (exposed-region-bounds y height co font-height) + (setf len + (coelesce-buffer-insert start-bit start-line + expanded-height end-line len))) + (multiple-value-setq (y height) + (exposed-region-peek-event display xwindow)) + (unless y (return))))) + (coelesce-exposed-regions-merge len))) + +;;; *coelesce-buffer* is a vector of records used to sort exposure events on a +;;; single hunk, so we can merge them into fewer, larger regions of exposure. +;;; COELESCE-BUFFER-INSERT places elements in this buffer, and each element +;;; is referenced with COELESCE-BUFFER-ELT. Each element of the coelescing +;;; buffer has the following accessors defined: +;;; COELESCE-BUFFER-ELT-START in pixels. +;;; COELESCE-BUFFER-ELT-START-LINE in dis-lines. +;;; COELESCE-BUFFER-ELT-HEIGHT in pixels. +;;; COELESCE-BUFFER-ELT-END-LINE in dis-lines. +;;; These are used by COELESCE-BUFFER-INSERT, COELESCE-EXPOSED-REGIONS-MERGE, +;;; and WRITE-N-EXPOSED-REGIONS. + +(defvar *coelesce-buffer-fill-ptr* 25) +(defvar *coelesce-buffer* (make-array *coelesce-buffer-fill-ptr*)) +(dotimes (i *coelesce-buffer-fill-ptr*) + (setf (svref *coelesce-buffer* i) (make-array 4))) + +(defmacro coelesce-buffer-elt-start (elt) + `(svref ,elt 0)) +(defmacro coelesce-buffer-elt-start-line (elt) + `(svref ,elt 1)) +(defmacro coelesce-buffer-elt-height (elt) + `(svref ,elt 2)) +(defmacro coelesce-buffer-elt-end-line (elt) + `(svref ,elt 3)) +(defmacro coelesce-buffer-elt (i) + `(svref *coelesce-buffer* ,i)) + +;;; COELESCE-BUFFER-INSERT inserts an exposed region record into +;;; *coelesce-buffer* such that start is less than all successive +;;; elements. Returns the new length of the buffer. +;;; +(defun coelesce-buffer-insert (start start-line height end-line len) + (declare (fixnum start start-line height end-line len)) + ;; + ;; Add element if len is to fill pointer. If fill pointer is to buffer + ;; length, then grow buffer. + (when (= len (the fixnum *coelesce-buffer-fill-ptr*)) + (when (= (the fixnum *coelesce-buffer-fill-ptr*) + (the fixnum (length (the simple-vector *coelesce-buffer*)))) + (let ((new (make-array (ash (length (the simple-vector *coelesce-buffer*)) + 1)))) + (replace (the simple-vector new) (the simple-vector *coelesce-buffer*) + :end1 *coelesce-buffer-fill-ptr* + :end2 *coelesce-buffer-fill-ptr*) + (setf *coelesce-buffer* new))) + (setf (coelesce-buffer-elt len) (make-array 4)) + (incf *coelesce-buffer-fill-ptr*)) + ;; + ;; Find point to insert record: start, start-line, height, and end-line. + (do ((i 0 (1+ i))) + ((= i len) + ;; Start is greater than all previous starts. Add it to the end. + (let ((region (coelesce-buffer-elt len))) + (setf (coelesce-buffer-elt-start region) start) + (setf (coelesce-buffer-elt-start-line region) start-line) + (setf (coelesce-buffer-elt-height region) height) + (setf (coelesce-buffer-elt-end-line region) end-line))) + (declare (fixnum i)) + (when (< start (the fixnum + (coelesce-buffer-elt-start (coelesce-buffer-elt i)))) + ;; + ;; Insert new element at i, using storage allocated at element len. + (let ((last (coelesce-buffer-elt len))) + (setf (coelesce-buffer-elt-start last) start) + (setf (coelesce-buffer-elt-start-line last) start-line) + (setf (coelesce-buffer-elt-height last) height) + (setf (coelesce-buffer-elt-end-line last) end-line) + ;; + ;; Shift elements after i (inclusively) to the right. + (do ((j (1- len) (1- j)) + (k len j) + (terminus (1- i))) + ((= j terminus)) + (declare (fixnum j k terminus)) + (setf (coelesce-buffer-elt k) (coelesce-buffer-elt j))) + ;; + ;; Stash element to insert at i. + (setf (coelesce-buffer-elt i) last)) + (return))) + (1+ len)) + + +;;; COELESCE-EXPOSED-REGIONS-MERGE merges/coelesces the regions in +;;; *coelesce-buffer*. It takes the number of elements and returns the new +;;; number of elements. The regions are examined one at a time relative to +;;; the current one. The current region remains so, with next advancing +;;; through the buffer, until a next region is found that does not overlap +;;; and is not adjacent. When this happens, the current values are stored +;;; in the current region, and the buffer's element after the current element +;;; becomes current. The next element that was found not to be in contact +;;; the old current element is stored in the new current element by copying +;;; its values there. The buffer's elements always stay in place, and their +;;; storage is re-used. After this process which makes the next region be +;;; the current region, the next pointer is incremented. +;;; +(defun coelesce-exposed-regions-merge (len) + (let* ((current 0) + (next 1) + (current-region (coelesce-buffer-elt 0)) + (current-height (coelesce-buffer-elt-height current-region)) + (current-end-line (coelesce-buffer-elt-end-line current-region)) + (current-end-bit (+ (the fixnum + (coelesce-buffer-elt-start current-region)) + current-height))) + (declare (fixnum current next current-height + current-end-line current-end-bit)) + (loop + (let* ((next-region (coelesce-buffer-elt next)) + (next-start (coelesce-buffer-elt-start next-region)) + (next-height (coelesce-buffer-elt-height next-region)) + (next-end-bit (+ next-start next-height))) + (declare (fixnum next-start next-height next-end-bit)) + (cond ((<= next-start current-end-bit) + (let ((extra-height (- next-end-bit current-end-bit))) + (declare (fixnum extra-height)) + ;; Maybe the next region is contained in the current. + (when (plusp extra-height) + (incf current-height extra-height) + (setf current-end-bit next-end-bit) + (setf current-end-line + (coelesce-buffer-elt-end-line next-region))))) + (t + ;; + ;; Update current record since next does not overlap + ;; with current. + (setf (coelesce-buffer-elt-height current-region) + current-height) + (setf (coelesce-buffer-elt-end-line current-region) + current-end-line) + ;; + ;; Move to new distinct region, copying data from next region. + (incf current) + (setf current-region (coelesce-buffer-elt current)) + (setf (coelesce-buffer-elt-start current-region) next-start) + (setf (coelesce-buffer-elt-start-line current-region) + (coelesce-buffer-elt-start-line next-region)) + (setf current-height next-height) + (setf current-end-bit next-end-bit) + (setf current-end-line + (coelesce-buffer-elt-end-line next-region))))) + (incf next) + (when (= next len) + (setf (coelesce-buffer-elt-height current-region) current-height) + (setf (coelesce-buffer-elt-end-line current-region) current-end-line) + (return))) + (1+ current))) + +;;; EXPOSED-REGION-BOUNDS returns as multiple values the first line affected, +;;; the first possible bit affected (accounting for the cursor), the end line +;;; affected, and the height of the region. +;;; +(defun exposed-region-bounds (y height cursor-offset font-height) + (declare (fixnum y height cursor-offset font-height)) + (let* ((start (truncate (the fixnum (- y hunk-top-border)) + font-height)) + (end (ceiling (the fixnum (- (the fixnum (+ y height)) + hunk-top-border)) + font-height))) + (values + start + (+ (the fixnum (* start font-height)) cursor-offset hunk-top-border) + end + (- (the fixnum (* (the fixnum (- end start)) font-height)) + cursor-offset)))) + +#+clx +(defun write-n-exposed-regions (hunk n) + (declare (fixnum n)) + (let* (;; Loop constants. + (end-dl (bitmap-hunk-end hunk)) + (xwindow (bitmap-hunk-xwindow hunk)) + (hunk-width (bitmap-hunk-width hunk)) + ;; Loop variables. + (dl (bitmap-hunk-start hunk)) + (i 0) + (region (coelesce-buffer-elt 0)) + (start-line (coelesce-buffer-elt-start-line region)) + (start (coelesce-buffer-elt-start region)) + (height (coelesce-buffer-elt-height region)) + (end-line (coelesce-buffer-elt-end-line region)) + (region-idx 0)) + (declare (fixnum i start start-line height end-line region-idx)) + (loop + (xlib:clear-area xwindow :x 0 :y start :width hunk-width :height height) + ;; Find this regions first line. + (loop + (when (or (eq dl end-dl) (= i start-line)) + (return)) + (incf i) + (setf dl (cdr dl))) + ;; Write this region's lines. + (loop + (when (or (eq dl end-dl) (= i end-line)) + (return)) + (hunk-write-line hunk (car dl) i) + (incf i) + (setf dl (cdr dl))) + ;; Get next region unless we're done. + (when (= (incf region-idx) n) (return)) + (setf region (coelesce-buffer-elt region-idx)) + (setf start (coelesce-buffer-elt-start region)) + (setf start-line (coelesce-buffer-elt-start-line region)) + (setf height (coelesce-buffer-elt-height region)) + (setf end-line (coelesce-buffer-elt-end-line region))) + ;; + ;; Check for modeline exposure. + (setf region (coelesce-buffer-elt (1- n))) + (setf start (coelesce-buffer-elt-start region)) + (setf height (coelesce-buffer-elt-height region)) + (when (and (bitmap-hunk-modeline-pos hunk) + (> (+ start height) + (- (bitmap-hunk-modeline-pos hunk) + (bitmap-hunk-bottom-border hunk)))) + (hunk-replace-modeline hunk) + (hunk-draw-bottom-border hunk)))) + +#+clx +(defun write-one-exposed-region (hunk y height) + (let* ((font-family (bitmap-hunk-font-family hunk)) + (font-height (font-family-height font-family)) + (co (font-family-cursor-y-offset font-family)) + (start-line (truncate (- y hunk-top-border) font-height)) + (end-line (ceiling (- (+ y height) hunk-top-border) font-height)) + (start-bit (+ (* start-line font-height) co hunk-top-border)) + (nheight (- (* (- end-line start-line) font-height) co)) + (hunk-end-line (bitmap-hunk-end hunk))) + (declare (fixnum font-height co start-line end-line start-bit nheight)) + (xlib:clear-area (bitmap-hunk-xwindow hunk) :x 0 :y start-bit + :width (bitmap-hunk-width hunk) :height nheight) + (do ((dl (bitmap-hunk-start hunk) (cdr dl)) + (i 0 (1+ i))) + ((or (eq dl hunk-end-line) (= i start-line)) + (do ((i i (1+ i)) + (dl dl (cdr dl))) + ((or (eq dl hunk-end-line) (= i end-line))) + (declare (fixnum i)) + (hunk-write-line hunk (car dl) i))) + (declare (fixnum i))) + (when (and (bitmap-hunk-modeline-pos hunk) + (> (+ start-bit nheight) + (- (bitmap-hunk-modeline-pos hunk) + (bitmap-hunk-bottom-border hunk)))) + (hunk-replace-modeline hunk) + (hunk-draw-bottom-border hunk)))) + + + + +;;;; Resized window handling. + +;;; :configure-notify events are sent because we select :structure-notify. +;;; This buys us a lot of events we have to write dummy handlers to ignore. +;;; + +;;; HUNK-RECONFIGURED -- Internal. +;;; +;;; This must note that the hunk changed to prevent certain redisplay problems +;;; with recentering the window that caused bogus lines to be drawn after the +;;; actual visible text in the window. We must also indicate the hunk is +;;; trashed to eliminate exposure event handling that comes after resizing. +;;; This also causes a full redisplay on the window which is the easiest and +;;; generally best looking thing. +;;; +(defun hunk-reconfigured (object event-key event-window window x y width + height border-width above-sibling + override-redirect-p send-event-p) + (declare (ignore event-key event-window window x y border-width + above-sibling override-redirect-p send-event-p)) + (typecase object + (bitmap-hunk + (when (or (/= width (bitmap-hunk-width object)) + (/= height (bitmap-hunk-height object))) + (hunk-changed object width height nil) + ;; Under X11, don't redisplay since an exposure event is coming next. + (setf (bitmap-hunk-trashed object) t))) + (window-group + (let ((old-width (window-group-width object)) + (old-height (window-group-height object))) + (when (or (/= width old-width) (/= height old-height)) + (window-group-changed object width height)))))) +;;; +#+clx (hemlock-ext:serve-configure-notify *hemlock-windows* #'hunk-reconfigured) + + +;;; HUNK-IGNORE-EVENT ignores the following unrequested events. They all take +;;; at least five arguments, but then there are up to four more optional. +;;; +(defun hunk-ignore-event (hunk event-key event-window window one + &optional two three four five) + (declare (ignore hunk event-key event-window window one two three four five)) + t) +;;; +#+clx (hemlock-ext:serve-destroy-notify *hemlock-windows* #'hunk-ignore-event) +#+clx (hemlock-ext:serve-unmap-notify *hemlock-windows* #'hunk-ignore-event) +#+clx (hemlock-ext:serve-map-notify *hemlock-windows* #'hunk-ignore-event) +#+clx (hemlock-ext:serve-reparent-notify *hemlock-windows* #'hunk-ignore-event) +#+clx (hemlock-ext:serve-gravity-notify *hemlock-windows* #'hunk-ignore-event) +#+clx (hemlock-ext:serve-circulate-notify *hemlock-windows* #'hunk-ignore-event) +#+clx (hemlock-ext:serve-client-message *hemlock-windows* #'hunk-ignore-event) + + + +;;;; Interface to X input events. + +;;; HUNK-KEY-INPUT and HUNK-MOUSE-INPUT. +;;; Each key and mouse event is turned into a character via +;;; HEMLOCK-EXT:TRANSLATE-CHARACTER or HEMLOCK-EXT:TRANSLATE-MOUSE-CHARACTER, either of which +;;; may return nil. Nil is returned for input that is considered uninteresting +;;; input; for example, shift and control. +;;; + +(defun hunk-key-input (hunk event-key event-window root child same-screen-p x y + root-x root-y modifiers time key-code send-event-p) + (declare (ignore event-key event-window root child same-screen-p root-x + root-y time send-event-p)) + (hunk-process-input hunk + (hemlock-ext:translate-key-event + (bitmap-device-display (device-hunk-device hunk)) + key-code modifiers) + x y)) +;;; +#+clx (hemlock-ext:serve-key-press *hemlock-windows* #'hunk-key-input) + +(defun hunk-mouse-input (hunk event-key event-window root child same-screen-p x y + root-x root-y modifiers time key-code send-event-p) + (declare (ignore event-window root child same-screen-p root-x root-y + time send-event-p)) + (hunk-process-input hunk + (hemlock-ext:translate-mouse-key-event key-code modifiers + event-key) + x y)) +;;; +#+clx (hemlock-ext:serve-button-press *hemlock-windows* #'hunk-mouse-input) +#+clx (hemlock-ext:serve-button-release *hemlock-windows* #'hunk-mouse-input) + +(defun hunk-process-input (hunk char x y) + (when char + (let* ((font-family (bitmap-hunk-font-family hunk)) + (font-width (font-family-width font-family)) + (font-height (font-family-height font-family)) + (ml-pos (bitmap-hunk-modeline-pos hunk)) + (height (bitmap-hunk-height hunk)) + (width (bitmap-hunk-width hunk)) + (handler (bitmap-hunk-input-handler hunk)) + (char-width (bitmap-hunk-char-width hunk))) + (cond ((not (and (< -1 x width) (< -1 y height))) + (funcall handler hunk char nil nil)) + ((and ml-pos (> y (- ml-pos (bitmap-hunk-bottom-border hunk)))) + (funcall handler hunk char + ;; (/ width x) doesn't handle ends of thumb bar + ;; and eob right, so do a bunch of truncating. + (min (truncate x (truncate width char-width)) + (1- char-width)) + nil)) + (t + (let* ((cx (truncate (- x hunk-left-border) font-width)) + (temp (truncate (- y hunk-top-border) font-height)) + (char-height (bitmap-hunk-char-height hunk)) + ;; Extra bits below bottom line and above modeline and + ;; thumb bar are considered part of the bottom line since + ;; we have already picked off the y=nil case. + (cy (if (< temp char-height) temp (1- char-height)))) + (if (and (< -1 cx char-width) + (< -1 cy)) + (funcall handler hunk char cx cy) + (funcall handler hunk char nil nil)))))))) + + + + +;;;; Handling boundary crossing events. + +;;; Entering and leaving a window are handled basically the same except that it +;;; is possible to get an entering event under X without getting an exiting +;;; event; specifically, when the mouse is in a Hemlock window that is over +;;; another window, and someone buries the top window, Hemlock only gets an +;;; entering event on the lower window (no exiting event for the buried +;;; window). +;;; +;;; :enter-notify and :leave-notify events are sent because we select +;;; :enter-window and :leave-window events. +;;; + +#+clx +(defun hunk-mouse-entered (hunk event-key event-window root child same-screen-p + x y root-x root-y state time mode kind send-event-p) + (declare (ignore event-key event-window child root same-screen-p + x y root-x root-y state time mode kind send-event-p)) + (when (and *cursor-dropped* (not *hemlock-listener*)) + (cursor-invert-center)) + (setf *hemlock-listener* t) + (let ((current-hunk (window-hunk (current-window)))) + (unless (and *current-highlighted-border* + (eq *current-highlighted-border* current-hunk)) + (setf (xlib:window-border (window-group-xparent + (bitmap-hunk-window-group current-hunk))) + *highlight-border-pixmap*) + (xlib:display-force-output + (bitmap-device-display (device-hunk-device current-hunk))) + (setf *current-highlighted-border* current-hunk))) + (let ((window (bitmap-hunk-window hunk))) + (when window (invoke-hook hemlock::enter-window-hook window)))) +;;; +#+clx (hemlock-ext:serve-enter-notify *hemlock-windows* #'hunk-mouse-entered) + +#+clx +(defun hunk-mouse-left (hunk event-key event-window root child same-screen-p + x y root-x root-y state time mode kind send-event-p) + (declare (ignore event-key event-window child root same-screen-p + x y root-x root-y state time mode kind send-event-p)) + (setf *hemlock-listener* nil) + (when *cursor-dropped* (cursor-invert-center)) + (when *current-highlighted-border* + (setf (xlib:window-border (window-group-xparent + (bitmap-hunk-window-group + *current-highlighted-border*))) + *default-border-pixmap*) + (xlib:display-force-output + (bitmap-device-display (device-hunk-device *current-highlighted-border*))) + (setf *current-highlighted-border* nil)) + (let ((window (bitmap-hunk-window hunk))) + (when window (invoke-hook hemlock::exit-window-hook window)))) +;;; +#+clx (hemlock-ext:serve-leave-notify *hemlock-windows* #'hunk-mouse-left) + + + + +;;;; Making a Window. + +(defparameter minimum-window-height 100 + "If the window created by splitting a window would be shorter than this, + then we create an overlapped window the same size instead.") + +;;; The width must be that of a tab for the screen image builder, and the +;;; height must be one line (two with a modeline). +;;; +(defconstant minimum-window-lines 2 + "Windows must have at least this many lines.") +(defconstant minimum-window-columns 10 + "Windows must be at least this many characters wide.") + +(eval-when (:compile-toplevel :execute :load-toplevel) +(defconstant xwindow-border-width 2 "X border around X windows") +(defconstant xwindow-border-width*2 (* xwindow-border-width 2)) +); eval-when + +;;; We must name windows (set the "name" property) to get around a bug in +;;; awm and twm. They will not handle menu clicks without a window having +;;; a name. We set the name to this silly thing. +;;; +(defvar *hemlock-window-count* 0) +;;; +(defun new-hemlock-window-name () + (let ((*print-base* 10)) + (format nil "Hemlock ~S" (incf *hemlock-window-count*)))) + +(declaim (inline surplus-window-height surplus-window-height-w/-modeline)) +;;; +(defun surplus-window-height (thumb-bar-p) + (+ hunk-top-border (if thumb-bar-p + hunk-thumb-bar-bottom-border + hunk-bottom-border))) +;;; +(defun surplus-window-height-w/-modeline (thumb-bar-p) + (+ (surplus-window-height thumb-bar-p) + hunk-modeline-top + hunk-modeline-bottom)) + + +;;; DEFAULT-CREATE-WINDOW-HOOK -- Internal. +;;; +;;; This is the default value for *create-window-hook*. It makes an X window +;;; for a new group/parent on the given display possibly prompting the user. +;;; +#+clx +(defun default-create-window-hook (display x y width height name font-family + &optional modelinep thumb-bar-p) + (maybe-prompt-user-for-window + (xlib:screen-root (xlib:display-default-screen display)) + x y width height font-family modelinep thumb-bar-p name)) + +#-clx +(defun default-create-window-hook (display x y width height name font-family + &optional modelinep thumb-bar-p) + (declare (ignore display x y width height name font-family + modelinep thumb-bar-p))) + +;;; MAYBE-PROMPT-USER-FOR-WINDOW -- Internal. +;;; +;;; This makes an X window and sets its standard properties according to +;;; supplied values. When some of these are nil, the window manager should +;;; prompt the user for those missing values when the window gets mapped. We +;;; use this when making new group/parent windows. Returns the window without +;;; mapping it. +;;; +(defun maybe-prompt-user-for-window (root x y width height font-family + modelinep thumb-bar-p icon-name) + (let ((font-height (font-family-height font-family)) + (font-width (font-family-width font-family)) + (extra-y (surplus-window-height thumb-bar-p)) + (extra-y-w/-modeline (surplus-window-height-w/-modeline thumb-bar-p))) + (create-window-with-properties + root x y + (if width (+ (* width font-width) hunk-left-border)) + (if height + (if modelinep + (+ (* (1+ height) font-height) extra-y-w/-modeline) + (+ (* height font-height) extra-y))) + font-width font-height icon-name + (+ (* minimum-window-columns font-width) hunk-left-border) + (if modelinep + (+ (* (1+ minimum-window-lines) font-height) extra-y-w/-modeline) + (+ (* minimum-window-lines font-height) extra-y)) + t))) + +(defvar *create-window-hook* #'default-create-window-hook + "Hemlock calls this function when it makes a new X window for a new group. + It passes as arguments the X display, x (from MAKE-WINDOW), y (from + MAKE-WINDOW), width (from MAKE-WINDOW), height (from MAKE-WINDOW), a name + for the window's icon-name, font-family (from MAKE-WINDOW), modelinep (from + MAKE-WINDOW), and whether the window will have a thumb-bar meter. The + function returns a window or nil.") + +;;; BITMAP-MAKE-WINDOW -- Internal. +;;; +#+clx +(defun bitmap-make-window (device start modelinep window font-family + ask-user x y width-arg height-arg proportion) + (let* ((display (bitmap-device-display device)) + (thumb-bar-p (value hemlock::thumb-bar-meter)) + (hunk (make-bitmap-hunk + :font-family font-family + :end *the-sentinel* :trashed t + :input-handler #'window-input-handler + :device device + :thumb-bar-p (and modelinep thumb-bar-p)))) + (multiple-value-bind + (xparent xwindow) + (maybe-make-x-window-and-parent window display start ask-user x y + width-arg height-arg font-family + modelinep thumb-bar-p proportion) + (unless xwindow (return-from bitmap-make-window nil)) + (let ((window-group (make-window-group xparent + (xlib:drawable-width xparent) + (xlib:drawable-height xparent)))) + (setf (bitmap-hunk-xwindow hunk) xwindow) + (setf (bitmap-hunk-window-group hunk) window-group) + (setf (bitmap-hunk-gcontext hunk) + (default-gcontext xwindow font-family)) + ;; + ;; Select input and enable event service before showing the window. + (setf (xlib:window-event-mask xwindow) child-interesting-xevents-mask) + (setf (xlib:window-event-mask xparent) group-interesting-xevents-mask) + (add-xwindow-object xwindow hunk *hemlock-windows*) + (add-xwindow-object xparent window-group *hemlock-windows*)) + (when xparent (xlib:map-window xparent)) + (xlib:map-window xwindow) + (xlib:display-finish-output display) + ;; A window is not really mapped until it is viewable. It is said to be + ;; mapped if a map request has been sent whether it is handled or not. + (loop (when (and (eq (xlib:window-map-state xwindow) :viewable) + (eq (xlib:window-map-state xparent) :viewable)) + (return))) + ;; + ;; Find out how big it is... + (xlib:with-state (xwindow) + (set-hunk-size hunk (xlib:drawable-width xwindow) + (xlib:drawable-height xwindow) modelinep))) + (setf (bitmap-hunk-window hunk) + (window-for-hunk hunk start modelinep)) + ;; If window is non-nil, then it is a new group/parent window, so don't + ;; link it into the current window's group. When ask-user is non-nil, + ;; we make a new group too. + (cond ((or window ask-user) + ;; This occurs when we make the world's first Hemlock window. + (unless *current-window* + (setq *current-window* (bitmap-hunk-window hunk))) + (setf (bitmap-hunk-previous hunk) hunk) + (setf (bitmap-hunk-next hunk) hunk)) + (t + (let ((h (window-hunk *current-window*))) + (shiftf (bitmap-hunk-next hunk) (bitmap-hunk-next h) hunk) + (setf (bitmap-hunk-previous (bitmap-hunk-next hunk)) hunk) + (setf (bitmap-hunk-previous hunk) h)))) + (push hunk (device-hunks device)) + (bitmap-hunk-window hunk))) + +;;; MAYBE-MAKE-X-WINDOW-AND-PARENT -- Internal. +;;; +;;; BITMAP-MAKE-WINDOW calls this. If xparent is non-nil, we clear it and +;;; return it with a child that fills it. If xparent is nil, and ask-user is +;;; non-nil, then we invoke *create-window-hook* to get a parent window and +;;; return it with a child that fills it. By default, we make a child in the +;;; CURRENT-WINDOW's parent. +;;; +#+clx +(defun maybe-make-x-window-and-parent (xparent display start ask-user x y width + height font-family modelinep thumb-p + proportion) + (let ((icon-name (buffer-name (line-buffer (mark-line start))))) + (cond (xparent + (check-type xparent xlib:window) + (let ((width (xlib:drawable-width xparent)) + (height (xlib:drawable-height xparent))) + (xlib:clear-area xparent :width width :height height) + (modify-parent-properties :set xparent modelinep thumb-p + (font-family-width font-family) + (font-family-height font-family)) + (values xparent (xwindow-for-xparent xparent icon-name)))) + (ask-user + (let ((xparent (funcall *create-window-hook* + display x y width height icon-name + font-family modelinep thumb-p))) + (values xparent (xwindow-for-xparent xparent icon-name)))) + (t + (let ((xparent (window-group-xparent + (bitmap-hunk-window-group + (window-hunk (current-window)))))) + (values xparent + (create-window-from-current + proportion font-family modelinep thumb-p xparent + icon-name))))))) + +;;; XWINDOW-FOR-XPARENT -- Internal. +;;; +;;; This returns a child of xparent that completely fills that parent window. +;;; We supply the font-width and font-height as nil because these are useless +;;; for child windows. +;;; +#+clx +(defun xwindow-for-xparent (xparent icon-name) + (xlib:with-state (xparent) + (create-window-with-properties xparent 0 0 + (xlib:drawable-width xparent) + (xlib:drawable-height xparent) + nil nil icon-name))) + +;;; CREATE-WINDOW-FROM-CURRENT -- Internal. +;;; +;;; This makes a child window on parent by splitting the current window. If +;;; the result will be too small, this returns nil. If the current window's +;;; height is odd, the extra pixel stays with it, and the new window is one +;;; pixel smaller. +;;; +#+clx +(defun create-window-from-current (proportion font-family modelinep thumb-p + parent icon-name) + (let* ((cur-hunk (window-hunk *current-window*)) + (cwin (bitmap-hunk-xwindow cur-hunk))) + ;; Compute current window's height and take a proportion of it. + (xlib:with-state (cwin) + (let* ((cw (xlib:drawable-width cwin)) + (ch (xlib:drawable-height cwin)) + (cy (xlib:drawable-y cwin)) + (new-ch (truncate (* ch (- 1 proportion)))) + (font-height (font-family-height font-family)) + (font-width (font-family-width font-family)) + (cwin-min (minimum-window-height + (font-family-height + (bitmap-hunk-font-family cur-hunk)) + (bitmap-hunk-modeline-pos cur-hunk) + (bitmap-hunk-thumb-bar-p cur-hunk))) + (new-min (minimum-window-height font-height modelinep + thumb-p))) + (declare (fixnum cw cy ch new-ch)) + ;; See if we have room for a new window. This should really + ;; check the current window and the new one against their + ;; relative fonts and the minimal window columns and line + ;; (including whether there is a modeline). + (if (and (> new-ch cwin-min) + (> (- ch new-ch) new-min)) + (let ((win (create-window-with-properties + parent 0 (+ cy new-ch) + cw (- ch new-ch) font-width font-height + icon-name))) + ;; No need to reshape current Hemlock window structure here + ;; since this call will send an appropriate event. + (setf (xlib:drawable-height cwin) new-ch) + ;; Set hints on parent, so the user can't resize it to be + ;; smaller than what will hold the current number of + ;; children. + (modify-parent-properties :add parent modelinep + thumb-p + (font-family-width font-family) + font-height) + win) + nil))))) + + +;;; MAKE-XWINDOW-LIKE-HWINDOW -- Interface. +;;; +;;; The window name is set to get around an awm and twm bug that inhibits menu +;;; clicks unless the window has a name; this could be used better. +;;; +#+clx +(defun make-xwindow-like-hwindow (window) + "This returns an group/parent xwindow with dimensions suitable for making a + Hemlock window like the argument window. The new window's position should + be the same as the argument window's position relative to the root. When + setting standard properties, we set x, y, width, and height to tell window + managers to put the window where we intend without querying the user." + (let* ((hunk (window-hunk window)) + (font-family (bitmap-hunk-font-family hunk)) + (xwin (bitmap-hunk-xwindow hunk))) + (multiple-value-bind (x y) + (window-root-xy xwin) + (create-window-with-properties + (xlib:screen-root (xlib:display-default-screen + (bitmap-device-display (device-hunk-device hunk)))) + x y (bitmap-hunk-width hunk) (bitmap-hunk-height hunk) + (font-family-width font-family) + (font-family-height font-family) + (buffer-name (window-buffer window)) + ;; When the user hands this window to MAKE-WINDOW, it will set the + ;; minimum width and height properties. + nil nil + t)))) + + + + +;;;; Deleting a window. + +;;; DEFAULT-DELETE-WINDOW-HOOK -- Internal. +;;; +#+clx +(defun default-delete-window-hook (xparent) + (xlib:destroy-window xparent)) +#-clx +(defun default-delete-window-hook (xparent) + (declare (ignore xparent))) +;;; +(defvar *delete-window-hook* #'default-delete-window-hook + "Hemlock calls this function to delete an X group/parent window. It passes + the X window as an argument.") + + +;;; BITMAP-DELETE-WINDOW -- Internal +;;; +;;; +#+clx +(defun bitmap-delete-window (window) + (let* ((hunk (window-hunk window)) + (xwindow (bitmap-hunk-xwindow hunk)) + (xparent (window-group-xparent (bitmap-hunk-window-group hunk))) + (display (bitmap-device-display (device-hunk-device hunk)))) + (remove-xwindow-object xwindow) + (setq *window-list* (delete window *window-list*)) + (when (eq *current-highlighted-border* hunk) + (setf *current-highlighted-border* nil)) + (when (and (eq *cursor-hunk* hunk) *cursor-dropped*) (lift-cursor)) + (xlib:display-force-output display) + (bitmap-delete-and-reclaim-window-space xwindow window) + (loop (unless (deleting-window-drop-event display xwindow) (return))) + (let ((device (device-hunk-device hunk))) + (setf (device-hunks device) (delete hunk (device-hunks device)))) + (cond ((eq hunk (bitmap-hunk-next hunk)) + ;; Is this the last window in the group? + (remove-xwindow-object xparent) + (xlib:display-force-output display) + (funcall *delete-window-hook* xparent) + (loop (unless (deleting-window-drop-event display xparent) + (return))) + (let ((window (find-if-not #'(lambda (window) + (eq window *echo-area-window*)) + *window-list*))) + (setf (current-buffer) (window-buffer window) + (current-window) window))) + (t + (modify-parent-properties :delete xparent + (bitmap-hunk-modeline-pos hunk) + (bitmap-hunk-thumb-bar-p hunk) + (font-family-width + (bitmap-hunk-font-family hunk)) + (font-family-height + (bitmap-hunk-font-family hunk))) + (let ((next (bitmap-hunk-next hunk)) + (prev (bitmap-hunk-previous hunk))) + (setf (bitmap-hunk-next prev) next) + (setf (bitmap-hunk-previous next) prev)))) + (let ((buffer (window-buffer window))) + (setf (buffer-windows buffer) (delete window (buffer-windows buffer))))) + nil) + +;;; BITMAP-DELETE-AND-RECLAIM-WINDOW-SPACE -- Internal. +;;; +;;; This destroys the X window after obtaining its necessary state information. +;;; If the previous or next window (in that order) is "stacked" over or under +;;; the target window, then it is grown to fill in the newly opened space. We +;;; fetch all the necessary configuration data up front, so we don't have to +;;; call XLIB:DESTROY-WINDOW while in the XLIB:WITH-STATE. +;;; +#+clx +(defun bitmap-delete-and-reclaim-window-space (xwindow hwindow) + (multiple-value-bind (y height) + (xlib:with-state (xwindow) + (values (xlib:drawable-y xwindow) + (xlib:drawable-height xwindow))) + (xlib:destroy-window xwindow) + (let ((hunk (window-hunk hwindow))) + (xlib:free-gcontext (bitmap-hunk-gcontext hunk)) + (unless (eq hunk (bitmap-hunk-next hunk)) + (unless (maybe-merge-with-previous-window hunk y height) + (merge-with-next-window hunk y height)))))) + +;;; MAYBE-MERGE-WITH-PREVIOUS-WINDOW -- Internal. +;;; +;;; This returns non-nil when it grows the previous hunk to include the +;;; argument hunk's screen space. +;;; +#+clx +(defun maybe-merge-with-previous-window (hunk y h) + (declare (fixnum y h)) + (let* ((prev (bitmap-hunk-previous hunk)) + (prev-xwin (bitmap-hunk-xwindow prev))) + (xlib:with-state (prev-xwin) + (if (< (xlib:drawable-y prev-xwin) y) + (incf (xlib:drawable-height prev-xwin) h))))) + +;;; MERGE-WITH-NEXT-WINDOW -- Internal. +;;; +;;; This trys to grow the next hunk's window to make use of the space created +;;; by deleting hunk's window. If this is possible, then we must also move the +;;; next window up to where hunk's window was. +;;; +;;; When we reconfigure the window, we must set the hunk trashed. This is a +;;; hack since twm is broken again and is sending exposure events before +;;; reconfigure notifications. Hemlock relies on the protocol's statement that +;;; reconfigures come before exposures to set the hunk trashed before getting +;;; the exposure. For now, we'll do it here too. +;;; +#+clx +(defun merge-with-next-window (hunk y h) + (declare (fixnum y h)) + (let* ((next (bitmap-hunk-next hunk)) + (next-xwin (bitmap-hunk-xwindow next))) + ;; Fetch height before setting y to save an extra round trip to the X + ;; server. + (let ((next-h (xlib:drawable-height next-xwin))) + (setf (xlib:drawable-y next-xwin) y) + (setf (xlib:drawable-height next-xwin) (+ next-h h))) + (setf (bitmap-hunk-trashed next) t) + (let ((hints (xlib:wm-normal-hints next-xwin))) + (setf (xlib:wm-size-hints-y hints) y) + (setf (xlib:wm-normal-hints next-xwin) hints)))) + + +;;; DELETING-WINDOW-DROP-EVENT -- Internal. +;;; +;;; This checks for any events on win. If there is one, remove it from the +;;; queue and return t. Otherwise, return nil. +;;; +#+clx +(defun deleting-window-drop-event (display win) + (xlib:display-finish-output display) + (let ((result nil)) + (xlib:process-event + display :timeout 0 + :handler #'(lambda (&key event-window window &allow-other-keys) + (if (or (eq event-window win) (eq window win)) + (setf result t) + nil))) + result)) + + +;;; MODIFY-PARENT-PROPERTIES -- Internal. +;;; +;;; This adds or deletes from xparent's min-height and min-width hints, so the +;;; window manager will hopefully prevent users from making a window group too +;;; small to hold all the windows in it. We add to the height when we split +;;; windows making additional ones, and we delete from it when we delete a +;;; window. +;;; +;;; NOTE, THIS FAILS TO MAINTAIN THE WIDTH CORRECTLY. We need to maintain the +;;; width as the MAX of all the windows' minimal widths. A window's minimal +;;; width is its font's width multiplied by minimum-window-columns. +;;; +#+clx +(defun modify-parent-properties (type xparent modelinep thumb-p + font-width font-height) + (let ((hints (xlib:wm-normal-hints xparent))) + (xlib:set-wm-properties + xparent + :resource-name "Hemlock" + :x (xlib:wm-size-hints-x hints) + :y (xlib:wm-size-hints-y hints) + :width (xlib:drawable-width xparent) + :height (xlib:drawable-height xparent) + :user-specified-position-p t + :user-specified-size-p t + :width-inc (xlib:wm-size-hints-width-inc hints) + :height-inc (xlib:wm-size-hints-height-inc hints) + :min-width (or (xlib:wm-size-hints-min-width hints) + (+ (* minimum-window-columns font-width) hunk-left-border)) + :min-height + (let ((delta (minimum-window-height font-height modelinep thumb-p))) + (ecase type + (:delete (- (xlib:wm-size-hints-min-height hints) delta)) + (:add (+ (or (xlib:wm-size-hints-min-height hints) 0) + delta)) + (:set delta)))))) + +;;; MINIMUM-WINDOW-HEIGHT -- Internal. +;;; +;;; This returns the minimum height necessary for a window given some of its +;;; parameters. This is the number of lines times font-height plus any extra +;;; pixels for aesthetics. +;;; +(defun minimum-window-height (font-height modelinep thumb-p) + (if modelinep + (+ (* (1+ minimum-window-lines) font-height) + (surplus-window-height-w/-modeline thumb-p)) + (+ (* minimum-window-lines font-height) + (surplus-window-height thumb-p)))) + + + + +;;;; Next and Previous windows. + +(defun bitmap-next-window (window) + "Return the next window after Window, wrapping around if Window is the + bottom window." + (check-type window window) + (bitmap-hunk-window (bitmap-hunk-next (window-hunk window)))) + +(defun bitmap-previous-window (window) + "Return the previous window after Window, wrapping around if Window is the + top window." + (check-type window window) + (bitmap-hunk-window (bitmap-hunk-previous (window-hunk window)))) + + + + +;;;; Setting window width and height. + +;;; %SET-WINDOW-WIDTH -- Internal +;;; +;;; Since we don't support non-full-width windows, this does nothing. +;;; +(defun %set-window-width (window new-value) + (declare (ignore window)) + new-value) + +;;; %SET-WINDOW-HEIGHT -- Internal +;;; +;;; Can't change window height either. +;;; +(defun %set-window-height (window new-value) + (declare (ignore window)) + new-value) + + + + +;;;; Random Typeout + +;;; Random typeout is done to a bitmap-hunk-output-stream +;;; (Bitmap-Hunk-Stream.Lisp). These streams have an associated hunk +;;; that is used for its font-family, foreground and background color, +;;; and X window pointer. The hunk is not associated with any Hemlock +;;; window, and the low level painting routines that use hunk dimensions +;;; are not used for output. The X window is resized as necessary with +;;; each use, but the hunk is only registered for input and boundary +;;; crossing event service; therefore, it never gets exposure or changed +;;; notifications. + +;;; These are set in INIT-BITMAP-SCREEN-MANAGER. +;;; +(defvar *random-typeout-start-x* 0 + "Where we put the the random typeout window.") +(defvar *random-typeout-start-y* 0 + "Where we put the the random typeout window.") +(defvar *random-typeout-start-width* 0 + "How wide the random typeout window is.") + + +;;; DEFAULT-RANDOM-TYPEOUT-HOOK -- Internal +;;; +;;; The default hook-function for random typeout. Nothing very fancy +;;; for now. If not given a window, makes one on top of the initial +;;; Hemlock window using specials set in INIT-BITMAP-SCREEN-MANAGER. If +;;; given a window, we will change the height subject to the constraint +;;; that the bottom won't be off the screen. Any resulting window has +;;; input and boundary crossing events selected, a hemlock cursor defined, +;;; and is mapped. +;;; +#+clx +(defun default-random-typeout-hook (device window height) + (declare (fixnum height)) + (let* ((display (bitmap-device-display device)) + (root (xlib:screen-root (xlib:display-default-screen display))) + (full-height (xlib:drawable-height root)) + (actual-height (if window + (multiple-value-bind (x y) (window-root-xy window) + (declare (ignore x) (fixnum y)) + (min (- full-height y xwindow-border-width*2) + height)) + (min (- full-height *random-typeout-start-y* + xwindow-border-width*2) + height))) + (win (cond (window + (setf (xlib:drawable-height window) actual-height) + window) + (t + (let ((win (xlib:create-window + :parent root + :x *random-typeout-start-x* + :y *random-typeout-start-y* + :width *random-typeout-start-width* + :height actual-height + :background *default-background-pixel* + :border-width xwindow-border-width + :border *default-border-pixmap* + :event-mask random-typeout-xevents-mask + :override-redirect :on :class :input-output + :cursor *hemlock-cursor*))) + (xlib:set-wm-properties + win :name "Pop-up Display" :icon-name "Pop-up Display" + :resource-name "Hemlock" + :x *random-typeout-start-x* + :y *random-typeout-start-y* + :width *random-typeout-start-width* + :height actual-height + :user-specified-position-p t :user-specified-size-p t + ;; Tell OpenLook pseudo-X11 server we want input. + :input :on) + win)))) + (gcontext (if (not window) (default-gcontext win)))) + (values win gcontext))) + +#-clx +(defun default-random-typeout-hook (device window height) + (declare (ignore device window height))) + +(defvar *random-typeout-hook* #'default-random-typeout-hook + "This function is called when a window is needed to display random typeout. + It is called with the Hemlock device, a pre-existing window or NIL, and the + number of pixels needed to display the number of lines requested in + WITH-RANDOM-TYPEOUT. It should return a window, and if a new window was + created, then a gcontext must be returned as the second value.") + +;;; BITMAP-RANDOM-TYPEOUT-SETUP -- Internal +;;; +;;; This function is called by the with-random-typeout macro to +;;; to set things up. It calls the *Random-Typeout-Hook* to get a window +;;; to work with, and then adjusts the random typeout stream's data-structures +;;; to match. +;;; +#+clx +(defun bitmap-random-typeout-setup (device stream height) + (let* ((*more-prompt-action* :empty) + (hwin-exists-p (random-typeout-stream-window stream)) + (hwindow (if hwin-exists-p + (change-bitmap-random-typeout-window hwin-exists-p height) + (setf (random-typeout-stream-window stream) + (make-bitmap-random-typeout-window + device + (buffer-start-mark + (line-buffer + (mark-line (random-typeout-stream-mark stream)))) + height))))) + (let ((xwindow (bitmap-hunk-xwindow (window-hunk hwindow))) + (display (bitmap-device-display device))) + (xlib:display-finish-output display) + (loop + (unless (xlib:event-case (display :timeout 0) + (:exposure (event-window) + (eq event-window xwindow)) + (t () nil)) + (return)))))) + +#+clx +(defun change-bitmap-random-typeout-window (hwindow height) + (update-modeline-field (window-buffer hwindow) hwindow :more-prompt) + (let* ((hunk (window-hunk hwindow)) + (xwin (bitmap-hunk-xwindow hunk))) + ;; + ;; *random-typeout-hook* sets the window's height to the right value. + (funcall *random-typeout-hook* (device-hunk-device hunk) xwin + (+ (* height (font-family-height (bitmap-hunk-font-family hunk))) + hunk-top-border (bitmap-hunk-bottom-border hunk) + hunk-modeline-top hunk-modeline-bottom)) + (xlib:with-state (xwin) + (hunk-changed hunk (xlib:drawable-width xwin) (xlib:drawable-height xwin) + nil)) + ;; + ;; We push this on here because we took it out the last time we cleaned up. + (push hwindow (buffer-windows (window-buffer hwindow))) + (setf (bitmap-hunk-trashed hunk) t) + (xlib:map-window xwin) + (setf (xlib:window-priority xwin) :above)) + hwindow) + +#+clx +(defun make-bitmap-random-typeout-window (device mark height) + (let* ((display (bitmap-device-display device)) + (hunk (make-bitmap-hunk + :font-family *default-font-family* + :end *the-sentinel* :trashed t + :input-handler #'window-input-handler + :device device :thumb-bar-p nil))) + (multiple-value-bind + (xwindow gcontext) + (funcall *random-typeout-hook* + device (bitmap-hunk-xwindow hunk) + (+ (* height (font-family-height *default-font-family*)) + hunk-top-border (bitmap-hunk-bottom-border hunk) + hunk-modeline-top hunk-modeline-bottom)) + ;; + ;; When gcontext, we just made the window, so tie some stuff together. + (when gcontext + (setf (xlib:gcontext-font gcontext) + (svref (font-family-map *default-font-family*) 0)) + (setf (bitmap-hunk-xwindow hunk) xwindow) + (setf (bitmap-hunk-gcontext hunk) gcontext) + ;; + ;; Select input and enable event service before showing the window. + (setf (xlib:window-event-mask xwindow) random-typeout-xevents-mask) + (add-xwindow-object xwindow hunk *hemlock-windows*)) + ;; + ;; Put the window on the screen so it's visible and we can know the size. + (xlib:map-window xwindow) + (xlib:display-finish-output display) + ;; A window is not really mapped until it is viewable (not visible). + ;; It is said to be mapped if a map request has been sent whether it + ;; is handled or not. + (loop (when (eq (xlib:window-map-state xwindow) :viewable) + (return))) + (xlib:with-state (xwindow) + (set-hunk-size hunk (xlib:drawable-width xwindow) + (xlib:drawable-height xwindow) t)) + ;; + ;; Get a Hemlock window and hide it from the rest of Hemlock. + (let ((hwin (window-for-hunk hunk mark *random-typeout-ml-fields*))) + (update-modeline-field (window-buffer hwin) hwin :more-prompt) + (setf (bitmap-hunk-window hunk) hwin) + (setf *window-list* (delete hwin *window-list*)) + hwin)))) + + +;;; RANDOM-TYPEOUT-CLEANUP -- Internal +;;; +;;; Clean up after random typeout. This just removes the window from +;;; the screen and sets the more-prompt action back to normal. +;;; +#+clx +(defun bitmap-random-typeout-cleanup (stream degree) + (when degree + (xlib:unmap-window (bitmap-hunk-xwindow + (window-hunk (random-typeout-stream-window stream)))))) + + + + +;;;; Initialization. + +;;; DEFAULT-CREATE-INITIAL-WINDOWS-HOOK makes the initial windows, main and +;;; echo. The main window is made according to "Default Initial Window X", +;;; "Default Initial Window Y", "Default Initial Window Width", and "Default +;;; Initial Window Height", prompting the user for any unspecified components. +;;; DEFAULT-CREATE-INITIAL-WINDOWS-ECHO is called to return the location and +;;; size of the echo area including how big its font is, and the main xwindow +;;; is potentially modified by this function. The window name is set to get +;;; around an awm and twm bug that inhibits menu clicks unless the window has a +;;; name; this could be used better. +;;; +#+clx +(defun default-create-initial-windows-hook (device) + (let ((root (xlib:screen-root (xlib:display-default-screen + (bitmap-device-display device))))) + (let* ((xwindow (maybe-prompt-user-for-window + root + (value hemlock::default-initial-window-x) + (value hemlock::default-initial-window-y) + (value hemlock::default-initial-window-width) + (value hemlock::default-initial-window-height) + *default-font-family* + t ;modelinep + (value hemlock::thumb-bar-meter) + "Hemlock"))) + (setf (xlib:window-border xwindow) *highlight-border-pixmap*) + (let ((main-win (make-window (buffer-start-mark *current-buffer*) + :device device + :window xwindow))) + (multiple-value-bind + (echo-x echo-y echo-width echo-height) + (default-create-initial-windows-echo + (xlib:drawable-height root) + (window-hunk main-win)) + (let ((echo-xwin (make-echo-xwindow root echo-x echo-y echo-width + echo-height))) + (setf *echo-area-window* + (hlet ((hemlock::thumb-bar-meter nil)) + (make-window + (buffer-start-mark *echo-area-buffer*) + :device device :modelinep t + :window echo-xwin))))) + (setf *current-window* main-win))))) + +#-clx +(defun default-create-initial-windows-hook (device) + (declare (ignore device))) + +;;; DEFAULT-CREATE-INITIAL-WINDOWS-ECHO makes the echo area window as wide as +;;; the main window and places it directly under it. If the echo area does not +;;; fit on the screen, we change the main window to make it fit. There is +;;; a problem in computing main-xwin's x and y relative to the root window +;;; which is where we line up the echo and main windows. Some losing window +;;; managers (awm and twm) reparent the window, so we have to make sure +;;; main-xwin's x and y are relative to the root and not some false parent. +;;; +#+clx +(defun default-create-initial-windows-echo (full-height hunk) + (declare (fixnum full-height)) + (let ((font-family (bitmap-hunk-font-family hunk)) + (xwindow (bitmap-hunk-xwindow hunk)) + (xparent (window-group-xparent (bitmap-hunk-window-group hunk)))) + (xlib:with-state (xwindow) + (let ((w (xlib:drawable-width xwindow)) + (h (xlib:drawable-height xwindow))) + (declare (fixnum w h)) + (multiple-value-bind (x y) + (window-root-xy xwindow + (xlib:drawable-x xwindow) + (xlib:drawable-y xwindow)) + (declare (fixnum x y)) + (let* ((ff-height (font-family-height font-family)) + (ff-width (font-family-width font-family)) + (echo-height (+ (* ff-height 4) + hunk-top-border hunk-bottom-border + hunk-modeline-top hunk-modeline-bottom))) + (declare (fixnum echo-height)) + (if (<= (+ y h echo-height xwindow-border-width*2) full-height) + (values x (+ y h xwindow-border-width*2) + w echo-height ff-width ff-height) + (let* ((newh (- full-height y echo-height xwindow-border-width*2 + ;; Since y is really the outside y, subtract + ;; two more borders, so the echo area's borders + ;; both appear on the screen. + xwindow-border-width*2))) + (setf (xlib:drawable-height xparent) newh) + (values x (+ y newh xwindow-border-width*2) + w echo-height ff-width ff-height))))))))) + +(defvar *create-initial-windows-hook* #'default-create-initial-windows-hook + "Hemlock uses this function when it initializes the screen manager to make + the first windows, typically the main and echo area windows. It takes a + Hemlock device as a required argument. It sets *current-window* and + *echo-area-window*.") + +(defun make-echo-xwindow (root x y width height) + (let* ((font-width (font-family-width *default-font-family*)) + (font-height (font-family-height *default-font-family*))) + (create-window-with-properties root x y width height + font-width font-height + "Echo Area" nil nil t))) + +#+clx +(defun init-bitmap-screen-manager (display) + ;; + ;; Setup stuff for X interaction. + (cond ((value hemlock::reverse-video) + (setf *default-background-pixel* + (xlib:screen-black-pixel (xlib:display-default-screen display))) + (setf *default-foreground-pixel* + (xlib:screen-white-pixel (xlib:display-default-screen display))) + (setf *cursor-background-color* (make-black-color)) + (setf *cursor-foreground-color* (make-white-color)) + (setf *hack-hunk-replace-line* nil)) + (t (setf *default-background-pixel* + (xlib:screen-white-pixel (xlib:display-default-screen display))) + (setf *default-foreground-pixel* + (xlib:screen-black-pixel (xlib:display-default-screen display))) + (setf *cursor-background-color* (make-white-color)) + (setf *cursor-foreground-color* (make-black-color)))) + (setf *foreground-background-xor* + (logxor *default-foreground-pixel* *default-background-pixel*)) + (setf *highlight-border-pixmap* *default-foreground-pixel*) + (setf *default-border-pixmap* (get-hemlock-grey-pixmap display)) + (get-hemlock-cursor display) + (add-hook hemlock::make-window-hook 'define-window-cursor) + ;; + ;; Make the device for the rest of initialization. + (let ((device (make-default-bitmap-device display))) + ;; + ;; Create initial windows. + (funcall *create-initial-windows-hook* device) + ;; + ;; Setup random typeout over the user's main window. + (let ((xwindow (bitmap-hunk-xwindow (window-hunk *current-window*)))) + (xlib:with-state (xwindow) + (multiple-value-bind (x y) + (window-root-xy xwindow (xlib:drawable-x xwindow) + (xlib:drawable-y xwindow)) + (setf *random-typeout-start-x* x) + (setf *random-typeout-start-y* y)) + (setf *random-typeout-start-width* (xlib:drawable-width xwindow))))) + (add-hook hemlock::window-buffer-hook 'set-window-name-for-window-buffer) + (add-hook hemlock::buffer-name-hook 'set-window-name-for-buffer-name) + (add-hook hemlock::set-window-hook 'set-window-hook-raise-fun) + (add-hook hemlock::buffer-modified-hook 'raise-echo-area-when-modified)) + +(defun make-default-bitmap-device (display) + (make-bitmap-device + :name "Windowed Bitmap Device" + :init #'init-bitmap-device + :exit #'exit-bitmap-device + :smart-redisplay #'smart-window-redisplay + :dumb-redisplay #'dumb-window-redisplay + :after-redisplay #'bitmap-after-redisplay + :clear nil + :note-read-wait #'frob-cursor + :put-cursor #'hunk-show-cursor + :show-mark #'bitmap-show-mark + :next-window #'bitmap-next-window + :previous-window #'bitmap-previous-window + :make-window #'bitmap-make-window + :delete-window #'bitmap-delete-window + :force-output #'bitmap-force-output + :finish-output #'bitmap-finish-output + :random-typeout-setup #'bitmap-random-typeout-setup + :random-typeout-cleanup #'bitmap-random-typeout-cleanup + :random-typeout-full-more #'do-bitmap-full-more + :random-typeout-line-more #'update-bitmap-line-buffered-stream + :beep #'bitmap-beep + :display display)) + +(defun init-bitmap-device (device) + (let ((display (bitmap-device-display device))) + (hemlock-ext:flush-display-events display) + (hemlock-window display t))) + +(defun exit-bitmap-device (device) + (hemlock-window (bitmap-device-display device) nil)) + +#+clx +(defun bitmap-finish-output (device window) + (declare (ignore window)) + (xlib:display-finish-output (bitmap-device-display device))) + +#+clx +(defun bitmap-force-output () + (xlib:display-force-output + (bitmap-device-display (device-hunk-device (window-hunk (current-window)))))) + +(defun bitmap-after-redisplay (device) + (let ((display (bitmap-device-display device))) + (loop (unless (hemlock-ext:object-set-event-handler display) (return))))) + + + + +;;;; Miscellaneous. + +;;; HUNK-RESET is called in redisplay to make sure the hunk is up to date. +;;; If the size is wrong, or it is trashed due to font changes, then we +;;; call HUNK-CHANGED. We also clear the hunk. +;;; +#+clx +(defun hunk-reset (hunk) + (let ((xwindow (bitmap-hunk-xwindow hunk)) + (trashed (bitmap-hunk-trashed hunk))) + (when trashed + (setf (bitmap-hunk-trashed hunk) nil) + (xlib:with-state (xwindow) + (let ((w (xlib:drawable-width xwindow)) + (h (xlib:drawable-height xwindow))) + (when (or (/= w (bitmap-hunk-width hunk)) + (/= h (bitmap-hunk-height hunk)) + (eq trashed :font-change)) + (hunk-changed hunk w h nil))))) + (xlib:clear-area xwindow :width (bitmap-hunk-width hunk) + :height (bitmap-hunk-height hunk)) + (hunk-draw-bottom-border hunk))) + +;;; HUNK-CHANGED -- Internal. +;;; +;;; HUNK-RESET and the changed window handler call this. Don't go through +;;; REDISPLAY-WINDOW-ALL since the window changed handler updates the window +;;; image. +;;; +(defun hunk-changed (hunk new-width new-height redisplay) + (set-hunk-size hunk new-width new-height) + (funcall (bitmap-hunk-changed-handler hunk) hunk) + (when redisplay (dumb-window-redisplay (bitmap-hunk-window hunk)))) + +;;; WINDOW-GROUP-CHANGED -- Internal. +;;; +;;; HUNK-RECONFIGURED calls this when the hunk was a window-group. This finds +;;; the windows in the changed group, sorts them by their vertical stacking +;;; order, and tries to resize the windows proportioned by their old sizes +;;; relative to the old group size. If that fails, this tries to make all the +;;; windows the same size, dividing up the new group's size. +;;; +#+clx +(defun window-group-changed (window-group new-width new-height) + (let ((xparent (window-group-xparent window-group)) + (affected-windows nil) + (count 0) + (old-xparent-height (window-group-height window-group))) + (setf (window-group-width window-group) new-width) + (setf (window-group-height window-group) new-height) + (dolist (window *window-list*) + (let ((test (window-group-xparent (bitmap-hunk-window-group + (window-hunk window))))) + (when (eq test xparent) + (push window affected-windows) + (incf count)))) + ;; Probably shoulds insertion sort them, but I'm lame. + ;; + (xlib:with-state (xparent) + (sort affected-windows #'< + :key #'(lambda (window) + (xlib:drawable-y + (bitmap-hunk-xwindow (window-hunk window)))))) + (let ((start 0)) + (declare (fixnum start)) + (do ((windows affected-windows (cdr windows))) + ((endp windows)) + (let* ((xwindow (bitmap-hunk-xwindow (window-hunk (car windows)))) + (new-child-height (round + (* new-height + (/ (xlib:drawable-height xwindow) + old-xparent-height)))) + (hunk (window-hunk (car windows)))) + ;; If there is not enough room for one of the windows, space them out + ;; evenly so there will be room. + ;; + (when (< new-child-height (minimum-window-height + (font-family-height + (bitmap-hunk-font-family hunk)) + (bitmap-hunk-modeline-pos hunk) + (bitmap-hunk-thumb-bar-p hunk))) + (reconfigure-windows-evenly affected-windows new-width new-height) + (return)) + (xlib:with-state (xwindow) + (setf (xlib:drawable-y xwindow) start + ;; Make the last window absorb or lose the number of pixels + ;; lost in rounding. + ;; + (xlib:drawable-height xwindow) (if (cdr windows) + new-child-height + (- new-height start)) + (xlib:drawable-width xwindow) new-width + start (+ start new-child-height 1)))))))) + +#+clx +(defun reconfigure-windows-evenly (affected-windows new-width new-height) + (let ((count (length affected-windows))) + (multiple-value-bind + (pixels-per-window remainder) + (truncate new-height count) + (let ((count-1 (1- count))) + (do ((windows affected-windows (cdr windows)) + (i 0 (1+ i))) + ((endp windows)) + (let ((xwindow (bitmap-hunk-xwindow (window-hunk (car windows))))) + (setf (xlib:drawable-y xwindow) (* i pixels-per-window)) + (setf (xlib:drawable-width xwindow) new-width) + (if (= i count-1) + (return (setf (xlib:drawable-height + (bitmap-hunk-xwindow + (window-hunk (car windows)))) + (+ pixels-per-window remainder))) + (setf (xlib:drawable-height xwindow) pixels-per-window)))))))) + +;;; SET-HUNK-SIZE -- Internal +;;; +;;; Given a pixel size for a bitmap hunk, set the char size. If the window +;;; is too small, we refuse to admit it; if the user makes unreasonably small +;;; windows, our only responsibity is to not blow up. X will clip any stuff +;;; that doesn't fit. +;;; +(defun set-hunk-size (hunk w h &optional modelinep) + (let* ((font-family (bitmap-hunk-font-family hunk)) + (font-width (font-family-width font-family)) + (font-height (font-family-height font-family))) + (setf (bitmap-hunk-height hunk) h) + (setf (bitmap-hunk-width hunk) w) + (setf (bitmap-hunk-char-width hunk) + (max (truncate (- w hunk-left-border) font-width) + minimum-window-columns)) + (let* ((h-minus-borders (- h hunk-top-border + (bitmap-hunk-bottom-border hunk))) + (hwin (bitmap-hunk-window hunk)) + (modelinep (or modelinep (and hwin (window-modeline-buffer hwin))))) + (setf (bitmap-hunk-char-height hunk) + (max (if modelinep + (1- (truncate (- h-minus-borders + hunk-modeline-top hunk-modeline-bottom) + font-height)) + (truncate h-minus-borders font-height)) + minimum-window-lines)) + (setf (bitmap-hunk-modeline-pos hunk) + (if modelinep (- h font-height + hunk-modeline-top hunk-modeline-bottom)))))) + +;;; BITMAP-HUNK-BOTTOM-BORDER -- Internal. +;;; +(defun bitmap-hunk-bottom-border (hunk) + (if (bitmap-hunk-thumb-bar-p hunk) + hunk-thumb-bar-bottom-border + hunk-bottom-border)) + + +;;; DEFAULT-GCONTEXT is used when making hunks. +;;; +#+clx +(defun default-gcontext (drawable &optional font-family) + (xlib:create-gcontext + :drawable drawable + :foreground *default-foreground-pixel* + :background *default-background-pixel* + :font (if font-family (svref (font-family-map font-family) 0)))) + + +;;; WINDOW-ROOT-XY returns the x and y coordinates for a window relative to +;;; its root. Some window managers reparent Hemlock's window, so we have +;;; to mess around possibly to get this right. If x and y are supplied, they +;;; are relative to xwin's parent. +;;; +#+clx +(defun window-root-xy (xwin &optional x y) + (multiple-value-bind (children parent root) + (xlib:query-tree xwin) + (declare (ignore children)) + (if (eq parent root) + (if (and x y) + (values x y) + (xlib:with-state (xwin) + (values (xlib:drawable-x xwin) (xlib:drawable-y xwin)))) + (multiple-value-bind + (tx ty) + (if (and x y) + (xlib:translate-coordinates parent x y root) + (xlib:with-state (xwin) + (xlib:translate-coordinates + parent (xlib:drawable-x xwin) (xlib:drawable-y xwin) root))) + (values (- tx xwindow-border-width) + (- ty xwindow-border-width)))))) + +;;; CREATE-WINDOW-WITH-PROPERTIES makes an X window with parent. X, y, w, and +;;; h are possibly nil, so we supply zero in this case. This would be used +;;; for prompting the user. Some standard properties are set to keep window +;;; managers in line. We name all windows because awm and twm window managers +;;; refuse to honor menu clicks over windows without names. Min-width and +;;; min-height are optional and only used for prompting the user for a window. +;;; +#+clx +(defun create-window-with-properties (parent x y w h font-width font-height + icon-name + &optional min-width min-height + window-group-p) + (let* ((win (xlib:create-window + :parent parent :x (or x 0) :y (or y 0) + :width (or w 0) :height (or h 0) + :background (if window-group-p :none *default-background-pixel*) + :border-width (if window-group-p xwindow-border-width 0) + :border (if window-group-p *default-border-pixmap* nil) + :class :input-output))) + (xlib:set-wm-properties + win :name (new-hemlock-window-name) :icon-name icon-name + :resource-name "Hemlock" + :x x :y y :width w :height h + :user-specified-position-p t :user-specified-size-p t + :width-inc font-width :height-inc font-height + :min-width min-width :min-height min-height + ;; Tell OpenLook pseudo-X11 server we want input. + :input :on) + win)) + + +;;; SET-WINDOW-HOOK-RAISE-FUN is a "Set Window Hook" function controlled by +;;; "Set Window Autoraise". When autoraising, check that it isn't only the +;;; echo area window that we autoraise; if it is only the echo area window, +;;; then see if window is the echo area window. +;;; +#+clx +(defun set-window-hook-raise-fun (window) + (let ((auto (value hemlock::set-window-autoraise))) + (when (and auto + (or (not (eq auto :echo-only)) + (eq window *echo-area-window*))) + (let* ((hunk (window-hunk window)) + (win (window-group-xparent (bitmap-hunk-window-group hunk)))) + (xlib:map-window win) + (setf (xlib:window-priority win) :above) + (xlib:display-force-output + (bitmap-device-display (device-hunk-device hunk))))))) + + +;;; REVERSE-VIDEO-HOOK-FUN is called when the variable "Reverse Video" is set. +;;; If we are running on a windowed bitmap, we first setup the default +;;; foregrounds and backgrounds. Having done that, we get a new cursor. Then +;;; we do over all the hunks, updating their graphics contexts, cursors, and +;;; backgrounds. The current window's border is given the new highlight pixmap. +;;; Lastly, we update the random typeout hunk and redisplay everything. +;;; + +#+clx +(defun reverse-video-hook-fun (name kind where new-value) + (declare (ignore name kind where)) + (when (windowed-monitor-p) + (let* ((current-window (current-window)) + (current-hunk (window-hunk current-window)) + (device (device-hunk-device current-hunk)) + (display (bitmap-device-display device))) + (cond + (new-value + (setf *default-background-pixel* + (xlib:screen-black-pixel (xlib:display-default-screen display))) + (setf *default-foreground-pixel* + (xlib:screen-white-pixel (xlib:display-default-screen display))) + (setf *cursor-background-color* (make-black-color)) + (setf *cursor-foreground-color* (make-white-color)) + (setf *hack-hunk-replace-line* nil)) + (t (setf *default-background-pixel* + (xlib:screen-white-pixel (xlib:display-default-screen display))) + (setf *default-foreground-pixel* + (xlib:screen-black-pixel (xlib:display-default-screen display))) + (setf *cursor-background-color* (make-white-color)) + (setf *cursor-foreground-color* (make-black-color)))) + (setf *highlight-border-pixmap* *default-foreground-pixel*) + (get-hemlock-cursor display) + (dolist (hunk (device-hunks device)) + (reverse-video-frob-hunk hunk)) + (dolist (rt-info *random-typeout-buffers*) + (reverse-video-frob-hunk + (window-hunk (random-typeout-stream-window (cdr rt-info))))) + (setf (xlib:window-border (bitmap-hunk-xwindow current-hunk)) + *highlight-border-pixmap*)) + (redisplay-all))) + +#-clx +(defun reverse-video-hook-fun (name kind where new-value) + (declare (ignore name kind where new-value))) + +#+clx +(defun reverse-video-frob-hunk (hunk) + (let ((gcontext (bitmap-hunk-gcontext hunk))) + (setf (xlib:gcontext-foreground gcontext) *default-foreground-pixel*) + (setf (xlib:gcontext-background gcontext) *default-background-pixel*)) + (let ((xwin (bitmap-hunk-xwindow hunk))) + (setf (xlib:window-cursor xwin) *hemlock-cursor*) + (setf (xlib:window-background xwin) *default-background-pixel*))) Index: /branches/ide-1.0/ccl/hemlock/src/archive/debug.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/archive/debug.lisp (revision 6567) +++ /branches/ide-1.0/ccl/hemlock/src/archive/debug.lisp (revision 6567) @@ -0,0 +1,561 @@ +;;; -*- Mode: Lisp; Package: ED; Log: hemlock.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; This contains commands for sending debugger commands to slaves in the +;;; debugger. +;;; +;;; Written by Bill Chiles. +;;; + +(in-package :hemlock) + + + + +;;;; DEFINE-DEBUGGER-COMMAND. + +(defmacro define-debugger-command (name doc cmd &key uses-argument) + `(defcommand ,(concatenate 'simple-string "Debug " name) (p) + ,doc ,doc + ,@(if uses-argument + nil + '((declare (ignore p)))) + (let* ((server-info (get-current-eval-server t)) + (wire (server-info-wire server-info))) + (wire:remote wire + (ts-stream-accept-input + (ts-data-stream (server-info-slave-info server-info)) + ,(if uses-argument + `(list ,cmd p) + cmd))) + (wire:wire-force-output wire)))) + + + + +;;;; Frame changing commands. + +(define-debugger-command "Up" + "Moves the \"Current Eval Server\" up one debugger frame." + :up) + +(define-debugger-command "Down" + "Moves the \"Current Eval Server\" down one debugger frame." + :down) + +(define-debugger-command "Top" + "Moves the \"Current Eval Server\" to the top of the debugging stack." + :top) + +(define-debugger-command "Bottom" + "Moves the \"Current Eval Server\" to the bottom of the debugging stack." + :bottom) + +(define-debugger-command "Frame" + "Moves the \"Current Eval Server\" to the absolute debugger frame number + indicated by the prefix argument." + :frame + :uses-argument t) + + + + +;;;; In and Out commands. + +(define-debugger-command "Quit" + "In the \"Current Eval Server\", throws to top level out of the debugger." + :quit) + +(define-debugger-command "Go" + "In the \"Current Eval Server\", tries the CONTINUE restart." + :go) + +(define-debugger-command "Abort" + "In the \"Current Eval Server\", execute the previous ABORT restart." + :abort) + +(define-debugger-command "Restart" + "In the \"Current Eval Server\", executes the restart indicated by the + prefix argument." + :restart + :uses-argument t) + + + + +;;;; Information commands. + +(define-debugger-command "Help" + "In the \"Current Eval Server\", prints the debugger's help text." + :help) + +(define-debugger-command "Error" + "In the \"Current Eval Server\", print the error condition and restart cases + upon entering the debugger." + :error) + +(define-debugger-command "Backtrace" + "Executes the debugger's BACKTRACE command." + :backtrace) + +(define-debugger-command "Print" + "In the \"Current Eval Server\", prints a representation of the debugger's + current frame." + :print) + +(define-debugger-command "Verbose Print" + "In the \"Current Eval Server\", prints a representation of the debugger's + current frame without elipsis." + :vprint) + +(define-debugger-command "List Locals" + "In the \"Current Eval Server\", prints the local variables for the debugger's + current frame." + :list-locals) + +(define-debugger-command "Source" + "In the \"Current Eval Server\", prints the source form for the debugger's + current frame." + :source) + +(define-debugger-command "Verbose Source" + "In the \"Current Eval Server\", prints the source form for the debugger's + current frame with surrounding forms for context." + :vsource) + + + + +;;;; Source editing. + +;;; "Debug Edit Source" -- Command. +;;; +;;; The :edit-source command in the slave debugger initiates a synchronous RPC +;;; into the editor via the wire in *terminal-io*, a typescript stream. This +;;; routine takes the necessary values, a file and source-path, and changes the +;;; editor's state to display that location. +;;; +;;; This command has to wait on SERVE-EVENT until some special is set by the +;;; RPC routine saying it is okay to return to the editor's top level. +;;; +(defvar *debug-editor-source-data* nil) +(defvar *in-debug-edit-source* nil) + +(defcommand "Debug Edit Source" (p) + "Given the \"Current Eval Server\"'s current debugger frame, place the user + at the location's source in the editor." + "Given the \"Current Eval Server\"'s current debugger frame, place the user + at the location's source in the editor." + (declare (ignore p)) + (let* ((server-info (get-current-eval-server t)) + (wire (server-info-wire server-info))) + ;; + ;; Tell the slave to tell the editor some source info. + (wire:remote wire + (ts-stream-accept-input + (ts-data-stream (server-info-slave-info server-info)) + :edit-source)) + (wire:wire-force-output wire) + ;; + ;; Wait for the source info. + (let ((*debug-editor-source-data* nil) + (*in-debug-edit-source* t)) + (catch 'blow-debug-edit-source + (loop + (system:serve-event) + (when *debug-editor-source-data* (return))))))) + +;;; EDIT-SOURCE-LOCATION -- Internal Interface. +;;; +;;; The slave calls this in the editor when the debugger gets an :edit-source +;;; command. This receives the information necessary to take the user in +;;; Hemlock to the source location, and does it. +;;; +(defun edit-source-location (name source-created-date tlf-offset + local-tlf-offset char-offset form-number) + (let ((pn (pathname name))) + (unless (probe-file pn) + (editor-error "Source file no longer exists: ~A." name)) + (multiple-value-bind (buffer newp) (find-file-buffer pn) + (let ((date (buffer-write-date buffer)) + (point (buffer-point buffer))) + (when newp (push-buffer-mark (copy-mark point) nil)) + (buffer-start point) + ;; + ;; Get to the top-level form in the buffer. + (cond ((buffer-modified buffer) + (loud-message "Buffer has been modified. Using form offset ~ + instead of character position.") + (dotimes (i local-tlf-offset) + (pre-command-parse-check point) + (form-offset point 1))) + ((not date) + (loud-message "Cannot compare write dates. Assuming source ~ + has not been modified -- ~A." + name) + (character-offset point char-offset)) + ((= source-created-date date) + (character-offset point char-offset)) + (t + (loud-message "File has been modified since reading the source. ~ + Using form offset instead of character position.") + (dotimes (i local-tlf-offset) + (pre-command-parse-check point) + (form-offset point 1)))) + ;; + ;; Read our form, get form-number translations, get the source-path, + ;; and make it usable. + ;; + ;; NOTE: Here READ is used in the editor lisp to look at a form + ;; that the compiler has digested in the slave lisp. The editor + ;; does not have the same environment at the slave so bad things + ;; can happen if READ hits a #. reader macro (like unknown package + ;; or undefined function errors) which can break the editor. This + ;; code basically inhibits the read-time eval. This doesn't always + ;; work right as the compiler may be seeing a different form structure + ;; and the compiler's version of PATH may not match the editor's. + ;; The main trouble seen in testing is that the 'form-number' + ;; supplied by the compiler was one more than what the vector + ;; returned by form-number-translations contained. For lack of a + ;; better solution, I (pw) just limit the form-number to legal range. + ;; This has worked ok on test code but may be off for some + ;; forms. At least the editor won't break. + + (let* ((vector (di:form-number-translations + (with-input-from-region + (s (region point (buffer-end-mark buffer))) + (let ((*read-suppress* t)) + (read s))) + tlf-offset)) + ;; Don't signal error on index overrun.It may be due + ;; to read-time eval getting form editing blind to + ;; editor + (index (min form-number (1- (length vector)))) + (path (nreverse (butlast (cdr (svref vector index)))))) + ;; + ;; Walk down to the form. Change to buffer in case we get an error + ;; while finding the form. + (change-to-buffer buffer) + (mark-to-debug-source-path point path))))) + (setf *debug-editor-source-data* t) + ;; + ;; While Hemlock was setting up the source edit, the user could have typed + ;; while looking at a buffer no longer current when the commands execute. + (clear-editor-input *editor-input*)) + +;;; CANNOT-EDIT-SOURCE-LOCATION -- Interface. +;;; +;;; The slave calls this when the debugger command "EDIT-SOURCE" runs, and the +;;; slave cannot give the editor source information. +;;; +(defun cannot-edit-source-location () + (loud-message "Can't edit source.") + (when *in-debug-edit-source* + (throw 'blow-debug-edit-source nil))) + + + +;;;; Breakpoints. + +;;; +;;; Breakpoint information for editor management. +;;; + +;;; This holds all the stuff we might want to know about a breakpoint in some +;;; slave. +;;; +(defstruct (breakpoint-info (:print-function print-breakpoint-info) + (:constructor make-breakpoint-info + (slave buffer remote-object name))) + (slave nil :type server-info) + (buffer nil :type buffer) + (remote-object nil :type wire:remote-object) + (name nil :type simple-string)) +;;; +(defun print-breakpoint-info (obj str n) + (declare (ignore n)) + (format str "#" (breakpoint-info-name obj))) + +(defvar *breakpoints* nil) + +(macrolet ((frob (name accessor) + `(defun ,name (key) + (let ((res nil)) + (dolist (bpt-info *breakpoints* res) + (when (eq (,accessor bpt-info) key) + (push bpt-info res))))))) + (frob slave-breakpoints breakpoint-info-slave) + (frob buffer-breakpoints breakpoint-info-buffer)) + +(defun delete-breakpoints-buffer-hook (buffer) + (let ((server-info (value current-eval-server))) + (when server-info + (let ((bpts (buffer-breakpoints buffer)) + (wire (server-info-wire server-info))) + (dolist (b bpts) + (setf *breakpoints* (delete b *breakpoints*)) + (when wire + (wire:remote wire + (di:delete-breakpoint (breakpoint-info-remote-object b)))) + (when wire + (wire:wire-force-output wire))))))) +;;; +(add-hook delete-buffer-hook 'delete-breakpoints-buffer-hook) + +;;; +;;; Setting breakpoints. +;;; + +;;; "Debug Breakpoint" uses this to prompt for :function-end and +;;; :function-start breakpoints. +;;; +(defvar *function-breakpoint-strings* + (make-string-table :initial-contents + '(("Start" . :function-start) ("End" . :function-end)))) +;;; +;;; Maybe this should use the wire level directly and hold onto remote-objects +;;; identifying the breakpoints. Then we could write commands to show where +;;; the breakpoints were and to individually deactivate or delete them. As it +;;; is now we probably have to delete all for a given function. What about +;;; setting user supplied breakpoint hook-functions, or Hemlock supplying a +;;; nice set such as something to simply print all locals at a certain +;;; location. +;;; +(defcommand "Debug Breakpoint" (p) + "This tries to set a breakpoint in the \"Current Eval Server\" at the + location designated by the current point. If there is no known code + location at the point, then this moves the point to the closest location + before the point. With an argument, this sets a breakpoint at the start + or end of the function, prompting the user for which one to use." + "This tries to set a breakpoint in the \"Current Eval Server\" at the + location designated by the current point. If there is no known code + location at the point, then this moves the point to the closest location + before the point. With an argument, this sets a breakpoint at the start + or end of the function, prompting the user for which one to use." + (let ((point (current-point))) + (pre-command-parse-check point) + (let ((name (find-defun-for-breakpoint point))) + (if p + (multiple-value-bind (str place) + (prompt-for-keyword + (list *function-breakpoint-strings*) + :prompt "Set breakpoint at function: " + :default :start :default-string "Start") + (declare (ignore str)) + (set-breakpoint-in-slave (get-current-eval-server t) name place)) + (let* ((path (find-path-for-breakpoint point)) + (server-info (get-current-eval-server t)) + (res (set-breakpoint-in-slave server-info name path))) + (cond ((not res) + (message "No code locations correspond with point.")) + ((wire:remote-object-p res) + (push (make-breakpoint-info server-info (current-buffer) + res name) + *breakpoints*) + (message "Breakpoint set.")) + (t + (resolve-ambiguous-breakpoint-location server-info + name res)))))))) + +;;; FIND-PATH-FOR-BREAKPOINT -- Internal. +;;; +;;; This walks up from point to the beginning of its containing DEFUN to return +;;; the pseudo source-path (no form-number, no top-level form offset, and in +;;; descent order from start of the DEFUN). +;;; +(defun find-path-for-breakpoint (point) + (with-mark ((m point) + (end point)) + (let ((path nil)) + (top-level-offset end -1) + (with-mark ((containing-form m)) + (loop + (when (mark= m end) (return)) + (backward-up-list containing-form) + (do ((count 0 (1+ count))) + ((mark= m containing-form) + ;; Count includes moving from the first form inside the + ;; containing-form paren to the outside of the containing-form + ;; paren -- one too many. + (push (1- count) path)) + (form-offset m -1)))) + path))) + +;;; SET-BREAKPOINT-IN-SLAVE -- Internal. +;;; +;;; This tells the slave to set a breakpoint for name. Path is a modified +;;; source-path (with no form-number or top-level-form offset) or a symbol +;;; (:function-start or :function-end). If the server dies while evaluating +;;; form, then this signals an editor-error. +;;; +(defun set-breakpoint-in-slave (server-info name path) + (when (server-info-notes server-info) + (editor-error "Server ~S is currently busy. See \"List Operations\"." + (server-info-name server-info))) + (multiple-value-bind (res error) + (wire:remote-value (server-info-wire server-info) + (di:set-breakpoint-for-editor (value current-package) + name path)) + (when error (editor-error "The server died before finishing.")) + res)) + +;;; RESOLVE-AMBIGUOUS-BREAKPOINT-LOCATION -- Internal. +;;; +;;; This helps the user select an ambiguous code location for "Debug +;;; Breakpoint". +;;; +(defun resolve-ambiguous-breakpoint-location (server-info name locs) + (declare (list locs)) + (let ((point (current-point)) + (loc-num (length locs)) + (count 1) + (cur-loc locs)) + (flet ((show-loc () + (top-level-offset point -1) + (mark-to-debug-source-path point (cdar cur-loc)))) + (show-loc) + (command-case (:prompt `("Ambiguous location ~D of ~D: " ,count ,loc-num) + :help "Pick a location to set a breakpoint." + :change-window nil) + (#\space "Move point to next possible location." + (setf cur-loc (cdr cur-loc)) + (cond (cur-loc + (incf count)) + (t + (setf cur-loc locs) + (setf count 1))) + (show-loc) + (reprompt)) + (:confirm "Choose the current location." + (let ((res (wire:remote-value (server-info-wire server-info) + (di:set-location-breakpoint-for-editor (caar cur-loc))))) + (unless (wire:remote-object-p res) + (editor-error "Couldn't set breakpoint from location?")) + (push (make-breakpoint-info server-info (current-buffer) res name) + *breakpoints*)) + (message "Breakpoint set.")))))) + +;;; MARK-TO-DEBUG-SOURCE-PATH -- Internal. +;;; +;;; This takes a mark at the beginning of a top-level form and modified debugger +;;; source-path. Path has no form number or top-level-form offset element, and +;;; it has been reversed to actually be usable. +;;; +(defun mark-to-debug-source-path (mark path) + (let ((quote-or-function nil)) + (pre-command-parse-check mark) + (dolist (n path) + (when quote-or-function + (editor-error + "Apparently settled on the symbol QUOTE or FUNCTION via their ~ + read macros, which is odd, but furthermore there seems to be ~ + more source-path left.")) + (unless (form-offset mark 1) + ;; Want to use the following and delete the next FORM-OFFSET -1. + ;; (scan-direction-valid mark t (or :open-paren :prefix)) + (editor-error + "Ran out of text in buffer with more source-path remaining.")) + (form-offset mark -1) + (ecase (next-character mark) + (#\( + (mark-after mark) + (form-offset mark n)) + (#\' + (case n + (0 (setf quote-or-function t)) + (1 (mark-after mark)) + (t (editor-error "Next form is QUOTE, but source-path index ~ + is other than zero or one.")))) + (#\# + (case (next-character (mark-after mark)) + (#\' + (case n + (0 (setf quote-or-function t)) + (1 (mark-after mark)) + (t (editor-error "Next form is FUNCTION, but source-path ~ + index is other than zero or one.")))) + (t (editor-error + "Can only parse ' and #' read macros.")))))) + ;; Get to the beginning of the form. + (form-offset mark 1) + (form-offset mark -1))) + +;;; +;;; Deleting breakpoints. +;;; + +(defhvar "Delete Breakpoints Confirm" + "This determines whether \"Debug Delete Breakpoints\" should ask for + confirmation before deleting breakpoints." + :value t) + +(defcommand "Debug Delete Breakpoints" (p) + "This deletes all breakpoints for the named DEFUN containing the point. + This affects the \"Current Eval Server\"." + "This deletes all breakpoints for the named DEFUN containing the point. + This affects the \"Current Eval Server\"." + (declare (ignore p)) + (let* ((server-info (get-current-eval-server t)) + (wire (server-info-wire server-info)) + (name (find-defun-for-breakpoint (current-point))) + (bpts (slave-breakpoints server-info))) + (cond ((not bpts) + (message "No breakpoints recorded for ~A." name)) + ((or (not (value delete-breakpoints-confirm)) + (prompt-for-y-or-n :prompt `("Delete breakpoints for ~A? " ,name) + :default t + :default-string "Y")) + (dolist (b bpts) + (when (string= name (breakpoint-info-name b)) + (setf *breakpoints* (delete b *breakpoints*)) + (wire:remote wire + (di:delete-breakpoint-for-editor + (breakpoint-info-remote-object b))))) + (wire:wire-force-output wire))))) + +;;; +;;; Breakpoint utilities. +;;; + +;;; FIND-DEFUN-FOR-BREAKPOINT -- Internal. +;;; +;;; This returns as a string the name of the DEFUN containing point. It +;;; signals any errors necessary to ensure "we are in good form". +;;; +(defun find-defun-for-breakpoint (point) + (with-mark ((m1 point) + (m2 point)) + (unless (top-level-offset m2 -1) + (editor-error "Must be inside a DEFUN.")) + ;; + ;; Check for DEFUN. + (mark-after (move-mark m1 m2)) + (unless (find-attribute m1 :whitespace #'zerop) + (editor-error "Must be inside a DEFUN.")) + (word-offset (move-mark m2 m1) 1) + (unless (string-equal (region-to-string (region m1 m2)) "defun") + (editor-error "Must be inside a DEFUN.")) + ;; + ;; Find name. + (unless (find-attribute m2 :whitespace #'zerop) + (editor-error "Function unnamed?")) + (form-offset (move-mark m1 m2) 1) + (region-to-string (region m2 m1)))) + + + + +;;;; Miscellaneous commands. + +(define-debugger-command "Flush Errors" + "In the \"Current Eval Server\", toggles whether the debugger ignores errors + or recursively enters itself." + :flush) Index: /branches/ide-1.0/ccl/hemlock/src/archive/dired.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/archive/dired.lisp (revision 6567) +++ /branches/ide-1.0/ccl/hemlock/src/archive/dired.lisp (revision 6567) @@ -0,0 +1,701 @@ +;;; -*- Log: hemlock.log; Package: dired -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; This file contains site dependent code for dired. +;;; Written by Bill Chiles. +;;; + +(defpackage "DIRED" + (:shadow "RENAME-FILE" "DELETE-FILE") + (:export "COPY-FILE" "RENAME-FILE" "FIND-FILE" "DELETE-FILE" + "MAKE-DIRECTORY" + "*UPDATE-DEFAULT*" "*CLOBBER-DEFAULT*" "*RECURSIVE-DEFAULT*" + "*REPORT-FUNCTION*" "*ERROR-FUNCTION*" "*YESP-FUNCTION*" + "PATHNAMES-FROM-PATTERN")) + +(in-package "DIRED") + + + +;;;; Exported parameters. + +(defparameter *update-default* nil + "Update arguments to utilities default to this value.") + +(defparameter *clobber-default* t + "Clobber arguments to utilities default to this value.") + +(defparameter *recursive-default* nil + "Recursive arguments to utilities default to this value.") + + + + +;;;; WILDCARDP + +(defconstant wildcard-char #\* + "Wildcard designator for file names will match any substring.") + +(defmacro wildcardp (file-namestring) + `(position wildcard-char (the simple-string ,file-namestring) :test #'char=)) + + + + +;;;; User interaction functions, variable declarations, and their defaults. + +(defun default-error-function (string &rest args) + (apply #'error string args)) +;;; +(defvar *error-function* #'default-error-function + "This function is called when an error is encountered in dired code.") + +(defun default-report-function (string &rest args) + (apply #'format t string args)) +;;; +(defvar *report-function* #'default-report-function + "This function is called when the user needs to be informed of something.") + +(defun default-yesp-function (string &rest args) + (apply #'format t string args) + (let ((answer (nstring-downcase (string-trim '(#\space #\tab) (read-line))))) + (declare (simple-string answer)) + (or (string= answer "") + (string= answer "y") + (string= answer "yes") + (string= answer "ye")))) +;;; +(defvar *yesp-function* #'default-yesp-function + "Function to query the user about clobbering an already existent file.") + + + + +;;;; Copy-File + +;;; WILD-MATCH objects contain information about wildcard matches. File is the +;;; Sesame namestring of the file matched, and substitute is a substring of the +;;; file-namestring of file. +;;; +(defstruct (wild-match (:print-function print-wild-match) + (:constructor make-wild-match (file substitute))) + file + substitute) + +(defun print-wild-match (obj str n) + (declare (ignore n)) + (format str "#" + (wild-match-file obj) (wild-match-substitute obj))) + + +(defun copy-file (spec1 spec2 &key (update *update-default*) + (clobber *clobber-default*) + (directory () directoryp)) + "Copy file spec1 to spec2. A single wildcard is acceptable, and directory + names may be used. If spec1 and spec2 are both directories, then a + recursive copy is done of the files and subdirectory structure of spec1; + if spec2 is in the subdirectory structure of spec1, the recursion will + not descend into it. Use spec1/* to copy only the files in spec1 to + directory spec2. If spec2 is a directory, and spec1 is a file, then + spec1 is copied into spec2 with the same pathname-name. Files are + copied maintaining the source's write date. If :update is non-nil, then + files are only copied if the source is newer than the destination, still + maintaining the source's write date; the user is not warned if the + destination is newer (not the same write date) than the source. If + :clobber and :update are nil, then if any file spec2 already exists, the + user will be asked whether it should be overwritten or not." + (cond + ((not directoryp) + (let* ((ses-name1 (ext:unix-namestring spec1 t)) + (exists1p (unix:unix-file-kind ses-name1)) + (ses-name2 (ext:unix-namestring spec2 nil)) + (pname1 (pathname ses-name1)) + (pname2 (pathname ses-name2)) + (dirp1 (directoryp pname1)) + (dirp2 (directoryp pname2)) + (wildp1 (wildcardp (file-namestring pname1))) + (wildp2 (wildcardp (file-namestring pname2)))) + (when (and dirp1 wildp1) + (funcall *error-function* + "Cannot have wildcards in directory names -- ~S." pname1)) + (when (and dirp2 wildp2) + (funcall *error-function* + "Cannot have wildcards in directory names -- ~S." pname2)) + (when (and dirp1 (not dirp2)) + (funcall *error-function* + "Cannot handle spec1 being a directory and spec2 a file.")) + (when (and wildp2 (not wildp1)) + (funcall *error-function* + "Cannot handle destination having wildcards without ~ + source having wildcards.")) + (when (and wildp1 (not wildp2) (not dirp2)) + (funcall *error-function* + "Cannot handle source with wildcards and destination ~ + without, unless destination is a directory.")) + (cond ((and dirp1 dirp2) + (unless (directory-existsp ses-name1) + (funcall *error-function* + "Directory does not exist -- ~S." pname1)) + (unless (directory-existsp ses-name2) + (enter-directory ses-name2)) + (recursive-copy pname1 pname2 update clobber pname2 + ses-name1 ses-name2)) + (dirp2 + ;; merge pname2 with pname1 to pick up a similar file-namestring. + (copy-file-1 pname1 wildp1 exists1p + (merge-pathnames pname2 pname1) + wildp1 update clobber)) + (t (copy-file-1 pname1 wildp1 exists1p + pname2 wildp2 update clobber))))) + (directory + (when (pathname-directory spec1) + (funcall *error-function* + "Spec1 is just a pattern when supplying directory -- ~S." + spec1)) + (let* ((pname2 (pathname (ext:unix-namestring spec2 nil))) + (dirp2 (directoryp pname2)) + (wildp1 (wildcardp spec1)) + (wildp2 (wildcardp (file-namestring pname2)))) + (unless wildp1 + (funcall *error-function* + "Pattern, ~S, does not contain a wildcard." + spec1)) + (when (and (not wildp2) (not dirp2)) + (funcall *error-function* + "Cannot handle source with wildcards and destination ~ + without, unless destination is a directory.")) + (copy-wildcard-files spec1 wildp1 + (if dirp2 (merge-pathnames pname2 spec1) pname2) + (if dirp2 wildp1 wildp2) + update clobber directory)))) + (values)) + +;;; RECURSIVE-COPY takes two pathnames that represent directories, and +;;; the files in pname1 are copied into pname2, recursively descending into +;;; subdirectories. If a subdirectory of pname1 does not exist in pname2, +;;; it is created. Pname1 is known to exist. Forbidden-dir is originally +;;; the same as pname2; this keeps us from infinitely recursing if pname2 +;;; is in the subdirectory structure of pname1. Returns t if some file gets +;;; copied. +;;; +(defun recursive-copy (pname1 pname2 update clobber + forbidden-dir ses-name1 ses-name2) + (funcall *report-function* "~&~S ==>~% ~S~%" ses-name1 ses-name2) + (dolist (spec (directory (directory-namestring pname1))) + (let ((spec-ses-name (namestring spec))) + (if (directoryp spec) + (unless (equal (pathname spec-ses-name) forbidden-dir) + (let* ((dir2-pname (merge-dirs spec pname2)) + (dir2-ses-name (namestring dir2-pname))) + (unless (directory-existsp dir2-ses-name) + (enter-directory dir2-ses-name)) + (recursive-copy spec dir2-pname update clobber forbidden-dir + spec-ses-name dir2-ses-name) + (funcall *report-function* "~&~S ==>~% ~S~%" ses-name1 + ses-name2))) + (copy-file-2 spec-ses-name + (namestring (merge-pathnames pname2 spec)) + update clobber))))) + +;;; MERGE-DIRS picks out the last directory name in the pathname pname1 and +;;; adds it to the end of the sequence of directory names from pname2, returning +;;; a pathname. +;;; +#| +(defun merge-dirs (pname1 pname2) + (let* ((dirs1 (pathname-directory pname1)) + (dirs2 (pathname-directory pname2)) + (dirs2-len (length dirs2)) + (new-dirs2 (make-array (1+ dirs2-len)))) + (declare (simple-vector dirs1 dirs2 new-dirs2)) + (replace new-dirs2 dirs2) + (setf (svref new-dirs2 dirs2-len) + (svref dirs1 (1- (length dirs1)))) + (make-pathname :directory new-dirs2 :device :absolute))) +|# + +(defun merge-dirs (pname1 pname2) + (let* ((dirs1 (pathname-directory pname1)) + (dirs2 (pathname-directory pname2)) + (dirs2-len (length dirs2)) + (new-dirs2 (make-list (1+ dirs2-len)))) + (replace new-dirs2 dirs2) + (setf (nth dirs2-len new-dirs2) + (nth (1- (length dirs1)) dirs1)) + (make-pathname :directory new-dirs2 :device :unspecific))) + +;;; COPY-FILE-1 takes pathnames which either both contain a single wildcard +;;; or none. Wildp1 and Wildp2 are either nil or indexes into the +;;; file-namestring of pname1 and pname2, respectively, indicating the position +;;; of the wildcard character. If there is no wildcard, then simply call +;;; COPY-FILE-2; otherwise, resolve the wildcard and copy those matching files. +;;; +(defun copy-file-1 (pname1 wildp1 exists1p pname2 wildp2 update clobber) + (if wildp1 + (copy-wildcard-files pname1 wildp1 pname2 wildp2 update clobber) + (let ((ses-name1 (namestring pname1))) + (unless exists1p (funcall *error-function* + "~S does not exist." ses-name1)) + (copy-file-2 ses-name1 (namestring pname2) update clobber)))) + +(defun copy-wildcard-files (pname1 wildp1 pname2 wildp2 update clobber + &optional directory) + (multiple-value-bind (dst-before dst-after) + (before-wildcard-after (file-namestring pname2) wildp2) + (dolist (match (resolve-wildcard pname1 wildp1 directory)) + (copy-file-2 (wild-match-file match) + (namestring (concatenate 'simple-string + (directory-namestring pname2) + dst-before + (wild-match-substitute match) + dst-after)) + update clobber)))) + +;;; COPY-FILE-2 copies ses-name1 to ses-name2 depending on the values of update +;;; and clobber, with respect to the documentation of COPY-FILE. If ses-name2 +;;; doesn't exist, then just copy it; otherwise, if update, then only copy it +;;; if the destination's write date precedes the source's, and if not clobber +;;; and not update, then ask the user before doing the copy. +;;; +(defun copy-file-2 (ses-name1 ses-name2 update clobber) + (let ((secs1 (get-write-date ses-name1))) + (cond ((not (probe-file ses-name2)) + (do-the-copy ses-name1 ses-name2 secs1)) + (update + (let ((secs2 (get-write-date ses-name2))) + (cond (clobber + (do-the-copy ses-name1 ses-name2 secs1)) + ((and (> secs2 secs1) + (funcall *yesp-function* + "~&~S ==> ~S~% ~ + ** Destination is newer than source. ~ + Overwrite it? " + ses-name1 ses-name2)) + (do-the-copy ses-name1 ses-name2 secs1)) + ((< secs2 secs1) + (do-the-copy ses-name1 ses-name2 secs1))))) + ((not clobber) + (when (funcall *yesp-function* + "~&~S ==> ~S~% ** Destination already exists. ~ + Overwrite it? " + ses-name1 ses-name2) + (do-the-copy ses-name1 ses-name2 secs1))) + (t (do-the-copy ses-name1 ses-name2 secs1))))) + +(defun do-the-copy (ses-name1 ses-name2 secs1) + (let* ((fd (open-file ses-name1))) + (unwind-protect + (multiple-value-bind (data byte-count mode) + (read-file fd ses-name1) + (unwind-protect (write-file ses-name2 data byte-count mode) + (system:deallocate-system-memory data byte-count))) + (close-file fd))) + (set-write-date ses-name2 secs1) + (funcall *report-function* "~&~S ==>~% ~S~%" ses-name1 ses-name2)) + + + +;;;; Rename-File + +(defun rename-file (spec1 spec2 &key (clobber *clobber-default*) + (directory () directoryp)) + "Rename file spec1 to spec2. A single wildcard is acceptable, and spec2 may + be a directory with the result spec being the merging of spec2 with spec1. + If clobber is nil and spec2 exists, then the user will be asked to confirm + the renaming. As with Unix mv, if you are renaming a directory, don't + specify the trailing slash." + (cond + ((not directoryp) + (let* ((ses-name1 (ext:unix-namestring spec1 t)) + (exists1p (unix:unix-file-kind ses-name1)) + (ses-name2 (ext:unix-namestring spec2 nil)) + (pname1 (pathname ses-name1)) + (pname2 (pathname ses-name2)) + (dirp2 (directoryp pname2)) + (wildp1 (wildcardp (file-namestring pname1))) + (wildp2 (wildcardp (file-namestring pname2)))) + (if (and dirp2 wildp2) + (funcall *error-function* + "Cannot have wildcards in directory names -- ~S." pname2)) + (if (and wildp2 (not wildp1)) + (funcall *error-function* + "Cannot handle destination having wildcards without ~ + source having wildcards.")) + (if (and wildp1 (not wildp2) (not dirp2)) + (funcall *error-function* + "Cannot handle source with wildcards and destination ~ + without, unless destination is a directory.")) + (if dirp2 + (rename-file-1 pname1 wildp1 exists1p (merge-pathnames pname2 + pname1) + wildp1 clobber) + (rename-file-1 pname1 wildp1 exists1p pname2 wildp2 clobber)))) + (directory + (when (pathname-directory spec1) + (funcall *error-function* + "Spec1 is just a pattern when supplying directory -- ~S." + spec1)) + + (let* ((pname2 (pathname (ext:unix-namestring spec2 nil))) + (dirp2 (directoryp pname2)) + (wildp1 (wildcardp spec1)) + (wildp2 (wildcardp (file-namestring pname2)))) + (unless wildp1 + (funcall *error-function* + "Pattern, ~S, does not contain a wildcard." + spec1)) + (when (and (not wildp2) (not dirp2)) + (funcall *error-function* + "Cannot handle source with wildcards and destination ~ + without, unless destination is a directory.")) + (rename-wildcard-files spec1 wildp1 + (if dirp2 (merge-pathnames pname2 spec1) pname2) + (if dirp2 wildp1 wildp2) + clobber directory)))) + (values)) + +;;; RENAME-FILE-1 takes pathnames which either both contain a single wildcard +;;; or none. Wildp1 and Wildp2 are either nil or indexes into the +;;; file-namestring of pname1 and pname2, respectively, indicating the position +;;; of the wildcard character. If there is no wildcard, then simply call +;;; RENAME-FILE-2; otherwise, resolve the wildcard and rename those matching files. +;;; +(defun rename-file-1 (pname1 wildp1 exists1p pname2 wildp2 clobber) + (if wildp1 + (rename-wildcard-files pname1 wildp1 pname2 wildp2 clobber) + (let ((ses-name1 (namestring pname1))) + (unless exists1p (funcall *error-function* + "~S does not exist." ses-name1)) + (rename-file-2 ses-name1 (namestring pname2) clobber)))) + +(defun rename-wildcard-files (pname1 wildp1 pname2 wildp2 clobber + &optional directory) + (multiple-value-bind (dst-before dst-after) + (before-wildcard-after (file-namestring pname2) wildp2) + (dolist (match (resolve-wildcard pname1 wildp1 directory)) + (rename-file-2 (wild-match-file match) + (namestring (concatenate 'simple-string + (directory-namestring pname2) + dst-before + (wild-match-substitute match) + dst-after)) + clobber)))) + +(defun rename-file-2 (ses-name1 ses-name2 clobber) + (cond ((and (probe-file ses-name2) (not clobber)) + (when (funcall *yesp-function* + "~&~S ==> ~S~% ** Destination already exists. ~ + Overwrite it? " + ses-name1 ses-name2) + (sub-rename-file ses-name1 ses-name2) + (funcall *report-function* "~&~S ==>~% ~S~%" ses-name1 ses-name2))) + (t (sub-rename-file ses-name1 ses-name2) + (funcall *report-function* "~&~S ==>~% ~S~%" ses-name1 ses-name2)))) + + + + +;;;; Find-File + +(defun find-file (file-name &optional (directory "") + (find-all-p nil find-all-suppliedp)) + "Find the file with file-namestring file recursively looking in directory. + If find-all-p is non-nil, then do not stop searching upon finding the first + occurance of file. File may contain a single wildcard, which causes + find-all-p to default to t instead of nil." + (let* ((file (coerce file-name 'simple-string)) + (wildp (wildcardp file)) + (find-all-p (if find-all-suppliedp find-all-p wildp))) + (declare (simple-string file)) + (catch 'found-file + (if wildp + (multiple-value-bind (before after) + (before-wildcard-after file wildp) + (find-file-aux file directory find-all-p before after)) + (find-file-aux file directory find-all-p)))) + (values)) + +(defun find-file-aux (the-file directory find-all-p &optional before after) + (declare (simple-string the-file)) + (dolist (spec (directory directory)) + (let* ((spec-ses-name (namestring spec)) + (spec-file-name (file-namestring spec-ses-name))) + (declare (simple-string spec-ses-name spec-file-name)) + (if (directoryp spec) + (find-file-aux the-file spec find-all-p before after) + (when (if before + (find-match before after spec-file-name :no-cons) + (string-equal the-file spec-file-name)) + (print spec-ses-name) + (unless find-all-p (throw 'found-file t))))))) + + + + +;;;; Delete-File + +;;; DELETE-FILE +;;; If spec is a directory, but recursive is nil, just pass the directory +;;; down through, letting LISP:DELETE-FILE signal an error if the directory +;;; is not empty. +;;; +(defun delete-file (spec &key (recursive *recursive-default*) + (clobber *clobber-default*)) + "Delete spec asking confirmation on each file if clobber is nil. A single + wildcard is acceptable. If recursive is non-nil, then a directory spec may + be given to recursively delete the entirety of the directory and its + subdirectory structure. An empty directory may be specified without + recursive being non-nil. When specifying a directory, the trailing slash + must be included." + (let* ((ses-name (ext:unix-namestring spec t)) + (pname (pathname ses-name)) + (wildp (wildcardp (file-namestring pname))) + (dirp (directoryp pname))) + (if dirp + (if recursive + (recursive-delete pname ses-name clobber) + (delete-file-2 ses-name clobber)) + (delete-file-1 pname ses-name wildp clobber))) + (values)) + +(defun recursive-delete (directory dir-ses-name clobber) + (dolist (spec (directory (directory-namestring directory))) + (let ((spec-ses-name (namestring spec))) + (if (directoryp spec) + (recursive-delete (pathname spec-ses-name) spec-ses-name clobber) + (delete-file-2 spec-ses-name clobber)))) + (delete-file-2 dir-ses-name clobber)) + +(defun delete-file-1 (pname ses-name wildp clobber) + (if wildp + (dolist (match (resolve-wildcard pname wildp)) + (delete-file-2 (wild-match-file match) clobber)) + (delete-file-2 ses-name clobber))) + +(defun delete-file-2 (ses-name clobber) + (when (or clobber (funcall *yesp-function* "~&Delete ~S? " ses-name)) + (if (directoryp ses-name) + (delete-directory ses-name) + (lisp:delete-file ses-name)) + (funcall *report-function* "~&~A~%" ses-name))) + + + + +;;;; Wildcard resolution + +(defun pathnames-from-pattern (pattern files) + "Return a list of pathnames from files whose file-namestrings match + pattern. Pattern must be a non-empty string and contains only one + asterisk. Files contains no directories." + (declare (simple-string pattern)) + (when (string= pattern "") + (funcall *error-function* "Must be a non-empty pattern.")) + (unless (= (count wildcard-char pattern :test #'char=) 1) + (funcall *error-function* "Pattern must contain one asterisk.")) + (multiple-value-bind (before after) + (before-wildcard-after pattern (wildcardp pattern)) + (let ((result nil)) + (dolist (f files result) + (let* ((ses-namestring (namestring f)) + (f-namestring (file-namestring ses-namestring)) + (match (find-match before after f-namestring))) + (when match (push f result))))))) + + +;;; RESOLVE-WILDCARD takes a pathname with a wildcard and the position of the +;;; wildcard character in the file-namestring and returns a list of wild-match +;;; objects. When directory is supplied, pname is just a pattern, or a +;;; file-namestring. It is an error for directory to be anything other than +;;; absolute pathnames in the same directory. Each wild-match object contains +;;; the Sesame namestring of a file in the same directory as pname, or +;;; directory, and a simple-string representing what the wildcard matched. +;;; +(defun resolve-wildcard (pname wild-pos &optional directory) + (multiple-value-bind (before after) + (before-wildcard-after (if directory + pname + (file-namestring pname)) + wild-pos) + (let (result) + (dolist (f (or directory (directory (directory-namestring pname))) + (nreverse result)) + (unless (directoryp f) + (let* ((ses-namestring (namestring f)) + (f-namestring (file-namestring ses-namestring)) + (match (find-match before after f-namestring))) + (if match + (push (make-wild-match ses-namestring match) result)))))))) + +;;; FIND-MATCH takes a "before wildcard" and "after wildcard" string and a +;;; file-namestring. If before and after match a substring of file-namestring +;;; and are respectively left bound and right bound, then anything left in +;;; between is the match returned. If no match is found, nil is returned. +;;; NOTE: if version numbers ever really exist, then this code will have to be +;;; changed since the file-namestring of a pathname contains the version number. +;;; +(defun find-match (before after file-namestring &optional no-cons) + (declare (simple-string before after file-namestring)) + (let ((before-len (length before)) + (after-len (length after)) + (name-len (length file-namestring))) + (if (>= name-len (+ before-len after-len)) + (let* ((start (if (string= before file-namestring + :end1 before-len :end2 before-len) + before-len)) + (end (- name-len after-len)) + (matchp (and start + (string= after file-namestring :end1 after-len + :start2 end :end2 name-len)))) + (if matchp + (if no-cons + t + (subseq file-namestring start end))))))) + +(defun before-wildcard-after (file-namestring wild-pos) + (declare (simple-string file-namestring)) + (values (subseq file-namestring 0 wild-pos) + (subseq file-namestring (1+ wild-pos) (length file-namestring)))) + + + + +;;;; Miscellaneous Utilities (e.g., MAKEDIR). + +(defun make-directory (name) + "Creates directory name. If name exists, then an error is signaled." + (let ((ses-name (ext:unix-namestring name nil))) + (when (unix:unix-file-kind ses-name) + (funcall *error-function* "Name already exists -- ~S" ses-name)) + (enter-directory ses-name)) + t) + + + + +;;;; Mach Operations + +(defun open-file (ses-name) + (multiple-value-bind (fd err) + (unix:unix-open ses-name unix:o_rdonly 0) + (unless fd + (funcall *error-function* "Opening ~S failed: ~A." ses-name err)) + fd)) + +(defun close-file (fd) + (unix:unix-close fd)) + +(defun read-file (fd ses-name) + (multiple-value-bind (winp dev-or-err ino mode nlink uid gid rdev size) + (unix:unix-fstat fd) + (declare (ignore ino nlink uid gid rdev)) + (unless winp (funcall *error-function* + "Opening ~S failed: ~A." ses-name dev-or-err)) + (let ((storage (system:allocate-system-memory size))) + (multiple-value-bind (read-bytes err) + (unix:unix-read fd storage size) + (when (or (null read-bytes) (not (= size read-bytes))) + (system:deallocate-system-memory storage size) + (funcall *error-function* + "Reading file ~S failed: ~A." ses-name err))) + (values storage size mode)))) + +(defun write-file (ses-name data byte-count mode) + (multiple-value-bind (fd err) (unix:unix-creat ses-name #o644) + (unless fd + (funcall *error-function* "Couldn't create file ~S: ~A" + ses-name (unix:get-unix-error-msg err))) + (multiple-value-bind (winp err) (unix:unix-write fd data 0 byte-count) + (unless winp + (funcall *error-function* "Writing file ~S failed: ~A" + ses-name + (unix:get-unix-error-msg err)))) + (unix:unix-fchmod fd (logand mode #o777)) + (unix:unix-close fd))) + +(defun set-write-date (ses-name secs) + (multiple-value-bind (winp dev-or-err ino mode nlink uid gid rdev size atime) + (unix:unix-stat ses-name) + (declare (ignore ino mode nlink uid gid rdev size)) + (unless winp + (funcall *error-function* "Couldn't stat file ~S failed: ~A." + ses-name dev-or-err)) + (multiple-value-bind (winp err) + (unix:unix-utimes ses-name atime 0 secs 0) + (unless winp + (funcall *error-function* "Couldn't set write date of file ~S: ~A" + ses-name (unix:get-unix-error-msg err)))))) + +(defun get-write-date (ses-name) + (multiple-value-bind (winp dev-or-err ino mode nlink uid gid rdev size + atime mtime) + (unix:unix-stat ses-name) + (declare (ignore ino mode nlink uid gid rdev size atime)) + (unless winp (funcall *error-function* "Couldn't stat file ~S failed: ~A." + ses-name dev-or-err)) + mtime)) + +;;; SUB-RENAME-FILE must exist because we can't use Common Lisp's RENAME-FILE. +;;; This is because it merges the new name with the old name to pick up +;;; defaults, and this conflicts with Unix-oid names. For example, renaming +;;; "foo.bar" to ".baz" causes a result of "foo.baz"! This routine doesn't +;;; have this problem. +;;; +(defun sub-rename-file (ses-name1 ses-name2) + (multiple-value-bind (res err) (unix:unix-rename ses-name1 ses-name2) + (unless res + (funcall *error-function* "Failed to rename ~A to ~A: ~A." + ses-name1 ses-name2 (unix:get-unix-error-msg err))))) + +(defun directory-existsp (ses-name) + (eq (unix:unix-file-kind ses-name) :directory)) + +(defun enter-directory (ses-name) + (declare (simple-string ses-name)) + (let* ((length-1 (1- (length ses-name))) + (name (if (= (position #\/ ses-name :test #'char= :from-end t) + length-1) + (subseq ses-name 0 (1- (length ses-name))) + ses-name))) + (multiple-value-bind (winp err) (unix:unix-mkdir name #o755) + (unless winp + (funcall *error-function* "Couldn't make directory ~S: ~A" + name + (unix:get-unix-error-msg err)))))) + +(defun delete-directory (ses-name) + (declare (simple-string ses-name)) + (multiple-value-bind (winp err) + (unix:unix-rmdir (subseq ses-name 0 + (1- (length ses-name)))) + (unless winp + (funcall *error-function* "Couldn't delete directory ~S: ~A" + ses-name + (unix:get-unix-error-msg err))))) + + + + +;;;; Misc. Utility Utilities + +;;; NSEPARATE-FILES destructively returns a list of file specs from listing. +(defun nseparate-files (listing) + (do (files hold) + ((null listing) files) + (setf hold (cdr listing)) + (unless (directoryp (car listing)) + (setf (cdr listing) files) + (setf files listing)) + (setf listing hold))) + + +(defun directoryp (p) + (not (or (pathname-name p) (pathname-type p)))) Index: /branches/ide-1.0/ccl/hemlock/src/archive/diredcoms.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/archive/diredcoms.lisp (revision 6567) +++ /branches/ide-1.0/ccl/hemlock/src/archive/diredcoms.lisp (revision 6567) @@ -0,0 +1,905 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Simple directory editing support. +;;; This file contains site dependent calls. +;;; +;;; Written by Blaine Burks and Bill Chiles. +;;; + +(in-package :hemlock) + + +(defmode "Dired" :major-p t + :documentation + "Dired permits convenient directory browsing and file operations including + viewing, deleting, copying, renaming, and wildcard specifications.") + + +(defstruct (dired-information (:print-function print-dired-information) + (:conc-name dired-info-)) + pathname ; Pathname of directory. + pattern ; FILE-NAMESTRING with wildcard possibly. + dot-files-p ; Whether to include UNIX dot files. + write-date ; Write date of directory. + files ; Simple-vector of dired-file structures. + file-list) ; List of pathnames for files, excluding directories. + +(defun print-dired-information (obj str n) + (declare (ignore n)) + (format str "#" (namestring (dired-info-pathname obj)))) + + +(defstruct (dired-file (:print-function print-dired-file) + (:constructor make-dired-file (pathname))) + pathname + (deleted-p nil) + (write-date nil)) + +(defun print-dired-file (obj str n) + (declare (ignore n)) + (format str "#" (namestring (dired-file-pathname obj)))) + + + + +;;;; "Dired" command. + +;;; *pathnames-to-dired-buffers* is an a-list mapping directory namestrings to +;;; buffers that display their contents. +;;; +(defvar *pathnames-to-dired-buffers* ()) + +(make-modeline-field + :name :dired-cmds :width 20 + :function + #'(lambda (buffer window) + (declare (ignore buffer window)) + " Type ? for help. ")) + +(defcommand "Dired" (p &optional directory) + "Prompts for a directory and edits it. If a dired for that directory already + exists, go to that buffer, otherwise create one. With an argument, include + UNIX dot files." + "Prompts for a directory and edits it. If a dired for that directory already + exists, go to that buffer, otherwise create one. With an argument, include + UNIX dot files." + (let ((info (if (hemlock-bound-p 'dired-information) + (value dired-information)))) + (dired-guts nil + ;; Propagate dot-files property to subdirectory edits. + (or (and info (dired-info-dot-files-p info)) + p) + directory))) + +(defcommand "Dired with Pattern" (p) + "Do a dired, prompting for a pattern which may include a single *. With an + argument, include UNIX dit files." + "Do a dired, prompting for a pattern which may include a single *. With an + argument, include UNIX dit files." + (dired-guts t p nil)) + +(defun dired-guts (patternp dot-files-p directory) + (let* ((dpn (value pathname-defaults)) + (directory (dired-directorify + (or directory + (prompt-for-file + :prompt "Edit Directory: " + :help "Pathname to edit." + :default (make-pathname + :device (pathname-device dpn) + :directory (pathname-directory dpn)) + :must-exist nil)))) + (pattern (if patternp + (prompt-for-string + :prompt "Filename pattern: " + :help "Type a filename with a single asterisk." + :trim t))) + (full-name (namestring (if pattern + (merge-pathnames directory pattern) + directory))) + (name (concatenate 'simple-string "Dired " full-name)) + (buffer (cdr (assoc full-name *pathnames-to-dired-buffers* + :test #'string=)))) + (declare (simple-string full-name)) + (setf (value pathname-defaults) (merge-pathnames directory dpn)) + (change-to-buffer + (cond (buffer + (when (and dot-files-p + (not (dired-info-dot-files-p + (variable-value 'dired-information + :buffer buffer)))) + (setf (dired-info-dot-files-p (variable-value 'dired-information + :buffer buffer)) + t) + (update-dired-buffer directory pattern buffer)) + buffer) + (t + (let ((buffer (make-buffer + name :modes '("Dired") + :modeline-fields + (append (value default-modeline-fields) + (list (modeline-field :dired-cmds))) + :delete-hook (list 'dired-buffer-delete-hook)))) + (unless (initialize-dired-buffer directory pattern + dot-files-p buffer) + (delete-buffer-if-possible buffer) + (editor-error "No entries for ~A." full-name)) + (push (cons full-name buffer) *pathnames-to-dired-buffers*) + buffer)))))) + +;;; INITIALIZE-DIRED-BUFFER gets a dired in the buffer and defines some +;;; variables to make it usable as a dired buffer. If there are no file +;;; satisfying directory, then this returns nil, otherwise t. +;;; +(defun initialize-dired-buffer (directory pattern dot-files-p buffer) + (multiple-value-bind (pathnames dired-files) + (dired-in-buffer directory pattern dot-files-p buffer) + (if (zerop (length dired-files)) + nil + (defhvar "Dired Information" + "Contains the information neccessary to manipulate dired buffers." + :buffer buffer + :value (make-dired-information :pathname directory + :pattern pattern + :dot-files-p dot-files-p + :write-date (file-write-date directory) + :files dired-files + :file-list pathnames))))) + +;;; CALL-PRINT-DIRECTORY gives us a nice way to report PRINT-DIRECTORY errors +;;; to the user and to clean up the dired buffer. +;;; +(defun call-print-directory (directory mark dot-files-p) + (handler-case (with-output-to-mark (s mark :full) + (print-directory directory s + :all dot-files-p :verbose t :return-list t)) + (error (condx) + (delete-buffer-if-possible (line-buffer (mark-line mark))) + (editor-error "~A" condx)))) + +;;; DIRED-BUFFER-DELETE-HOOK is called on dired buffers upon deletion. This +;;; removes the buffer from the pathnames mapping, and it deletes and buffer +;;; local variables referring to it. +;;; +(defun dired-buffer-delete-hook (buffer) + (setf *pathnames-to-dired-buffers* + (delete buffer *pathnames-to-dired-buffers* :test #'eq :key #'cdr))) + + + + +;;;; Dired deletion and undeletion. + +(defcommand "Dired Delete File" (p) + "Marks a file for deletion; signals an error if not in a dired buffer. + With an argument, this prompts for a pattern that may contain at most one + wildcard, an asterisk, and all names matching the pattern will be flagged + for deletion." + "Marks a file for deletion; signals an error if not in a dired buffer." + (dired-frob-deletion p t)) + +(defcommand "Dired Undelete File" (p) + "Removes a mark for deletion; signals and error if not in a dired buffer. + With an argument, this prompts for a pattern that may contain at most one + wildcard, an asterisk, and all names matching the pattern will be unflagged + for deletion." + "Removes a mark for deletion; signals and error if not in a dired buffer." + (dired-frob-deletion p nil)) + +(defcommand "Dired Delete File and Down Line" (p) + "Marks file for deletion and moves down a line. + See \"Dired Delete File\"." + "Marks file for deletion and moves down a line. + See \"Dired Delete File\"." + (declare (ignore p)) + (dired-frob-deletion nil t) + (dired-down-line (current-point))) + +(defcommand "Dired Undelete File and Down Line" (p) + "Marks file undeleted and moves down a line. + See \"Dired Delete File\"." + "Marks file undeleted and moves down a line. + See \"Dired Delete File\"." + (declare (ignore p)) + (dired-frob-deletion nil nil) + (dired-down-line (current-point))) + +(defcommand "Dired Delete File with Pattern" (p) + "Prompts for a pattern and marks matching files for deletion. + See \"Dired Delete File\"." + "Prompts for a pattern and marks matching files for deletion. + See \"Dired Delete File\"." + (declare (ignore p)) + (dired-frob-deletion t t) + (dired-down-line (current-point))) + +(defcommand "Dired Undelete File with Pattern" (p) + "Prompts for a pattern and marks matching files undeleted. + See \"Dired Delete File\"." + "Prompts for a pattern and marks matching files undeleted. + See \"Dired Delete File\"." + (declare (ignore p)) + (dired-frob-deletion t nil) + (dired-down-line (current-point))) + +;;; DIRED-FROB-DELETION takes arguments indicating whether to prompt for a +;;; pattern and whether to mark the file deleted or undeleted. This uses +;;; CURRENT-POINT and CURRENT-BUFFER, and if not in a dired buffer, signal +;;; an error. +;;; +(defun dired-frob-deletion (patternp deletep) + (unless (hemlock-bound-p 'dired-information) + (editor-error "Not in Dired buffer.")) + (with-mark ((mark (current-point) :left-inserting)) + (let* ((dir-info (value dired-information)) + (files (dired-info-files dir-info)) + (del-files + (if patternp + (dired:pathnames-from-pattern + (prompt-for-string + :prompt "Filename pattern: " + :help "Type a filename with a single asterisk." + :trim t) + (dired-info-file-list dir-info)) + (list (dired-file-pathname + (array-element-from-mark mark files))))) + (note-char (if deletep #\D #\space))) + (with-writable-buffer ((current-buffer)) + (dolist (f del-files) + (let* ((pos (position f files :test #'equal + :key #'dired-file-pathname)) + (dired-file (svref files pos))) + (buffer-start mark) + (line-offset mark pos 0) + (setf (dired-file-deleted-p dired-file) deletep) + (if deletep + (setf (dired-file-write-date dired-file) + (file-write-date (dired-file-pathname dired-file))) + (setf (dired-file-write-date dired-file) nil)) + (setf (next-character mark) note-char))))))) + +(defun dired-down-line (point) + (line-offset point 1) + (when (blank-line-p (mark-line point)) + (line-offset point -1))) + + + + +;;;; Dired file finding and going to dired buffers. + +(defcommand "Dired Edit File" (p) + "Read in file or recursively \"Dired\" a directory." + "Read in file or recursively \"Dired\" a directory." + (declare (ignore p)) + (let ((point (current-point))) + (when (blank-line-p (mark-line point)) (editor-error "Not on a file line.")) + (let ((pathname (dired-file-pathname + (array-element-from-mark + point (dired-info-files (value dired-information)))))) + (if (directoryp pathname) + (dired-command nil (directory-namestring pathname)) + (change-to-buffer (find-file-buffer pathname)))))) + +(defcommand "Dired View File" (p) + "Read in file as if by \"View File\" or recursively \"Dired\" a directory. + This associates the file's buffer with the dired buffer." + "Read in file as if by \"View File\". + This associates the file's buffer with the dired buffer." + (declare (ignore p)) + (let ((point (current-point))) + (when (blank-line-p (mark-line point)) (editor-error "Not on a file line.")) + (let ((pathname (dired-file-pathname + (array-element-from-mark + point (dired-info-files (value dired-information)))))) + (if (directoryp pathname) + (dired-command nil (directory-namestring pathname)) + (let* ((dired-buf (current-buffer)) + (buffer (view-file-command nil pathname))) + (push #'(lambda (buffer) + (declare (ignore buffer)) + (setf dired-buf nil)) + (buffer-delete-hook dired-buf)) + (setf (variable-value 'view-return-function :buffer buffer) + #'(lambda () + (if dired-buf + (change-to-buffer dired-buf) + (dired-from-buffer-pathname-command nil))))))))) + +(defcommand "Dired from Buffer Pathname" (p) + "Invokes \"Dired\" on the directory part of the current buffer's pathname. + With an argument, also prompt for a file pattern within that directory." + "Invokes \"Dired\" on the directory part of the current buffer's pathname. + With an argument, also prompt for a file pattern within that directory." + (let ((pathname (buffer-pathname (current-buffer)))) + (if pathname + (dired-command p (directory-namestring pathname)) + (editor-error "No pathname associated with buffer.")))) + +(defcommand "Dired Up Directory" (p) + "Invokes \"Dired\" on the directory up one level from the current Dired + buffer." + "Invokes \"Dired\" on the directory up one level from the current Dired + buffer." + (declare (ignore p)) + (unless (hemlock-bound-p 'dired-information) + (editor-error "Not in Dired buffer.")) + (let ((dirs (or (pathname-directory + (dired-info-pathname (value dired-information))) + '(:relative)))) + (dired-command nil + (truename (make-pathname :directory (nconc dirs '(:UP))))))) + + + + +;;;; Dired misc. commands -- update, help, line motion. + +(defcommand "Dired Update Buffer" (p) + "Recompute the contents of a dired buffer. + This maintains delete flags for files that have not been modified." + "Recompute the contents of a dired buffer. + This maintains delete flags for files that have not been modified." + (declare (ignore p)) + (unless (hemlock-bound-p 'dired-information) + (editor-error "Not in Dired buffer.")) + (let ((buffer (current-buffer)) + (dir-info (value dired-information))) + (update-dired-buffer (dired-info-pathname dir-info) + (dired-info-pattern dir-info) + buffer))) + +;;; UPDATE-DIRED-BUFFER updates buffer with a dired of directory, deleting +;;; whatever is in the buffer already. This assumes buffer was previously +;;; used as a dired buffer having necessary variables bound. The new files +;;; are compared to the old ones propagating any deleted flags if the name +;;; and the write date is the same for both specifications. +;;; +(defun update-dired-buffer (directory pattern buffer) + (with-writable-buffer (buffer) + (delete-region (buffer-region buffer)) + (let ((dir-info (variable-value 'dired-information :buffer buffer))) + (multiple-value-bind (pathnames new-dired-files) + (dired-in-buffer directory pattern + (dired-info-dot-files-p dir-info) + buffer) + (let ((point (buffer-point buffer)) + (old-dired-files (dired-info-files dir-info))) + (declare (simple-vector old-dired-files)) + (dotimes (i (length old-dired-files)) + (let ((old-file (svref old-dired-files i))) + (when (dired-file-deleted-p old-file) + (let ((pos (position (dired-file-pathname old-file) + new-dired-files :test #'equal + :key #'dired-file-pathname))) + (when pos + (let* ((new-file (svref new-dired-files pos)) + (write-date (file-write-date + (dired-file-pathname new-file)))) + (when (= (dired-file-write-date old-file) write-date) + (setf (dired-file-deleted-p new-file) t) + (setf (dired-file-write-date new-file) write-date) + (setf (next-character + (line-offset (buffer-start point) pos 0)) + #\D)))))))) + (setf (dired-info-files dir-info) new-dired-files) + (setf (dired-info-file-list dir-info) pathnames) + (setf (dired-info-write-date dir-info) + (file-write-date directory)) + (move-mark point (buffer-start-mark buffer))))))) + +;;; DIRED-IN-BUFFER inserts a dired listing of directory in buffer returning +;;; two values: a list of pathnames of files only, and an array of dired-file +;;; structures. This uses FILTER-REGION to insert a space for the indication +;;; of whether the file is flagged for deletion. Then we clean up extra header +;;; and trailing lines known to be in the output (into every code a little +;;; slime must fall). +;;; +(defun dired-in-buffer (directory pattern dot-files-p buffer) + (let ((point (buffer-point buffer))) + (with-writable-buffer (buffer) + (let* ((pathnames (call-print-directory + (if pattern + (merge-pathnames directory pattern) + directory) + point + dot-files-p)) + (dired-files (make-array (length pathnames)))) + (declare (list pathnames) (simple-vector dired-files)) + (filter-region #'(lambda (str) + (concatenate 'simple-string " " str)) + (buffer-region buffer)) + (delete-characters point -2) + (delete-region (line-to-region (mark-line (buffer-start point)))) + (delete-characters point) + (do ((p pathnames (cdr p)) + (i 0 (1+ i))) + ((null p)) + (setf (svref dired-files i) (make-dired-file (car p)))) + (values (delete-if #'directoryp pathnames) dired-files))))) + + +(defcommand "Dired Help" (p) + "How to use dired." + "How to use dired." + (declare (ignore p)) + (describe-mode-command nil "Dired")) + +(defcommand "Dired Next File" (p) + "Moves to next undeleted file." + "Moves to next undeleted file." + (unless (dired-line-offset (current-point) (or p 1)) + (editor-error "Not enough lines."))) + +(defcommand "Dired Previous File" (p) + "Moves to previous undeleted file." + "Moves to next undeleted file." + (unless (dired-line-offset (current-point) (or p -1)) + (editor-error "Not enough lines."))) + +;;; DIRED-LINE-OFFSET moves mark n undeleted file lines, returning mark. If +;;; there are not enough lines, mark remains unmoved, this returns nil. +;;; +(defun dired-line-offset (mark n) + (with-mark ((m mark)) + (let ((step (if (plusp n) 1 -1))) + (dotimes (i (abs n) (move-mark mark m)) + (loop + (unless (line-offset m step 0) + (return-from dired-line-offset nil)) + (when (blank-line-p (mark-line m)) + (return-from dired-line-offset nil)) + (when (char= (next-character m) #\space) + (return))))))) + + + + +;;;; Dired user interaction functions. + +(defun dired-error-function (string &rest args) + (apply #'editor-error string args)) + +(defun dired-report-function (string &rest args) + (clear-echo-area) + (apply #'message string args)) + +(defun dired-yesp-function (string &rest args) + (prompt-for-y-or-n :prompt (cons string args) :default t)) + + + + +;;;; Dired expunging and quitting. + +(defcommand "Dired Expunge Files" (p) + "Expunges files marked for deletion. + Query the user if value of \"Dired File Expunge Confirm\" is non-nil. Do + the same with directories and the value of \"Dired Directory Expunge + Confirm\"." + "Expunges files marked for deletion. + Query the user if value of \"Dired File Expunge Confirm\" is non-nil. Do + the same with directories and the value of \"Dired Directory Expunge + Confirm\"." + (declare (ignore p)) + (when (expunge-dired-files) + (dired-update-buffer-command nil)) + (maintain-dired-consistency)) + +(defcommand "Dired Quit" (p) + "Expunges the files in a dired buffer and then exits." + "Expunges the files in a dired buffer and then exits." + (declare (ignore p)) + (expunge-dired-files) + (delete-buffer-if-possible (current-buffer))) + +(defhvar "Dired File Expunge Confirm" + "When set (the default), \"Dired Expunge Files\" and \"Dired Quit\" will ask + for confirmation before deleting the marked files." + :value t) + +(defhvar "Dired Directory Expunge Confirm" + "When set (the default), \"Dired Expunge Files\" and \"Dired Quit\" will ask + for confirmation before deleting each marked directory." + :value t) + +(defun expunge-dired-files () + (multiple-value-bind (marked-files marked-dirs) (get-marked-dired-files) + (let ((dired:*error-function* #'dired-error-function) + (dired:*report-function* #'dired-report-function) + (dired:*yesp-function* #'dired-yesp-function) + (we-did-something nil)) + (when (and marked-files + (or (not (value dired-file-expunge-confirm)) + (prompt-for-y-or-n :prompt "Really delete files? " + :default t + :must-exist t + :default-string "Y"))) + (setf we-did-something t) + (dolist (file-info marked-files) + (let ((pathname (car file-info)) + (write-date (cdr file-info))) + (if (= write-date (file-write-date pathname)) + (dired:delete-file (namestring pathname) :clobber t + :recursive nil) + (message "~A has been modified, it remains unchanged." + (namestring pathname)))))) + (when marked-dirs + (dolist (dir-info marked-dirs) + (let ((dir (car dir-info)) + (write-date (cdr dir-info))) + (if (= write-date (file-write-date dir)) + (when (or (not (value dired-directory-expunge-confirm)) + (prompt-for-y-or-n + :prompt (list "~a is a directory. Delete it? " + (directory-namestring dir)) + :default t + :must-exist t + :default-string "Y")) + (dired:delete-file (directory-namestring dir) :clobber t + :recursive t) + (setf we-did-something t)) + (message "~A has been modified, it remains unchanged."))))) + we-did-something))) + + + + +;;;; Dired copying and renaming. + +(defhvar "Dired Copy File Confirm" + "Can be either t, nil, or :update. T means always query before clobbering an + existing file, nil means don't query before clobbering an existing file, and + :update means only ask if the existing file is newer than the source." + :value T) + +(defhvar "Dired Rename File Confirm" + "When non-nil, dired will query before clobbering an existing file." + :value T) + +(defcommand "Dired Copy File" (p) + "Copy the file under the point" + "Copy the file under the point" + (declare (ignore p)) + (let* ((point (current-point)) + (confirm (value dired-copy-file-confirm)) + (source (dired-file-pathname + (array-element-from-mark + point (dired-info-files (value dired-information))))) + (dest (prompt-for-file + :prompt (if (directoryp source) + "Destination Directory Name: " + "Destination Filename: ") + :help "Name of new file." + :default source + :must-exist nil)) + (dired:*error-function* #'dired-error-function) + (dired:*report-function* #'dired-report-function) + (dired:*yesp-function* #'dired-yesp-function)) + (dired:copy-file source dest :update (if (eq confirm :update) t nil) + :clobber (not confirm))) + (maintain-dired-consistency)) + +(defcommand "Dired Rename File" (p) + "Rename the file or directory under the point" + "Rename the file or directory under the point" + (declare (ignore p)) + (let* ((point (current-point)) + (source (dired-namify (dired-file-pathname + (array-element-from-mark + point + (dired-info-files (value dired-information)))))) + (dest (prompt-for-file + :prompt "New Filename: " + :help "The new name for this file." + :default source + :must-exist nil)) + (dired:*error-function* #'dired-error-function) + (dired:*report-function* #'dired-report-function) + (dired:*yesp-function* #'dired-yesp-function)) + ;; ARRAY-ELEMENT-FROM-MARK moves mark to line start. + (dired:rename-file source dest :clobber (value dired-rename-file-confirm))) + (maintain-dired-consistency)) + +(defcommand "Dired Copy with Wildcard" (p) + "Copy files that match a pattern containing ONE wildcard." + "Copy files that match a pattern containing ONE wildcard." + (declare (ignore p)) + (let* ((dir-info (value dired-information)) + (confirm (value dired-copy-file-confirm)) + (pattern (prompt-for-string + :prompt "Filename pattern: " + :help "Type a filename with a single asterisk." + :trim t)) + (destination (namestring + (prompt-for-file + :prompt "Destination Spec: " + :help "Destination spec. May contain ONE asterisk." + :default (dired-info-pathname dir-info) + :must-exist nil))) + (dired:*error-function* #'dired-error-function) + (dired:*yesp-function* #'dired-yesp-function) + (dired:*report-function* #'dired-report-function)) + (dired:copy-file pattern destination :update (if (eq confirm :update) t nil) + :clobber (not confirm) + :directory (dired-info-file-list dir-info))) + (maintain-dired-consistency)) + +(defcommand "Dired Rename with Wildcard" (p) + "Rename files that match a pattern containing ONE wildcard." + "Rename files that match a pattern containing ONE wildcard." + (declare (ignore p)) + (let* ((dir-info (value dired-information)) + (pattern (prompt-for-string + :prompt "Filename pattern: " + :help "Type a filename with a single asterisk." + :trim t)) + (destination (namestring + (prompt-for-file + :prompt "Destination Spec: " + :help "Destination spec. May contain ONE asterisk." + :default (dired-info-pathname dir-info) + :must-exist nil))) + (dired:*error-function* #'dired-error-function) + (dired:*yesp-function* #'dired-yesp-function) + (dired:*report-function* #'dired-report-function)) + (dired:rename-file pattern destination + :clobber (not (value dired-rename-file-confirm)) + :directory (dired-info-file-list dir-info))) + (maintain-dired-consistency)) + +(defcommand "Delete File" (p) + "Delete a file. Specify directories with a trailing slash." + "Delete a file. Specify directories with a trailing slash." + (declare (ignore p)) + (let* ((spec (namestring + (prompt-for-file + :prompt "Delete File: " + :help '("Name of File or Directory to delete. ~ + One wildcard is permitted.") + :must-exist nil))) + (directoryp (directoryp spec)) + (dired:*error-function* #'dired-error-function) + (dired:*report-function* #'dired-report-function) + (dired:*yesp-function* #'dired-yesp-function)) + (when (or (not directoryp) + (not (value dired-directory-expunge-confirm)) + (prompt-for-y-or-n + :prompt (list "~A is a directory. Delete it? " + (directory-namestring spec)) + :default t :must-exist t :default-string "Y"))) + (dired:delete-file spec :recursive t + :clobber (or directoryp + (value dired-file-expunge-confirm)))) + (maintain-dired-consistency)) + +(defcommand "Copy File" (p) + "Copy a file, allowing ONE wildcard." + "Copy a file, allowing ONE wildcard." + (declare (ignore p)) + (let* ((confirm (value dired-copy-file-confirm)) + (source (namestring + (prompt-for-file + :prompt "Source Filename: " + :help "Name of File to copy. One wildcard is permitted." + :must-exist nil))) + (dest (namestring + (prompt-for-file + :prompt (if (directoryp source) + "Destination Directory Name: " + "Destination Filename: ") + :help "Name of new file." + :default source + :must-exist nil))) + (dired:*error-function* #'dired-error-function) + (dired:*report-function* #'dired-report-function) + (dired:*yesp-function* #'dired-yesp-function)) + (dired:copy-file source dest :update (if (eq confirm :update) t nil) + :clobber (not confirm))) + (maintain-dired-consistency)) + +(defcommand "Rename File" (p) + "Rename a file, allowing ONE wildcard." + "Rename a file, allowing ONE wildcard." + (declare (ignore p)) + (let* ((source (namestring + (prompt-for-file + :prompt "Source Filename: " + :help "Name of file to rename. One wildcard is permitted." + :must-exist nil))) + (dest (namestring + (prompt-for-file + :prompt (if (directoryp source) + "Destination Directory Name: " + "Destination Filename: ") + :help "Name of new file." + :default source + :must-exist nil))) + (dired:*error-function* #'dired-error-function) + (dired:*report-function* #'dired-report-function) + (dired:*yesp-function* #'dired-yesp-function)) + (dired:rename-file source dest + :clobber (not (value dired-rename-file-confirm)))) + (maintain-dired-consistency)) + +(defun maintain-dired-consistency () + (dolist (info *pathnames-to-dired-buffers*) + (let* ((directory (directory-namestring (car info))) + (buffer (cdr info)) + (dir-info (variable-value 'dired-information :buffer buffer)) + (write-date (file-write-date directory))) + (unless (= (dired-info-write-date dir-info) write-date) + (update-dired-buffer directory (dired-info-pattern dir-info) buffer))))) + + + + +;;;; Dired utilities. + +;;; GET-MARKED-DIRED-FILES returns as multiple values a list of file specs +;;; and a list of directory specs that have been marked for deletion. This +;;; assumes the current buffer is a "Dired" buffer. +;;; +(defun get-marked-dired-files () + (let* ((files (dired-info-files (value dired-information))) + (length (length files)) + (marked-files ()) + (marked-dirs ())) + (unless files (editor-error "Not in Dired buffer.")) + (do ((i 0 (1+ i))) + ((= i length) (values (nreverse marked-files) (nreverse marked-dirs))) + (let* ((thing (svref files i)) + (pathname (dired-file-pathname thing))) + (when (and (dired-file-deleted-p thing) ; file marked for delete + (probe-file pathname)) ; file still exists + (if (directoryp pathname) + (push (cons pathname (file-write-date pathname)) marked-dirs) + (push (cons pathname (file-write-date pathname)) + marked-files))))))) + +;;; ARRAY-ELEMENT-FROM-MARK -- Internal Interface. +;;; +;;; This counts the lines between it and the beginning of the buffer. The +;;; number is used to index vector as if each line mapped to an element +;;; starting with the zero'th element (lines are numbered starting at 1). +;;; This must use AREF since some modes use this with extendable vectors. +;;; +(defun array-element-from-mark (mark vector + &optional (error-msg "Invalid line.")) + (when (blank-line-p (mark-line mark)) (editor-error error-msg)) + (aref vector + (1- (count-lines (region + (buffer-start-mark (line-buffer (mark-line mark))) + mark))))) + +;;; DIRED-NAMIFY and DIRED-DIRECTORIFY are implementation dependent slime. +;;; +(defun dired-namify (pathname) + (let* ((string (namestring pathname)) + (last (1- (length string)))) + (if (char= (schar string last) #\/) + (subseq string 0 last) + string))) +;;; +;;; This is necessary to derive a canonical representation for directory +;;; names, so "Dired" can map various strings naming one directory to that +;;; one directory. +;;; +(defun dired-directorify (pathname) + (let ((directory (ext:unix-namestring pathname))) + (if (directoryp directory) + directory + (pathname (concatenate 'simple-string (namestring directory) "/"))))) + + + + +;;;; View Mode. + +(defmode "View" :major-p nil + :setup-function 'setup-view-mode + :cleanup-function 'cleanup-view-mode + :precedence 5.0 + :documentation + "View mode scrolls forwards and backwards in a file with the buffer read-only. + Scrolling off the end optionally deletes the buffer.") + +(defun setup-view-mode (buffer) + (defhvar "View Return Function" + "Function that gets called when quitting or returning from view mode." + :value nil + :buffer buffer) + (setf (buffer-writable buffer) nil)) +;;; +(defun cleanup-view-mode (buffer) + (delete-variable 'view-return-function :buffer buffer) + (setf (buffer-writable buffer) t)) + +(defcommand "View File" (p &optional pathname) + "Reads a file in as if by \"Find File\", but read-only. Commands exist + for scrolling convenience." + "Reads a file in as if by \"Find File\", but read-only. Commands exist + for scrolling convenience." + (declare (ignore p)) + (let* ((pn (or pathname + (prompt-for-file + :prompt "View File: " :must-exist t + :help "Name of existing file to read into its own buffer." + :default (buffer-default-pathname (current-buffer))))) + (buffer (make-buffer (format nil "View File ~A" (gensym))))) + (visit-file-command nil pn buffer) + (setf (buffer-minor-mode buffer "View") t) + (change-to-buffer buffer) + buffer)) + +(defcommand "View Return" (p) + "Return to a parent buffer, if it exists." + "Return to a parent buffer, if it exists." + (declare (ignore p)) + (unless (call-view-return-fun) + (editor-error "No View return method for this buffer."))) + +(defcommand "View Quit" (p) + "Delete a buffer in view mode." + "Delete a buffer in view mode, invoking VIEW-RETURN-FUNCTION if it exists for + this buffer." + (declare (ignore p)) + (let* ((buf (current-buffer)) + (funp (call-view-return-fun))) + (delete-buffer-if-possible buf) + (unless funp (editor-error "No View return method for this buffer.")))) + +;;; CALL-VIEW-RETURN-FUN returns nil if there is no current +;;; view-return-function. If there is one, it calls it and returns t. +;;; +(defun call-view-return-fun () + (if (hemlock-bound-p 'view-return-function) + (let ((fun (value view-return-function))) + (cond (fun + (funcall fun) + t))))) + + +(defhvar "View Scroll Deleting Buffer" + "When this is set, \"View Scroll Down\" deletes the buffer when the end + of the file is visible." + :value t) + +(defcommand "View Scroll Down" (p) + "Scroll the current window down through its buffer. + If the end of the file is visible, then delete the buffer if \"View Scroll + Deleting Buffer\" is set. If the buffer is associated with a dired buffer, + this returns there instead of to the previous buffer." + "Scroll the current window down through its buffer. + If the end of the file is visible, then delete the buffer if \"View Scroll + Deleting Buffer\" is set. If the buffer is associated with a dired buffer, + this returns there instead of to the previous buffer." + (if (and (not p) + (displayed-p (buffer-end-mark (current-buffer)) + (current-window)) + (value view-scroll-deleting-buffer)) + (view-quit-command nil) + (scroll-window-down-command p))) + +(defcommand "View Edit File" (p) + "Turn off \"View\" mode in this buffer." + "Turn off \"View\" mode in this buffer." + (declare (ignore p)) + (let ((buf (current-buffer))) + (setf (buffer-minor-mode buf "View") nil) + (warn-about-visit-file-buffers buf))) + +(defcommand "View Help" (p) + "Shows \"View\" mode help message." + "Shows \"View\" mode help message." + (declare (ignore p)) + (describe-mode-command nil "View")) Index: /branches/ide-1.0/ccl/hemlock/src/archive/display.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/archive/display.lisp (revision 6567) +++ /branches/ide-1.0/ccl/hemlock/src/archive/display.lisp (revision 6567) @@ -0,0 +1,310 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Written by Bill Chiles. +;;; +;;; This is the device independent redisplay entry points for Hemlock. +;;; + +(in-package :hemlock-internals) + + + +;;;; Main redisplay entry points. + +(defvar *things-to-do-once* () + "This is a list of lists of functions and args to be applied to. The + functions are called with args supplied at the top of the command loop.") + +(defvar *screen-image-trashed* () + "This variable is set to true if the screen has been trashed by some screen + manager operation, and thus should be totally refreshed. This is currently + only used by tty redisplay.") + +;;; True if we are in redisplay, and thus don't want to enter it recursively. +;;; +(defvar *in-redisplay* nil) + +(declaim (special *window-list*)) + +(eval-when (:compile-toplevel :execute) + +;;; REDISPLAY-LOOP -- Internal. +;;; +;;; This executes internal redisplay routines on all windows interleaved with +;;; checking for input, and if any input shows up we punt returning +;;; :editor-input. Special-fun is for windows that the redisplay interface +;;; wants to recenter to keep the window's buffer's point visible. General-fun +;;; is for other windows. +;;; +;;; Whenever we invoke one of the internal routines, we keep track of the +;;; non-nil return values, so we can return t when we are done. Returning t +;;; means redisplay should run again to make sure it converged. To err on the +;;; safe side, if any window had any changed lines, then let's go through +;;; redisplay again; that is, return t. +;;; +;;; After checking each window, we put the cursor in the appropriate place and +;;; force output. When we try to position the cursor, it may no longer lie +;;; within the window due to buffer modifications during redisplay. If it is +;;; out of the window, return t to indicate we need to finish redisplaying. +;;; +;;; Then we check for the after-redisplay method. Routines such as REDISPLAY +;;; and REDISPLAY-ALL want to invoke the after method to make sure we handle +;;; any events generated from redisplaying. There wouldn't be a problem with +;;; handling these events if we were going in and out of Hemlock's event +;;; handling, but some user may loop over one of these interface functions for +;;; a long time without going through Hemlock's input loop; when that happens, +;;; each call to redisplay may not result in a complete redisplay of the +;;; device. Routines such as INTERNAL-REDISPLAY don't want to worry about this +;;; since Hemlock calls them while going in and out of the input/event-handling +;;; loop. +;;; +;;; Around all of this, we establish the 'redisplay-catcher tag. Some device +;;; redisplay methods throw to this to abort redisplay in addition to this +;;; code. +;;; +(defmacro redisplay-loop (general-fun special-fun &optional (afterp t)) + (let* ((device (gensym)) (point (gensym)) (hunk (gensym)) (n-res (gensym)) + (win-var (gensym)) + (general-form (if (symbolp general-fun) + `(,general-fun ,win-var) + `(funcall ,general-fun ,win-var))) + (special-form (if (symbolp special-fun) + `(,special-fun ,win-var) + `(funcall ,special-fun ,win-var)))) + `(let ((,n-res nil) + (*in-redisplay* t)) + (catch 'redisplay-catcher + (when (listen-editor-input *real-editor-input*) + (throw 'redisplay-catcher :editor-input)) + (let ((,win-var *current-window*)) + (when ,special-form (setf ,n-res t))) + (dolist (,win-var *window-list*) + (unless (eq ,win-var *current-window*) + (when (listen-editor-input *real-editor-input*) + (throw 'redisplay-catcher :editor-input)) + (when (if (window-display-recentering ,win-var) + ,special-form + ,general-form) + (setf ,n-res t)))) + (let* ((,hunk (window-hunk *current-window*)) + (,device (device-hunk-device ,hunk)) + (,point (window-point *current-window*))) + (move-mark ,point (buffer-point (window-buffer *current-window*))) + (multiple-value-bind (x y) + (mark-to-cursorpos ,point *current-window*) + (if x + (funcall (device-put-cursor ,device) ,hunk x y) + (setf ,n-res t))) + (when (device-force-output ,device) + (funcall (device-force-output ,device))) + ,@(if afterp + `((when (device-after-redisplay ,device) + (funcall (device-after-redisplay ,device) ,device) + ;; The after method may have queued input that the input + ;; loop won't see until the next input arrives, so check + ;; here to return the correct value as per the redisplay + ;; contract. + (when (listen-editor-input *real-editor-input*) + (setf ,n-res :editor-input))))) + ,n-res))))) + +) ;eval-when + + +;;; REDISPLAY -- Public. +;;; +;;; This function updates the display of all windows which need it. It assumes +;;; it's internal representation of the screen is accurate and attempts to do +;;; the minimal amount of output to bring the screen into correspondence. +;;; *screen-image-trashed* is only used by terminal redisplay. +;;; +(defun redisplay () + "The main entry into redisplay; updates any windows that seem to need it." + (when *things-to-do-once* + (dolist (thing *things-to-do-once*) (apply (car thing) (cdr thing))) + (setf *things-to-do-once* nil)) + (cond (*in-redisplay* t) + (*screen-image-trashed* + (when (eq (redisplay-all) t) + (setf *screen-image-trashed* nil) + t)) + (t + (redisplay-loop redisplay-window redisplay-window-recentering)))) + + +;;; REDISPLAY-ALL -- Public. +;;; +;;; Update the screen making no assumptions about its correctness. This is +;;; useful if the screen gets trashed, or redisplay gets lost. Since windows +;;; may be on different devices, we have to go through the list clearing all +;;; possible devices. Always returns T or :EDITOR-INPUT, never NIL. +;;; +(defun redisplay-all () + "An entry into redisplay; causes all windows to be fully refreshed." + (let ((cleared-devices nil)) + (dolist (w *window-list*) + (let* ((hunk (window-hunk w)) + (device (device-hunk-device hunk))) + (unless (member device cleared-devices :test #'eq) + (when (device-clear device) + (funcall (device-clear device) device)) + ;; + ;; It's cleared whether we did clear it or there was no method. + (push device cleared-devices))))) + (redisplay-loop + redisplay-window-all + #'(lambda (window) + (setf (window-tick window) (tick)) + (update-window-image window) + (maybe-recenter-window window) + (funcall (device-dumb-redisplay + (device-hunk-device (window-hunk window))) + window) + t))) + + + + +;;;; Internal redisplay entry points. + +(defun internal-redisplay () + "The main internal entry into redisplay. This is just like REDISPLAY, but it + doesn't call the device's after-redisplay method." + (when *things-to-do-once* + (dolist (thing *things-to-do-once*) (apply (car thing) (cdr thing))) + (setf *things-to-do-once* nil)) + (cond (*in-redisplay* t) + (*screen-image-trashed* + (when (eq (redisplay-all) t) + (setf *screen-image-trashed* nil) + t)) + (t + (redisplay-loop redisplay-window redisplay-window-recentering)))) + +;;; REDISPLAY-WINDOWS-FROM-MARK -- Internal Interface. +;;; +;;; hemlock-output-stream methods call this to update the screen. It only +;;; redisplays windows which are displaying the buffer concerned and doesn't +;;; deal with making the cursor track the point. *screen-image-trashed* is +;;; only used by terminal redisplay. This must call the device after-redisplay +;;; method since stream output may occur without ever returning to the +;;; Hemlock input/event-handling loop. +;;; +(defun redisplay-windows-from-mark (mark) + (when *things-to-do-once* + (dolist (thing *things-to-do-once*) (apply (car thing) (cdr thing))) + (setf *things-to-do-once* nil)) + (cond ((or *in-redisplay* (not *in-the-editor*)) t) + ((listen-editor-input *real-editor-input*) :editor-input) + (*screen-image-trashed* + (when (eq (redisplay-all) t) + (setf *screen-image-trashed* nil) + t)) + (t + (catch 'redisplay-catcher + (let ((buffer (line-buffer (mark-line mark)))) + (when buffer + (flet ((frob (win) + (let* ((device (device-hunk-device (window-hunk win))) + (force (device-force-output device)) + (after (device-after-redisplay device))) + (when force (funcall force)) + (when after (funcall after device))))) + (let ((windows (buffer-windows buffer))) + (when (member *current-window* windows :test #'eq) + (redisplay-window-recentering *current-window*) + (frob *current-window*)) + (dolist (window windows) + (unless (eq window *current-window*) + (redisplay-window window) + (frob window))))))))))) + +;;; REDISPLAY-WINDOW -- Internal. +;;; +;;; Return t if there are any changed lines, nil otherwise. +;;; +(defun redisplay-window (window) + "Maybe updates the window's image and calls the device's smart redisplay + method. NOTE: the smart redisplay method may throw to + 'hi::redisplay-catcher to abort redisplay." + (maybe-update-window-image window) + (prog1 + (not (eq (window-first-changed window) *the-sentinel*)) + (funcall (device-smart-redisplay (device-hunk-device (window-hunk window))) + window))) + +(defun redisplay-window-all (window) + "Updates the window's image and calls the device's dumb redisplay method." + (setf (window-tick window) (tick)) + (update-window-image window) + (funcall (device-dumb-redisplay (device-hunk-device (window-hunk window))) + window) + t) + +(defun random-typeout-redisplay (window) + (catch 'redisplay-catcher + (maybe-update-window-image window) + (let* ((device (device-hunk-device (window-hunk window))) + (force (device-force-output device))) + (funcall (device-smart-redisplay device) window) + (when force (funcall force))))) + + + +;;;; Support for redisplay entry points. + +;;; REDISPLAY-WINDOW-RECENTERING -- Internal. +;;; +;;; This tries to be clever about updating the window image unnecessarily, +;;; recenters the window if the window's buffer's point moved off the window, +;;; and does a smart redisplay. We call the redisplay method even if we didn't +;;; update the image or recenter because someone else may have modified the +;;; window's image and already have updated it; if nothing happened, then the +;;; smart method shouldn't do anything anyway. NOTE: the smart redisplay +;;; method may throw to 'hi::redisplay-catcher to abort redisplay. +;;; +;;; This return t if there are any changed lines, nil otherwise. +;;; +(defun redisplay-window-recentering (window) + (setup-for-recentering-redisplay window) + (invoke-hook hemlock::redisplay-hook window) + (setup-for-recentering-redisplay window) + (prog1 + (not (eq (window-first-changed window) *the-sentinel*)) + (funcall (device-smart-redisplay (device-hunk-device (window-hunk window))) + window))) + +(defun setup-for-recentering-redisplay (window) + (let* ((display-start (window-display-start window)) + (old-start (window-old-start window))) + ;; + ;; If the start is in the middle of a line and it wasn't before, + ;; then move the start there. + (when (and (same-line-p display-start old-start) + (not (start-line-p display-start)) + (start-line-p old-start)) + (line-start display-start)) + (maybe-update-window-image window) + (maybe-recenter-window window))) + + +;;; MAYBE-UPDATE-WINDOW-IMAGE only updates if the text has changed or the +;;; display start. +;;; +(defun maybe-update-window-image (window) + (when (or (> (buffer-modified-tick (window-buffer window)) + (window-tick window)) + (mark/= (window-display-start window) + (window-old-start window))) + (setf (window-tick window) (tick)) + (update-window-image window) + t)) Index: /branches/ide-1.0/ccl/hemlock/src/archive/dylan.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/archive/dylan.lisp (revision 6567) +++ /branches/ide-1.0/ccl/hemlock/src/archive/dylan.lisp (revision 6567) @@ -0,0 +1,66 @@ +;;; -*- Package: hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; This file contains a minimal dylan mode. +;;; +(in-package :hemlock) + +;;; hack .. + +(setf (getstring "dylan" *mode-names*) nil) + + +(defmode "Dylan" :major-p t) +(defcommand "Dylan Mode" (p) + "Put the current buffer into \"Dylan\" mode." + "Put the current buffer into \"Dylan\" mode." + (declare (ignore p)) + (setf (buffer-major-mode (current-buffer)) "Dylan")) + +(define-file-type-hook ("dylan") (buffer type) + (declare (ignore type)) + (setf (buffer-major-mode buffer) "Dylan")) + +(defhvar "Indent Function" + "Indentation function which is invoked by \"Indent\" command. + It must take one argument that is the prefix argument." + :value #'generic-indent + :mode "Dylan") + +(defhvar "Auto Fill Space Indent" + "When non-nil, uses \"Indent New Comment Line\" to break lines instead of + \"New Line\"." + :mode "Dylan" :value t) + +(defhvar "Comment Start" + "String that indicates the start of a comment." + :mode "Dylan" :value "//") + +(defhvar "Comment End" + "String that ends comments. Nil indicates #\newline termination." + :mode "Dylan" :value nil) + +(defhvar "Comment Begin" + "String that is inserted to begin a comment." + :mode "Dylan" :value "// ") + +(bind-key "Delete Previous Character Expanding Tabs" #k"backspace" + :mode "Dylan") +(bind-key "Delete Previous Character Expanding Tabs" #k"delete" :mode "Dylan") + +;;; hacks... + +(shadow-attribute :scribe-syntax #\< nil "Dylan") +(shadow-attribute :scribe-syntax #\> nil "Dylan") +(bind-key "Self Insert" #k"\>" :mode "Dylan") +(bind-key "Scribe Insert Bracket" #k")" :mode "Dylan") +(bind-key "Scribe Insert Bracket" #k"]" :mode "Dylan") +(bind-key "Scribe Insert Bracket" #k"}" :mode "Dylan") Index: /branches/ide-1.0/ccl/hemlock/src/archive/eval-server.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/archive/eval-server.lisp (revision 6567) +++ /branches/ide-1.0/ccl/hemlock/src/archive/eval-server.lisp (revision 6567) @@ -0,0 +1,1097 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +(hemlock-ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; This file contains code for connecting to eval servers and some command +;;; level stuff too. +;;; +;;; Written by William Lott. +;;; + +(in-package :hemlock) + + + + +;;;; Structures. + +(defstruct (server-info (:print-function print-server-info)) + name ; String name of this server. + wire ; Wire connected to this server. + notes ; List of note objects for operations + ; which have not yet completed. + slave-info ; Ts-Info used in "Slave Lisp" buffer + ; (formerly the "Lisp Listener" buffer). + slave-buffer ; "Slave Lisp" buffer for slave's *terminal-io*. + background-info ; Ts-Info structure of typescript we use in + ; "background" buffer. + background-buffer ; Buffer "background" typescript is in. + (errors ; Array of errors while compiling + (make-array 16 :adjustable t :fill-pointer 0)) + error-index) ; Index of current error. +;;; +(defun print-server-info (obj stream n) + (declare (ignore n)) + (format stream "#" (server-info-name obj))) + + +(defstruct (error-info (:print-function print-error-info)) + buffer ; Buffer this error is for. + message ; Error Message + line ; Pointer to message in log buffer. + region) ; Region of faulty text +;;; +(defun print-error-info (obj stream n) + (declare (ignore n)) + (format stream "#" (error-info-message obj))) + + +(defvar *server-names* (make-string-table) + "A string-table of the name of all Eval servers and their corresponding + server-info structures.") + +(defvar *abort-operations* nil + "T iff we should ignore any operations sent to us.") + +(defvar *inside-operation* nil + "T iff we are currenly working on an operation. A catcher for the tag + abort-operation will be established whenever this is T.") + +(defconstant *slave-connect-wait* 300) + +;;; Used internally for communications. +;;; +(defvar *newly-created-slave* nil) +(defvar *compiler-wire* nil) +(defvar *compiler-error-stream* nil) +(defvar *compiler-note* nil) + + + + +;;;; Hemlock Variables + +(defhvar "Current Compile Server" + "The Server-Info object for the server currently used for compilation + requests." + :value nil) + +(defhvar "Current Package" + "This variable holds the name of the package currently used for Lisp + evaluation and compilation. If it is Nil, the value of *Package* is used + instead." + :value nil) + +(defhvar "Slave Utility" + "This is the pathname of the utility to fire up slave Lisps. It defaults + to \"cmucl\"." + :value "cmucl") + +(defhvar "Slave Utility Switches" + "These are additional switches to pass to the Slave Utility. + For example, (list \"-core\" ). The -slave + switch and the editor name are always supplied, and they should + not be present in this variable." + :value nil) + +(defhvar "Ask About Old Servers" + "When set (the default), Hemlock will prompt for an existing server's name + in preference to prompting for a new slave's name and creating it." + :value t) + +(defhvar "Confirm Slave Creation" + "When set (the default), Hemlock always confirms a slave's creation for + whatever reason." + :value t) + + +(defhvar "Slave GC Alarm" + "Determines that is done when the slave notifies that it is GCing. + :MESSAGE prints a message in the echo area, :LOUD-MESSAGE beeps as well. + NIL does nothing." + :value :message) + + + +;;;; Slave destruction. + +;;; WIRE-DIED -- Internal. +;;; +;;; The routine is called whenever a wire dies. We roll through all the +;;; servers looking for any that use this wire and nuke them with server-died. +;;; +(defun wire-died (wire) + (let ((servers nil)) + (do-strings (name info *server-names*) + (declare (ignore name)) + (when (eq wire (server-info-wire info)) + (push info servers))) + (dolist (server servers) + (server-died server)))) + +;;; SERVER-DIED -- Internal. +;;; +;;; Clean up the server. Remove any references to it from variables, etc. +;;; +(defun server-died (server) + (declare (special *breakpoints*)) + (let ((name (server-info-name server))) + (delete-string name *server-names*) + (message "Server ~A just died." name)) + (when (server-info-wire server) + #+NILGB + (let ((fd (hemlock.wire:wire-fd (server-info-wire server)))) + (system:invalidate-descriptor fd) + (unix:unix-close fd)) + (setf (server-info-wire server) nil)) + (when (server-info-slave-info server) + (ts-buffer-wire-died (server-info-slave-info server)) + (setf (server-info-slave-info server) nil)) + (when (server-info-background-info server) + (ts-buffer-wire-died (server-info-background-info server)) + (setf (server-info-background-info server) nil)) + (clear-server-errors server) + (when (eq server (variable-value 'current-eval-server :global)) + (setf (variable-value 'current-eval-server :global) nil)) + (when (eq server (variable-value 'current-compile-server :global)) + (setf (variable-value 'current-compile-server :global) nil)) + (dolist (buffer *buffer-list*) + (dolist (var '(current-eval-server current-compile-server server-info)) + (when (and (hemlock-bound-p var :buffer buffer) + (eq (variable-value var :buffer buffer) server)) + (delete-variable var :buffer buffer)))) + (setf *breakpoints* (delete-if #'(lambda (b) + (eq (breakpoint-info-slave b) server)) + *breakpoints*))) + +;;; SERVER-CLEANUP -- Internal. +;;; +;;; This routine is called as a buffer delete hook. It takes care of any +;;; per-buffer cleanup that is necessary. It clears out all references to the +;;; buffer from server-info structures and that any errors that refer to this +;;; buffer are finalized. +;;; +(defun server-cleanup (buffer) + (let ((info (if (hemlock-bound-p 'server-info :buffer buffer) + (variable-value 'server-info :buffer buffer)))) + (when info + (when (eq buffer (server-info-slave-buffer info)) + (setf (server-info-slave-buffer info) nil) + (setf (server-info-slave-info info) nil)) + (when (eq buffer (server-info-background-buffer info)) + (setf (server-info-background-buffer info) nil) + (setf (server-info-background-info info) nil)))) + (do-strings (string server *server-names*) + (declare (ignore string)) + (clear-server-errors server + #'(lambda (error) + (eq (error-info-buffer error) buffer))))) +;;; +(add-hook delete-buffer-hook 'server-cleanup) + +;;; CLEAR-SERVER-ERRORS -- Public. +;;; +;;; Clears all known errors for the given server and resets it so more can +;;; accumulate. +;;; +(defun clear-server-errors (server &optional test-fn) + "This clears compiler errors for server cleaning up any pointers for GC + purposes and allowing more errors to register." + (let ((array (server-info-errors server)) + (current nil)) + (dotimes (i (fill-pointer array)) + (let ((error (aref array i))) + (when (or (null test-fn) + (funcall test-fn error)) + (let ((region (error-info-region error))) + (when (regionp region) + (delete-mark (region-start region)) + (delete-mark (region-end region)))) + (setf (aref array i) nil)))) + (let ((index (server-info-error-index server))) + (when index + (setf current + (or (aref array index) + (find-if-not #'null array + :from-end t + :end current))))) + (delete nil array) + (setf (server-info-error-index server) + (position current array)))) + + + + +;;;; Slave creation. + +;;; INITIALIZE-SERVER-STUFF -- Internal. +;;; +;;; Reinitialize stuff when a core file is saved. +;;; +(defun initialize-server-stuff () + (clrstring *server-names*)) + + +(defvar *editor-name* nil "Name of this editor.") +(defvar *accept-connections* nil + "When set, allow slaves to connect to the editor.") + +;;; GET-EDITOR-NAME -- Internal. +;;; +;;; Pick a name for the editor. Names consist of machine-name:port-number. If +;;; in ten tries we can't get an unused port, choak. We don't save the result +;;; of HEMLOCK.WIRE:CREATE-REQUEST-SERVER because we don't think the editor needs to +;;; ever kill the request server, and we can always inhibit connection with +;;; "Accept Connections". +;;; +(defun get-editor-name () + (if *editor-name* + *editor-name* + (let ((random-state (make-random-state t))) + (dotimes (tries 10 (error "Could not create an internet listener.")) + (let ((port (+ 2000 (random 10000 random-state)))) + (setf port 4711) ;### + (when (handler-case (hemlock.wire:create-request-server + port + #'(lambda (wire addr) + (declare (ignore addr)) + (values *accept-connections* + #'(lambda () (wire-died wire))))) + (error () nil)) + (return (setf *editor-name* + (format nil "~A:~D" (machine-instance) port))))))))) + + +;;; MAKE-BUFFERS-FOR-TYPESCRIPT -- Internal. +;;; +;;; This function returns no values because it is called remotely for value by +;;; connecting slaves. Though we know the system will propagate nil back to +;;; the slave, we indicate here that nil is meaningless. +;;; +(defun make-buffers-for-typescript (slave-name background-name) + "Make the interactive and background buffers slave-name and background-name. + If either is nil, then prompt the user." + (multiple-value-bind (slave-name background-name) + (cond ((not (and slave-name background-name)) + (pick-slave-buffer-names)) + ((getstring slave-name *server-names*) + (multiple-value-bind + (new-sn new-bn) + (pick-slave-buffer-names) + (message "~S is already an eval server; ~ + using ~S instead." + slave-name new-sn) + (values new-sn new-bn))) + (t (values slave-name background-name))) + (let* ((slave-buffer (or (getstring slave-name *buffer-names*) + (make-buffer slave-name :modes '("Lisp")))) + (background-buffer (or (getstring background-name *buffer-names*) + (make-buffer background-name + :modes '("Lisp")))) + (server-info (make-server-info :name slave-name + :wire hemlock.wire:*current-wire* + :slave-buffer slave-buffer + :background-buffer background-buffer)) + (slave-info (typescriptify-buffer slave-buffer server-info + hemlock.wire:*current-wire*)) + (background-info (typescriptify-buffer background-buffer server-info + hemlock.wire:*current-wire*))) + (setf (server-info-slave-info server-info) slave-info) + (setf (server-info-background-info server-info) background-info) + (setf (getstring slave-name *server-names*) server-info) + (unless (variable-value 'current-eval-server :global) + (setf (variable-value 'current-eval-server :global) server-info)) + (hemlock.wire:remote-value + hemlock.wire:*current-wire* + (made-buffers-for-typescript (hemlock.wire:make-remote-object slave-info) + (hemlock.wire:make-remote-object background-info))) + (setf *newly-created-slave* server-info) + (values)))) + + +;;; CREATE-SLAVE -- Public. +;;; +#+NILGB +(defun create-slave (&optional name) + "This creates a slave that tries to connect to the editor. When the slave + connects to the editor, this returns a slave-information structure. Name is + the name of the interactive buffer. If name is nil, this generates a name. + If name is supplied, and a buffer with that name already exists, this + signals an error. In case the slave never connects, this will eventually + timeout and signal an editor-error." + (when (and name (getstring name *buffer-names*)) + (editor-error "Buffer ~A is already in use." name)) + (let ((lisp (unix-namestring (merge-pathnames (value slave-utility) "path:") + t t))) + (unless lisp + (editor-error "Can't find ``~S'' in your path to run." + (value slave-utility))) + (multiple-value-bind (slave background) + (if name + (values name (format nil "Background ~A" name)) + (pick-slave-buffer-names)) + (when (value confirm-slave-creation) + (setf slave (prompt-for-string + :prompt "New slave name? " + :help "Enter the name to use for the newly created slave." + :default slave + :default-string slave)) + (setf background (format nil "Background ~A" slave)) + (when (getstring slave *buffer-names*) + (editor-error "Buffer ~A is already in use." slave)) + (when (getstring background *buffer-names*) + (editor-error "Buffer ~A is already in use." background))) + (message "Spawning slave ... ") + (let ((proc + (ext:run-program lisp + `("-slave" ,(get-editor-name) + ,@(if slave (list "-slave-buffer" slave)) + ,@(if background + (list "-background-buffer" background)) + ,@(value slave-utility-switches)) + :wait nil + :output "/dev/null" + :if-output-exists :append)) + (*accept-connections* t) + (*newly-created-slave* nil)) + (unless proc + (editor-error "Could not start slave.")) + (dotimes (i *slave-connect-wait* + (editor-error + "Client Lisp is still unconnected. ~ + You must use \"Accept Slave Connections\" to ~ + allow the slave to connect at this point.")) + (system:serve-event 1) + (case (ext:process-status proc) + (:exited + (editor-error "The slave lisp exited before connecting.")) + (:signaled + (editor-error "The slave lisp was kill before connecting."))) + (when *newly-created-slave* + (message "DONE") + (return *newly-created-slave*))))))) + +;;; MAYBE-CREATE-SERVER -- Internal interface. +;;; +(defun maybe-create-server () + "If there is an existing server and \"Ask about Old Servers\" is set, then + prompt for a server's name and return that server's info. Otherwise, + create a new server." + (if (value ask-about-old-servers) + (multiple-value-bind (first-server-name first-server-info) + (do-strings (name info *server-names*) + (return (values name info))) + (if first-server-info + (multiple-value-bind + (name info) + (prompt-for-keyword (list *server-names*) + :prompt "Existing server name: " + :default first-server-name + :default-string first-server-name + :help + "Enter the name of an existing eval server." + :must-exist t) + (declare (ignore name)) + (or info (create-slave))) + (create-slave))) + (create-slave))) + + +(defvar *next-slave-index* 0 + "Number to use when creating the next slave.") + +;;; PICK-SLAVE-BUFFER-NAMES -- Internal. +;;; +;;; Return two unused names to use for the slave and background buffers. +;;; +(defun pick-slave-buffer-names () + (loop + (let ((slave (format nil "Slave ~D" (incf *next-slave-index*))) + (background (format nil "Background Slave ~D" *next-slave-index*))) + (unless (or (getstring slave *buffer-names*) + (getstring background *buffer-names*)) + (return (values slave background)))))) + + + + +;;;; Slave selection. + +;;; GET-CURRENT-EVAL-SERVER -- Public. +;;; +(defun get-current-eval-server (&optional errorp) + "Returns the server-info struct for the current eval server. If there is + none, and errorp is non-nil, then signal an editor error. If there is no + current server, and errorp is nil, then create one, prompting the user for + confirmation. Also, set the current server to be the newly created one." + (let ((info (value current-eval-server))) + (cond (info) + (errorp + (editor-error "No current eval server.")) + (t + (setf (value current-eval-server) (maybe-create-server)))))) + +;;; GET-CURRENT-COMPILE-SERVER -- Public. +;;; +;;; If a current compile server is defined, return it, otherwise return the +;;; current eval server using get-current-eval-server. +;;; +(defun get-current-compile-server (&optional errorp) + "Returns the server-info struct for the current compile server. If there is + no current compile server, return the current eval server." + (or (value current-compile-server) + (get-current-eval-server errorp))) + + + + +;;;; Server Manipulation commands. + +(defcommand "Select Slave" (p) + "Switch to the current slave's buffer. When given an argument, create a new + slave." + "Switch to the current slave's buffer. When given an argument, create a new + slave." + (let* ((info (if p (create-slave) (get-current-eval-server))) + (slave (server-info-slave-buffer info))) + (unless slave + (editor-error "The current eval server doesn't have a slave buffer!")) + (change-to-buffer slave))) + +(defcommand "Select Background" (p) + "Switch to the current slave's background buffer. When given an argument, use + the current compile server instead of the current eval server." + "Switch to the current slave's background buffer. When given an argument, use + the current compile server instead of the current eval server." + (let* ((info (if p + (get-current-compile-server t) + (get-current-eval-server t))) + (background (server-info-background-buffer info))) + (unless background + (editor-error "The current ~A server doesn't have a background buffer!" + (if p "compile" "eval"))) + (change-to-buffer background))) + +#+NILGB +(defcommand "Kill Slave" (p) + "This aborts any operations in the slave, tells the slave to QUIT, and shuts + down the connection to the specified eval server. This makes no attempt to + assure the eval server actually dies." + "This aborts any operations in the slave, tells the slave to QUIT, and shuts + down the connection to the specified eval server. This makes no attempt to + assure the eval server actually dies." + (declare (ignore p)) + (let ((default (and (value current-eval-server) + (server-info-name (value current-eval-server))))) + (multiple-value-bind + (name info) + (prompt-for-keyword + (list *server-names*) + :prompt "Kill Slave: " + :help "Enter the name of the eval server you wish to destroy." + :must-exist t + :default default + :default-string default) + (declare (ignore name)) + (let ((wire (server-info-wire info))) + (when wire + (ext:send-character-out-of-band (hemlock.wire:wire-fd wire) #\N) + (hemlock.wire:remote wire (ext:quit)) + (hemlock.wire:wire-force-output wire))) + (server-died info)))) + +#+NILGB +(defcommand "Kill Slave and Buffers" (p) + "This is the same as \"Kill Slave\", but it also deletes the slaves + interaction and background buffers." + "This is the same as \"Kill Slave\", but it also deletes the slaves + interaction and background buffers." + (declare (ignore p)) + (let ((default (and (value current-eval-server) + (server-info-name (value current-eval-server))))) + (multiple-value-bind + (name info) + (prompt-for-keyword + (list *server-names*) + :prompt "Kill Slave: " + :help "Enter the name of the eval server you wish to destroy." + :must-exist t + :default default + :default-string default) + (declare (ignore name)) + (let ((wire (server-info-wire info))) + (when wire + (ext:send-character-out-of-band (hemlock.wire:wire-fd wire) #\N) + (hemlock.wire:remote wire (ext:quit)) + (hemlock.wire:wire-force-output wire))) + (let ((buffer (server-info-slave-buffer info))) + (when buffer (delete-buffer-if-possible buffer))) + (let ((buffer (server-info-background-buffer info))) + (when buffer (delete-buffer-if-possible buffer))) + (server-died info)))) + +(defcommand "Accept Slave Connections" (p) + "This causes Hemlock to accept slave connections and displays the port of + the editor's connections request server. This is suitable for use with the + Lisp's -slave switch. Given an argument, this inhibits slave connections." + "This causes Hemlock to accept slave connections and displays the port of + the editor's connections request server. This is suitable for use with the + Lisp's -slave switch. Given an argument, this inhibits slave connections." + (let ((accept (not p))) + (setf *accept-connections* accept) + (message "~:[Inhibiting~;Accepting~] connections to ~S" + accept (get-editor-name)))) + + + + +;;;; Slave initialization junk. + +(defvar *original-beep-function* nil + "Handle on original beep function.") + +(defvar *original-gc-notify-before* nil + "Handle on original before-GC notification function.") + +(defvar *original-gc-notify-after* nil + "Handle on original after-GC notification function.") + +(defvar *original-terminal-io* nil + "Handle on original *terminal-io* so we can restore it.") + +(defvar *original-standard-input* nil + "Handle on original *standard-input* so we can restore it.") + +(defvar *original-standard-output* nil + "Handle on original *standard-output* so we can restore it.") + +(defvar *original-error-output* nil + "Handle on original *error-output* so we can restore it.") + +(defvar *original-debug-io* nil + "Handle on original *debug-io* so we can restore it.") + +(defvar *original-query-io* nil + "Handle on original *query-io* so we can restore it.") + +(defvar *original-trace-output* nil + "Handle on original *trace-output* so we can restore it.") + +(defvar *background-io* nil + "Stream connected to the editor's background buffer in case we want to use it + in the future.") + +;;; CONNECT-STREAM -- internal +;;; +;;; Run in the slave to create a new stream and connect it to the supplied +;;; buffer. Returns the stream. +;;; +(defun connect-stream (remote-buffer) + (let ((stream (make-ts-stream hemlock.wire:*current-wire* remote-buffer))) + (hemlock.wire:remote hemlock.wire:*current-wire* + (ts-buffer-set-stream remote-buffer + (hemlock.wire:make-remote-object stream))) + stream)) + +;;; MADE-BUFFERS-FOR-TYPESCRIPT -- Internal Interface. +;;; +;;; Run in the slave by the editor with the two buffers' info structures, +;;; actually remote-objects in the slave. Does any necessary stream hacking. +;;; Return nil to make sure no weird objects try to go back over the wire +;;; since the editor calls this in the slave for value. The editor does this +;;; for synch'ing, not for values. +;;; +(defun made-buffers-for-typescript (slave-info background-info) + (setf *original-terminal-io* *terminal-io*) + (warn "made-buffers-for-typescript ~S ~S ~S." + (connect-stream slave-info) + *terminal-io* + (connect-stream background-info)) + (sleep 3) + (macrolet ((frob (symbol new-value) + `(setf ,(intern (concatenate 'simple-string + "*ORIGINAL-" + (subseq (string symbol) 1))) + ,symbol + ,symbol ,new-value))) + #+NILGB + (let ((wire hemlock.wire:*current-wire*)) + (frob system:*beep-function* + #'(lambda (&optional stream) + (declare (ignore stream)) + (hemlock.wire:remote-value wire (beep)))) + (frob ext:*gc-notify-before* + #'(lambda (bytes-in-use) + (hemlock.wire:remote wire + (slave-gc-notify-before + slave-info + (format nil + "~%[GC threshold exceeded with ~:D bytes in use. ~ + Commencing GC.]~%" + bytes-in-use))) + (hemlock.wire:wire-force-output wire))) + (frob ext:*gc-notify-after* + #'(lambda (bytes-retained bytes-freed new-trigger) + (hemlock.wire:remote wire + (slave-gc-notify-after + slave-info + (format nil + "[GC completed with ~:D bytes retained and ~:D ~ + bytes freed.]~%[GC will next occur when at least ~ + ~:D bytes are in use.]~%" + bytes-retained bytes-freed new-trigger))) + (hemlock.wire:wire-force-output wire)))) + (warn "#7")(sleep 1) + (frob *terminal-io* (connect-stream slave-info)) + #+NIL + (progn + (setf cl-user::*io* (connect-stream slave-info)) + (let ((*terminal-io* *original-terminal-io*)) + (warn "#8")(sleep 1)) + (frob *standard-input* (make-synonym-stream '*terminal-io*)) + (let ((*terminal-io* *original-terminal-io*)) + (warn "#9")(sleep 1)) + (frob *standard-output* *standard-input*) + (let ((*terminal-io* *original-terminal-io*)) + (warn "#10")(sleep 1)) + ;;### + ;;(frob *error-output* *standard-input*) + ;;(frob *debug-io* *standard-input*) + (let ((*terminal-io* *original-terminal-io*)) + (warn "#11")(sleep 1)) + (frob *query-io* *standard-input*) + (let ((*terminal-io* *original-terminal-io*)) + (warn "#12")(sleep 1))) + (frob *trace-output* *original-terminal-io*) + ) + #+NILGB (setf *background-io* (connect-stream background-info)) + nil) + +;;; SLAVE-GC-NOTIFY-BEFORE and SLAVE-GC-NOTIFY-AFTER -- internal +;;; +;;; These two routines are run in the editor by the slave's gc notify routines. +;;; +(defun slave-gc-notify-before (remote-ts message) + (let ((ts (hemlock.wire:remote-object-value remote-ts))) + (ts-buffer-output-string ts message t) + (when (value slave-gc-alarm) + (message "~A is GC'ing." (buffer-name (ts-data-buffer ts))) + (when (eq (value slave-gc-alarm) :loud-message) + (beep))))) + +(defun slave-gc-notify-after (remote-ts message) + (let ((ts (hemlock.wire:remote-object-value remote-ts))) + (ts-buffer-output-string ts message t) + (when (value slave-gc-alarm) + (message "~A is done GC'ing." (buffer-name (ts-data-buffer ts))) + (when (eq (value slave-gc-alarm) :loud-message) + (beep))))) + +;;; EDITOR-DIED -- internal +;;; +;;; Run in the slave when the editor goes belly up. +;;; +(defun editor-died () + (macrolet ((frob (symbol) + (let ((orig (intern (concatenate 'simple-string + "*ORIGINAL-" + (subseq (string symbol) 1))))) + `(when ,orig + (setf ,symbol ,orig))))) + #+NILGB + (progn + (frob system:*beep-function*) + (frob ext:*gc-notify-before*) + (frob ext:*gc-notify-after*)) + (frob *terminal-io*) + (frob *standard-input*) + (frob *standard-output*) + (frob *error-output*) + (frob *debug-io*) + (frob *query-io*) + (frob *trace-output*)) + (setf *background-io* nil) + (format t "~2&Connection to editor died.~%") + #+NILGB + (ext:quit)) + +;;; START-SLAVE -- internal +;;; +;;; Initiate the process by which a lisp becomes a slave. +;;; +(defun start-slave (editor) + (declare (simple-string editor)) + (let ((seperator (position #\: editor :test #'char=))) + (unless seperator + (error "Editor name ~S invalid. ~ + Must be of the form \"MachineName:PortNumber\"." + editor)) + (let ((machine (subseq editor 0 seperator)) + (port (parse-integer editor :start (1+ seperator)))) + (format t "Connecting to ~A:~D~%" machine port) + (connect-to-editor machine port)))) + + +;;; PRINT-SLAVE-STATUS -- Internal +;;; +;;; Print out some useful information about what the slave is up to. +;;; +#+NILGB +(defun print-slave-status () + (ignore-errors + (multiple-value-bind (sys user faults) + (system:get-system-info) + (let* ((seconds (truncate (+ sys user) 1000000)) + (minutes (truncate seconds 60)) + (hours (truncate minutes 60)) + (days (truncate hours 24))) + (format *error-output* "~&; Used ~D:~2,'0D:~2,'0D~V@{!~}, " + hours (rem minutes 60) (rem seconds 60) days)) + (format *error-output* "~D fault~:P. In: " faults) + + (do ((i 0 (1+ i)) + (frame (di:top-frame) (di:frame-down frame))) + (#-x86(= i 3) + #+x86 + (and (> i 6) ; get past extra cruft + (let ((name (di:debug-function-name + (di:frame-debug-function frame)))) + (and (not (string= name "Bogus stack frame")) + (not (string= name "Foreign function call land"))))) + (prin1 (di:debug-function-name (di:frame-debug-function frame)) + *error-output*)) + (unless frame (return))) + (terpri *error-output*) + (force-output *error-output*))) + (values)) + + +;;; CONNECT-TO-EDITOR -- internal +;;; +;;; Do the actual connect to the editor. +;;; +(defun connect-to-editor (machine port + &optional + (slave (find-eval-server-switch "slave-buffer")) + (background (find-eval-server-switch + "background-buffer"))) + (let ((wire (hemlock.wire:connect-to-remote-server machine port 'editor-died))) + #+NILGB + (progn + (ext:add-oob-handler (hemlock.wire:wire-fd wire) + #\B + #'(lambda () + (system:without-hemlock + (system:with-interrupts + (break "Software Interrupt"))))) + (ext:add-oob-handler (hemlock.wire:wire-fd wire) + #\T + #'(lambda () + (when lisp::*in-top-level-catcher* + (throw 'lisp::top-level-catcher nil)))) + (ext:add-oob-handler (hemlock.wire:wire-fd wire) + #\A + #'abort) + (ext:add-oob-handler (hemlock.wire:wire-fd wire) + #\N + #'(lambda () + (setf *abort-operations* t) + (when *inside-operation* + (throw 'abort-operation + (if debug::*in-the-debugger* + :was-in-debugger))))) + (ext:add-oob-handler (hemlock.wire:wire-fd wire) #\S #'print-slave-status)) + + (hemlock.wire:remote-value wire + (make-buffers-for-typescript slave background)))) + + + +;;;; Eval server evaluation functions. + +(defvar *eval-form-stream* + (make-two-way-stream + #+NILGB + (lisp::make-lisp-stream + :in #'(lambda (&rest junk) + (declare (ignore junk)) + (error "You cannot read when handling an eval_form request."))) + #-NILGB + (make-concatenated-stream) + (make-broadcast-stream))) + +;;; SERVER-EVAL-FORM -- Public. +;;; Evaluates the given form (which is a string to be read from in the given +;;; package) and returns the results as a list. +;;; +(defun server-eval-form (package form) + (declare (type (or string null) package) (simple-string form)) + (handler-bind + ((error #'(lambda (condition) + (hemlock.wire:remote hemlock.wire:*current-wire* + (eval-form-error (format nil "~A~&" condition))) + (return-from server-eval-form nil)))) + (let ((*package* (if package + (lisp::package-or-lose package) + *package*)) + (*terminal-io* *eval-form-stream*)) + (stringify-list (multiple-value-list (eval (read-from-string form))))))) + + +;;; DO-OPERATION -- Internal. +;;; Checks to see if we are aborting operations. If not, do the operation +;;; wrapping it with operation-started and operation-completed calls. Also +;;; deals with setting up *terminal-io* and *package*. +;;; +(defmacro do-operation ((note package terminal-io) &body body) + `(let ((aborted t) + (*terminal-io* (if ,terminal-io + (hemlock.wire:remote-object-value ,terminal-io) + *terminal-io*)) + (*package* (maybe-make-package ,package))) + (unwind-protect + (unless *abort-operations* + (when (eq :was-in-debugger + (catch 'abort-operation + (let ((*inside-operation* t)) + (hemlock.wire:remote hemlock.wire:*current-wire* + (operation-started ,note)) + (hemlock.wire:wire-force-output hemlock.wire:*current-wire*) + ,@body + (setf aborted nil)))) + (format t + "~&[Operation aborted. ~ + You are no longer in this instance of the debugger.]~%"))) + (hemlock.wire:remote hemlock.wire:*current-wire* + (operation-completed ,note aborted)) + (hemlock.wire:wire-force-output hemlock.wire:*current-wire*)))) + + +;;; unique-thingie is a unique eof-value for READ'ing. Its a parameter, so +;;; we can reload the file. +;;; +(defparameter unique-thingie (gensym) + "Used as eof-value in reads to check for the end of a file.") + +;;; SERVER-EVAL-TEXT -- Public. +;;; +;;; Evaluate all the forms read from text in the given package, and send the +;;; results back. The error handler bound does not handle any errors. It +;;; simply notifies the client that an error occurred and then returns. +;;; +(defun server-eval-text (note package text terminal-io) + (do-operation (note package terminal-io) + (with-input-from-string (stream text) + (let ((last-pos 0)) + (handler-bind + ((error + #'(lambda (condition) + (hemlock.wire:remote hemlock.wire:*current-wire* + (lisp-error note last-pos + (file-position stream) + (format nil "~A~&" condition)))))) + (loop + (let ((form (read stream nil unique-thingie))) + (when (eq form unique-thingie) + (return nil)) + (let* ((values (stringify-list (multiple-value-list (eval form)))) + (pos (file-position stream))) + (hemlock.wire:remote hemlock.wire:*current-wire* + (eval-text-result note last-pos pos values)) + (setf last-pos pos))))))))) + +(defun stringify-list (list) + (mapcar #'prin1-to-string list)) +#| +(defun stringify-list (list) + (mapcar #'(lambda (thing) + (with-output-to-string (stream) + (write thing + :stream stream :radix nil :base 10 :circle t + :pretty nil :level nil :length nil :case :upcase + :array t :gensym t))) + list)) +|# + + + +;;;; Eval server compilation stuff. + +;;; DO-COMPILER-OPERATION -- Internal. +;;; +;;; Useful macro that does the operation with *compiler-note* and +;;; *compiler-wire* bound. +;;; +(defmacro do-compiler-operation ((note package terminal-io error) &body body) + #+NILGB + `(let ((*compiler-note* ,note) + (*compiler-error-stream* ,error) + (*compiler-wire* hemlock.wire:*current-wire*) + (c:*compiler-notification-function* #'compiler-note-in-editor)) + (do-operation (*compiler-note* ,package ,terminal-io) + (unwind-protect + (handler-bind ((error #'compiler-error-handler)) + ,@body) + (when *compiler-error-stream* + (force-output *compiler-error-stream*)))))) + +;;; COMPILER-NOTE-IN-EDITOR -- Internal. +;;; +;;; DO-COMPILER-OPERATION binds c:*compiler-notification-function* to this, so +;;; interesting observations in the compilation can be propagated back to the +;;; editor. If there is a notification point defined, we send information +;;; about the position and kind of error. The actual error text is written out +;;; using typescript operations. +;;; +;;; Start and End are the compiler's best guess at the file position where the +;;; error occurred. Function is some string describing where the error was. +;;; +(defun compiler-note-in-editor (severity function name pos) + (declare (ignore name)) + (when *compiler-wire* + (force-output *compiler-error-stream*) + (hemlock.wire:remote *compiler-wire* + (compiler-error *compiler-note* pos pos function severity))) + (hemlock.wire:wire-force-output *compiler-wire*)) + + +;;; COMPILER-ERROR-HANDLER -- Internal. +;;; +;;; The error handler function for the compiler interfaces. +;;; DO-COMPILER-OPERATION binds this as an error handler while evaluating the +;;; compilation form. +;;; +(defun compiler-error-handler (condition) + (when *compiler-wire* + (hemlock.wire:remote *compiler-wire* + (lisp-error *compiler-note* nil nil + (format nil "~A~&" condition))))) + + +;;; SERVER-COMPILE-TEXT -- Public. +;;; +;;; Similar to server-eval-text, except that the stuff is compiled. +;;; +#+NILGB +(defun server-compile-text (note package text defined-from + terminal-io error-output) + (let ((error-output (if error-output + (hemlock.wire:remote-object-value error-output)))) + (do-compiler-operation (note package terminal-io error-output) + (with-input-from-string (input-stream text) + (terpri error-output) + (c::compile-from-stream input-stream + :error-stream error-output + :source-info defined-from))))) + +;;; SERVER-COMPILE-FILE -- Public. +;;; +;;; Compiles the file sending error info back to the editor. +;;; +(defun server-compile-file (note package input output error trace + load terminal background) + (macrolet ((frob (x) + `(if (hemlock.wire:remote-object-p ,x) + (hemlock.wire:remote-object-value ,x) + ,x))) + (let ((error-stream (frob background))) + (do-compiler-operation (note package terminal error-stream) + (compile-file (frob input) + :output-file (frob output) + :error-file (frob error) + :trace-file (frob trace) + :load load + :error-output error-stream))))) + + + +;;;; Other random eval server stuff. + +;;; MAYBE-MAKE-PACKAGE -- Internal. +;;; +;;; Returns a package for a name. Creates it if it doesn't already exist. +;;; +(defun maybe-make-package (name) + (cond ((null name) *package*) + ((find-package name)) + (t + (hemlock.wire:remote-value (ts-stream-wire *terminal-io*) + (ts-buffer-output-string + (ts-stream-typescript *terminal-io*) + (format nil "~&Creating package ~A.~%" name) + t)) + (make-package name)))) + +;;; SERVER-SET-PACKAGE -- Public. +;;; +;;; Serves package setting requests. It simply sets +;;; *package* to an already existing package or newly created one. +;;; +(defun server-set-package (package) + (setf *package* (maybe-make-package package))) + +;;; SERVER-ACCEPT-OPERATIONS -- Public. +;;; +;;; Start accepting operations again. +;;; +(defun server-accept-operations () + (setf *abort-operations* nil)) + + + + +;;;; Command line switches. + +#+NILGB +(progn + +;;; FIND-EVAL-SERVER-SWITCH -- Internal. +;;; +;;; This is special to the switches supplied by CREATE-SLAVE and fetched by +;;; CONNECT-EDITOR-SERVER, so we can use STRING=. +;;; +(defun find-eval-server-switch (string) + #+NILGB + (let ((switch (find string ext:*command-line-switches* + :test #'string= + :key #'ext:cmd-switch-name))) + (if switch + (or (ext:cmd-switch-value switch) + (car (ext:cmd-switch-words switch)))))) + + +(defun slave-switch-demon (switch) + (let ((editor (ext:cmd-switch-arg switch))) + (unless editor + (error "Editor to connect to unspecified.")) + (start-slave editor) + (setf debug:*help-line-scroll-count* most-positive-fixnum))) +;;; +(defswitch "slave" 'slave-switch-demon) +(defswitch "slave-buffer") +(defswitch "background-buffer") + + +(defun edit-switch-demon (switch) + (declare (ignore switch)) +#| (let ((arg (or (ext:cmd-switch-value switch) + (car (ext:cmd-switch-words switch))))) + (when (stringp arg) (setq *editor-name* arg)))|# + (let ((initp (not (ext:get-command-line-switch "noinit")))) + (if (stringp (car ext:*command-line-words*)) + (ed (car ext:*command-line-words*) :init initp) + (ed nil :init initp)))) +;;; +(defswitch "edit" 'edit-switch-demon) +) + +#+SBCL +(defun hemlock.wire::serve-all-events () + (sleep .1)) Index: /branches/ide-1.0/ccl/hemlock/src/archive/hunk-draw.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/archive/hunk-draw.lisp (revision 6567) +++ /branches/ide-1.0/ccl/hemlock/src/archive/hunk-draw.lisp (revision 6567) @@ -0,0 +1,504 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Written by Bill Chiles and Rob MacLachlan. +;;; +;;; Hemlock screen painting routines for the IBM RT running X. +;;; +(in-package :hemlock-internals) + + +;;;; TODO + +;; . do away with these bogus macros HUNK-PUT-STRING and HUNK-REPLACE-LINE-STRING. + +;; . concentrate these in a single point where we draw a string, so that we +;; can easily introduce foreground and background colors for syntax +;; highlighting and neater region highlighting. + +;; --GB 2003-05-22 + +(defparameter hunk-height-limit 80 "Maximum possible height for any hunk.") +(defparameter hunk-width-limit 200 "Maximum possible width for any hunk.") +(defparameter hunk-top-border 2 "Clear area at beginning.") +(defparameter hunk-left-border 10 "Clear area before first character.") +(defparameter hunk-bottom-border 3 "Minimum Clear area at end.") +(defparameter hunk-thumb-bar-bottom-border 10 + "Minimum Clear area at end including room for thumb bar." ) +(defparameter hunk-modeline-top 2 "Extra black pixels above modeline chars.") +(defparameter hunk-modeline-bottom 2 "Extra black pixels below modeline chars.") + + + + +;;;; Character translations for CLX + +;;; HEMLOCK-TRANSLATE-DEFAULT. +;;; +;;; CLX glyph drawing routines allow for a character translation function. The +;;; default one takes a string (any kind) or a vector of numbers and slams them +;;; into the outgoing request buffer. When the argument is a string, it stops +;;; processing if it sees a character that is not GRAPHIC-CHAR-P. For each +;;; graphical character, the function ultimately calls CHAR-CODE. +;;; +;;; Hemlock only passes simple-strings in, and these can only contain graphical +;;; characters because of the line image builder, except for one case -- +;;; *line-wrap-char* which anyone can set. Those who want to do evil things +;;; with this should know what they are doing: if they want a funny glyph as +;;; a line wrap char, then they should use CODE-CHAR on the font index. This +;;; allows the following function to translate everything with CHAR-CODE, and +;;; everybody's happy. +;;; +;;; Actually, Hemlock can passes the line string when doing random-typeout which +;;; does contain ^L's, tabs, etc. Under X10 these came out as funny glyphs, +;;; and under X11 the output is aborted without this function. +;;; +(defun hemlock-translate-default (src src-start src-end font dst dst-start) + (declare (simple-string src) + (fixnum src-start src-end dst-start) + (vector dst) + (ignore font)) + (do ((i src-start (1+ i)) + (j dst-start (1+ j))) + ((>= i src-end) i) + (declare (fixnum i j)) + (setf (aref dst j) (char-code (schar src i))))) + +#+clx +(defvar *glyph-translate-function* #'xlib:translate-default) + + + + +;;;; Drawing a line. + +;;;; We hack along --GB +#+clx +(defun find-color (window color) + (let ((ht (or (getf (xlib:window-plist window) :color-hash) + (setf (getf (xlib:window-plist window) :color-hash) + (make-hash-table :test #'equalp))))) + (or (gethash color ht) + (setf (gethash color ht) (xlib:alloc-color (xlib:window-colormap window) color))))) + +(defparameter *color-map* + #("black" "white" + "black" "white" + "black" "white" + "black" "cornflower blue" + + "black" "white" + "black" "white" + "black" "white" + "black" "white" + + "blue4" "white" ;8 = comments + "green4" "white" ;9 = strings + "red" "white" ;10 = quote + "black" "white" + + "black" "white" + "black" "white" + "black" "white" + "black" "white")) + +;;; HUNK-PUT-STRING takes a character (x,y) pair and computes at which pixel +;;; coordinate to draw string with font from start to end. +;;; +(defmacro hunk-put-string (x y font string start end) + (let ((gcontext (gensym))) + `(let ((,gcontext (bitmap-hunk-gcontext hunk))) + (xlib:with-gcontext (,gcontext :font ,font) + (xlib:draw-image-glyphs + (bitmap-hunk-xwindow hunk) ,gcontext + (+ hunk-left-border (* ,x (font-family-width font-family))) + (+ hunk-top-border (* ,y (font-family-height font-family)) + (font-family-baseline font-family)) + ,string :start ,start :end ,end + :translate *glyph-translate-function*))))) + +(defun hunk-put-string* (hunk x y font-family font string start end) + (let ((gcontext (bitmap-hunk-gcontext hunk)) + (font (svref (font-family-map font-family) font)) + (fg (find-color (bitmap-hunk-xwindow hunk) (svref *color-map* (* font 2)))) + (bg (find-color (bitmap-hunk-xwindow hunk) (svref *color-map* (1+ (* font 2)))))) + (xlib:with-gcontext (gcontext :font font + :foreground fg + :background bg) + (xlib:draw-image-glyphs + (bitmap-hunk-xwindow hunk) gcontext + (+ hunk-left-border (* x (font-family-width font-family))) + (+ hunk-top-border (* y (font-family-height font-family)) + (font-family-baseline font-family)) + string :start start :end end + :translate *glyph-translate-function*)))) + +;;; HUNK-REPLACE-LINE-STRING takes a character (x,y) pair and computes at +;;; which pixel coordinate to draw string with font from start to end. We draw +;;; the text on a pixmap and later blast it out to avoid line flicker since +;;; server on the RT is not very clever; it clears the entire line before +;;; drawing text. + +(defun hunk-replace-line-string* (hunk gcontext x y font-family font string start end) + (declare (ignore y)) + (let ((font (svref (font-family-map font-family) font)) + (fg (find-color (bitmap-hunk-xwindow hunk) (svref *color-map* (* font 2)))) + (bg (find-color (bitmap-hunk-xwindow hunk) (svref *color-map* (1+ (* font 2)))))) + (xlib:with-gcontext (gcontext :font font + :foreground fg + :background bg) + (xlib:draw-image-glyphs + (hunk-replace-line-pixmap) gcontext + (+ hunk-left-border (* x (font-family-width font-family))) + (font-family-baseline font-family) + string :start start :end end + :translate *glyph-translate-function*)))) + +;;; Hunk-Write-Line -- Internal +;;; +;;; Paint a dis-line on a hunk, taking font-changes into consideration. +;;; The area of the hunk drawn on is assumed to be cleared. If supplied, +;;; the line is written at Position, and the position in the dis-line +;;; is ignored. +;;; +(defun hunk-write-line (hunk dl &optional (position (dis-line-position dl))) + (let* ((font-family (bitmap-hunk-font-family hunk)) + (chars (dis-line-chars dl)) + (length (dis-line-length dl))) + (let ((last 0) + (last-font 0)) + (do ((change (dis-line-font-changes dl) (font-change-next change))) + ((null change) + (hunk-put-string* hunk last position font-family last-font chars last length)) + (let ((x (font-change-x change))) + (hunk-put-string* hunk last position font-family last-font chars last x) + (setq last x + last-font (font-change-font change)) ))))) + + +;;; We hack this since the X11 server's aren't clever about DRAW-IMAGE-GLYPHS; +;;; that is, they literally clear the line, and then blast the new glyphs. +;;; We don't hack replacing the line when reverse video is turned on because +;;; this doesn't seem to work too well. Also, hacking replace line on the +;;; color Megapel display is SLOW! +;;; +(defvar *hack-hunk-replace-line* t) + +;;; Hunk-Replace-Line -- Internal +;;; +;;; Similar to Hunk-Write-Line, but the line need not be clear. +;;; +(defun hunk-replace-line (hunk dl &optional + (position (dis-line-position dl))) + (if *hack-hunk-replace-line* + (hunk-replace-line-on-a-pixmap hunk dl position) + (old-hunk-replace-line hunk dl position))) + +(defun old-hunk-replace-line (hunk dl &optional (position (dis-line-position dl))) + (let* ((font-family (bitmap-hunk-font-family hunk)) + (chars (dis-line-chars dl)) + (length (dis-line-length dl)) + (height (font-family-height font-family)) ) + (let ((last 0) + (last-font 0)) + (do ((change (dis-line-font-changes dl) (font-change-next change))) + ((null change) + (hunk-put-string* hunk last position font-family last-font chars last length) + (let ((dx (+ hunk-left-border + (* (font-family-width font-family) length)))) + (xlib:clear-area (bitmap-hunk-xwindow hunk) + :x dx + :y (+ hunk-top-border (* position height)) + :width (- (bitmap-hunk-width hunk) dx) + :height height))) + (let ((x (font-change-x change))) + (hunk-put-string* hunk last position font-family last-font chars last x) + (setq last x last-font (font-change-font change)) ))))) + +(defvar *hunk-replace-line-pixmap* nil) + +(defun hunk-replace-line-pixmap () + (if *hunk-replace-line-pixmap* + *hunk-replace-line-pixmap* + (let* ((hunk (window-hunk *current-window*)) + (gcontext (bitmap-hunk-gcontext hunk)) + (screen (xlib:display-default-screen + (bitmap-device-display (device-hunk-device hunk)))) + (height (font-family-height *default-font-family*)) + (pixmap (xlib:create-pixmap + :width (* hunk-width-limit + (font-family-width *default-font-family*)) + :height height :depth (xlib:screen-root-depth screen) + :drawable (xlib:screen-root screen)))) + (xlib:with-gcontext (gcontext :function boole-1 + :foreground *default-background-pixel*) + (xlib:draw-rectangle pixmap gcontext 0 0 hunk-left-border height t)) + (setf *hunk-replace-line-pixmap* pixmap)))) + +(defun hunk-replace-line-on-a-pixmap (hunk dl position) + (let* ((font-family (bitmap-hunk-font-family hunk)) + (chars (dis-line-chars dl)) + (length (dis-line-length dl)) + (height (font-family-height font-family)) + (last 0) + (last-font 0) + (gcontext (bitmap-hunk-gcontext hunk))) + (do ((change (dis-line-font-changes dl) (font-change-next change))) + ((null change) + (hunk-replace-line-string* hunk gcontext last position font-family last-font chars last length) + (let* ((dx (+ hunk-left-border + (* (font-family-width font-family) length))) + (dy (+ hunk-top-border (* position height))) + (xwin (bitmap-hunk-xwindow hunk))) + (xlib:with-gcontext (gcontext :exposures nil) + (xlib:copy-area (hunk-replace-line-pixmap) gcontext + 0 0 dx height xwin 0 dy)) + (xlib:clear-area xwin :x dx :y dy + :width (- (bitmap-hunk-width hunk) dx) + :height height))) + (let ((x (font-change-x change))) + (hunk-replace-line-string* hunk gcontext last position font-family last-font chars last x) + (setq last x last-font (font-change-font change)))))) + + +;;; HUNK-REPLACE-MODELINE sets the entire mode line to the the foreground +;;; color, so the initial bits where no characters go also is highlighted. +;;; Then the text is drawn background on foreground (hightlighted). This +;;; function assumes that BITMAP-HUNK-MODELINE-POS will not return nil; +;;; that is, there is a modeline. This function should assume the gcontext's +;;; font is the default font of the hunk. We must LET bind the foreground and +;;; background values before entering XLIB:WITH-GCONTEXT due to a non-obvious +;;; or incorrect implementation. +;;; +(defun hunk-replace-modeline (hunk) + (let* ((dl (bitmap-hunk-modeline-dis-line hunk)) + (font-family (bitmap-hunk-font-family hunk)) + (default-font (svref (font-family-map font-family) 0)) + (modeline-pos (bitmap-hunk-modeline-pos hunk)) + (xwindow (bitmap-hunk-xwindow hunk)) + (gcontext (bitmap-hunk-gcontext hunk))) + (xlib:draw-rectangle xwindow gcontext 0 modeline-pos + (bitmap-hunk-width hunk) + (+ hunk-modeline-top hunk-modeline-bottom + (font-family-height font-family)) + t) + (xlib:with-gcontext (gcontext :foreground + (xlib:gcontext-background gcontext) + :background + (xlib:gcontext-foreground gcontext) + :font default-font) + (xlib:draw-image-glyphs xwindow gcontext hunk-left-border + (+ modeline-pos hunk-modeline-top + (font-family-baseline font-family)) + (dis-line-chars dl) + :end (dis-line-length dl) + :translate *glyph-translate-function*)))) + + + +;;;; Cursor/Border color manipulation. + +;;; *hemlock-listener* is set to t by default because we can't know from X +;;; whether we come up with the pointer in our window. There is no initial +;;; :enter-window event. Defaulting this to nil causes the cursor to be hollow +;;; when the window comes up under the mouse, and you have to know how to fix +;;; it. Defaulting it to t causes the cursor to always come up full, as if +;;; Hemlock is the X listener, but this recovers naturally as you move into the +;;; window. This also coincides with Hemlock's border coming up highlighted, +;;; even when Hemlock is not the listener. +;;; +(defvar *hemlock-listener* t + "Highlight border when the cursor is dropped and Hemlock can receive input.") +(defvar *current-highlighted-border* nil + "When non-nil, the bitmap-hunk with the highlighted border.") + +(defvar *hunk-cursor-x* 0 "The current cursor X position in pixels.") +(defvar *hunk-cursor-y* 0 "The current cursor Y position in pixels.") +(defvar *cursor-hunk* nil "Hunk the cursor is displayed on.") +(defvar *cursor-dropped* nil) ; True if the cursor is currently displayed. + +;;; HUNK-SHOW-CURSOR locates the cursor at character position (x,y) in hunk. +;;; If the cursor is currently displayed somewhere, then lift it, and display +;;; it at its new location. +;;; +(defun hunk-show-cursor (hunk x y) + (unless (and (= x *hunk-cursor-x*) + (= y *hunk-cursor-y*) + (eq hunk *cursor-hunk*)) + (let ((cursor-down *cursor-dropped*)) + (when cursor-down (lift-cursor)) + (setf *hunk-cursor-x* x) + (setf *hunk-cursor-y* y) + (setf *cursor-hunk* hunk) + (when cursor-down (drop-cursor))))) + +;;; FROB-CURSOR is the note-read-wait method for bitmap redisplay. We +;;; show a cursor and highlight the listening window's border when waiting +;;; for input. +;;; +(defun frob-cursor (on) + (if on (drop-cursor) (lift-cursor))) + +(declaim (special *default-border-pixmap* *highlight-border-pixmap*)) + +;;; DROP-CURSOR and LIFT-CURSOR are separate functions from FROB-CURSOR +;;; because they are called a couple places (e.g., HUNK-EXPOSED-REGION +;;; and SMART-WINDOW-REDISPLAY). When the cursor is being dropped, since +;;; this means Hemlock is listening in the *cursor-hunk*, make sure the +;;; border of the window is highlighted as well. +;;; +(defun drop-cursor () + (unless *cursor-dropped* + (unless *hemlock-listener* (cursor-invert-center)) + (cursor-invert) + (when *hemlock-listener* + (cond (*current-highlighted-border* + (unless (eq *current-highlighted-border* *cursor-hunk*) + (setf (xlib:window-border + (window-group-xparent + (bitmap-hunk-window-group *current-highlighted-border*))) + *default-border-pixmap*) + (setf (xlib:window-border + (window-group-xparent + (bitmap-hunk-window-group *cursor-hunk*))) + *highlight-border-pixmap*) + ;; For complete gratuitous pseudo-generality, should force + ;; output on *current-highlighted-border* device too. + (xlib:display-force-output + (bitmap-device-display (device-hunk-device *cursor-hunk*))))) + (t (setf (xlib:window-border + (window-group-xparent + (bitmap-hunk-window-group *cursor-hunk*))) + *highlight-border-pixmap*) + (xlib:display-force-output + (bitmap-device-display (device-hunk-device *cursor-hunk*))))) + (setf *current-highlighted-border* *cursor-hunk*)) + (setq *cursor-dropped* t))) + +;;; +(defun lift-cursor () + (when *cursor-dropped* + (unless *hemlock-listener* (cursor-invert-center)) + (cursor-invert) + (setq *cursor-dropped* nil))) + + +(defun cursor-invert-center () + (let ((family (bitmap-hunk-font-family *cursor-hunk*)) + (gcontext (bitmap-hunk-gcontext *cursor-hunk*))) + (xlib:with-gcontext (gcontext :function boole-xor + :foreground *foreground-background-xor*) + (xlib:draw-rectangle (bitmap-hunk-xwindow *cursor-hunk*) + gcontext + (+ hunk-left-border + (* *hunk-cursor-x* (font-family-width family)) + (font-family-cursor-x-offset family) + 1) + (+ hunk-top-border + (* *hunk-cursor-y* (font-family-height family)) + (font-family-cursor-y-offset family) + 1) + (- (font-family-cursor-width family) 2) + (- (font-family-cursor-height family) 2) + t))) + (xlib:display-force-output + (bitmap-device-display (device-hunk-device *cursor-hunk*)))) + +(defun cursor-invert () + (let ((family (bitmap-hunk-font-family *cursor-hunk*)) + (gcontext (bitmap-hunk-gcontext *cursor-hunk*))) + (xlib:with-gcontext (gcontext :function boole-xor + :foreground *foreground-background-xor*) + (xlib:draw-rectangle (bitmap-hunk-xwindow *cursor-hunk*) + gcontext + (+ hunk-left-border + (* *hunk-cursor-x* (font-family-width family)) + (font-family-cursor-x-offset family)) + (+ hunk-top-border + (* *hunk-cursor-y* (font-family-height family)) + (font-family-cursor-y-offset family)) + (font-family-cursor-width family) + (font-family-cursor-height family) + t))) + (xlib:display-force-output + (bitmap-device-display (device-hunk-device *cursor-hunk*)))) + + + + +;;;; Clearing and Copying Lines. + +(defun hunk-clear-lines (hunk start count) + (let ((height (font-family-height (bitmap-hunk-font-family hunk)))) + (xlib:clear-area (bitmap-hunk-xwindow hunk) + :x 0 :y (+ hunk-top-border (* start height)) + :width (bitmap-hunk-width hunk) + :height (* count height)))) + +(defun hunk-copy-lines (hunk src dst count) + (let ((height (font-family-height (bitmap-hunk-font-family hunk))) + (xwindow (bitmap-hunk-xwindow hunk))) + (xlib:copy-area xwindow (bitmap-hunk-gcontext hunk) + 0 (+ hunk-top-border (* src height)) + (bitmap-hunk-width hunk) (* height count) + xwindow 0 (+ hunk-top-border (* dst height))))) + + + + +;;;; Drawing bottom border meter. + +;;; HUNK-DRAW-BOTTOM-BORDER assumes eight-character-space tabs. The LOGAND +;;; calls in the loop are testing for no remainder when dividing by 8, 4, +;;; and other. This lets us quickly draw longer notches at tab stops and +;;; half way in between. This function assumes that +;;; BITMAP-HUNK-MODELINE-POS will not return nil; that is, that there is a +;;; modeline. +;;; +(defun hunk-draw-bottom-border (hunk) + (when (bitmap-hunk-thumb-bar-p hunk) + (let* ((xwindow (bitmap-hunk-xwindow hunk)) + (gcontext (bitmap-hunk-gcontext hunk)) + (modeline-pos (bitmap-hunk-modeline-pos hunk)) + (font-family (bitmap-hunk-font-family hunk)) + (font-width (font-family-width font-family))) + (xlib:clear-area xwindow :x 0 :y (- modeline-pos + hunk-thumb-bar-bottom-border) + :width (bitmap-hunk-width hunk) + :height hunk-bottom-border) + (let ((x (+ hunk-left-border (ash font-width -1))) + (y7 (- modeline-pos 7)) + (y5 (- modeline-pos 5)) + (y3 (- modeline-pos 3))) + (dotimes (i (bitmap-hunk-char-width hunk)) + (cond ((zerop (logand i 7)) + (xlib:draw-rectangle xwindow gcontext + x y7 (if (= i 80) 2 1) 7 t)) + ((zerop (logand i 3)) + (xlib:draw-rectangle xwindow gcontext x y5 1 5 t)) + (t + (xlib:draw-rectangle xwindow gcontext x y3 1 3 t))) + (incf x font-width)))))) + +;; $Log$ +;; Revision 1.1 2003/10/19 08:57:15 gb +;; Initial revision +;; +;; Revision 1.1.2.2 2003/09/18 13:40:16 gb +;; Conditionalize for #-CLX, a little more. +;; +;; Revision 1.1.2.1 2003/08/10 19:11:27 gb +;; New files, imported from upstream CVS as of 03/08/09. +;; +;; Revision 1.4 2003/08/05 19:54:17 gilbert +;; - did away with some macros +;; - invested in a left margin for added readability of hemlock frames. +;; Index: /branches/ide-1.0/ccl/hemlock/src/archive/input.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/archive/input.lisp (revision 6567) +++ /branches/ide-1.0/ccl/hemlock/src/archive/input.lisp (revision 6567) @@ -0,0 +1,501 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the code that handles input to Hemlock. +;;; +(in-package :hemlock-internals) + +;;; +;;; INPUT-WAITING is exported solely as a hack for the kbdmac definition +;;; mechanism. +;;; + + +;;; These are public variables users hand to the four basic editor input +;;; routines for method dispatching: +;;; GET-KEY-EVENT +;;; UNGET-KEY-EVENT +;;; LISTEN-EDITOR-INPUT +;;; CLEAR-EDITOR-INPUT +;;; +(defvar *editor-input* nil + "A structure used to do various operations on terminal input.") + +(defvar *real-editor-input* () + "Useful when we want to read from the terminal when *editor-input* is + rebound.") + + + + +;;;; editor-input structure. + +(defstruct (editor-input (:print-function + (lambda (s stream d) + (declare (ignore s d)) + (write-string "#" stream)))) + get ; A function that returns the next key-event in the queue. + unget ; A function that puts a key-event at the front of the queue. + listen ; A function that tells whether the queue is empty. + clear ; A function that empties the queue. + ;; + ;; Queue of events on this stream. The queue always contains at least one + ;; one element, which is the key-event most recently read. If no event has + ;; been read, the event is a dummy with a nil key-event. + head + tail) + + +;;; These are the elements of the editor-input event queue. +;;; +(defstruct (input-event (:constructor make-input-event ())) + next ; Next queued event, or NIL if none. + hunk ; Screen hunk event was read from. + key-event ; Key-event read. + x ; X and Y character position of mouse cursor. + y + unread-p) + +(defvar *free-input-events* ()) + +(defun new-event (key-event x y hunk next &optional unread-p) + (let ((res (if *free-input-events* + (shiftf *free-input-events* + (input-event-next *free-input-events*)) + (make-input-event)))) + (setf (input-event-key-event res) key-event) + (setf (input-event-x res) x) + (setf (input-event-y res) y) + (setf (input-event-hunk res) hunk) + (setf (input-event-next res) next) + (setf (input-event-unread-p res) unread-p) + res)) + +;;; This is a public variable. +;;; +(defvar *last-key-event-typed* () + "This variable contains the last key-event typed by the user and read as + input.") + +;;; This is a public variable. SITE-INIT initializes this. +;;; +(defvar *key-event-history* nil + "This ring holds the last 60 key-events read by the command interpreter.") + +(declaim (special *input-transcript*)) + +;;; DQ-EVENT is used in editor stream methods for popping off input. +;;; If there is an event not yet read in Stream, then pop the queue +;;; and return the character. If there is none, return NIL. +;;; +(defun dq-event (stream) + (hemlock-ext:without-interrupts + (let* ((head (editor-input-head stream)) + (next (input-event-next head))) + (if next + (let ((key-event (input-event-key-event next))) + (setf (editor-input-head stream) next) + (shiftf (input-event-next head) *free-input-events* head) + (ring-push key-event *key-event-history*) + (setf *last-key-event-typed* key-event) + (when *input-transcript* + (vector-push-extend key-event *input-transcript*)) + key-event))))) + +;;; Q-EVENT is used in low level input fetching routines to add input to the +;;; editor stream. +;;; +(defun q-event (stream key-event &optional x y hunk) + (hemlock-ext:without-interrupts + (let ((new (new-event key-event x y hunk nil)) + (tail (editor-input-tail stream))) + (setf (input-event-next tail) new) + (setf (editor-input-tail stream) new)))) + +(defun un-event (key-event stream) + (hemlock-ext:without-interrupts + (let* ((head (editor-input-head stream)) + (next (input-event-next head)) + (new (new-event key-event (input-event-x head) (input-event-y head) + (input-event-hunk head) next t))) + (setf (input-event-next head) new) + (unless next (setf (editor-input-tail stream) new))))) + + + + +;;;; Keyboard macro hacks. + +(defvar *input-transcript* () + "If this variable is non-null then it should contain an adjustable vector + with a fill pointer into which all keyboard input will be pushed.") + +;;; INPUT-WAITING -- Internal +;;; +;;; An Evil hack that tells us whether there is an unread key-event on +;;; *editor-input*. Note that this is applied to the real *editor-input* +;;; rather than to a kbdmac stream. +;;; +(defun input-waiting () + "Returns true if there is a key-event which has been unread-key-event'ed + on *editor-input*. Used by the keyboard macro stuff." + (let ((next (input-event-next + (editor-input-head *real-editor-input*)))) + (and next (input-event-unread-p next)))) + + + + +;;;; Input method macro. + +(defvar *in-hemlock-stream-input-method* nil + "This keeps us from undefined nasties like re-entering Hemlock stream + input methods from input hooks and scheduled events.") + +(declaim (special *screen-image-trashed*)) + +;;; These are the characters GET-KEY-EVENT notices when it pays attention +;;; to aborting input. This happens via EDITOR-INPUT-METHOD-MACRO. +;;; +(defparameter editor-abort-key-events (list #k"Control-g" #k"Control-G")) + +#+clx +(defun cleanup-for-wm-closed-display(closed-display) + ;; Remove fd-handlers + (hemlock-ext:disable-clx-event-handling closed-display) + ;; Close file descriptor and note DEAD. + (xlib:close-display closed-display) + ;; + ;; At this point there is not much sense to returning to Lisp + ;; as the editor cannot be re-entered (there are lots of pointers + ;; to the dead display around that will cause subsequent failures). + ;; Maybe could switch to tty mode then (save-all-files-and-exit)? + ;; For now, just assume user wanted an easy way to kill the session. + (hemlock-ext:quit)) + +(defmacro abort-key-event-p (key-event) + `(member ,key-event editor-abort-key-events)) + +;;; EDITOR-INPUT-METHOD-MACRO -- Internal. +;;; +;;; WINDOWED-GET-KEY-EVENT and TTY-GET-KEY-EVENT use this. Somewhat odd stuff +;;; goes on here because this is the place where Hemlock waits, so this is +;;; where we redisplay, check the time for scheduled events, etc. In the loop, +;;; we call the input hook when we get a character and leave the loop. If +;;; there isn't any input, invoke any scheduled events whose time is up. +;;; Unless SERVE-EVENT returns immediately and did something, (serve-event 0), +;;; call redisplay, note that we are going into a read wait, and call +;;; SERVE-EVENT with a wait or infinite timeout. Upon exiting the loop, turn +;;; off the read wait note and check for the abort character. Return the +;;; key-event we got. We bind an error condition handler here because the +;;; default Hemlock error handler goes into a little debugging prompt loop, but +;;; if we got an error in getting input, we should prompt the user using the +;;; input method (recursively even). +;;; +(eval-when (:compile-toplevel :execute) + +(defmacro editor-input-method-macro () + `(handler-bind + ((error + (lambda (condition) + (when (typep condition 'stream-error) + (let* ((stream (stream-error-stream condition)) + (display *editor-windowed-input*) + (display-stream + #+CLX + (and display (xlib::display-input-stream display)))) + (when (eq stream display-stream) + ;;(format *error-output* "~%Hemlock: Display died!~%~%") + (cleanup-for-wm-closed-display display) + (exit-hemlock nil)) + (let ((device + (device-hunk-device (window-hunk (current-window))))) + (funcall (device-exit device) device)) + (invoke-debugger condition))))) + #+(and CLX ) + (xlib:closed-display + (lambda(condition) + (let ((display (xlib::closed-display-display condition))) + (format *error-output* + "Closed display on stream ~a~%" + (xlib::display-input-stream display))) + (exit-hemlock nil))) + ) +; (when *in-hemlock-stream-input-method* +; (error "Entering Hemlock stream input method recursively!")) + (let ((*in-hemlock-stream-input-method* t) + (nrw-fun (device-note-read-wait + (device-hunk-device (window-hunk (current-window))))) + key-event) + (loop + (when (setf key-event (dq-event stream)) + (dolist (f (variable-value 'hemlock::input-hook)) (funcall f)) + (return)) + (invoke-scheduled-events) + (unless (or (hemlock-ext:serve-event 0) + (internal-redisplay)) + (internal-redisplay) + (when nrw-fun (funcall nrw-fun t)) + (let ((wait (next-scheduled-event-wait))) + (if wait (hemlock-ext:serve-event wait) (hemlock-ext:serve-event))))) + (when nrw-fun (funcall nrw-fun nil)) + (when (and (abort-key-event-p key-event) + ;; ignore-abort-attempts-p must exist outside the macro. + ;; in this case it is bound in GET-KEY-EVENT. + (not ignore-abort-attempts-p)) + (beep) + (throw 'editor-top-level-catcher nil)) + key-event))) +) ;eval-when + + + + +;;;; Editor input from windowing system. +#+clx +(defstruct (windowed-editor-input + (:include editor-input + (get #'windowed-get-key-event) + (unget #'windowed-unget-key-event) + (listen #'windowed-listen) + (clear #'windowed-clear-input)) + (:print-function + (lambda (s stream d) + (declare (ignore s d)) + (write-string "#" stream))) + (:constructor make-windowed-editor-input + (&optional (head (make-input-event)) (tail head)))) + hunks) ; List of bitmap-hunks which input to this stream. + +#+clx +;;; There's actually no difference from the TTY case... +(defun windowed-get-key-event (stream ignore-abort-attempts-p) + (tty-get-key-event stream ignore-abort-attempts-p)) + +#+clx +(defun windowed-unget-key-event (key-event stream) + (un-event key-event stream)) + +#+clx +(defun windowed-clear-input (stream) + (loop (unless (hemlock-ext:serve-event 0) (return))) + (hemlock-ext:without-interrupts + (let* ((head (editor-input-head stream)) + (next (input-event-next head))) + (when next + (setf (input-event-next head) nil) + (shiftf (input-event-next (editor-input-tail stream)) + *free-input-events* next) + (setf (editor-input-tail stream) head))))) + +#+clx +(defun windowed-listen (stream) + (loop + ;; Don't service anymore events if we just got some input. + (when (input-event-next (editor-input-head stream)) + (return t)) + ;; + ;; If nothing is pending, check the queued input. + (unless (hemlock-ext:serve-event 0) + (return (not (null (input-event-next (editor-input-head stream)))))))) + + + +;;;; Editor input from a tty. + +(defstruct (tty-editor-input + (:include editor-input + (get #'tty-get-key-event) + (unget #'tty-unget-key-event) + (listen #'tty-listen) + (clear #'tty-clear-input)) + (:print-function + (lambda (obj stream n) + (declare (ignore obj n)) + (write-string "#" stream))) + (:constructor make-tty-editor-input + (fd &optional (head (make-input-event)) (tail head)))) + fd) + +(defun tty-get-key-event (stream ignore-abort-attempts-p) + (editor-input-method-macro)) + +(defun tty-unget-key-event (key-event stream) + (un-event key-event stream)) + +(defun tty-clear-input (stream) + (hemlock-ext:without-interrupts + (let* ((head (editor-input-head stream)) + (next (input-event-next head))) + (when next + (setf (input-event-next head) nil) + (shiftf (input-event-next (editor-input-tail stream)) + *free-input-events* next) + (setf (editor-input-tail stream) head))))) + +;;; Note that we never return NIL as long as there are events to be served with +;;; SERVE-EVENT. Thus non-keyboard input (i.e. process output) +;;; effectively causes LISTEN to block until either all the non-keyboard input +;;; has happened, or there is some real keyboard input. +;;; +(defun tty-listen (stream) + (loop + ;; Don't service anymore events if we just got some input. + (when (or (input-event-next (editor-input-head stream)) + (editor-tty-listen stream)) + (return t)) + ;; If nothing is pending, check the queued input. + (unless (hemlock-ext:serve-event 0) + (return (not (null (input-event-next (editor-input-head stream)))))))) + + + +;;;; GET-KEY-EVENT, UNGET-KEY-EVENT, LISTEN-EDITOR-INPUT, CLEAR-EDITOR-INPUT. + +;;; GET-KEY-EVENT -- Public. +;;; +(defun get-key-event (editor-input &optional ignore-abort-attempts-p) + "This function returns a key-event as soon as it is available on + editor-input. Editor-input is either *editor-input* or *real-editor-input*. + Ignore-abort-attempts-p indicates whether #k\"C-g\" and #k\"C-G\" throw to + the editor's top-level command loop; when this is non-nil, this function + returns those key-events when the user types them. Otherwise, it aborts the + editor's current state, returning to the command loop." + (funcall (editor-input-get editor-input) editor-input ignore-abort-attempts-p)) + +;;; UNGET-KEY-EVENT -- Public. +;;; +(defun unget-key-event (key-event editor-input) + "This function returns the key-event to editor-input, so the next invocation + of GET-KEY-EVENT will return the key-event. If the key-event is #k\"C-g\" + or #k\"C-G\", then whether GET-KEY-EVENT returns it depends on its second + argument. Editor-input is either *editor-input* or *real-editor-input*." + (funcall (editor-input-unget editor-input) key-event editor-input)) + +;;; CLEAR-EDITOR-INPUT -- Public. +;;; +(defun clear-editor-input (editor-input) + "This function flushes any pending input on editor-input. Editor-input + is either *editor-input* or *real-editor-input*." + (funcall (editor-input-clear editor-input) editor-input)) + +;;; LISTEN-EDITOR-INPUT -- Public. +;;; +(defun listen-editor-input (editor-input) + "This function returns whether there is any input available on editor-input. + Editor-input is either *editor-input* or *real-editor-input*." + (funcall (editor-input-listen editor-input) editor-input)) + + + + +;;;; LAST-KEY-EVENT-CURSORPOS and WINDOW-INPUT-HANDLER. + +;;; LAST-KEY-EVENT-CURSORPOS -- Public +;;; +;;; Just look up the saved info in the last read key event. +;;; +(defun last-key-event-cursorpos () + "Return as values, the (X, Y) character position and window where the + last key event happened. If this cannot be determined, Nil is returned. + If in the modeline, return a Y position of NIL and the correct X and window. + Returns nil for terminal input." + (let* ((ev (editor-input-head *real-editor-input*)) + (hunk (input-event-hunk ev)) + (window (and hunk (device-hunk-window hunk)))) + (when window + (values (input-event-x ev) (input-event-y ev) window)))) + +;;; WINDOW-INPUT-HANDLER -- Internal +;;; +;;; This is the input-handler function for hunks that implement windows. It +;;; just queues the events on *real-editor-input*. +;;; +(defun window-input-handler (hunk char x y) + (q-event *real-editor-input* char x y hunk)) + + + + +;;;; Random typeout input routines. + +(defun wait-for-more (stream) + (let ((key-event (more-read-key-event))) + (cond ((logical-key-event-p key-event :yes)) + ((or (logical-key-event-p key-event :do-all) + (logical-key-event-p key-event :exit)) + (setf (random-typeout-stream-no-prompt stream) t) + (random-typeout-cleanup stream)) + ((logical-key-event-p key-event :keep) + (setf (random-typeout-stream-no-prompt stream) t) + (maybe-keep-random-typeout-window stream) + (random-typeout-cleanup stream)) + ((logical-key-event-p key-event :no) + (random-typeout-cleanup stream) + (throw 'more-punt nil)) + (t + (unget-key-event key-event *editor-input*) + (random-typeout-cleanup stream) + (throw 'more-punt nil))))) + +(declaim (special *more-prompt-action*)) + +(defun maybe-keep-random-typeout-window (stream) + (let* ((window (random-typeout-stream-window stream)) + (buffer (window-buffer window)) + (start (buffer-start-mark buffer))) + (when (typep (hi::device-hunk-device (hi::window-hunk window)) + 'hi::bitmap-device) + (let ((*more-prompt-action* :normal)) + (update-modeline-field buffer window :more-prompt) + (random-typeout-redisplay window)) + (buffer-start (buffer-point buffer)) + (let* ((xwindow (make-xwindow-like-hwindow window)) + (window (make-window start :window xwindow))) + (unless window + #+clx(xlib:destroy-window xwindow) + (editor-error "Could not create random typeout window.")))))) + +(defun end-random-typeout (stream) + (let ((*more-prompt-action* :flush) + (window (random-typeout-stream-window stream))) + (update-modeline-field (window-buffer window) window :more-prompt) + (random-typeout-redisplay window)) + (unless (random-typeout-stream-no-prompt stream) + (let* ((key-event (more-read-key-event)) + (keep-p (logical-key-event-p key-event :keep))) + (when keep-p (maybe-keep-random-typeout-window stream)) + (random-typeout-cleanup stream) + (unless (or (logical-key-event-p key-event :do-all) + (logical-key-event-p key-event :exit) + (logical-key-event-p key-event :no) + (logical-key-event-p key-event :yes) + keep-p) + (unget-key-event key-event *editor-input*))))) + +;;; MORE-READ-KEY-EVENT -- Internal. +;;; +;;; This gets some input from the type of stream bound to *editor-input*. Need +;;; to loop over SERVE-EVENT since it returns on any kind of event (not +;;; necessarily a key or button event). +;;; +;;; Currently this does not work for keyboard macro streams! +;;; +(defun more-read-key-event () + (clear-editor-input *editor-input*) + (let ((key-event (loop + (let ((key-event (dq-event *editor-input*))) + (when key-event (return key-event)) + (hemlock-ext:serve-event))))) + (when (abort-key-event-p key-event) + (beep) + (throw 'editor-top-level-catcher nil)) + key-event)) Index: /branches/ide-1.0/ccl/hemlock/src/archive/lispbuf.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/archive/lispbuf.lisp (revision 6567) +++ /branches/ide-1.0/ccl/hemlock/src/archive/lispbuf.lisp (revision 6567) @@ -0,0 +1,794 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Stuff to do a little lisp hacking in the editor's Lisp environment. +;;; + +(in-package :hemlock) + + +(defmacro in-lisp (&body body) + "Evaluates body inside HANDLE-LISP-ERRORS. *package* is bound to the package + named by \"Current Package\" if it is non-nil." + (let ((name (gensym)) (package (gensym))) + `(handle-lisp-errors + (let* ((,name (value current-package)) + (,package (and ,name (find-package ,name)))) + (progv (if ,package '(*package*)) (if ,package (list ,package)) + ,@body))))) + + +(define-file-option "Package" (buffer value) + (defhvar "Current Package" + "The package used for evaluation of Lisp in this buffer." + :buffer buffer + :value + (let* ((eof (list nil)) + (thing (read-from-string value nil eof))) + (when (eq thing eof) (error "Bad package file option value.")) + (cond + ((stringp thing) + thing) + ((symbolp thing) + (symbol-name thing)) + ((characterp thing) + (string thing)) + (t + (message + "Ignoring \"package\" file option -- cannot convert to a string.")))) + :hooks (list 'package-name-change-hook))) + + + +;;;; Eval Mode Interaction. + +(declaim (special * ** *** - + ++ +++ / // ///)) + + +(defun get-prompt () + #+cmu (locally (declare (special ext:*prompt*)) + (if (functionp ext:*prompt*) + (funcall ext:*prompt*) + ext:*prompt*)) + #+sbcl (with-output-to-string (out) + (funcall sb-int:*repl-prompt-fun* out)) + #-(or cmu sbcl) "* ") + + +(defun show-prompt (&optional (stream *standard-output*)) + #-sbcl (princ (get-prompt) stream) + #+sbcl (funcall sb-int:*repl-prompt-fun* stream)) + + +(defun setup-eval-mode (buffer) + (let ((point (buffer-point buffer))) + (setf (buffer-minor-mode buffer "Eval") t) + (setf (buffer-minor-mode buffer "Editor") t) + (setf (buffer-major-mode buffer) "Lisp") + (buffer-end point) + (defhvar "Current Package" + "This variable holds the name of the package currently used for Lisp + evaluation and compilation. If it is Nil, the value of *Package* is used + instead." + :value nil + :buffer buffer) + (unless (hemlock-bound-p 'buffer-input-mark :buffer buffer) + (defhvar "Buffer Input Mark" + "Mark used for Eval Mode input." + :buffer buffer + :value (copy-mark point :right-inserting)) + (defhvar "Eval Output Stream" + "Output stream used for Eval Mode output in this buffer." + :buffer buffer + :value (make-hemlock-output-stream point)) + (defhvar "Interactive History" + "A ring of the regions input to an interactive mode (Eval or Typescript)." + :buffer buffer + :value (make-ring (value interactive-history-length))) + (defhvar "Interactive Pointer" + "Pointer into \"Interactive History\"." + :buffer buffer + :value 0) + (defhvar "Searching Interactive Pointer" + "Pointer into \"Interactive History\"." + :buffer buffer + :value 0)) + (let ((*standard-output* + (variable-value 'eval-output-stream :buffer buffer))) + (fresh-line) + (show-prompt)) + (move-mark (variable-value 'buffer-input-mark :buffer buffer) point))) + +(defmode "Eval" :major-p nil :setup-function #'setup-eval-mode) + +(defun eval-mode-lisp-mode-hook (buffer on) + "Turn on Lisp mode when we go into Eval Mode." + (when on + (setf (buffer-major-mode buffer) "Lisp"))) +;;; +(add-hook eval-mode-hook 'eval-mode-lisp-mode-hook) + +(defhvar "Editor Definition Info" + "When this is non-nil, the editor Lisp is used to determine definition + editing information; otherwise, the slave Lisp is used." + :value t + :mode "Eval") + + +(defvar *selected-eval-buffer* nil) + +(defcommand "Select Eval Buffer" (p) + "Goto buffer in \"Eval\" mode, creating one if necessary." + "Goto buffer in \"Eval\" mode, creating one if necessary." + (declare (ignore p)) + (unless *selected-eval-buffer* + (when (getstring "Eval" *buffer-names*) + (editor-error "There is already a buffer named \"Eval\"!")) + (setf *selected-eval-buffer* + (make-buffer "Eval" + :delete-hook + (list #'(lambda (buf) + (declare (ignore buf)) + (setf *selected-eval-buffer* nil))))) + (setf (buffer-minor-mode *selected-eval-buffer* "Eval") t)) + (change-to-buffer *selected-eval-buffer*)) + + +(defvar lispbuf-eof '(nil)) + +(defhvar "Unwedge Interactive Input Confirm" + "When set (the default), trying to confirm interactive input when the + point is not after the input mark causes Hemlock to ask the user if he + needs to be unwedged. When not set, an editor error is signaled + informing the user that the point is before the input mark." + :value t) + +(defun unwedge-eval-buffer () + (abort-eval-input-command nil)) + +(defhvar "Unwedge Interactive Input Fun" + "Function to call when input is confirmed, but the point is not past the + input mark." + :value #'unwedge-eval-buffer + :mode "Eval") + +(defhvar "Unwedge Interactive Input String" + "String to add to \"Point not past input mark. \" explaining what will + happen if the the user chooses to be unwedged." + :value "Prompt again at the end of the buffer? " + :mode "Eval") + +(defcommand "Confirm Eval Input" (p) + "Evaluate Eval Mode input between point and last prompt." + "Evaluate Eval Mode input between point and last prompt." + (declare (ignore p)) + (let ((input-region (get-interactive-input))) + (when input-region + (let* ((output (value eval-output-stream)) + (*standard-output* output) + (*error-output* output) + (*trace-output* output)) + (fresh-line) + (in-lisp + ;; Copy the region to keep the output and input streams from interacting + ;; since input-region is made of permanent marks into the buffer. + (with-input-from-region (stream (copy-region input-region)) + (loop + (let ((form (read stream nil lispbuf-eof))) + (when (eq form lispbuf-eof) + ;; Move the buffer's input mark to the end of the buffer. + (move-mark (region-start input-region) + (region-end input-region)) + (return)) + (setq +++ ++ ++ + + - - form) + (let ((this-eval (multiple-value-list (eval form)))) + (fresh-line) + (dolist (x this-eval) (prin1 x) (terpri)) + (show-prompt) + (setq /// // // / / this-eval) + (setq *** ** ** * * (car this-eval))))))))))) + +(defcommand "Abort Eval Input" (p) + "Move to the end of the buffer and prompt." + "Move to the end of the buffer and prompt." + (declare (ignore p)) + (let ((point (current-point))) + (buffer-end point) + (insert-character point #\newline) + (insert-string point "Aborted.") + (insert-character point #\newline) + (insert-string point (get-prompt)) + (move-mark (value buffer-input-mark) point))) + + + + +;;;; General interactive commands used in eval and typescript buffers. + +(defun get-interactive-input () + "Tries to return a region. When the point is not past the input mark, and + the user has \"Unwedge Interactive Input Confirm\" set, the buffer is + optionally fixed up, and nil is returned. Otherwise, an editor error is + signalled. When a region is returned, the start is the current buffer's + input mark, and the end is the current point moved to the end of the buffer." + (let ((point (current-point)) + (mark (value buffer-input-mark))) + (cond + ((mark>= point mark) + (buffer-end point) + (let* ((input-region (region mark point)) + (string (region-to-string input-region)) + (ring (value interactive-history))) + (when (and (or (zerop (ring-length ring)) + (string/= string (region-to-string (ring-ref ring 0)))) + (> (length string) (value minimum-interactive-input-length))) + (ring-push (copy-region input-region) ring)) + input-region)) + ((value unwedge-interactive-input-confirm) + (beep) + (when (prompt-for-y-or-n + :prompt (concatenate 'simple-string + "Point not past input mark. " + (value unwedge-interactive-input-string)) + :must-exist t :default t :default-string "yes") + (funcall (value unwedge-interactive-input-fun)) + (message "Unwedged.")) + nil) + (t + (editor-error "Point not past input mark."))))) + +(defhvar "Interactive History Length" + "This is the length used for the history ring in interactive buffers. + It must be set before turning on the mode." + :value 10) + +(defhvar "Minimum Interactive Input Length" + "When the number of characters in an interactive buffer exceeds this value, + it is pushed onto the interactive history, otherwise it is lost forever." + :value 2) + + +(defvar *previous-input-search-string* "ignore") + +(defvar *previous-input-search-pattern* + ;; Give it a bogus string since you can't give it the empty string. + (new-search-pattern :string-insensitive :forward "ignore")) + +(defun get-previous-input-search-pattern (string) + (if (string= *previous-input-search-string* string) + *previous-input-search-pattern* + (new-search-pattern :string-insensitive :forward + (setf *previous-input-search-string* string) + *previous-input-search-pattern*))) + +(defcommand "Search Previous Interactive Input" (p) + "Search backward through the interactive history using the current input as + a search string. Consecutive invocations repeat the previous search." + "Search backward through the interactive history using the current input as + a search string. Consecutive invocations repeat the previous search." + (declare (ignore p)) + (let* ((mark (value buffer-input-mark)) + (ring (value interactive-history)) + (point (current-point)) + (just-invoked (eq (last-command-type) :searching-interactive-input))) + (when (mark<= point mark) + (editor-error "Point not past input mark.")) + (when (zerop (ring-length ring)) + (editor-error "No previous input in this buffer.")) + (unless just-invoked + (get-previous-input-search-pattern (region-to-string (region mark point)))) + (let ((found-it (find-previous-input ring just-invoked))) + (unless found-it + (editor-error "Couldn't find ~a." *previous-input-search-string*)) + (delete-region (region mark point)) + (insert-region point (ring-ref ring found-it)) + (setf (value searching-interactive-pointer) found-it)) + (setf (last-command-type) :searching-interactive-input))) + +(defun find-previous-input (ring againp) + (let ((ring-length (ring-length ring)) + (base (if againp + (+ (value searching-interactive-pointer) 1) + 0))) + (loop + (when (= base ring-length) + (if againp + (setf base 0) + (return nil))) + (with-mark ((m (region-start (ring-ref ring base)))) + (when (find-pattern m *previous-input-search-pattern*) + (return base))) + (incf base)))) + +(defcommand "Previous Interactive Input" (p) + "Insert the previous input in an interactive mode (Eval or Typescript). + If repeated, keep rotating the history. With prefix argument, rotate + that many times." + "Pop the *interactive-history* at the point." + (let* ((point (current-point)) + (mark (value buffer-input-mark)) + (ring (value interactive-history)) + (length (ring-length ring)) + (p (or p 1))) + (when (or (mark< point mark) (zerop length)) (editor-error)) + (cond + ((eq (last-command-type) :interactive-history) + (let ((base (mod (+ (value interactive-pointer) p) length))) + (delete-region (region mark point)) + (insert-region point (ring-ref ring base)) + (setf (value interactive-pointer) base))) + (t + (let ((base (mod (if (minusp p) p (1- p)) length)) + (region (delete-and-save-region (region mark point)))) + (insert-region point (ring-ref ring base)) + (when (mark/= (region-start region) (region-end region)) + (ring-push region ring) + (incf base)) + (setf (value interactive-pointer) base))))) + (setf (last-command-type) :interactive-history)) + +(defcommand "Next Interactive Input" (p) + "Rotate the interactive history backwards. The region is left around the + inserted text. With prefix argument, rotate that many times." + "Call previous-interactive-input-command with negated arg." + (previous-interactive-input-command (- (or p 1)))) + +(defcommand "Kill Interactive Input" (p) + "Kill any input to an interactive mode (Eval or Typescript)." + "Kill any input to an interactive mode (Eval or Typescript)." + (declare (ignore p)) + (let ((point (buffer-point (current-buffer))) + (mark (value buffer-input-mark))) + (when (mark< point mark) (editor-error)) + (kill-region (region mark point) :kill-backward))) + +(defcommand "Interactive Beginning of Line" (p) + "If on line with current prompt, go to after it, otherwise do what + \"Beginning of Line\" always does." + "Go to after prompt when on prompt line." + (let ((mark (value buffer-input-mark)) + (point (current-point))) + (if (and (same-line-p point mark) (or (not p) (= p 1))) + (move-mark point mark) + (beginning-of-line-command p)))) + +(defcommand "Reenter Interactive Input" (p) + "Copies the form to the left of point to be after the interactive buffer's + input mark. When the current region is active, it is copied instead." + "Copies the form to the left of point to be after the interactive buffer's + input mark. When the current region is active, it is copied instead." + (declare (ignore p)) + (unless (hemlock-bound-p 'buffer-input-mark) + (editor-error "Not in an interactive buffer.")) + (let ((point (current-point))) + (let ((region (if (region-active-p) + ;; Copy this, so moving point doesn't affect the region. + (copy-region (current-region)) + (with-mark ((start point) + (end point)) + (pre-command-parse-check start) + (unless (form-offset start -1) + (editor-error "Not after complete form.")) + (region (copy-mark start) (copy-mark end)))))) + (buffer-end point) + (push-buffer-mark (copy-mark point)) + (insert-region point region) + (setf (last-command-type) :ephemerally-active)))) + + + + +;;; Other stuff. + +(defmode "Editor") + +(defcommand "Editor Mode" (p) + "Turn on \"Editor\" mode in the current buffer. If it is already on, turn it + off. When in editor mode, most lisp compilation and evaluation commands + manipulate the editor process instead of the current eval server." + "Toggle \"Editor\" mode in the current buffer." + (declare (ignore p)) + (setf (buffer-minor-mode (current-buffer) "Editor") + (not (buffer-minor-mode (current-buffer) "Editor")))) + +(define-file-option "Editor" (buffer value) + (declare (ignore value)) + (setf (buffer-minor-mode buffer "Editor") t)) + +(defhvar "Editor Definition Info" + "When this is non-nil, the editor Lisp is used to determine definition + editing information; otherwise, the slave Lisp is used." + :value t + :mode "Editor") + +(defcommand "Editor Compile Defun" (p) + "Compiles the current or next top-level form in the editor Lisp. + First the form is evaluated, then the result of this evaluation + is passed to compile. If the current region is active, this + compiles the region." + "Evaluates the current or next top-level form in the editor Lisp." + (declare (ignore p)) + (if (region-active-p) + (editor-compile-region (current-region)) + (editor-compile-region (defun-region (current-point)) t))) + +(defcommand "Editor Compile Region" (p) + "Compiles lisp forms between the point and the mark in the editor Lisp." + "Compiles lisp forms between the point and the mark in the editor Lisp." + (declare (ignore p)) + (editor-compile-region (current-region))) + +(defun defun-region (mark) + "This returns a region around the current or next defun with respect to mark. + Mark is not used to form the region. If there is no appropriate top level + form, this signals an editor-error. This calls PRE-COMMAND-PARSE-CHECK." + (with-mark ((start mark) + (end mark)) + (pre-command-parse-check start) + (cond ((not (mark-top-level-form start end)) + (editor-error "No current or next top level form.")) + (t (region start end))))) + +(defun editor-compile-region (region &optional quiet) + (unless quiet (message "Compiling region ...")) + (in-lisp + (with-input-from-region (stream region) + (with-pop-up-display (*error-output* :height 19) + ;; JDz: We don't record source locations and what not, but this + ;; is portable. CMUCL specific implementation removed because + ;; it does not work on HEMLOCK-REGION-STREAM (but it can be + ;; added back later if CMUCL starts using user-extensible + ;; streams internally.) + (funcall (compile nil `(lambda () + ,@(loop for form = (read stream nil stream) + until (eq form stream) + collect form)))))))) + + +(defcommand "Editor Evaluate Defun" (p) + "Evaluates the current or next top-level form in the editor Lisp. + If the current region is active, this evaluates the region." + "Evaluates the current or next top-level form in the editor Lisp." + (declare (ignore p)) + (if (region-active-p) + (editor-evaluate-region-command nil) + (with-input-from-region (stream (defun-region (current-point))) + (clear-echo-area) + (in-lisp + (message "Editor Evaluation returned ~S" + (eval (read stream))))))) + +(defcommand "Editor Evaluate Region" (p) + "Evaluates lisp forms between the point and the mark in the editor Lisp." + "Evaluates lisp forms between the point and the mark in the editor Lisp." + (declare (ignore p)) + (with-input-from-region (stream (current-region)) + (clear-echo-area) + (write-string "Evaluating region in the editor ..." *echo-area-stream*) + (finish-output *echo-area-stream*) + (in-lisp + (do ((object (read stream nil lispbuf-eof) + (read stream nil lispbuf-eof))) + ((eq object lispbuf-eof)) + (eval object))) + (message "Evaluation complete."))) + +(defcommand "Editor Re-evaluate Defvar" (p) + "Evaluate the current or next top-level form if it is a DEFVAR. Treat the + form as if the variable is not bound. This occurs in the editor Lisp." + "Evaluate the current or next top-level form if it is a DEFVAR. Treat the + form as if the variable is not bound. This occurs in the editor Lisp." + (declare (ignore p)) + (with-input-from-region (stream (defun-region (current-point))) + (clear-echo-area) + (in-lisp + (let ((form (read stream))) + (unless (eq (car form) 'defvar) (editor-error "Not a DEFVAR.")) + (makunbound (cadr form)) + (message "Evaluation returned ~S" (eval form)))))) + +(defcommand "Editor Macroexpand Expression" (p) + "Show the macroexpansion of the current expression in the null environment. + With an argument, use MACROEXPAND instead of MACROEXPAND-1." + "Show the macroexpansion of the current expression in the null environment. + With an argument, use MACROEXPAND instead of MACROEXPAND-1." + (let ((point (buffer-point (current-buffer)))) + (with-mark ((start point)) + (pre-command-parse-check start) + (with-mark ((end start)) + (unless (form-offset end 1) (editor-error)) + (in-lisp + (with-pop-up-display (rts) + (write-string (with-input-from-region (s (region start end)) + (prin1-to-string (funcall (if p + 'macroexpand + 'macroexpand-1) + (read s)))) + rts))))))) + +(defcommand "Editor Evaluate Expression" (p) + "Prompt for an expression to evaluate in the editor Lisp." + "Prompt for an expression to evaluate in the editor Lisp." + (declare (ignore p)) + (in-lisp + (multiple-value-call #'message "=> ~@{~#[~;~S~:;~S, ~]~}" + (eval (prompt-for-expression + :prompt "Editor Eval: " + :help "Expression to evaluate"))))) + +(defcommand "Editor Evaluate Buffer" (p) + "Evaluates the text in the current buffer in the editor Lisp." + "Evaluates the text in the current buffer redirecting *Standard-Output* to + the echo area. This occurs in the editor Lisp. The prefix argument is + ignored." + (declare (ignore p)) + (clear-echo-area) + (write-string "Evaluating buffer in the editor ..." *echo-area-stream*) + (finish-output *echo-area-stream*) + (with-input-from-region (stream (buffer-region (current-buffer))) + (let ((*standard-output* *echo-area-stream*)) + (in-lisp + (do ((object (read stream nil lispbuf-eof) + (read stream nil lispbuf-eof))) + ((eq object lispbuf-eof)) + (eval object)))) + (message "Evaluation complete."))) + + + +;;; With-Output-To-Window -- Internal +;;; +;;; +(defmacro with-output-to-window ((stream name) &body forms) + "With-Output-To-Window (Stream Name) {Form}* + Bind Stream to a stream that writes into the buffer named Name a la + With-Output-To-Mark. The buffer is created if it does not exist already + and a window is created to display the buffer if it is not displayed. + For the duration of the evaluation this window is made the current window." + (let ((nam (gensym)) (buffer (gensym)) (point (gensym)) + (window (gensym)) (old-window (gensym))) + `(let* ((,nam ,name) + (,buffer (or (getstring ,nam *buffer-names*) (make-buffer ,nam))) + (,point (buffer-end (buffer-point ,buffer))) + (,window (or (car (buffer-windows ,buffer)) (make-window ,point))) + (,old-window (current-window))) + (unwind-protect + (progn (setf (current-window) ,window) + (buffer-end ,point) + (with-output-to-mark (,stream ,point) ,@forms)) + (setf (current-window) ,old-window))))) + +(defcommand "Editor Compile File" (p) + "Prompts for file to compile in the editor Lisp. Does not compare source + and binary write dates. Does not check any buffer for that file for + whether the buffer needs to be saved." + "Prompts for file to compile." + (declare (ignore p)) + (let ((pn (prompt-for-file :default + (buffer-default-pathname (current-buffer)) + :prompt "File to compile: "))) + (with-output-to-window (*error-output* "Compiler Warnings") + (in-lisp (compile-file (namestring pn) #+cmu :error-file #+cmu nil))))) + + +(defun older-or-non-existent-fasl-p (pathname &optional definitely) + (let ((obj-pn (probe-file (compile-file-pathname pathname)))) + (or definitely + (not obj-pn) + (< (file-write-date obj-pn) (file-write-date pathname))))) + + +(defcommand "Editor Compile Buffer File" (p) + "Compile the file in the current buffer in the editor Lisp if its associated + binary file (of type .fasl) is older than the source or doesn't exist. When + the binary file is up to date, the user is asked if the source should be + compiled anyway. When the prefix argument is supplied, compile the file + without checking the binary file. When \"Compile Buffer File Confirm\" is + set, this command will ask for confirmation when it otherwise would not." + "Compile the file in the current buffer in the editor Lisp if the fasl file + isn't up to date. When p, always do it." + (let* ((buf (current-buffer)) + (pn (buffer-pathname buf))) + (unless pn (editor-error "Buffer has no associated pathname.")) + (cond ((buffer-modified buf) + (when (or (not (value compile-buffer-file-confirm)) + (prompt-for-y-or-n + :default t :default-string "Y" + :prompt (list "Save and compile file ~A? " + (namestring pn)))) + (write-buffer-file buf pn) + (with-output-to-window (*error-output* "Compiler Warnings") + (in-lisp (compile-file (namestring pn) #+cmu :error-file #+cmu nil))))) + ((older-or-non-existent-fasl-p pn p) + (when (or (not (value compile-buffer-file-confirm)) + (prompt-for-y-or-n + :default t :default-string "Y" + :prompt (list "Compile file ~A? " (namestring pn)))) + (with-output-to-window (*error-output* "Compiler Warnings") + (in-lisp (compile-file (namestring pn) #+cmu :error-file #+cmu nil))))) + (t (when (or p + (prompt-for-y-or-n + :default t :default-string "Y" + :prompt + "Fasl file up to date, compile source anyway? ")) + (with-output-to-window (*error-output* "Compiler Warnings") + (in-lisp (compile-file (namestring pn) #+cmu :error-file #+cmu nil)))))))) + +(defcommand "Editor Compile Group" (p) + "Compile each file in the current group which needs it in the editor Lisp. + If a file has type LISP and there is a curresponding file with type + FASL which has been written less recently (or it doesn't exit), then + the file is compiled, with error output directed to the \"Compiler Warnings\" + buffer. If a prefix argument is provided, then all the files are compiled. + All modified files are saved beforehand." + "Do a Compile-File in each file in the current group that seems to need it + in the editor Lisp." + (save-all-files-command ()) + (unless *active-file-group* (editor-error "No active file group.")) + (dolist (file *active-file-group*) + (when (string-equal (pathname-type file) "lisp") + (let ((tn (probe-file file))) + (cond ((not tn) + (message "File ~A not found." (namestring file))) + ((older-or-non-existent-fasl-p tn p) + (with-output-to-window (*error-output* "Compiler Warnings") + (in-lisp (compile-file (namestring tn) #+cmu :error-file #+cmu nil))))))))) + +(defcommand "List Compile Group" (p) + "List any files that would be compiled by \"Compile Group\". All Modified + files are saved before checking to generate a consistent list." + "Do a Compile-File in each file in the current group that seems to need it." + (declare (ignore p)) + (save-all-files-command ()) + (unless *active-file-group* (editor-error "No active file group.")) + (with-pop-up-display (s) + (write-line "\"Compile Group\" would compile the following files:" s) + (force-output s) + (dolist (file *active-file-group*) + (when (string-equal (pathname-type file) "lisp") + (let ((tn (probe-file file))) + (cond ((not tn) + (format s "File ~A not found.~%" (namestring file))) + ((older-or-non-existent-fasl-p tn) + (write-line (namestring tn) s))) + (force-output s)))))) + +(defhvar "Load Pathname Defaults" + "The default pathname used by the load command.") + +(defcommand "Editor Load File" (p) + "Prompt for a file to load into Editor Lisp." + "Prompt for a file to load into the Editor Lisp." + (declare (ignore p)) + (let ((name (truename (prompt-for-file + :default + (or (value load-pathname-defaults) + (buffer-default-pathname (current-buffer))) + :prompt "Editor file to load: " + :help "The name of the file to load")))) + (setv load-pathname-defaults name) + (in-lisp (load name)))) + + + + +;;;; Lisp documentation stuff. + +;;; FUNCTION-TO-DESCRIBE is used in "Editor Describe Function Call" and +;;; "Describe Function Call". +;;; +(defmacro function-to-describe (var error-name) + `(cond ((not (symbolp ,var)) + (,error-name "~S is not a symbol." ,var)) + ((macro-function ,var)) + ((fboundp ,var) + (if (listp (symbol-function ,var)) + ,var + (symbol-function ,var))) + (t + (,error-name "~S is not a function." ,var)))) + +(defcommand "Editor Describe Function Call" (p) + "Describe the most recently typed function name in the editor Lisp." + "Describe the most recently typed function name in the editor Lisp." + (declare (ignore p)) + (with-mark ((mark1 (current-point)) + (mark2 (current-point))) + (pre-command-parse-check mark1) + (unless (backward-up-list mark1) (editor-error)) + (form-offset (move-mark mark2 (mark-after mark1)) 1) + (with-input-from-region (s (region mark1 mark2)) + (in-lisp + (let* ((sym (read s)) + (fun (function-to-describe sym editor-error))) + (with-pop-up-display (*standard-output*) + (editor-describe-function fun sym))))))) + + +(defcommand "Editor Describe Symbol" (p) + "Describe the previous s-expression if it is a symbol in the editor Lisp." + "Describe the previous s-expression if it is a symbol in the editor Lisp." + (declare (ignore p)) + (with-mark ((mark1 (current-point)) + (mark2 (current-point))) + (mark-symbol mark1 mark2) + (with-input-from-region (s (region mark1 mark2)) + (in-lisp + (let ((thing (read s))) + (if (symbolp thing) + (with-pop-up-display (*standard-output*) + (describe thing)) + (if (and (consp thing) + (or (eq (car thing) 'quote) + (eq (car thing) 'function)) + (symbolp (cadr thing))) + (with-pop-up-display (*standard-output*) + (describe (cadr thing))) + (editor-error "~S is not a symbol, or 'symbol, or #'symbol." + thing)))))))) + +;;; MARK-SYMBOL moves mark1 and mark2 around the previous or current symbol. +;;; However, if the marks are immediately before the first constituent char +;;; of the symbol name, we use the next symbol since the marks probably +;;; correspond to the point, and Hemlock's cursor display makes it look like +;;; the point is within the symbol name. This also tries to ignore :prefix +;;; characters such as quotes, commas, etc. +;;; +(defun mark-symbol (mark1 mark2) + (pre-command-parse-check mark1) + (with-mark ((tmark1 mark1) + (tmark2 mark1)) + (cond ((and (form-offset tmark1 1) + (form-offset (move-mark tmark2 tmark1) -1) + (or (mark= mark1 tmark2) + (and (find-attribute tmark2 :lisp-syntax + #'(lambda (x) (not (eq x :prefix)))) + (mark= mark1 tmark2)))) + (form-offset mark2 1)) + (t + (form-offset mark1 -1) + (find-attribute mark1 :lisp-syntax + #'(lambda (x) (not (eq x :prefix)))) + (form-offset (move-mark mark2 mark1) 1))))) + + +(defcommand "Editor Describe" (p) + "Call Describe on a Lisp object. + Prompt for an expression which is evaluated to yield the object." + "Prompt for an object to describe." + (declare (ignore p)) + (in-lisp + (let* ((exp (prompt-for-expression + :prompt "Object: " + :help "Expression to evaluate to get object to describe.")) + (obj (eval exp))) + (with-pop-up-display (*standard-output*) + (describe obj))))) + + +(defcommand "Filter Region" (p) + "Apply a Lisp function to each line of the region. + An expression is prompted for which should evaluate to a Lisp function + from a string to a string. The function must neither modify its argument + nor modify the return value after it is returned." + "Call prompt for a function, then call Filter-Region with it and the region." + (declare (ignore p)) + (let* ((exp (prompt-for-expression + :prompt "Function: " + :help "Expression to evaluate to get function to use as filter.")) + (fun (in-lisp (eval exp))) + (region (current-region))) + (let* ((start (copy-mark (region-start region) :left-inserting)) + (end (copy-mark (region-end region) :left-inserting)) + (region (region start end)) + (undo-region (copy-region region))) + (filter-region fun region) + (make-region-undo :twiddle "Filter Region" region undo-region)))) Index: /branches/ide-1.0/ccl/hemlock/src/archive/lispeval.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/archive/lispeval.lisp (revision 6567) +++ /branches/ide-1.0/ccl/hemlock/src/archive/lispeval.lisp (revision 6567) @@ -0,0 +1,978 @@ +;;; -*- Package: Hemlock; Log: hemlock.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; This file contains code for sending requests to eval servers and the +;;; commands based on that code. +;;; +;;; Written by William Lott and Rob MacLachlan. +;;; + +(in-package :hemlock) + + +;;; The note structure holds everything we need to know about an +;;; operation. Not all operations use all the available fields. +;;; +(defstruct (note (:print-function %print-note)) + (state :unsent) ; :unsent, :pending, :running, :aborted or :dead. + server ; Server-Info for the server this op is on. + context ; Short string describing what this op is doing. + kind ; Either :eval, :compile, or :compile-file + buffer ; Buffer source came from. + region ; Region of request + package ; Package or NIL if none + text ; string containing request + input-file ; File to compile or where stuff was found + net-input-file ; Net version of above. + output-file ; Temporary output file for compiler fasl code. + net-output-file ; Net version of above + output-date ; Temp-file is created before calling compiler, + ; and this is its write date. + lap-file ; The lap file for compiles + error-file ; The file to dump errors into + load ; Load compiled file or not? + (errors 0) ; Count of compiler errors. + (warnings 0) ; Count of compiler warnings. + (notes 0)) ; Count of compiler notes. +;;; +(defun %print-note (note stream d) + (declare (ignore d)) + (format stream "#" + (note-context note) + (note-state note))) + + + + +;;;; Note support routines. + +;;; QUEUE-NOTE -- Internal. +;;; +;;; This queues note for server. SERVER-INFO-NOTES keeps notes in stack order, +;;; not queue order. We also link the note to the server and try to send it +;;; to the server. If we didn't send this note, we tell the user the server +;;; is busy and that we're queuing his note to be sent later. +;;; +(defun queue-note (note server) + (push note (server-info-notes server)) + (setf (note-server note) server) + (maybe-send-next-note server) + (when (eq (note-state note) :unsent) + (message "Server ~A busy, ~A queued." + (server-info-name server) + (note-context note)))) + +;;; MAYBE-SEND-NEXT-NOTE -- Internal. +;;; +;;; Loop over all notes in server. If we see any :pending or :running, then +;;; punt since we can't send one. Otherwise, by the end of the list, we may +;;; have found an :unsent one, and if we did, next will be the last :unsent +;;; note. Remember, SERVER-INFO-NOTES is kept in stack order not queue order. +;;; +(defun maybe-send-next-note (server) + (let ((busy nil) + (next nil)) + (dolist (note (server-info-notes server)) + (ecase (note-state note) + ((:pending :running) + (setf busy t) + (return)) + (:unsent + (setf next note)) + (:aborted :dead))) + (when (and (not busy) next) + (send-note next)))) + +(defun send-note (note) + (let* ((remote (hemlock.wire:make-remote-object note)) + (server (note-server note)) + (ts (server-info-slave-info server)) + (bg (server-info-background-info server)) + (wire (server-info-wire server))) + (setf (note-state note) :pending) + (message "Sending ~A." (note-context note)) + (case (note-kind note) + (:eval + (hemlock.wire:remote wire + (server-eval-text remote + (note-package note) + (note-text note) + (and ts (ts-data-stream ts))))) + (:compile + (hemlock.wire:remote wire + (server-compile-text remote + (note-package note) + (note-text note) + (note-input-file note) + (and ts (ts-data-stream ts)) + (and bg (ts-data-stream bg))))) + (:compile-file + (macrolet ((frob (x) + `(if (pathnamep ,x) + (namestring ,x) + ,x))) + (hemlock.wire:remote wire + (server-compile-file remote + (note-package note) + (frob (or (note-net-input-file note) + (note-input-file note))) + (frob (or (note-net-output-file note) + (note-output-file note))) + (frob (note-error-file note)) + (frob (note-lap-file note)) + (note-load note) + (and ts (ts-data-stream ts)) + (and bg (ts-data-stream bg)))))) + (t + (error "Unknown note kind ~S" (note-kind note)))) + (hemlock.wire:wire-force-output wire))) + + + +;;;; Server Callbacks. + +(defun operation-started (note) + (let ((note (hemlock.wire:remote-object-value note))) + (setf (note-state note) :running) + (message "The ~A started." (note-context note))) + (values)) + +(defun eval-form-error (message) + (editor-error message)) + +(defun lisp-error (note start end msg) + (declare (ignore start end)) + (let ((note (hemlock.wire:remote-object-value note))) + (loud-message "During ~A: ~A" + (note-context note) + msg)) + (values)) + +(defun compiler-error (note start end function severity) + (let* ((note (hemlock.wire:remote-object-value note)) + (server (note-server note)) + (line (mark-line + (buffer-end-mark + (server-info-background-buffer server)))) + (message (format nil "~:(~A~) ~@[in ~A ~]during ~A." + severity + function + (note-context note))) + (error (make-error-info :buffer (note-buffer note) + :message message + :line line))) + (message "~A" message) + (case severity + (:error (incf (note-errors note))) + (:warning (incf (note-warnings note))) + (:note (incf (note-notes note)))) + (let ((region (case (note-kind note) + (:compile + (note-region note)) + (:compile-file + (let ((buff (note-buffer note))) + (and buff (buffer-region buff)))) + (t + (error "Compiler error in ~S?" note))))) + (when region + (let* ((region-end (region-end region)) + (m1 (copy-mark (region-start region) :left-inserting)) + (m2 (copy-mark m1 :left-inserting))) + (when start + (character-offset m1 start) + (when (mark> m1 region-end) + (move-mark m1 region-end))) + (unless (and end (character-offset m2 end)) + (move-mark m2 region-end)) + + (setf (error-info-region error) + (region m1 m2))))) + + (vector-push-extend error (server-info-errors server))) + + (values)) + +(defun eval-text-result (note start end values) + (declare (ignore note start end)) + (message "=> ~{~#[~;~A~:;~A, ~]~}" values) + (values)) + +(defun operation-completed (note abortp) + (let* ((note (hemlock.wire:remote-object-value note)) + (server (note-server note)) + (file (note-output-file note))) + (hemlock.wire:forget-remote-translation note) + (setf (note-state note) :dead) + (setf (server-info-notes server) + (delete note (server-info-notes server) + :test #'eq)) + (setf (note-server note) nil) + + (if abortp + (loud-message "The ~A aborted." (note-context note)) + (let ((errors (note-errors note)) + (warnings (note-warnings note)) + (notes (note-notes note))) + (message "The ~A complete.~ + ~@[ ~D error~:P~]~@[ ~D warning~:P~]~@[ ~D note~:P~]" + (note-context note) + (and (plusp errors) errors) + (and (plusp warnings) warnings) + (and (plusp notes) notes)))) + + (let ((region (note-region note))) + (when (regionp region) + (delete-mark (region-start region)) + (delete-mark (region-end region)) + (setf (note-region note) nil))) + + (when (and (eq (note-kind note) + :compile-file) + (not (eq file t)) + file) + (if (> (file-write-date file) + (note-output-date note)) + (let ((new-name (make-pathname :type "fasl" + :defaults (note-input-file note)))) + (rename-file file new-name) + #+NILGB + (unix:unix-chmod (namestring new-name) #o644)) + (delete-file file))) + (maybe-send-next-note server)) + (values)) + + + +;;;; Stuff to send noise to the server. + +;;; EVAL-FORM-IN-SERVER -- Public. +;;; +(defun eval-form-in-server (server-info form + &optional (package (value current-package))) + "This evals form, a simple-string, in the server for server-info. Package + is the name of the package in which the server reads form, and it defaults + to the value of \"Current Package\". If package is nil, then the slave uses + the value of *package*. If server is busy with other requests, this signals + an editor-error to prevent commands using this from hanging. If the server + dies while evaluating form, then this signals an editor-error. This returns + a list of strings which are the printed representation of all the values + returned by form in the server." + (declare (simple-string form)) + (when (server-info-notes server-info) + (editor-error "Server ~S is currently busy. See \"List Operations\"." + (server-info-name server-info))) + (multiple-value-bind (values error) + (hemlock.wire:remote-value (server-info-wire server-info) + (server-eval-form package form)) + (when error + (editor-error "The server died before finishing")) + values)) + +;;; EVAL-FORM-IN-SERVER-1 -- Public. +;;; +;;; We use VALUES to squelch the second value of READ-FROM-STRING. +;;; +(defun eval-form-in-server-1 (server-info form + &optional (package (value current-package))) + "This calls EVAL-FORM-IN-SERVER and returns the result of READ'ing from + the first string EVAL-FORM-IN-SERVER returns." + (values (read-from-string + (car (eval-form-in-server server-info form package))))) + +(defun string-eval (string + &key + (server (get-current-eval-server)) + (package (value current-package)) + (context (format nil + "evaluation of ~S" + string))) + "Queues the evaluation of string on an eval server. String is a simple + string. If package is not supplied, the string is eval'ed in the slave's + current package." + (declare (simple-string string)) + (queue-note (make-note :kind :eval + :context context + :package package + :text string) + server) + (values)) + +(defun region-eval (region + &key + (server (get-current-eval-server)) + (package (value current-package)) + (context (region-context region "evaluation"))) + "Queues the evaluation of a region of text on an eval server. If package + is not supplied, the string is eval'ed in the slave's current package." + (let ((region (region (copy-mark (region-start region) :left-inserting) + (copy-mark (region-end region) :left-inserting)))) + (queue-note (make-note :kind :eval + :context context + :region region + :package package + :text (region-to-string region)) + server)) + (values)) + +(defun region-compile (region + &key + (server (get-current-eval-server)) + (package (value current-package))) + "Queues a compilation on an eval server. If package is not supplied, the + string is eval'ed in the slave's current package." + (let* ((region (region (copy-mark (region-start region) :left-inserting) + (copy-mark (region-end region) :left-inserting))) + (buf (line-buffer (mark-line (region-start region)))) + (pn (and buf (buffer-pathname buf))) + (defined-from (if pn (namestring pn) "unknown"))) + (queue-note (make-note :kind :compile + :context (region-context region "compilation") + :buffer (and region + (region-start region) + (mark-line (region-start region)) + (line-buffer (mark-line + (region-start region)))) + :region region + :package package + :text (region-to-string region) + :input-file defined-from) + server)) + (values)) + + + + +;;;; File compiling noise. + +(defhvar "Remote Compile File" + "When set (the default), this causes slave file compilations to assume the + compilation is occurring on a remote machine. This means the source file + must be world readable. Unsetting this, causes no file accesses to go + through the super root." + :value nil) + +;;; FILE-COMPILE compiles files in a client Lisp. Because of Unix file +;;; protection, one cannot write files over the net unless they are publicly +;;; writeable. To get around this, we create a temporary file that is +;;; publicly writeable for compiler output. This file is renamed to an +;;; ordinary output name if the compiler wrote anything to it, or deleted +;;; otherwise. No temporary file is created when output-file is not t. +;;; + +(defun file-compile (file + &key + buffer + (output-file t) + error-file + lap-file + load + (server (get-current-compile-server)) + (package (value current-package))) + "Compiles file in a client Lisp. When output-file is t, a temporary + output file is used that is publicly writeable in case the client is on + another machine. This file is renamed or deleted after compilation. + Setting \"Remote Compile File\" to nil, inhibits this. If package is not + supplied, the string is eval'ed in the slave's current package." + + (let* ((file (truename file)) ; in case of search-list in pathname. + (namestring (namestring file)) + (note (make-note + :kind :compile-file + :context (format nil "compilation of ~A" namestring) + :buffer buffer + :region nil + :package package + :input-file file + :output-file output-file + :error-file error-file + :lap-file lap-file + :load load))) + + (when (and (value remote-compile-file) + (eq output-file t)) + (multiple-value-bind (net-infile ofile net-ofile date) + (file-compile-temp-file file) + (setf (note-net-input-file note) net-infile) + (setf (note-output-file note) ofile) + (setf (note-net-output-file note) net-ofile) + (setf (note-output-date note) date))) + + (clear-server-errors server + #'(lambda (error) + (eq (error-info-buffer error) + buffer))) + (queue-note note server))) + +;;; FILE-COMPILE-TEMP-FILE creates a a temporary file that is publicly +;;; writable in the directory file is in and with a .fasl type. Four values +;;; are returned -- a pathname suitable for referencing file remotely, the +;;; pathname of the temporary file created, a pathname suitable for referencing +;;; the temporary file remotely, and the write date of the temporary file. +;;; + +#+NILGB +(defun file-compile-temp-file (file) + (let ((ofile (loop (let* ((sym (gensym)) + (f (merge-pathnames + (format nil "compile-file-~A.fasl" sym) + file))) + (unless (probe-file f) (return f)))))) + (multiple-value-bind (fd err) + (unix:unix-open (namestring ofile) + unix:o_creat #o666) + (unless fd + (editor-error "Couldn't create compiler temporary output file:~%~ + ~A" (unix:get-unix-error-msg err))) + (unix:unix-fchmod fd #o666) + (unix:unix-close fd)) + (let ((net-ofile (pathname-for-remote-access ofile))) + (values (make-pathname :directory (pathname-directory net-ofile) + :defaults file) + ofile + net-ofile + (file-write-date ofile))))) + +(defun pathname-for-remote-access (file) + (let* ((machine (machine-instance)) + (usable-name (nstring-downcase + (the simple-string + (subseq machine 0 (position #\. machine)))))) + (declare (simple-string machine usable-name)) + (make-pathname :directory (concatenate 'simple-string + "/../" + usable-name + (directory-namestring file)) + :defaults file))) + +;;; REGION-CONTEXT -- internal +;;; +;;; Return a string which describes the code in a region. Thing is the +;;; thing being done to the region. "compilation" or "evaluation"... + +(defun region-context (region thing) + (declare (simple-string thing)) + (pre-command-parse-check (region-start region)) + (let ((start (region-start region))) + (with-mark ((m1 start)) + (unless (start-defun-p m1) + (top-level-offset m1 1)) + (with-mark ((m2 m1)) + (mark-after m2) + (form-offset m2 2) + (format nil + "~A of ~S" + thing + (if (eq (mark-line m1) (mark-line m2)) + (region-to-string (region m1 m2)) + (concatenate 'simple-string + (line-string (mark-line m1)) + "..."))))))) + + + +;;;; Commands (Gosh, wow gee!) + +(defcommand "Editor Server Name" (p) + "Echos the editor server's name which can be supplied with the -slave switch + to connect to a designated editor." + "Echos the editor server's name which can be supplied with the -slave switch + to connect to a designated editor." + (declare (ignore p)) + (if *editor-name* + (message "This editor is named ~S." *editor-name*) + (message "This editor is not currently named."))) + +(defcommand "Set Buffer Package" (p) + "Set the package to be used by Lisp evaluation and compilation commands + while in this buffer. When in a slave's interactive buffers, do NOT + set the editor's package variable, but changed the slave's *package*." + "Prompt for a package to make into a buffer-local variable current-package." + (declare (ignore p)) + (let* ((name (string (prompt-for-expression + :prompt "Package name: " + :help "Name of package to associate with this buffer."))) + (buffer (current-buffer)) + (info (value current-eval-server))) + (cond ((and info + (or (eq (server-info-slave-buffer info) buffer) + (eq (server-info-background-buffer info) buffer))) + (hemlock.wire:remote (server-info-wire info) + (server-set-package name)) + (hemlock.wire:wire-force-output (server-info-wire info))) + ((eq buffer *selected-eval-buffer*) + (setf *package* (maybe-make-package name))) + (t + (defhvar "Current Package" + "The package used for evaluation of Lisp in this buffer." + :buffer buffer :value name))) + (when (buffer-modeline-field-p buffer :package) + (dolist (w (buffer-windows buffer)) + (update-modeline-field buffer w :package))))) + +(defcommand "Current Compile Server" (p) + "Echos the current compile server's name. With prefix argument, + shows global one. Does not signal an error or ask about creating a slave." + "Echos the current compile server's name. With prefix argument, + shows global one." + (let ((info (if p + (variable-value 'current-compile-server :global) + (value current-compile-server)))) + (if info + (message "~A" (server-info-name info)) + (message "No ~:[current~;global~] compile server." p)))) + +(defcommand "Set Compile Server" (p) + "Specifies the name of the server used globally for file compilation requests." + "Call select-current-compile-server." + (declare (ignore p)) + (hlet ((ask-about-old-servers t)) + (setf (variable-value 'current-compile-server :global) + (maybe-create-server)))) + +(defcommand "Set Buffer Compile Server" (p) + "Specifies the name of the server used for file compilation requests in + the current buffer." + "Call select-current-compile-server after making a buffer local variable." + (declare (ignore p)) + (hlet ((ask-about-old-servers t)) + (defhvar "Current Compile Server" + "The Server-Info object for the server currently used for compilation requests." + :buffer (current-buffer) + :value (maybe-create-server)))) + +(defcommand "Current Eval Server" (p) + "Echos the current eval server's name. With prefix argument, shows + global one. Does not signal an error or ask about creating a slave." + "Echos the current eval server's name. With prefix argument, shows + global one. Does not signal an error or ask about creating a slave." + (let ((info (if p + (variable-value 'current-eval-server :global) + (value current-eval-server)))) + (if info + (message "~A" (server-info-name info)) + (message "No ~:[current~;global~] eval server." p)))) + +(defcommand "Set Eval Server" (p) + "Specifies the name of the server used globally for evaluation and + compilation requests." + "Call select-current-server." + (declare (ignore p)) + (hlet ((ask-about-old-servers t)) + (setf (variable-value 'current-eval-server :global) + (maybe-create-server)))) + +(defcommand "Set Buffer Eval Server" (p) + "Specifies the name of the server used for evaluation and compilation + requests in the current buffer." + "Call select-current-server after making a buffer local variable." + (declare (ignore p)) + (hlet ((ask-about-old-servers t)) + (defhvar "Current Eval Server" + "The Server-Info for the eval server used in this buffer." + :buffer (current-buffer) + :value (maybe-create-server)))) + +(defcommand "Evaluate Defun" (p) + "Evaluates the current or next top-level form. + If the current region is active, then evaluate it." + "Evaluates the current or next top-level form." + (declare (ignore p)) + (if (region-active-p) + (evaluate-region-command nil) + (region-eval (defun-region (current-point))))) + +(defcommand "Re-evaluate Defvar" (p) + "Evaluate the current or next top-level form if it is a DEFVAR. Treat the + form as if the variable is not bound." + "Evaluate the current or next top-level form if it is a DEFVAR. Treat the + form as if the variable is not bound." + (declare (ignore p)) + (let* ((form (defun-region (current-point))) + (start (region-start form))) + (with-mark ((var-start start) + (var-end start)) + (mark-after var-start) + (form-offset var-start 1) + (form-offset (move-mark var-end var-start) 1) + (let ((exp (concatenate 'simple-string + "(makunbound '" + (region-to-string (region var-start var-end)) + ")"))) + (eval-form-in-server (get-current-eval-server) exp))) + (region-eval form))) + +;;; We use Prin1-To-String in the client so that the expansion gets pretty +;;; printed. Since the expansion can contain unreadable stuff, we can't expect +;;; to be able to read that string back in the editor. We shove the region +;;; at the client Lisp as a string, so it can read from the string with the +;;; right package environment. +;;; + +(defcommand "Macroexpand Expression" (p) + "Show the macroexpansion of the current expression in the null environment. + With an argument, use MACROEXPAND instead of MACROEXPAND-1." + "Show the macroexpansion of the current expression in the null environment. + With an argument, use MACROEXPAND instead of MACROEXPAND-1." + (let ((point (current-point))) + (with-mark ((start point)) + (pre-command-parse-check start) + (with-mark ((end start)) + (unless (form-offset end 1) (editor-error)) + (with-pop-up-display (s) + (write-string + (eval-form-in-server-1 + (get-current-eval-server) + (format nil "(prin1-to-string (~S (read-from-string ~S)))" + (if p 'macroexpand 'macroexpand-1) + (region-to-string (region start end)))) + s)))))) + +(defcommand "Evaluate Expression" (p) + "Prompt for an expression to evaluate." + "Prompt for an expression to evaluate." + (declare (ignore p)) + (let ((exp (prompt-for-string + :prompt "Eval: " + :help "Expression to evaluate."))) + (message "=> ~{~#[~;~A~:;~A, ~]~}" + (eval-form-in-server (get-current-eval-server) exp)))) + +(defcommand "Compile Defun" (p) + "Compiles the current or next top-level form. + First the form is evaluated, then the result of this evaluation + is passed to compile. If the current region is active, compile + the region." + "Evaluates the current or next top-level form." + (declare (ignore p)) + (if (region-active-p) + (compile-region-command nil) + (region-compile (defun-region (current-point))))) + +(defcommand "Compile Region" (p) + "Compiles lisp forms between the point and the mark." + "Compiles lisp forms between the point and the mark." + (declare (ignore p)) + (region-compile (current-region))) + +(defcommand "Evaluate Region" (p) + "Evaluates lisp forms between the point and the mark." + "Evaluates lisp forms between the point and the mark." + (declare (ignore p)) + (region-eval (current-region))) + +(defcommand "Evaluate Buffer" (p) + "Evaluates the text in the current buffer." + "Evaluates the text in the current buffer redirecting *Standard-Output* to + the echo area. The prefix argument is ignored." + (declare (ignore p)) + (let ((b (current-buffer))) + (region-eval (buffer-region b) + :context (format nil + "evaluation of buffer ``~A''" + (buffer-name b))))) + +(defcommand "Load File" (p) + "Prompt for a file to load into the current eval server." + "Prompt for a file to load into the current eval server." + (declare (ignore p)) + (let ((name (truename (prompt-for-file + :default + (or (value load-pathname-defaults) + (buffer-default-pathname (current-buffer))) + :prompt "File to load: " + :help "The name of the file to load")))) + (setv load-pathname-defaults name) + (string-eval (format nil "(load ~S)" + (namestring + (if (value remote-compile-file) + (pathname-for-remote-access name) + name)))))) + +(defcommand "Compile File" (p) + "Prompts for file to compile. Does not compare source and binary write + dates. Does not check any buffer for that file for whether the buffer + needs to be saved." + "Prompts for file to compile." + (declare (ignore p)) + (let ((pn (prompt-for-file :default + (buffer-default-pathname (current-buffer)) + :prompt "File to compile: "))) + (file-compile pn))) + +(defhvar "Compile Buffer File Confirm" + "When set, \"Compile Buffer File\" prompts before doing anything." + :value t) + +(defcommand "Compile Buffer File" (p) + "Compile the file in the current buffer if its associated binary file + (of type .fasl) is older than the source or doesn't exist. When the + binary file is up to date, the user is asked if the source should be + compiled anyway. When the prefix argument is supplied, compile the + file without checking the binary file. When \"Compile Buffer File + Confirm\" is set, this command will ask for confirmation when it + otherwise would not." + "Compile the file in the current buffer if the fasl file isn't up to date. + When p, always do it." + (let* ((buf (current-buffer)) + (pn (buffer-pathname buf))) + (unless pn (editor-error "Buffer has no associated pathname.")) + (cond ((buffer-modified buf) + (when (or (not (value compile-buffer-file-confirm)) + (prompt-for-y-or-n + :default t :default-string "Y" + :prompt (list "Save and compile file ~A? " + (namestring pn)))) + (write-buffer-file buf pn) + (file-compile pn :buffer buf))) + ((older-or-non-existent-fasl-p pn p) + (when (or (not (value compile-buffer-file-confirm)) + (prompt-for-y-or-n + :default t :default-string "Y" + :prompt (list "Compile file ~A? " (namestring pn)))) + (file-compile pn :buffer buf))) + ((or p + (prompt-for-y-or-n + :default t :default-string "Y" + :prompt + "Fasl file up to date, compile source anyway? ")) + (file-compile pn :buffer buf))))) + +(defcommand "Compile Group" (p) + "Compile each file in the current group which needs it. + If a file has type LISP and there is a curresponding file with type + FASL which has been written less recently (or it doesn't exit), then + the file is compiled, with error output directed to the \"Compiler Warnings\" + buffer. If a prefix argument is provided, then all the files are compiled. + All modified files are saved beforehand." + "Do a Compile-File in each file in the current group that seems to need it." + (save-all-files-command ()) + (unless *active-file-group* (editor-error "No active file group.")) + (dolist (file *active-file-group*) + (when (string-equal (pathname-type file) "lisp") + (let ((tn (probe-file file))) + (cond ((not tn) + (message "File ~A not found." (namestring file))) + ((older-or-non-existent-fasl-p tn p) + (file-compile tn))))))) + + + +;;;; Error hacking stuff. + +(defcommand "Flush Compiler Error Information" (p) + "Flushes all infomation about errors encountered while compiling using the + current server" + "Flushes all infomation about errors encountered while compiling using the + current server" + (declare (ignore p)) + (clear-server-errors (get-current-compile-server t))) + +(defcommand "Next Compiler Error" (p) + "Move to the next compiler error for the current server. If an argument is + given, advance that many errors." + "Move to the next compiler error for the current server. If an argument is + given, advance that many errors." + (let* ((server (get-current-compile-server t)) + (errors (server-info-errors server)) + (fp (fill-pointer errors))) + (when (zerop fp) + (editor-error "There are no compiler errors.")) + (let* ((old-index (server-info-error-index server)) + (new-index (+ (or old-index -1) (or p 1)))) + (when (< new-index 0) + (if old-index + (editor-error "Can't back up ~R, only at the ~:R compiler error." + (- p) (1+ old-index)) + (editor-error "Not even at the first compiler error."))) + (when (>= new-index fp) + (if (= (1+ (or old-index -1)) fp) + (editor-error "No more compiler errors.") + (editor-error "Only ~R remaining compiler error~:P." + (- fp old-index 1)))) + (setf (server-info-error-index server) new-index) + ;; Display the silly error. + (let ((error (aref errors new-index))) + (let ((region (error-info-region error))) + (if region + (let* ((start (region-start region)) + (buffer (line-buffer (mark-line start)))) + (change-to-buffer buffer) + (move-mark (buffer-point buffer) start)) + (message "Hmm, no region for this error."))) + (let* ((line (error-info-line error)) + (buffer (line-buffer line))) + (if (and line (bufferp buffer)) + (let ((mark (mark line 0))) + (unless (buffer-windows buffer) + (let ((window (find-if-not + #'(lambda (window) + (or (eq window (current-window)) + (eq window *echo-area-window*))) + *window-list*))) + (if window + (setf (window-buffer window) buffer) + (make-window mark)))) + (move-mark (buffer-point buffer) mark) + (dolist (window (buffer-windows buffer)) + (move-mark (window-display-start window) mark) + (move-mark (window-point window) mark)) + (delete-mark mark)) + (message "Hmm, no line for this error."))))))) + +(defcommand "Previous Compiler Error" (p) + "Move to the previous compiler error. If an argument is given, move back + that many errors." + "Move to the previous compiler error. If an argument is given, move back + that many errors." + (next-compiler-error-command (- (or p 1)))) + + + + +;;;; Operation management commands: + +(defcommand "Abort Operations" (p) + "Abort all operations on current eval server connection." + "Abort all operations on current eval server connection." + (declare (ignore p)) + (let* ((server (get-current-eval-server)) + (wire (server-info-wire server))) + ;; Tell the slave to abort the current operation and to ignore any further + ;; operations. + (dolist (note (server-info-notes server)) + (setf (note-state note) :aborted)) + #+NILGB (ext:send-character-out-of-band (hemlock.wire:wire-fd wire) #\N) + (hemlock.wire:remote-value wire (server-accept-operations)) + ;; Synch'ing with server here, causes any operations queued at the socket or + ;; in the server to be ignored, and the last thing evaluated is an + ;; instruction to go on accepting operations. + (hemlock.wire:wire-force-output wire) + (dolist (note (server-info-notes server)) + (when (eq (note-state note) :pending) + ;; The HEMLOCK.WIRE:REMOTE-VALUE call should have allowed a handshake to + ;; tell the editor anything :pending was aborted. + (error "Operation ~S is still around after we aborted it?" note))) + ;; Forget anything queued in the editor. + (setf (server-info-notes server) nil))) + +(defcommand "List Operations" (p) + "List all eval server operations which have not yet completed." + "List all eval server operations which have not yet completed." + (declare (ignore p)) + (let ((notes nil)) + ;; Collect all notes, reversing them since they act like a queue but + ;; are not in queue order. + (do-strings (str val *server-names*) + (declare (ignore str)) + (setq notes (nconc notes (reverse (server-info-notes val))))) + (if notes + (with-pop-up-display (s) + (dolist (note notes) + (format s "~@(~8A~) ~A on ~A.~%" + (note-state note) + (note-context note) + (server-info-name (note-server note))))) + (message "No uncompleted operations."))) + (values)) + + + +;;;; Describing in the client lisp. + +;;; "Describe Function Call" gets the function name from the current form +;;; as a string. This string is used as the argument to a call to +;;; DESCRIBE-FUNCTION-CALL-AUX which is eval'ed in the client lisp. The +;;; auxiliary function's name is qualified since it is read in the client +;;; Lisp with *package* bound to the buffer's package. The result comes +;;; back as a list of strings, so we read the first string to get out the +;;; string value returned by DESCRIBE-FUNCTION-CALL-AUX in the client Lisp. +;;; +(defcommand "Describe Function Call" (p) + "Describe the current function call." + "Describe the current function call." + (let ((info (value current-eval-server))) + (cond + ((not info) + (message "Describing from the editor Lisp ...") + (editor-describe-function-call-command p)) + (t + (with-mark ((mark1 (current-point)) + (mark2 (current-point))) + (pre-command-parse-check mark1) + (unless (backward-up-list mark1) (editor-error)) + (form-offset (move-mark mark2 (mark-after mark1)) 1) + (let* ((package (value current-package)) + (package-exists + (eval-form-in-server-1 + info + (format nil + "(if (find-package ~S) t (package-name *package*))" + package) + nil))) + (unless (eq package-exists t) + (message "Using package ~S in ~A since ~ + ~:[there is no current package~;~:*~S does not exist~]." + package-exists (server-info-name info) package)) + (with-pop-up-display (s) + (write-string (eval-form-in-server-1 + info + (format nil "(hemlock::describe-function-call-aux ~S)" + (region-to-string (region mark1 mark2))) + (if (eq package-exists t) package nil)) + s)))))))) + +;;; DESCRIBE-FUNCTION-CALL-AUX is always evaluated in a client Lisp to some +;;; editor, relying on the fact that the cores have the same functions. String +;;; is the name of a function that is read (in the client Lisp). The result is +;;; a string of all the output from EDITOR-DESCRIBE-FUNCTION. +;;; +(defun describe-function-call-aux (string) + (let* ((sym (read-from-string string)) + (fun (function-to-describe sym error))) + (with-output-to-string (*standard-output*) + (editor-describe-function fun sym)))) + +;;; "Describe Symbol" gets the symbol name and quotes it as the argument to a +;;; call to DESCRIBE-SYMBOL-AUX which is eval'ed in the client lisp. The +;;; auxiliary function's name is qualified since it is read in the client Lisp +;;; with *package* bound to the buffer's package. The result comes back as a +;;; list of strings, so we read the first string to get out the string value +;;; returned by DESCRIBE-SYMBOL-AUX in the client Lisp. +;;; + +(defcommand "Describe Symbol" (p) + "Describe the previous s-expression if it is a symbol." + "Describe the previous s-expression if it is a symbol." + (declare (ignore p)) + (let ((info (value current-eval-server))) + (cond + ((not info) + (message "Describing from the editor Lisp ...") + (editor-describe-symbol-command nil)) + (t + (with-mark ((mark1 (current-point)) + (mark2 (current-point))) + (mark-symbol mark1 mark2) + (with-pop-up-display (s) + (write-string (eval-form-in-server-1 + info + (format nil "(hemlock::describe-symbol-aux '~A)" + (region-to-string (region mark1 mark2)))) + s))))))) + +(defun describe-symbol-aux (thing) + (with-output-to-string (*standard-output*) + (describe (if (and (consp thing) + (or (eq (car thing) 'quote) + (eq (car thing) 'function)) + (symbolp (cadr thing))) + (cadr thing) + thing)))) Index: /branches/ide-1.0/ccl/hemlock/src/archive/mh.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/archive/mh.lisp (revision 6567) +++ /branches/ide-1.0/ccl/hemlock/src/archive/mh.lisp (revision 6567) @@ -0,0 +1,3180 @@ +;;; -*- Package: Hemlock; Log: hemlock.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; This is a mailer interface to MH. +;;; +;;; Written by Bill Chiles. +;;; + +(in-package :hemlock) + + + + +;;;; General stuff. + +(defvar *new-mail-buffer* nil) + +(defvar *mh-utility-bit-bucket* (make-broadcast-stream)) + + +(defattribute "Digit" + "This is just a (mod 2) attribute for base 10 digit characters.") +;;; +(dotimes (i 10) + (setf (character-attribute :digit (digit-char i)) 1)) + + +(defmacro number-string (number) + `(let ((*print-base* 10)) + (prin1-to-string ,number))) + + +(defmacro do-headers-buffers ((buffer-var folder &optional hinfo-var) + &rest forms) + "The Forms are evaluated with Buffer-Var bound to each buffer containing + headers lines for folder. Optionally Hinfo-Var is bound to the + headers-information structure." + (let ((folder-var (gensym)) + (hinfo (gensym))) + `(let ((,folder-var ,folder)) + (declare (simple-string ,folder-var)) + (dolist (,buffer-var *buffer-list*) + (when (hemlock-bound-p 'headers-information :buffer ,buffer-var) + (let ((,hinfo (variable-value 'headers-information + :buffer ,buffer-var))) + (when (string= (the simple-string (headers-info-folder ,hinfo)) + ,folder-var) + ,@(if hinfo-var + `((let ((,hinfo-var ,hinfo)) + ,@forms)) + forms)))))))) + +(defmacro do-headers-lines ((hbuffer &key line-var mark-var) &rest forms) + "Forms are evaluated for each non-blank line. When supplied Line-Var and + Mark-Var are to the line and a :left-inserting mark at the beginning of the + line. This works with DELETE-HEADERS-BUFFER-LINE, but one should be careful + using this to modify the hbuffer." + (let ((line-var (or line-var (gensym))) + (mark-var (or mark-var (gensym))) + (id (gensym))) + `(with-mark ((,mark-var (buffer-point ,hbuffer) :left-inserting)) + (buffer-start ,mark-var) + (loop + (let* ((,line-var (mark-line ,mark-var)) + (,id (line-message-id ,line-var))) + (unless (blank-line-p ,line-var) + ,@forms) + (if (or (not (eq ,line-var (mark-line ,mark-var))) + (string/= ,id (line-message-id ,line-var))) + (line-start ,mark-var) + (unless (line-offset ,mark-var 1 0) (return)))))))) + +(defmacro with-headers-mark ((mark-var hbuffer msg) &rest forms) + "Forms are executed with Mark-Var bound to a :left-inserting mark at the + beginning of the headers line representing msg. If no such line exists, + no execution occurs." + (let ((line (gensym))) + `(do-headers-lines (,hbuffer :line-var ,line :mark-var ,mark-var) + (when (string= (the simple-string (line-message-id ,line)) + (the simple-string ,msg)) + ,@forms + (return))))) + + + + +;;;; Headers Mode. + +(defmode "Headers" :major-p t) + +(defhvar "Headers Information" + "This holds the information about the current headers buffer." + :value nil) + +(defstruct (headers-info (:print-function print-headers-info)) + buffer ;Buffer for these headers. + folder ;String name of folder with leading MH "+". + msg-seq ;MH sequence of messages in buffer. + msg-strings ;List of strings representing msg-seq. + other-msg-bufs ;List of message buffers referencing this headers buffer. + draft-bufs ;List of draft buffers referencing this headers buffer. + msg-buffer) + +(defun print-headers-info (obj str n) + (declare (ignore n)) + (format str "#" (headers-info-folder obj))) + +(defmacro line-message-deleted (line) + `(getf (line-plist ,line) 'mh-msg-deleted)) + +(defmacro line-message-id (line) + `(getf (line-plist ,line) 'mh-msg-id)) + +(defun headers-current-message (hinfo) + (let* ((point (buffer-point (headers-info-buffer hinfo))) + (line (mark-line point))) + (unless (blank-line-p line) + (values (line-message-id line) + (copy-mark point))))) + +(defcommand "Message Headers" (p) + "Prompts for a folder and messages, displaying headers in a buffer in the + current window. With an argument, prompt for a pick expression." + "Show some headers." + (let ((folder (prompt-for-folder))) + (new-message-headers + folder + (prompt-for-message :prompt (if p + "MH messages to pick from: " + "MH messages: ") + :folder folder + :messages "all") + p))) + +(defcommand "Pick Headers" (p) + "Further narrow the selection of this folders headers. + Prompts for a pick expression to pick over the headers in the current + buffer. Entering an empty expression displays all the headers for that + folder." + "Prompts for a pick expression to pick over the headers in the current + buffer." + (declare (ignore p)) + (let ((hinfo (value headers-information))) + (unless hinfo + (editor-error "Pick Headers only works in a headers buffer.")) + (pick-message-headers hinfo))) + +;;; PICK-MESSAGE-HEADERS picks messages from info's messages based on an +;;; expression provided by the user. If the expression is empty, we do +;;; headers on all the messages in folder. The buffer's name is changed to +;;; reflect the messages picked over and the expression used. +;;; +(defun pick-message-headers (hinfo) + (let ((folder (headers-info-folder hinfo)) + (msgs (headers-info-msg-strings hinfo))) + (multiple-value-bind (pick user-pick) + (prompt-for-pick-expression) + (let* ((hbuffer (headers-info-buffer hinfo)) + (new-mail-buf-p (eq hbuffer *new-mail-buffer*)) + (region (cond (pick + (message-headers-to-region + folder (pick-messages folder msgs pick))) + (new-mail-buf-p + (maybe-get-new-mail-msg-hdrs folder)) + (t (message-headers-to-region folder + (list "all")))))) + (with-writable-buffer (hbuffer) + (revamp-headers-buffer hbuffer hinfo) + (when region (insert-message-headers hbuffer hinfo region))) + (setf (buffer-modified hbuffer) nil) + (buffer-start (buffer-point hbuffer)) + (setf (buffer-name hbuffer) + (cond (pick (format nil "Headers ~A ~A ~A" folder msgs user-pick)) + (new-mail-buf-p (format nil "Unseen Headers ~A" folder)) + (t (format nil "Headers ~A (all)" folder)))))))) + +;;; NEW-MESSAGE-HEADERS picks over msgs if pickp is non-nil, or it just scans +;;; msgs. It is important to pick and get the message headers region before +;;; making the buffer and info structures since PICK-MESSAGES and +;;; MESSAGE-HEADERS-TO-REGION will call EDITOR-ERROR if they fail. The buffer +;;; name is chosen based on folder, msgs, and an optional pick expression. +;;; +(defun new-message-headers (folder msgs &optional pickp) + (multiple-value-bind (pick-exp user-pick) + (if pickp (prompt-for-pick-expression)) + (let* ((pick (if pick-exp (pick-messages folder msgs pick-exp))) + (region (message-headers-to-region folder (or pick msgs))) + (hbuffer (maybe-make-mh-buffer (format nil "Headers ~A ~A~:[~; ~S~]" + folder msgs pick user-pick) + :headers)) + (hinfo (make-headers-info :buffer hbuffer :folder folder))) + (insert-message-headers hbuffer hinfo region) + (defhvar "Headers Information" + "This holds the information about the current headers buffer." + :value hinfo :buffer hbuffer) + (setf (buffer-modified hbuffer) nil) + (setf (buffer-writable hbuffer) nil) + (buffer-start (buffer-point hbuffer)) + (change-to-buffer hbuffer)))) + +(defhvar "MH Scan Line Form" + "This is a pathname of a file containing an MH format expression for headers + lines." + :value (pathname "library:mh-scan")) + +;;; MESSAGE-HEADERS-TO-REGION uses the MH "scan" utility output headers into +;;; buffer for folder and msgs. +;;; +;;; (value fill-column) should really be done as if the buffer were current, +;;; but Hemlock doesn't let you do this without the buffer being current. +;;; +(defun message-headers-to-region (folder msgs &optional width) + (let ((region (make-empty-region))) + (with-output-to-mark (*standard-output* (region-end region) :full) + (mh "scan" + `(,folder ,@msgs + "-form" ,(namestring (truename (value mh-scan-line-form))) + "-width" ,(number-string (or width (value fill-column))) + "-noheader"))) + region)) + +(defun insert-message-headers (hbuffer hinfo region) + (ninsert-region (buffer-point hbuffer) region) + (let ((seq (set-message-headers-ids hbuffer :return-seq))) + (setf (headers-info-msg-seq hinfo) seq) + (setf (headers-info-msg-strings hinfo) (mh-sequence-strings seq))) + (when (value virtual-message-deletion) + (note-deleted-headers hbuffer + (mh-sequence-list (headers-info-folder hinfo) + "hemlockdeleted")))) + +(defun set-message-headers-ids (hbuffer &optional return-seq) + (let ((msgs nil)) + (do-headers-lines (hbuffer :line-var line) + (let* ((line-str (line-string line)) + (num (parse-integer line-str :junk-allowed t))) + (declare (simple-string line-str)) + (unless num + (editor-error "MH scan lines must contain the message id as the ~ + first thing on the line for the Hemlock interface.")) + (setf (line-message-id line) (number-string num)) + (when return-seq (setf msgs (mh-sequence-insert num msgs))))) + msgs)) + +(defun note-deleted-headers (hbuffer deleted-seq) + (when deleted-seq + (do-headers-lines (hbuffer :line-var line :mark-var hmark) + (if (mh-sequence-member-p (line-message-id line) deleted-seq) + (note-deleted-message-at-mark hmark) + (setf (line-message-deleted line) nil))))) + +;;; PICK-MESSAGES -- Internal Interface. +;;; +;;; This takes a folder (with a + in front of the name), messages to pick +;;; over, and an MH pick expression (in the form returned by +;;; PROMPT-FOR-PICK-EXPRESSION). Sequence is an MH sequence to set to exactly +;;; those messages chosen by the pick when zerop is non-nil; when zerop is nil, +;;; pick adds the messages to the sequence along with whatever messages were +;;; already in the sequence. This returns a list of message specifications. +;;; +(defun pick-messages (folder msgs expression &optional sequence (zerop t)) + (let* ((temp (with-output-to-string (*standard-output*) + (unless + ;; If someone bound *signal-mh-errors* to nil around this + ;; function, MH pick outputs bogus messages (for example, + ;; "0"), and MH would return without calling EDITOR-ERROR. + (mh "pick" `(,folder + ,@msgs + ,@(if sequence `("-sequence" ,sequence)) + ,@(if zerop '("-zero")) + "-list" ; -list must follow -sequence. + ,@expression)) + (return-from pick-messages nil)))) + (len (length temp)) + (start 0) + (result nil)) + (declare (simple-string temp)) + (loop + (let ((end (position #\newline temp :start start :test #'char=))) + (cond ((not end) + (return (nreverse (cons (subseq temp start) result)))) + ((= start end) + (return (nreverse result))) + (t + (push (subseq temp start end) result) + (when (>= (setf start (1+ end)) len) + (return (nreverse result))))))))) + + +(defcommand "Delete Headers Buffer and Message Buffers" (p &optional buffer) + "Prompts for a headers buffer to delete along with its associated message + buffers. Any associated draft buffers are left alone, but their associated + message buffers will be deleted." + "Deletes the current headers buffer and its associated message buffers." + (declare (ignore p)) + (let* ((default (cond ((value headers-information) (current-buffer)) + ((value message-information) (value headers-buffer)))) + (buffer (or buffer + (prompt-for-buffer :default default + :default-string + (if default (buffer-name default)))))) + (unless (hemlock-bound-p 'headers-information :buffer buffer) + (editor-error "Not a headers buffer -- ~A" (buffer-name buffer))) + (let* ((hinfo (variable-value 'headers-information :buffer buffer)) + ;; Copy list since buffer cleanup hook is destructive. + (other-bufs (copy-list (headers-info-other-msg-bufs hinfo))) + (msg-buf (headers-info-msg-buffer hinfo))) + (when msg-buf (delete-buffer-if-possible msg-buf)) + (dolist (b other-bufs) (delete-buffer-if-possible b)) + (delete-buffer-if-possible (headers-info-buffer hinfo))))) + +(defhvar "Expunge Messages Confirm" + "When set (the default), \"Expunge Messages\" and \"Quit Headers\" will ask + for confirmation before expunging messages and packing the folder's message + id's." + :value t) + +(defhvar "Temporary Draft Folder" + "This is the folder name where MH fcc: messages are kept that are intended + to be deleted and expunged when messages are expunged for any other + folder -- \"Expunge Messages\" and \"Quit Headers\"." + :value nil) + +;;; "Quit Headers" doesn't expunge or compact unless there is a deleted +;;; sequence. This collapses other headers buffers into the same folder +;;; differently than "Expunge Messages" since the latter assumes there will +;;; always be one remaining headers buffer. This command folds all headers +;;; buffers into the folder that are not the current buffer or the new mail +;;; buffer into one buffer. When the current buffer is the new mail buffer +;;; we do not check for more unseen headers since we are about to delete +;;; the buffer anyway. The other headers buffers must be deleted before +;;; making the new one due to aliasing the buffer structure and +;;; MAYBE-MAKE-MH-BUFFER. +;;; +(defcommand "Quit Headers" (p) + "Quit headers buffer possibly expunging deleted messages. + This affects the current headers buffer. When there are deleted messages + the user is asked for confirmation on expunging the messages and packing the + folder's message id's. Then the buffer and all its associated message + buffers are deleted. Setting \"Quit Headers Confirm\" to nil inhibits + prompting. When \"Temporary Draft Folder\" is bound, this folder's messages + are deleted and expunged." + "This affects the current headers buffer. When there are deleted messages + the user is asked for confirmation on expunging the messages and packing + the folder. Then the buffer and all its associated message buffers are + deleted." + (declare (ignore p)) + (let* ((hinfo (value headers-information)) + (minfo (value message-information)) + (hdrs-buf (cond (hinfo (current-buffer)) + (minfo (value headers-buffer))))) + (unless hdrs-buf + (editor-error "Not in or associated with any headers buffer.")) + (let* ((folder (cond (hinfo (headers-info-folder hinfo)) + (minfo (message-info-folder minfo)))) + (deleted-seq (mh-sequence-list folder "hemlockdeleted"))) + (when (and deleted-seq + (or (not (value expunge-messages-confirm)) + (prompt-for-y-or-n + :prompt (list "Expunge messages and pack folder ~A? " + folder) + :default t + :default-string "Y"))) + (message "Deleting messages ...") + (mh "rmm" (list folder "hemlockdeleted")) + (let ((*standard-output* *mh-utility-bit-bucket*)) + (message "Compacting folder ...") + (mh "folder" (list folder "-fast" "-pack"))) + (message "Maintaining consistency ...") + (let (hbufs) + (declare (list hbufs)) + (do-headers-buffers (b folder) + (unless (or (eq b hdrs-buf) (eq b *new-mail-buffer*)) + (push b hbufs))) + (dolist (b hbufs) + (delete-headers-buffer-and-message-buffers-command nil b)) + (when hbufs + (new-message-headers folder (list "all")))) + (expunge-messages-fix-draft-buffers folder) + (unless (eq hdrs-buf *new-mail-buffer*) + (expunge-messages-fix-unseen-headers folder)) + (delete-and-expunge-temp-drafts))) + (delete-headers-buffer-and-message-buffers-command nil hdrs-buf))) + +;;; DELETE-AND-EXPUNGE-TEMP-DRAFTS deletes all the messages in the +;;; temporary draft folder if there is one defined. Any headers buffers +;;; into this folder are deleted with their message buffers. We have to +;;; create a list of buffers to delete since buffer deletion destructively +;;; modifies the same list DO-HEADERS-BUFFERS uses. "rmm" is run without +;;; error reporting since it signals an error if there are no messages to +;;; delete. This function must return; for example, "Quit Headers" would +;;; not complete successfully if this ended up calling EDITOR-ERROR. +;;; +(defun delete-and-expunge-temp-drafts () + (let ((temp-draft-folder (value temporary-draft-folder))) + (when temp-draft-folder + (setf temp-draft-folder (coerce-folder-name temp-draft-folder)) + (message "Deleting and expunging temporary drafts ...") + (when (mh "rmm" (list temp-draft-folder "all") :errorp nil) + (let (hdrs) + (declare (list hdrs)) + (do-headers-buffers (b temp-draft-folder) + (push b hdrs)) + (dolist (b hdrs) + (delete-headers-buffer-and-message-buffers-command nil b))))))) + + + + +;;;; Message Mode. + +(defmode "Message" :major-p t) + +(defhvar "Message Information" + "This holds the information about the current message buffer." + :value nil) + +(defstruct message/draft-info + headers-mark) ;Mark pointing to a headers line in a headers buffer. + +(defstruct (message-info (:include message/draft-info) + (:print-function print-message-info)) + folder ;String name of folder with leading MH "+". + msgs ;List of strings representing messages to be shown. + draft-buf ;Possible draft buffer reference. + keep) ;Whether message buffer may be re-used. + +(defun print-message-info (obj str n) + (declare (ignore n)) + (format str "#" + (message-info-folder obj) (message-info-msgs obj))) + + +(defcommand "Next Message" (p) + "Show the next message. + When in a message buffer, shows the next message in the associated headers + buffer. When in a headers buffer, moves point down a line and shows that + message." + "When in a message buffer, shows the next message in the associated headers + buffer. When in a headers buffer, moves point down a line and shows that + message." + (declare (ignore p)) + (show-message-offset 1)) + +(defcommand "Previous Message" (p) + "Show the previous message. + When in a message buffer, shows the previous message in the associated + headers buffer. When in a headers buffer, moves point up a line and shows + that message." + "When in a message buffer, shows the previous message in the associated + headers buffer. When in a headers buffer, moves point up a line and + shows that message." + (declare (ignore p)) + (show-message-offset -1)) + +(defcommand "Next Undeleted Message" (p) + "Show the next undeleted message. + When in a message buffer, shows the next undeleted message in the associated + headers buffer. When in a headers buffer, moves point down to a line + without a deleted message and shows that message." + "When in a message buffer, shows the next undeleted message in the associated + headers buffer. When in a headers buffer, moves point down to a line without + a deleted message and shows that message." + (declare (ignore p)) + (show-message-offset 1 :undeleted)) + +(defcommand "Previous Undeleted Message" (p) + "Show the previous undeleted message. + When in a message buffer, shows the previous undeleted message in the + associated headers buffer. When in a headers buffer, moves point up a line + without a deleted message and shows that message." + "When in a message buffer, shows the previous undeleted message in the + associated headers buffer. When in a headers buffer, moves point up a line + without a deleted message and shows that message." + (declare (ignore p)) + (show-message-offset -1 :undeleted)) + +(defun show-message-offset (offset &optional undeleted) + (let ((minfo (value message-information))) + (cond + ((not minfo) + (let ((hinfo (value headers-information))) + (unless hinfo (editor-error "Not in a message or headers buffer.")) + (show-message-offset-hdrs-buf hinfo offset undeleted))) + ((message-info-keep minfo) + (let ((hbuf (value headers-buffer))) + (unless hbuf (editor-error "Not associated with a headers buffer.")) + (let ((hinfo (variable-value 'headers-information :buffer hbuf)) + (point (buffer-point hbuf))) + (move-mark point (message-info-headers-mark minfo)) + (show-message-offset-hdrs-buf hinfo offset undeleted)))) + (t + (show-message-offset-msg-buf minfo offset undeleted))))) + +(defun show-message-offset-hdrs-buf (hinfo offset undeleted) + (unless hinfo (editor-error "Not in a message or headers buffer.")) + (unless (show-message-offset-mark (buffer-point (headers-info-buffer hinfo)) + offset undeleted) + (editor-error "No ~:[previous~;next~] ~:[~;undeleted ~]message." + (plusp offset) undeleted)) + (show-headers-message hinfo)) + +(defun show-message-offset-msg-buf (minfo offset undeleted) + (let ((msg-mark (message-info-headers-mark minfo))) + (unless msg-mark (editor-error "Not associated with a headers buffer.")) + (unless (show-message-offset-mark msg-mark offset undeleted) + (let ((hbuf (value headers-buffer)) + (mbuf (current-buffer))) + (setf (current-buffer) hbuf) + (setf (window-buffer (current-window)) hbuf) + (delete-buffer-if-possible mbuf)) + (editor-error "No ~:[previous~;next~] ~:[~;undeleted ~]message." + (plusp offset) undeleted)) + (move-mark (buffer-point (line-buffer (mark-line msg-mark))) msg-mark) + (let* ((next-msg (line-message-id (mark-line msg-mark))) + (folder (message-info-folder minfo)) + (mbuffer (current-buffer))) + (with-writable-buffer (mbuffer) + (delete-region (buffer-region mbuffer)) + (setf (buffer-name mbuffer) (get-storable-msg-buf-name folder next-msg)) + (setf (message-info-msgs minfo) next-msg) + (read-mh-file (merge-pathnames next-msg + (merge-relative-pathnames + (strip-folder-name folder) + (mh-directory-pathname))) + mbuffer) + (let ((unseen-seq (mh-profile-component "unseen-sequence"))) + (when unseen-seq + (mark-one-message folder next-msg unseen-seq :delete)))))) + (let ((dbuffer (message-info-draft-buf minfo))) + (when dbuffer + (delete-variable 'message-buffer :buffer dbuffer) + (setf (message-info-draft-buf minfo) nil)))) + +(defun get-storable-msg-buf-name (folder msg) + (let ((name (format nil "Message ~A ~A" folder msg))) + (if (not (getstring name *buffer-names*)) + name + (let ((n 2)) + (loop + (setf name (format nil "Message ~A ~A copy ~D" folder msg n)) + (unless (getstring name *buffer-names*) + (return name)) + (incf n)))))) + +(defun show-message-offset-mark (msg-mark offset undeleted) + (with-mark ((temp msg-mark)) + (let ((winp + (cond (undeleted + (loop + (unless (and (line-offset temp offset 0) + (not (blank-line-p (mark-line temp)))) + (return nil)) + (unless (line-message-deleted (mark-line temp)) + (return t)))) + ((and (line-offset temp offset 0) + (not (blank-line-p (mark-line temp))))) + (t nil)))) + (if winp (move-mark msg-mark temp))))) + + +(defcommand "Show Message" (p) + "Shows the current message. + Prompts for a folder and message(s), displaying this in the current window. + When invoked in a headers buffer, shows the message on the current line." + "Show a message." + (declare (ignore p)) + (let ((hinfo (value headers-information))) + (if hinfo + (show-headers-message hinfo) + (let ((folder (prompt-for-folder))) + (show-prompted-message folder (prompt-for-message :folder folder)))))) + +;;; SHOW-HEADERS-MESSAGE shows the current message for hinfo. If there is a +;;; main message buffer, clobber it, and we don't have to deal with kept +;;; messages or draft associations since those operations should have moved +;;; the message buffer into the others list. Remove the message from the +;;; unseen sequence, and make sure the message buffer is displayed in some +;;; window. +;;; +(defun show-headers-message (hinfo) + (multiple-value-bind (cur-msg cur-mark) + (headers-current-message hinfo) + (unless cur-msg (editor-error "Not on a header line.")) + (let* ((mbuffer (headers-info-msg-buffer hinfo)) + (folder (headers-info-folder hinfo)) + (buf-name (get-storable-msg-buf-name folder cur-msg)) + (writable nil)) + (cond (mbuffer + (setf (buffer-name mbuffer) buf-name) + (setf writable (buffer-writable mbuffer)) + (setf (buffer-writable mbuffer) t) + (delete-region (buffer-region mbuffer)) + (let ((minfo (variable-value 'message-information :buffer mbuffer))) + (move-mark (message-info-headers-mark minfo) cur-mark) + (delete-mark cur-mark) + (setf (message-info-msgs minfo) cur-msg))) + (t (setf mbuffer (maybe-make-mh-buffer buf-name :message)) + (setf (headers-info-msg-buffer hinfo) mbuffer) + (defhvar "Message Information" + "This holds the information about the current headers buffer." + :value (make-message-info :folder folder + :msgs cur-msg + :headers-mark cur-mark) + :buffer mbuffer) + (defhvar "Headers Buffer" + "This is bound in message and draft buffers to their + associated headers buffer." + :value (headers-info-buffer hinfo) :buffer mbuffer))) + (read-mh-file (merge-pathnames + cur-msg + (merge-relative-pathnames (strip-folder-name folder) + (mh-directory-pathname))) + mbuffer) + (setf (buffer-writable mbuffer) writable) + (let ((unseen-seq (mh-profile-component "unseen-sequence"))) + (when unseen-seq (mark-one-message folder cur-msg unseen-seq :delete))) + (get-message-buffer-window mbuffer)))) + +;;; SHOW-PROMPTED-MESSAGE takes an arbitrary message spec and blasts those +;;; messages into a message buffer. First we pick the message to get them +;;; individually specified as normalized message ID's -- all integers and +;;; no funny names such as "last". +;;; +(defun show-prompted-message (folder msgs) + (let* ((msgs (pick-messages folder msgs nil)) + (mbuffer (maybe-make-mh-buffer (format nil "Message ~A ~A" folder msgs) + :message))) + (defhvar "Message Information" + "This holds the information about the current headers buffer." + :value (make-message-info :folder folder :msgs msgs) + :buffer mbuffer) + (let ((*standard-output* (make-hemlock-output-stream (buffer-point mbuffer) + :full))) + (mh "show" `(,folder ,@msgs "-noshowproc" "-noheader")) + (setf (buffer-modified mbuffer) nil)) + (buffer-start (buffer-point mbuffer)) + (setf (buffer-writable mbuffer) nil) + (get-message-buffer-window mbuffer))) + +;;; GET-MESSAGE-BUFFER-WINDOW currently just changes to buffer, unless buffer +;;; has any windows, in which case it uses the first one. It could prompt for +;;; a window, split the current window, split the current window or use the +;;; next one if there is one, funcall an Hvar. It could take a couple +;;; arguments to control its behaviour. Whatever. +;;; +(defun get-message-buffer-window (mbuffer) + (let ((wins (buffer-windows mbuffer))) + (cond (wins + (setf (current-buffer) mbuffer) + (setf (current-window) (car wins))) + (t (change-to-buffer mbuffer))))) + + +(defhvar "Scroll Message Showing Next" + "When this is set, \"Scroll Message\" shows the next message when the end + of the current message is visible." + :value t) + +(defcommand "Scroll Message" (p) + "Scroll the current window down through the current message. + If the end of the message is visible, then show the next undeleted message + if \"Scroll Message Showing Next\" is non-nil." + "Scroll the current window down through the current message." + (if (and (not p) + (displayed-p (buffer-end-mark (current-buffer)) (current-window)) + (value scroll-message-showing-next)) + (show-message-offset 1 :undeleted) + (scroll-window-down-command p))) + + +(defcommand "Keep Message" (p) + "Keeps the current message buffer from being re-used. Also, if the buffer + would be deleted due to a draft completion, it will not be." + "Keeps the current message buffer from being re-used. Also, if the buffer + would be deleted due to a draft completion, it will not be." + (declare (ignore p)) + (let ((minfo (value message-information))) + (unless minfo (editor-error "Not in a message buffer.")) + (let ((hbuf (value headers-buffer))) + (when hbuf + (let ((mbuf (current-buffer)) + (hinfo (variable-value 'headers-information :buffer hbuf))) + (when (eq (headers-info-msg-buffer hinfo) mbuf) + (setf (headers-info-msg-buffer hinfo) nil) + (push mbuf (headers-info-other-msg-bufs hinfo)))))) + (setf (message-info-keep minfo) t))) + +(defcommand "Edit Message Buffer" (p) + "Recursively edit message buffer. + Puts the current message buffer into \"Text\" mode allowing modifications in + a recursive edit. While in this state, the buffer is associated with the + pathname of the message, so saving the file is possible." + "Puts the current message buffer into \"Text\" mode allowing modifications in + a recursive edit. While in this state, the buffer is associated with the + pathname of the message, so saving the file is possible." + (declare (ignore p)) + (let* ((minfo (value message-information))) + (unless minfo (editor-error "Not in a message buffer.")) + (let* ((msgs (message-info-msgs minfo)) + (mbuf (current-buffer)) + (mbuf-name (buffer-name mbuf)) + (writable (buffer-writable mbuf)) + (abortp t)) + (when (consp msgs) + (editor-error + "There appears to be more than one message in this buffer.")) + (unwind-protect + (progn + (setf (buffer-writable mbuf) t) + (setf (buffer-pathname mbuf) + (merge-pathnames + msgs + (merge-relative-pathnames + (strip-folder-name (message-info-folder minfo)) + (mh-directory-pathname)))) + (setf (buffer-major-mode mbuf) "Text") + (do-recursive-edit) + (setf abortp nil)) + (when (and (not abortp) + (buffer-modified mbuf) + (prompt-for-y-or-n + :prompt "Message buffer modified, save it? " + :default t)) + (save-file-command nil mbuf)) + (setf (buffer-modified mbuf) nil) + ;; "Save File", which the user may have used, changes the buffer's name. + (unless (getstring mbuf-name *buffer-names*) + (setf (buffer-name mbuf) mbuf-name)) + (setf (buffer-writable mbuf) writable) + (setf (buffer-pathname mbuf) nil) + (setf (buffer-major-mode mbuf) "Message"))))) + + + + +;;;; Draft Mode. + +(defmode "Draft") + +(defhvar "Draft Information" + "This holds the information about the current draft buffer." + :value nil) + +(defstruct (draft-info (:include message/draft-info) + (:print-function print-draft-info)) + folder ;String name of draft folder with leading MH "+". + message ;String id of draft folder message. + pathname ;Pathname of draft in the draft folder directory. + delivered ;This is set when the draft was really sent. + replied-to-folder ;Folder of message draft is in reply to. + replied-to-msg) ;Message draft is in reply to. + +(defun print-draft-info (obj str n) + (declare (ignore n)) + (format str "#" (draft-info-message obj))) + + +(defhvar "Reply to Message Prefix Action" + "This is one of :cc-all, :no-cc-all, or nil. When an argument is supplied to + \"Reply to Message\", this value determines how arguments passed to the + MH utility." + :value nil) + +(defcommand "Reply to Message" (p) + "Sets up a draft in reply to the current message. + Prompts for a folder and message to reply to. When in a headers buffer, + replies to the message on the current line. When in a message buffer, + replies to that message. With an argument, regard \"Reply to Message Prefix + Action\" for carbon copy arguments to the MH utility." + "Prompts for a folder and message to reply to. When in a headers buffer, + replies to the message on the current line. When in a message buffer, + replies to that message." + (let ((hinfo (value headers-information)) + (minfo (value message-information))) + (cond (hinfo + (multiple-value-bind (cur-msg cur-mark) + (headers-current-message hinfo) + (unless cur-msg (editor-error "Not on a header line.")) + (setup-reply-draft (headers-info-folder hinfo) + cur-msg hinfo cur-mark p))) + (minfo + (setup-message-buffer-draft (current-buffer) minfo :reply p)) + (t + (let ((folder (prompt-for-folder))) + (setup-reply-draft folder + (car (prompt-for-message :folder folder)) + nil nil p)))))) + +;;; SETUP-REPLY-DRAFT takes a folder and msg to draft a reply to. Optionally, +;;; a headers buffer and mark are associated with the draft. First, the draft +;;; buffer is associated with the headers buffer if there is one. Then the +;;; message buffer is created and associated with the drafter buffer and +;;; headers buffer. Argument may be used to pass in the argument from the +;;; command. +;;; +(defun setup-reply-draft (folder msg &optional hinfo hmark argument) + (let* ((dbuffer (sub-setup-message-draft + "repl" :end-of-buffer + `(,folder ,msg + ,@(if argument + (case (value reply-to-message-prefix-action) + (:no-cc-all '("-nocc" "all")) + (:cc-all '("-cc" "all"))))))) + (dinfo (variable-value 'draft-information :buffer dbuffer)) + (h-buf (if hinfo (headers-info-buffer hinfo)))) + (setf (draft-info-replied-to-folder dinfo) folder) + (setf (draft-info-replied-to-msg dinfo) msg) + (when h-buf + (defhvar "Headers Buffer" + "This is bound in message and draft buffers to their associated + headers buffer." + :value h-buf :buffer dbuffer) + (setf (draft-info-headers-mark dinfo) hmark) + (push dbuffer (headers-info-draft-bufs hinfo))) + (let ((msg-buf (maybe-make-mh-buffer (format nil "Message ~A ~A" folder msg) + :message))) + (defhvar "Message Information" + "This holds the information about the current headers buffer." + :value (make-message-info :folder folder :msgs msg + :headers-mark + (if h-buf (copy-mark hmark) hmark) + :draft-buf dbuffer) + :buffer msg-buf) + (when h-buf + (defhvar "Headers Buffer" + "This is bound in message and draft buffers to their associated + headers buffer." + :value h-buf :buffer msg-buf) + (push msg-buf (headers-info-other-msg-bufs hinfo))) + (read-mh-file (merge-pathnames + msg + (merge-relative-pathnames (strip-folder-name folder) + (mh-directory-pathname))) + msg-buf) + (setf (buffer-writable msg-buf) nil) + (defhvar "Message Buffer" + "This is bound in draft buffers to their associated message buffer." + :value msg-buf :buffer dbuffer)) + (get-draft-buffer-window dbuffer))) + + +(defcommand "Forward Message" (p) + "Forward current message. + Prompts for a folder and message to forward. When in a headers buffer, + forwards the message on the current line. When in a message buffer, + forwards that message." + "Prompts for a folder and message to reply to. When in a headers buffer, + replies to the message on the current line. When in a message buffer, + replies to that message." + (declare (ignore p)) + (let ((hinfo (value headers-information)) + (minfo (value message-information))) + (cond (hinfo + (multiple-value-bind (cur-msg cur-mark) + (headers-current-message hinfo) + (unless cur-msg (editor-error "Not on a header line.")) + (setup-forward-draft (headers-info-folder hinfo) + cur-msg hinfo cur-mark))) + (minfo + (setup-message-buffer-draft (current-buffer) minfo :forward)) + (t + (let ((folder (prompt-for-folder))) + (setup-forward-draft folder + (car (prompt-for-message :folder folder)))))))) + +;;; SETUP-FORWARD-DRAFT sets up a draft forwarding folder's msg. When there +;;; is a headers buffer involved (hinfo and hmark), the draft is associated +;;; with it. +;;; +;;; This function is like SETUP-REPLY-DRAFT (in addition to "forw" and +;;; :to-field), but it does not setup a message buffer. If this is added as +;;; something forward drafts want, then SETUP-REPLY-DRAFT should be +;;; parameterized and renamed. +;;; +(defun setup-forward-draft (folder msg &optional hinfo hmark) + (let* ((dbuffer (sub-setup-message-draft "forw" :to-field + (list folder msg))) + (dinfo (variable-value 'draft-information :buffer dbuffer)) + (h-buf (if hinfo (headers-info-buffer hinfo)))) + (when h-buf + (defhvar "Headers Buffer" + "This is bound in message and draft buffers to their associated + headers buffer." + :value h-buf :buffer dbuffer) + (setf (draft-info-headers-mark dinfo) hmark) + (push dbuffer (headers-info-draft-bufs hinfo))) + (get-draft-buffer-window dbuffer))) + + +(defcommand "Send Message" (p) + "Setup a draft buffer. + Setup a draft buffer, reserving a draft folder message. When invoked in a + headers buffer, the current message is available in an associated message + buffer." + "Setup a draft buffer, reserving a draft folder message. When invoked in + a headers buffer, the current message is available in an associated + message buffer." + (declare (ignore p)) + (let ((hinfo (value headers-information)) + (minfo (value message-information))) + (cond (hinfo (setup-headers-message-draft hinfo)) + (minfo (setup-message-buffer-draft (current-buffer) minfo :compose)) + (t (setup-message-draft))))) + +(defun setup-message-draft () + (get-draft-buffer-window (sub-setup-message-draft "comp" :to-field))) + +;;; SETUP-HEADERS-MESSAGE-DRAFT sets up a draft buffer associated with a +;;; headers buffer and a message buffer. The headers current message is +;;; inserted in the message buffer which is also associated with the headers +;;; buffer. The draft buffer is associated with the message buffer. +;;; +(defun setup-headers-message-draft (hinfo) + (multiple-value-bind (cur-msg cur-mark) + (headers-current-message hinfo) + (unless cur-msg (message "Draft not associated with any message.")) + (let* ((dbuffer (sub-setup-message-draft "comp" :to-field)) + (dinfo (variable-value 'draft-information :buffer dbuffer)) + (h-buf (headers-info-buffer hinfo))) + (when cur-msg + (defhvar "Headers Buffer" + "This is bound in message and draft buffers to their associated headers + buffer." + :value h-buf :buffer dbuffer) + (push dbuffer (headers-info-draft-bufs hinfo))) + (when cur-msg + (setf (draft-info-headers-mark dinfo) cur-mark) + (let* ((folder (headers-info-folder hinfo)) + (msg-buf (maybe-make-mh-buffer + (format nil "Message ~A ~A" folder cur-msg) + :message))) + (defhvar "Message Information" + "This holds the information about the current headers buffer." + :value (make-message-info :folder folder :msgs cur-msg + :headers-mark (copy-mark cur-mark) + :draft-buf dbuffer) + :buffer msg-buf) + (defhvar "Headers Buffer" + "This is bound in message and draft buffers to their associated + headers buffer." + :value h-buf :buffer msg-buf) + (push msg-buf (headers-info-other-msg-bufs hinfo)) + (read-mh-file (merge-pathnames + cur-msg + (merge-relative-pathnames (strip-folder-name folder) + (mh-directory-pathname))) + msg-buf) + (setf (buffer-writable msg-buf) nil) + (defhvar "Message Buffer" + "This is bound in draft buffers to their associated message buffer." + :value msg-buf :buffer dbuffer))) + (get-draft-buffer-window dbuffer)))) + +;;; SETUP-MESSAGE-BUFFER-DRAFT takes a message buffer and its message +;;; information. A draft buffer is created according to type, and the two +;;; buffers are associated. Any previous association of the message buffer and +;;; a draft buffer is dropped. Any association between the message buffer and +;;; a headers buffer is propagated to the draft buffer, and if the message +;;; buffer is the headers buffer's main message buffer, it is moved to "other" +;;; status. Argument may be used to pass in the argument from the command. +;;; +(defun setup-message-buffer-draft (msg-buf minfo type &optional argument) + (let* ((msgs (message-info-msgs minfo)) + (cur-msg (if (consp msgs) (car msgs) msgs)) + (folder (message-info-folder minfo)) + (dbuffer + (ecase type + (:reply + (sub-setup-message-draft + "repl" :end-of-buffer + `(,folder ,cur-msg + ,@(if argument + (case (value reply-to-message-prefix-action) + (:no-cc-all '("-nocc" "all")) + (:cc-all '("-cc" "all"))))))) + (:compose + (sub-setup-message-draft "comp" :to-field)) + (:forward + (sub-setup-message-draft "forw" :to-field + (list folder cur-msg))))) + (dinfo (variable-value 'draft-information :buffer dbuffer))) + (when (message-info-draft-buf minfo) + (delete-variable 'message-buffer :buffer (message-info-draft-buf minfo))) + (setf (message-info-draft-buf minfo) dbuffer) + (when (eq type :reply) + (setf (draft-info-replied-to-folder dinfo) folder) + (setf (draft-info-replied-to-msg dinfo) cur-msg)) + (when (hemlock-bound-p 'headers-buffer :buffer msg-buf) + (let* ((hbuf (variable-value 'headers-buffer :buffer msg-buf)) + (hinfo (variable-value 'headers-information :buffer hbuf))) + (defhvar "Headers Buffer" + "This is bound in message and draft buffers to their associated + headers buffer." + :value hbuf :buffer dbuffer) + (setf (draft-info-headers-mark dinfo) + (copy-mark (message-info-headers-mark minfo))) + (push dbuffer (headers-info-draft-bufs hinfo)) + (when (eq (headers-info-msg-buffer hinfo) msg-buf) + (setf (headers-info-msg-buffer hinfo) nil) + (push msg-buf (headers-info-other-msg-bufs hinfo))))) + (defhvar "Message Buffer" + "This is bound in draft buffers to their associated message buffer." + :value msg-buf :buffer dbuffer) + (get-draft-buffer-window dbuffer))) + +(defvar *draft-to-pattern* + (new-search-pattern :string-insensitive :forward "To:")) + +(defun sub-setup-message-draft (utility point-action &optional args) + (mh utility `(,@args "-nowhatnowproc")) + (let* ((folder (mh-draft-folder)) + (draft-msg (mh-current-message folder)) + (msg-pn (merge-pathnames draft-msg (mh-draft-folder-pathname))) + (dbuffer (maybe-make-mh-buffer (format nil "Draft ~A" draft-msg) + :draft))) + (read-mh-file msg-pn dbuffer) + (setf (buffer-pathname dbuffer) msg-pn) + (defhvar "Draft Information" + "This holds the information about the current draft buffer." + :value (make-draft-info :folder (coerce-folder-name folder) + :message draft-msg + :pathname msg-pn) + :buffer dbuffer) + (let ((point (buffer-point dbuffer))) + (ecase point-action + (:to-field + (when (find-pattern point *draft-to-pattern*) + (line-end point))) + (:end-of-buffer (buffer-end point)))) + dbuffer)) + +(defun read-mh-file (pathname buffer) + (unless (probe-file pathname) + (editor-error "No such message -- ~A" (namestring pathname))) + (read-file pathname (buffer-point buffer)) + (setf (buffer-write-date buffer) (file-write-date pathname)) + (buffer-start (buffer-point buffer)) + (setf (buffer-modified buffer) nil)) + + +(defvar *draft-buffer-window-fun* 'change-to-buffer + "This is called by GET-DRAFT-BUFFER-WINDOW to display a new draft buffer. + The default is CHANGE-TO-BUFFER which uses the current window.") + +;;; GET-DRAFT-BUFFER-WINDOW is called to display a new draft buffer. +;;; +(defun get-draft-buffer-window (dbuffer) + (funcall *draft-buffer-window-fun* dbuffer)) + + +(defcommand "Reply to Message in Other Window" (p) + "Reply to message, creating another window for draft buffer. + Prompts for a folder and message to reply to. When in a headers buffer, + replies to the message on the current line. When in a message buffer, + replies to that message. The current window is split displaying the draft + buffer in the new window and the message buffer in the current." + "Prompts for a folder and message to reply to. When in a headers buffer, + replies to the message on the current line. When in a message buffer, + replies to that message." + (let ((*draft-buffer-window-fun* #'draft-buffer-in-other-window)) + (reply-to-message-command p))) + +(defun draft-buffer-in-other-window (dbuffer) + (when (hemlock-bound-p 'message-buffer :buffer dbuffer) + (let ((mbuf (variable-value 'message-buffer :buffer dbuffer))) + (when (not (eq (current-buffer) mbuf)) + (change-to-buffer mbuf)))) + (setf (current-buffer) dbuffer) + (setf (current-window) (make-window (buffer-start-mark dbuffer))) + (defhvar "Split Window Draft" + "Indicates window needs to be cleaned up for draft." + :value t :buffer dbuffer)) + +(defhvar "Deliver Message Confirm" + "When set, \"Deliver Message\" will ask for confirmation before sending the + draft. This is off by default since \"Deliver Message\" is not bound to + any key by default." + :value t) + +(defcommand "Deliver Message" (p) + "Save and deliver the current draft buffer. + When in a draft buffer, this saves the file and uses SEND to deliver the + draft. Otherwise, this prompts for a draft message id, invoking SEND." + "When in a draft buffer, this saves the file and uses SEND to deliver the + draft. Otherwise, this prompts for a draft message id, invoking SEND." + (declare (ignore p)) + (let ((dinfo (value draft-information))) + (cond (dinfo + (deliver-draft-buffer-message dinfo)) + (t + (let* ((folder (coerce-folder-name (mh-draft-folder))) + (msg (prompt-for-message :folder folder))) + (mh "send" `("-draftfolder" ,folder "-draftmessage" ,@msg))))))) + +(defun deliver-draft-buffer-message (dinfo) + (when (draft-info-delivered dinfo) + (editor-error "This draft has already been delivered.")) + (when (or (not (value deliver-message-confirm)) + (prompt-for-y-or-n :prompt "Deliver message? " :default t)) + (let ((dbuffer (current-buffer))) + (when (buffer-modified dbuffer) + (write-buffer-file dbuffer (buffer-pathname dbuffer))) + (message "Delivering draft ...") + (mh "send" `("-draftfolder" ,(draft-info-folder dinfo) + "-draftmessage" ,(draft-info-message dinfo))) + (setf (draft-info-delivered dinfo) t) + (let ((replied-folder (draft-info-replied-to-folder dinfo)) + (replied-msg (draft-info-replied-to-msg dinfo))) + (when replied-folder + (message "Annotating message being replied to ...") + (mh "anno" `(,replied-folder ,replied-msg "-component" "replied")) + (do-headers-buffers (hbuf replied-folder) + (with-headers-mark (hmark hbuf replied-msg) + (mark-to-note-replied-msg hmark) + (with-writable-buffer (hbuf) + (setf (next-character hmark) #\A)))) + (dolist (b *buffer-list*) + (when (and (hemlock-bound-p 'message-information :buffer b) + (buffer-modeline-field-p b :replied-to-message)) + (dolist (w (buffer-windows b)) + (update-modeline-field b w :replied-to-message)))))) + (maybe-delete-extra-draft-window dbuffer (current-window)) + (let ((mbuf (value message-buffer))) + (when (and mbuf + (not (hemlock-bound-p 'netnews-message-info :buffer mbuf))) + (let ((minfo (variable-value 'message-information :buffer mbuf))) + (when (and minfo (not (message-info-keep minfo))) + (delete-buffer-if-possible mbuf))))) + (delete-buffer-if-possible dbuffer)))) + +(defcommand "Delete Draft and Buffer" (p) + "Delete the current draft and associated message and buffer." + "Delete the current draft and associated message and buffer." + (declare (ignore p)) + (let ((dinfo (value draft-information)) + (dbuffer (current-buffer))) + (unless dinfo (editor-error "No draft associated with buffer.")) + (maybe-delete-extra-draft-window dbuffer (current-window)) + (delete-file (draft-info-pathname dinfo)) + (let ((mbuf (value message-buffer))) + (when (and mbuf + (not (hemlock-bound-p 'netnews-message-info :buffer mbuf))) + (let ((minfo (variable-value 'message-information :buffer mbuf))) + (when (and minfo (not (message-info-keep minfo))) + (delete-buffer-if-possible mbuf))))) + (delete-buffer-if-possible dbuffer))) + +;;; MAYBE-DELETE-EXTRA-DRAFT-WINDOW -- Internal. +;;; +;;; This takes a draft buffer and a window into it that should not be deleted. +;;; If "Split Window Draft" is bound in the buffer, and there are at least two +;;; windows in dbuffer-window's group, then we delete some window. Blow away +;;; the variable, so we don't think this is still a split window draft buffer. +;;; +(defun maybe-delete-extra-draft-window (dbuffer dbuffer-window) + (when (and (hemlock-bound-p 'split-window-draft :buffer dbuffer) + ;; Since we know bitmap devices have window groups, this loop is + ;; more correct than testing the length of *window-list* and + ;; accounting for *echo-area-window* being in there. + (do ((start dbuffer-window) + (count 1 (1+ count)) + (w (next-window dbuffer-window) (next-window w))) + ((eq start w) (> count 1)))) + (delete-window (next-window dbuffer-window)) + (delete-variable 'split-window-draft :buffer dbuffer))) + +(defcommand "Remail Message" (p) + "Prompts for a folder and message to remail. Prompts for a resend-to + address string and resend-cc address string. When in a headers buffer, + remails the message on the current line. When in a message buffer, + remails that message." + "Prompts for a folder and message to remail. Prompts for a resend-to + address string and resend-cc address string. When in a headers buffer, + remails the message on the current line. When in a message buffer, + remails that message." + (declare (ignore p)) + (let ((hinfo (value headers-information)) + (minfo (value message-information))) + (cond (hinfo + (multiple-value-bind (cur-msg cur-mark) + (headers-current-message hinfo) + (unless cur-msg (editor-error "Not on a header line.")) + (delete-mark cur-mark) + (remail-message (headers-info-folder hinfo) cur-msg + (prompt-for-string :prompt "Resend To: ") + (prompt-for-string :prompt "Resend Cc: ")))) + (minfo + (remail-message (message-info-folder minfo) + (message-info-msgs minfo) + (prompt-for-string :prompt "Resend To: ") + (prompt-for-string :prompt "Resend Cc: "))) + (t + (let ((folder (prompt-for-folder))) + (remail-message folder + (car (prompt-for-message :folder folder)) + (prompt-for-string :prompt "Resend To: ") + (prompt-for-string :prompt "Resend Cc: ")))))) + (message "Message remailed.")) + + +;;; REMAIL-MESSAGE claims a draft folder message with "dist". This is then +;;; sucked into a buffer and modified by inserting the supplied addresses. +;;; "send" is used to deliver the draft, but it requires certain evironment +;;; variables to make it do the right thing. "mhdist" says the draft is only +;;; remailing information, and "mhaltmsg" is the message to send. "mhannotate" +;;; must be set due to a bug in MH's "send"; it will not notice the "mhdist" +;;; flag unless there is some message to be annotated. This command does not +;;; provide for annotation of the remailed message. +;;; +(defun remail-message (folder msg resend-to resend-cc) + (mh "dist" `(,folder ,msg "-nowhatnowproc")) + (let* ((draft-folder (mh-draft-folder)) + (draft-msg (mh-current-message draft-folder))) + (setup-remail-draft-message draft-msg resend-to resend-cc) + (mh "send" `("-draftfolder" ,draft-folder "-draftmessage" ,draft-msg) + :environment + `((:|mhdist| . "1") + (:|mhannotate| . "1") + (:|mhaltmsg| . ,(namestring + (merge-pathnames msg (merge-relative-pathnames + (strip-folder-name folder) + (mh-directory-pathname))))))))) + +;;; SETUP-REMAIL-DRAFT-MESSAGE takes a draft folder and message that have been +;;; created with the MH "dist" utility. A buffer is created with this +;;; message's pathname, searching for "resent-to:" and "resent-cc:", filling in +;;; the supplied argument values. After writing out the results, the buffer +;;; is deleted. +;;; +(defvar *draft-resent-to-pattern* + (new-search-pattern :string-insensitive :forward "resent-to:")) +(defvar *draft-resent-cc-pattern* + (new-search-pattern :string-insensitive :forward "resent-cc:")) + +(defun setup-remail-draft-message (msg resend-to resend-cc) + (let* ((msg-pn (merge-pathnames msg (mh-draft-folder-pathname))) + (dbuffer (maybe-make-mh-buffer (format nil "Draft ~A" msg) + :draft)) + (point (buffer-point dbuffer))) + (read-mh-file msg-pn dbuffer) + (when (find-pattern point *draft-resent-to-pattern*) + (line-end point) + (insert-string point resend-to)) + (buffer-start point) + (when (find-pattern point *draft-resent-cc-pattern*) + (line-end point) + (insert-string point resend-cc)) + (write-file (buffer-region dbuffer) msg-pn :keep-backup nil) + ;; The draft buffer delete hook expects this to be bound. + (defhvar "Draft Information" + "This holds the information about the current draft buffer." + :value :ignore + :buffer dbuffer) + (delete-buffer dbuffer))) + + + + +;;;; Message and Draft Stuff. + +(defhvar "Headers Buffer" + "This is bound in message and draft buffers to their associated headers + buffer." + :value nil) + +(defcommand "Goto Headers Buffer" (p) + "Selects associated headers buffer if it exists. + The headers buffer's point is moved to the appropriate line, pushing a + buffer mark where point was." + "Selects associated headers buffer if it exists." + (declare (ignore p)) + (let ((h-buf (value headers-buffer))) + (unless h-buf (editor-error "No associated headers buffer.")) + (let ((info (or (value message-information) (value draft-information)))) + (change-to-buffer h-buf) + (push-buffer-mark (copy-mark (current-point))) + (move-mark (current-point) (message/draft-info-headers-mark info))))) + +(defhvar "Message Buffer" + "This is bound in draft buffers to their associated message buffer." + :value nil) + +(defcommand "Goto Message Buffer" (p) + "Selects associated message buffer if it exists." + "Selects associated message buffer if it exists." + (declare (ignore p)) + (let ((msg-buf (value message-buffer))) + (unless msg-buf (editor-error "No associated message buffer.")) + (change-to-buffer msg-buf))) + + +(defhvar "Message Insertion Prefix" + "This is a fill prefix that is used when inserting text from a message buffer + into a draft buffer by \"Insert Message Region\". It defaults to three + spaces." + :value " ") + +(defhvar "Message Insertion Column" + "This is a fill column that is used when inserting text from a message buffer + into a draft buffer by \"Insert Message Region\"." + :value 75) + +(defcommand "Insert Message Region" (p) + "Copy the current region into the associated draft or post buffer. When + in a message buffer that has an associated draft or post buffer, the + current active region is copied into the draft or post buffer. It is + filled using \"Message Insertion Prefix\" and \"Message Insertion + Column\". If an argument is supplied, the filling is inhibited. + If both a draft buffer and post buffer are associated with this, then it + is inserted into the draft buffer." + "When in a message buffer that has an associated draft or post buffer, + the current active region is copied into the post or draft buffer. It is + filled using \"Message Insertion Prefix\" and \"Message Insertion + Column\". If an argument is supplied, the filling is inhibited." + (let* ((minfo (value message-information)) + (nm-info (if (hemlock-bound-p 'netnews-message-info) + (value netnews-message-info))) + (post-buffer (and nm-info (nm-info-post-buffer nm-info))) + (post-info (and post-buffer + (variable-value 'post-info :buffer post-buffer))) + dbuf kind) + (cond (minfo + (setf kind :mail) + (setf dbuf (message-info-draft-buf minfo))) + (nm-info + (setf kind :netnews) + (setf dbuf (or (nm-info-draft-buffer nm-info) + (nm-info-post-buffer nm-info)))) + (t (editor-error "Not in a netnews message or message buffer."))) + (unless dbuf + (editor-error "Message buffer not associated with any draft or post ~ + buffer.")) + (let* ((region (copy-region (current-region))) + (dbuf-point (buffer-point dbuf)) + (dbuf-mark (copy-mark dbuf-point))) + (cond ((and (eq kind :mail) + (hemlock-bound-p 'split-window-draft :buffer dbuf) + (> (length (the list *window-list*)) 2) + (buffer-windows dbuf)) + (setf (current-buffer) dbuf + (current-window) (car (buffer-windows dbuf)))) + ((and (eq kind :netnews) + (and (member (post-info-message-window post-info) + *window-list*) + (member (post-info-reply-window post-info) + *window-list*))) + (setf (current-buffer) dbuf + (current-window) (post-info-reply-window post-info))) + (t (change-to-buffer dbuf))) + (push-buffer-mark dbuf-mark) + (ninsert-region dbuf-point region) + (unless p + (fill-region-by-paragraphs (region dbuf-mark dbuf-point) + (value message-insertion-prefix) + (value message-insertion-column))))) + (setf (last-command-type) :ephemerally-active)) + + +(defhvar "Message Buffer Insertion Prefix" + "This is a line prefix that is inserted at the beginning of every line in + a message buffer when inserting those lines into a draft buffer with + \"Insert Message Buffer\". It defaults to four spaces." + :value " ") + +(defcommand "Insert Message Buffer" (p) + "Insert entire (associated) message buffer into (associated) draft or + post buffer. When in a draft or post buffer with an associated message + buffer, or when in a message buffer that has an associated draft or post + buffer, the message buffer is inserted into the draft buffer. When + there are both an associated draft and post buffer, the text is inserted + into the draft buffer. Each inserted line is modified by prefixing it + with \"Message Buffer Insertion Prefix\". If an argument is supplied + the prefixing is inhibited." + "When in a draft or post buffer with an associated message buffer, or + when in a message buffer that has an associated draft or post buffer, the + message buffer is inserted into the draft buffer. Each inserted line is + modified by prefixing it with \"Message Buffer Insertion Prefix\". If an + argument is supplied the prefixing is inhibited." + (let ((minfo (value message-information)) + (dinfo (value draft-information)) + mbuf dbuf message-kind) + (cond (minfo + (setf message-kind :mail) + (setf dbuf (message-info-draft-buf minfo)) + (unless dbuf + (editor-error + "Message buffer not associated with any draft buffer.")) + (setf mbuf (current-buffer)) + (change-to-buffer dbuf)) + (dinfo + (setf message-kind :mail) + (setf mbuf (value message-buffer)) + (unless mbuf + (editor-error + "Draft buffer not associated with any message buffer.")) + (setf dbuf (current-buffer))) + ((hemlock-bound-p 'netnews-message-info) + (setf message-kind :netnews) + (setf mbuf (current-buffer)) + (let ((nm-info (value netnews-message-info))) + (setf dbuf (or (nm-info-draft-buffer nm-info) + (nm-info-post-buffer nm-info))) + (unless dbuf + (editor-error "Message buffer not associated with any draft ~ + or post buffer."))) + (change-to-buffer dbuf)) + ((hemlock-bound-p 'post-info) + (setf message-kind :netnews) + (let ((post-info (value post-info))) + (setf mbuf (post-info-message-buffer post-info)) + (unless mbuf + (editor-error "Post buffer not associated with any message ~ + buffer."))) + (setf dbuf (current-buffer))) + (t (editor-error "Not in a draft, message, news-message, or post ~ + buffer."))) + (let* ((dbuf-point (buffer-point dbuf)) + (dbuf-mark (copy-mark dbuf-point))) + (push-buffer-mark dbuf-mark) + (insert-region dbuf-point (buffer-region mbuf)) + (unless p + (let ((prefix (value message-buffer-insertion-prefix))) + (with-mark ((temp dbuf-mark :left-inserting)) + (loop + (when (mark>= temp dbuf-point) (return)) + (insert-string temp prefix) + (unless (line-offset temp 1 0) (return))))))) + (ecase message-kind + (:mail + (insert-message-buffer-cleanup-split-draft dbuf mbuf)) + (:netnews + (nn-reply-cleanup-split-windows dbuf)))) + (setf (last-command-type) :ephemerally-active)) + +;;; INSERT-MESSAGE-BUFFER-CLEANUP-SPLIT-DRAFT tries to delete an extra window +;;; due to "Reply to Message in Other Window". Since we just inserted the +;;; message buffer in the draft buffer, we don't need the other window into +;;; the message buffer. +;;; +(defun insert-message-buffer-cleanup-split-draft (dbuf mbuf) + (when (and (hemlock-bound-p 'split-window-draft :buffer dbuf) + (> (length (the list *window-list*)) 2)) + (let ((win (car (buffer-windows mbuf)))) + (cond + (win + (when (eq win (current-window)) + (let ((dwin (car (buffer-windows dbuf)))) + (unless dwin + (editor-error "Couldn't fix windows for split window draft.")) + (setf (current-buffer) dbuf) + (setf (current-window) dwin))) + (delete-window win)) + (t ;; This happens when invoked with the message buffer current. + (let ((dwins (buffer-windows dbuf))) + (when (> (length (the list dwins)) 1) + (delete-window (find-if #'(lambda (w) + (not (eq w (current-window)))) + dwins))))))) + (delete-variable 'split-window-draft :buffer dbuf))) + + +;;; CLEANUP-MESSAGE-BUFFER is called when a buffer gets deleted. It cleans +;;; up references to a message buffer. +;;; +(defun cleanup-message-buffer (buffer) + (let ((minfo (variable-value 'message-information :buffer buffer))) + (when (hemlock-bound-p 'headers-buffer :buffer buffer) + (let* ((hinfo (variable-value 'headers-information + :buffer (variable-value 'headers-buffer + :buffer buffer))) + (msg-buf (headers-info-msg-buffer hinfo))) + (if (eq msg-buf buffer) + (setf (headers-info-msg-buffer hinfo) nil) + (setf (headers-info-other-msg-bufs hinfo) + (delete buffer (headers-info-other-msg-bufs hinfo) + :test #'eq)))) + (delete-mark (message-info-headers-mark minfo)) + ;; + ;; Do this for MAYBE-MAKE-MH-BUFFER since it isn't necessary for GC. + (delete-variable 'headers-buffer :buffer buffer)) + (when (message-info-draft-buf minfo) + (delete-variable 'message-buffer + :buffer (message-info-draft-buf minfo))))) + +;;; CLEANUP-DRAFT-BUFFER is called when a buffer gets deleted. It cleans +;;; up references to a draft buffer. +;;; +(defun cleanup-draft-buffer (buffer) + (let ((dinfo (variable-value 'draft-information :buffer buffer))) + (when (hemlock-bound-p 'headers-buffer :buffer buffer) + (let* ((hinfo (variable-value 'headers-information + :buffer (variable-value 'headers-buffer + :buffer buffer)))) + (setf (headers-info-draft-bufs hinfo) + (delete buffer (headers-info-draft-bufs hinfo) :test #'eq)) + (delete-mark (draft-info-headers-mark dinfo)))) + (when (hemlock-bound-p 'message-buffer :buffer buffer) + (setf (message-info-draft-buf + (variable-value 'message-information + :buffer (variable-value 'message-buffer + :buffer buffer))) + nil)))) + +;;; CLEANUP-HEADERS-BUFFER is called when a buffer gets deleted. It cleans +;;; up references to a headers buffer. +;;; +(defun cleanup-headers-buffer (buffer) + (let* ((hinfo (variable-value 'headers-information :buffer buffer)) + (msg-buf (headers-info-msg-buffer hinfo))) + (when msg-buf + (cleanup-headers-reference + msg-buf (variable-value 'message-information :buffer msg-buf))) + (dolist (b (headers-info-other-msg-bufs hinfo)) + (cleanup-headers-reference + b (variable-value 'message-information :buffer b))) + (dolist (b (headers-info-draft-bufs hinfo)) + (cleanup-headers-reference + b (variable-value 'draft-information :buffer b))))) + +(defun cleanup-headers-reference (buffer info) + (delete-mark (message/draft-info-headers-mark info)) + (setf (message/draft-info-headers-mark info) nil) + (delete-variable 'headers-buffer :buffer buffer) + (when (typep info 'draft-info) + (setf (draft-info-replied-to-folder info) nil) + (setf (draft-info-replied-to-msg info) nil))) + +;;; REVAMP-HEADERS-BUFFER cleans up a headers buffer for immediate re-use. +;;; After deleting the buffer's region, there will be one line in the buffer +;;; because of how Hemlock regions work, so we have to delete that line's +;;; plist. Then we clean up any references to the buffer and delete the +;;; main message buffer. The other message buffers are left alone assuming +;;; they are on the "others" list because they are being used in some +;;; particular way (for example, a draft buffer refers to one or the user has +;;; kept it). Then some slots of the info structure are set to nil. +;;; +(defun revamp-headers-buffer (hbuffer hinfo) + (delete-region (buffer-region hbuffer)) + (setf (line-plist (mark-line (buffer-point hbuffer))) nil) + (let ((msg-buf (headers-info-msg-buffer hinfo))) + ;; Deleting the buffer sets the slot to nil. + (when msg-buf (delete-buffer-if-possible msg-buf)) + (cleanup-headers-buffer hbuffer)) + (setf (headers-info-other-msg-bufs hinfo) nil) + (setf (headers-info-draft-bufs hinfo) nil) + (setf (headers-info-msg-seq hinfo) nil) + (setf (headers-info-msg-strings hinfo) nil)) + + + + +;;;; Incorporating new mail. + +(defhvar "New Mail Folder" + "This is the folder new mail is incorporated into." + :value "+inbox") + +(defcommand "Incorporate New Mail" (p) + "Incorporates new mail into \"New Mail Folder\", displaying INC output in + a pop-up window." + "Incorporates new mail into \"New Mail Folder\", displaying INC output in + a pop-up window." + (declare (ignore p)) + (with-pop-up-display (s) + (incorporate-new-mail s))) + +(defhvar "Unseen Headers Message Spec" + "This is an MH message spec suitable any message prompt. It is used to + supply headers for the unseen headers buffer, in addition to the + unseen-sequence name that is taken from the user's MH profile, when + incorporating new mail and after expunging. This value is a string." + :value nil) + +(defcommand "Incorporate and Read New Mail" (p) + "Incorporates new mail and generates a headers buffer. + Incorporates new mail into \"New Mail Folder\", and creates a headers buffer + with the new messages. To use this, you must define an unseen- sequence in + your profile. Each time this is invoked the unseen-sequence is SCAN'ed, and + the headers buffer's contents are replaced." + "Incorporates new mail into \"New Mail Folder\", and creates a headers + buffer with the new messages. This buffer will be appended to with + successive uses of this command." + (declare (ignore p)) + (let ((unseen-seq (mh-profile-component "unseen-sequence"))) + (unless unseen-seq + (editor-error "No unseen-sequence defined in MH profile.")) + (incorporate-new-mail) + (let* ((folder (value new-mail-folder)) + ;; Stash current message before fetching unseen headers. + (cur-msg (mh-current-message folder)) + (region (get-new-mail-msg-hdrs folder unseen-seq))) + ;; Fetch message headers before possibly making buffer in case we error. + (when (not (and *new-mail-buffer* + (member *new-mail-buffer* *buffer-list* :test #'eq))) + (let ((name (format nil "Unseen Headers ~A" folder))) + (when (getstring name *buffer-names*) + (editor-error "There already is a buffer named ~S!" name)) + (setf *new-mail-buffer* + (make-buffer name :modes (list "Headers") + :delete-hook '(new-mail-buf-delete-hook))) + (setf (buffer-writable *new-mail-buffer*) nil))) + (cond ((hemlock-bound-p 'headers-information + :buffer *new-mail-buffer*) + (let ((hinfo (variable-value 'headers-information + :buffer *new-mail-buffer*))) + (unless (string= (headers-info-folder hinfo) folder) + (editor-error + "An unseen headers buffer already exists but into another ~ + folder. Your mail has already been incorporated into the ~ + specified folder.")) + (with-writable-buffer (*new-mail-buffer*) + (revamp-headers-buffer *new-mail-buffer* hinfo)) + ;; Restore the name in case someone used "Pick Headers". + (setf (buffer-name *new-mail-buffer*) + (format nil "Unseen Headers ~A" folder)) + (insert-new-mail-message-headers hinfo region cur-msg))) + (t + (let ((hinfo (make-headers-info :buffer *new-mail-buffer* + :folder folder))) + (defhvar "Headers Information" + "This holds the information about the current headers buffer." + :value hinfo :buffer *new-mail-buffer*) + (insert-new-mail-message-headers hinfo region cur-msg))))))) + +;;; NEW-MAIL-BUF-DELETE-HOOK is invoked whenever the new mail buffer is +;;; deleted. +;;; +(defun new-mail-buf-delete-hook (buffer) + (declare (ignore buffer)) + (setf *new-mail-buffer* nil)) + +;;; GET-NEW-MAIL-MSG-HDRS takes a folder and the unseen-sequence name. It +;;; returns a region with the unseen message headers and any headers due to +;;; the "Unseen Headers Message Spec" variable. +;;; +(defun get-new-mail-msg-hdrs (folder unseen-seq) + (let* ((unseen-headers-message-spec (value unseen-headers-message-spec)) + (other-msgs (if unseen-headers-message-spec + (breakup-message-spec + (string-trim '(#\space #\tab) + unseen-headers-message-spec)))) + (msg-spec (cond ((null other-msgs) + (list unseen-seq)) + ((member unseen-seq other-msgs :test #'string=) + other-msgs) + (t (cons unseen-seq other-msgs))))) + (message-headers-to-region folder msg-spec))) + +;;; INSERT-NEW-MAIL-MESSAGE-HEADERS inserts region in the new mail buffer. +;;; Then we look for the header line with cur-msg id, moving point there. +;;; There may have been unseen messages before incorporating new mail, and +;;; cur-msg should be the first new message. Then we either switch to the +;;; new mail headers, or show the current message. +;;; +(defun insert-new-mail-message-headers (hinfo region cur-msg) + (declare (simple-string cur-msg)) + (with-writable-buffer (*new-mail-buffer*) + (insert-message-headers *new-mail-buffer* hinfo region)) + (let ((point (buffer-point *new-mail-buffer*))) + (buffer-start point) + (with-headers-mark (cur-mark *new-mail-buffer* cur-msg) + (move-mark point cur-mark))) + (change-to-buffer *new-mail-buffer*)) + + +(defhvar "Incorporate New Mail Hook" + "Functions on this hook are invoked immediately after new mail is + incorporated." + :value nil) + +(defun incorporate-new-mail (&optional stream) + "Incorporates new mail, passing INC's output to stream. When stream is + nil, output is flushed." + (unless (new-mail-p) (editor-error "No new mail.")) + (let ((args `(,(coerce-folder-name (value new-mail-folder)) + ,@(if stream nil '("-silent")) + "-form" ,(namestring (truename (value mh-scan-line-form))) + "-width" ,(number-string (value fill-column))))) + (message "Incorporating new mail ...") + (mh "inc" args)) + (when (value incorporate-new-mail-hook) + (message "Invoking new mail hooks ...")) + (invoke-hook incorporate-new-mail-hook)) + + + + +;;;; Deletion. + +(defhvar "Virtual Message Deletion" + "When set, \"Delete Message\" merely MARK's a message into the + \"hemlockdeleted\" sequence; otherwise, RMM is invoked." + :value t) + +(defcommand "Delete Message and Show Next" (p) + "Delete message and show next undeleted message. + This command is only valid in a headers buffer or a message buffer + associated with some headers buffer. The current message is deleted, and + the next undeleted one is shown." + "Delete the current message and show the next undeleted one." + (declare (ignore p)) + (let ((hinfo (value headers-information)) + (minfo (value message-information))) + (cond (hinfo + (multiple-value-bind (cur-msg cur-mark) + (headers-current-message hinfo) + (unless cur-msg (editor-error "Not on a header line.")) + (delete-mark cur-mark) + (delete-message (headers-info-folder hinfo) cur-msg))) + (minfo + (delete-message (message-info-folder minfo) + (message-info-msgs minfo))) + (t + (editor-error "Not in a headers or message buffer.")))) + (show-message-offset 1 :undeleted)) + +(defcommand "Delete Message and Down Line" (p) + "Deletes the current message, moving point to the next line. + When in a headers buffer, deletes the message on the current line. Then it + moves point to the next non-blank line." + "Deletes current message and moves point down a line." + (declare (ignore p)) + (let ((hinfo (value headers-information))) + (unless hinfo (editor-error "Not in a headers buffer.")) + (multiple-value-bind (cur-msg cur-mark) + (headers-current-message hinfo) + (unless cur-msg (editor-error "Not on a header line.")) + (delete-message (headers-info-folder hinfo) cur-msg) + (when (line-offset cur-mark 1) + (unless (blank-line-p (mark-line cur-mark)) + (move-mark (current-point) cur-mark))) + (delete-mark cur-mark)))) + +;;; "Delete Message" unlike "Headers Delete Message" cannot know for sure +;;; which message id's have been deleted, so when virtual message deletion +;;; is not used, we cannot use DELETE-HEADERS-BUFFER-LINE to keep headers +;;; buffers consistent. However, the message id's in the buffer (if deleted) +;;; will generate MH errors if operations are attempted with them, and +;;; if the user ever packs the folder with "Expunge Messages", the headers +;;; buffer will be updated. +;;; +(defcommand "Delete Message" (p) + "Prompts for a folder, messages to delete, and pick expression. When in + a headers buffer into the same folder specified, the messages prompt + defaults to those messages in the buffer; \"all\" may be entered if this is + not what is desired. When \"Virtual Message Deletion\" is set, messages are + only MARK'ed for deletion. See \"Expunge Messages\". When this feature is + not used, headers and message buffers message id's my not be consistent + with MH." + "Prompts for a folder and message to delete. When \"Virtual Message + Deletion\" is set, messages are only MARK'ed for deletion. See \"Expunge + Messages\"." + (declare (ignore p)) + (let* ((folder (prompt-for-folder)) + (hinfo (value headers-information)) + (temp-msgs (prompt-for-message + :folder folder + :messages + (if (and hinfo + (string= folder + (the simple-string + (headers-info-folder hinfo)))) + (headers-info-msg-strings hinfo)) + :prompt "MH messages to pick from: ")) + (pick-exp (prompt-for-pick-expression)) + (msgs (pick-messages folder temp-msgs pick-exp)) + (virtually (value virtual-message-deletion))) + (declare (simple-string folder)) + (if virtually + (mh "mark" `(,folder ,@msgs "-sequence" "hemlockdeleted" "-add")) + (mh "rmm" `(,folder ,@msgs))) + (if virtually + (let ((deleted-seq (mh-sequence-list folder "hemlockdeleted"))) + (when deleted-seq + (do-headers-buffers (hbuf folder) + (with-writable-buffer (hbuf) + (note-deleted-headers hbuf deleted-seq))))) + (do-headers-buffers (hbuf folder hinfo) + (do-headers-lines (hbuf :line-var line :mark-var hmark) + (when (member (line-message-id line) msgs :test #'string=) + (delete-headers-buffer-line hinfo hmark))))))) + +(defcommand "Headers Delete Message" (p) + "Delete current message. + When in a headers buffer, deletes the message on the current line. When + in a message buffer, deletes that message. When \"Virtual Message + Deletion\" is set, messages are only MARK'ed for deletion. See \"Expunge + Messages\"." + "When in a headers buffer, deletes the message on the current line. When + in a message buffer, deletes that message. When \"Virtual Message + Deletion\" is set, messages are only MARK'ed for deletion. See \"Expunge + Messages\"." + (declare (ignore p)) + (let ((hinfo (value headers-information)) + (minfo (value message-information))) + (cond (hinfo + (multiple-value-bind (cur-msg cur-mark) + (headers-current-message hinfo) + (unless cur-msg (editor-error "Not on a header line.")) + (delete-mark cur-mark) + (delete-message (headers-info-folder hinfo) cur-msg))) + (minfo + (let ((msgs (message-info-msgs minfo))) + (delete-message (message-info-folder minfo) + (if (consp msgs) (car msgs) msgs))) + (message "Message deleted.")) + (t (editor-error "Not in a headers or message buffer."))))) + +;;; DELETE-MESSAGE takes a folder and message id and either flags this message +;;; for deletion or deletes it. All headers buffers into folder are updated, +;;; either by flagging a headers line or deleting it. +;;; +(defun delete-message (folder msg) + (cond ((value virtual-message-deletion) + (mark-one-message folder msg "hemlockdeleted" :add) + (do-headers-buffers (hbuf folder) + (with-headers-mark (hmark hbuf msg) + (with-writable-buffer (hbuf) + (note-deleted-message-at-mark hmark))))) + (t (mh "rmm" (list folder msg)) + (do-headers-buffers (hbuf folder hinfo) + (with-headers-mark (hmark hbuf msg) + (delete-headers-buffer-line hinfo hmark))))) + (dolist (b *buffer-list*) + (when (and (hemlock-bound-p 'message-information :buffer b) + (buffer-modeline-field-p b :deleted-message)) + (dolist (w (buffer-windows b)) + (update-modeline-field b w :deleted-message))))) + +;;; NOTE-DELETED-MESSAGE-AT-MARK takes a mark at the beginning of a valid +;;; headers line, sticks a "D" on the line, and frobs the line's deleted +;;; property. This assumes the headers buffer is modifiable. +;;; +(defun note-deleted-message-at-mark (mark) + (find-attribute mark :digit) + (find-attribute mark :digit #'zerop) + (character-offset mark 2) + (setf (next-character mark) #\D) + (setf (line-message-deleted (mark-line mark)) t)) + +;;; DELETE-HEADERS-BUFFER-LINE takes a headers information and a mark on the +;;; line to be deleted. Before deleting the line, we check to see if any +;;; message or draft buffers refer to the buffer because of the line. Due +;;; to how regions are deleted, line plists get messed up, so they have to +;;; be regenerated. We regenerate them for the whole buffer, so we don't have +;;; to hack the code to know which lines got messed up. +;;; +(defun delete-headers-buffer-line (hinfo hmark) + (delete-headers-line-references hinfo hmark) + (let ((id (line-message-id (mark-line hmark))) + (hbuf (headers-info-buffer hinfo))) + (with-writable-buffer (hbuf) + (with-mark ((end (line-start hmark) :left-inserting)) + (unless (line-offset end 1 0) (buffer-end end)) + (delete-region (region hmark end)))) + (let ((seq (mh-sequence-delete id (headers-info-msg-seq hinfo)))) + (setf (headers-info-msg-seq hinfo) seq) + (setf (headers-info-msg-strings hinfo) (mh-sequence-strings seq))) + (set-message-headers-ids hbuf) + (when (value virtual-message-deletion) + (let ((deleted-seq (mh-sequence-list (headers-info-folder hinfo) + "hemlockdeleted"))) + (do-headers-lines (hbuf :line-var line) + (setf (line-message-deleted line) + (mh-sequence-member-p (line-message-id line) deleted-seq))))))) + + +;;; DELETE-HEADERS-LINE-REFERENCES removes any message buffer or draft buffer +;;; pointers to a headers buffer or marks into the headers buffer. Currently +;;; message buffers and draft buffers are identified differently for no good +;;; reason; probably message buffers should be located in the same way draft +;;; buffers are. Also, we currently assume only one of other-msg-bufs could +;;; refer to the line (similarly for draft-bufs), but this might be bug +;;; prone. The message buffer case couldn't happen since the buffer name +;;; would cause MAYBE-MAKE-MH-BUFFER to re-use the buffer, but you could reply +;;; to the same message twice simultaneously. +;;; +(defun delete-headers-line-references (hinfo hmark) + (let ((msg-id (line-message-id (mark-line hmark))) + (main-msg-buf (headers-info-msg-buffer hinfo))) + (declare (simple-string msg-id)) + (when main-msg-buf + (let ((minfo (variable-value 'message-information :buffer main-msg-buf))) + (when (string= (the simple-string (message-info-msgs minfo)) + msg-id) + (cond ((message-info-draft-buf minfo) + (cleanup-headers-reference main-msg-buf minfo) + (setf (headers-info-msg-buffer hinfo) nil)) + (t (delete-buffer-if-possible main-msg-buf)))))) + (dolist (mbuf (headers-info-other-msg-bufs hinfo)) + (let ((minfo (variable-value 'message-information :buffer mbuf))) + (when (string= (the simple-string (message-info-msgs minfo)) + msg-id) + (cond ((message-info-draft-buf minfo) + (cleanup-headers-reference mbuf minfo) + (setf (headers-info-other-msg-bufs hinfo) + (delete mbuf (headers-info-other-msg-bufs hinfo) + :test #'eq))) + (t (delete-buffer-if-possible mbuf))) + (return))))) + (dolist (dbuf (headers-info-draft-bufs hinfo)) + (let ((dinfo (variable-value 'draft-information :buffer dbuf))) + (when (same-line-p (draft-info-headers-mark dinfo) hmark) + (cleanup-headers-reference dbuf dinfo) + (setf (headers-info-draft-bufs hinfo) + (delete dbuf (headers-info-draft-bufs hinfo) :test #'eq)) + (return))))) + + +(defcommand "Undelete Message" (p) + "Prompts for a folder, messages to undelete, and pick expression. When in + a headers buffer into the same folder specified, the messages prompt + defaults to those messages in the buffer; \"all\" may be entered if this is + not what is desired. This command is only meaningful if you have + \"Virtual Message Deletion\" set." + "Prompts for a folder, messages to undelete, and pick expression. When in + a headers buffer into the same folder specified, the messages prompt + defaults to those messages in the buffer; \"all\" may be entered if this is + not what is desired. This command is only meaningful if you have + \"Virtual Message Deletion\" set." + (declare (ignore p)) + (unless (value virtual-message-deletion) + (editor-error "You don't use virtual message deletion.")) + (let* ((folder (prompt-for-folder)) + (hinfo (value headers-information)) + (temp-msgs (prompt-for-message + :folder folder + :messages + (if (and hinfo + (string= folder + (the simple-string + (headers-info-folder hinfo)))) + (headers-info-msg-strings hinfo)) + :prompt "MH messages to pick from: ")) + (pick-exp (prompt-for-pick-expression)) + (msgs (if pick-exp + (or (pick-messages folder temp-msgs pick-exp) temp-msgs) + temp-msgs))) + (declare (simple-string folder)) + (mh "mark" `(,folder ,@msgs "-sequence" "hemlockdeleted" "-delete")) + (let ((deleted-seq (mh-sequence-list folder "hemlockdeleted"))) + (do-headers-buffers (hbuf folder) + (with-writable-buffer (hbuf) + (do-headers-lines (hbuf :line-var line :mark-var hmark) + (when (and (line-message-deleted line) + (not (mh-sequence-member-p (line-message-id line) + deleted-seq))) + (note-undeleted-message-at-mark hmark)))))))) + +(defcommand "Headers Undelete Message" (p) + "Undelete the current message. + When in a headers buffer, undeletes the message on the current line. When + in a message buffer, undeletes that message. This command is only + meaningful if you have \"Virtual Message Deletion\" set." + "When in a headers buffer, undeletes the message on the current line. When + in a message buffer, undeletes that message. This command is only + meaningful if you have \"Virtual Message Deletion\" set." + (declare (ignore p)) + (unless (value virtual-message-deletion) + (editor-error "You don't use virtual message deletion.")) + (let ((hinfo (value headers-information)) + (minfo (value message-information))) + (cond (hinfo + (multiple-value-bind (cur-msg cur-mark) + (headers-current-message hinfo) + (unless cur-msg (editor-error "Not on a header line.")) + (delete-mark cur-mark) + (undelete-message (headers-info-folder hinfo) cur-msg))) + (minfo + (undelete-message (message-info-folder minfo) + (message-info-msgs minfo)) + (message "Message undeleted.")) + (t (editor-error "Not in a headers or message buffer."))))) + +;;; UNDELETE-MESSAGE takes a folder and a message id. All headers buffers into +;;; folder are updated. +;;; +(defun undelete-message (folder msg) + (mark-one-message folder msg "hemlockdeleted" :delete) + (do-headers-buffers (hbuf folder) + (with-headers-mark (hmark hbuf msg) + (with-writable-buffer (hbuf) + (note-undeleted-message-at-mark hmark)))) + (dolist (b *buffer-list*) + (when (and (hemlock-bound-p 'message-information :buffer b) + (buffer-modeline-field-p b :deleted-message)) + (dolist (w (buffer-windows b)) + (update-modeline-field b w :deleted-message))))) + +;;; NOTE-UNDELETED-MESSAGE-AT-MARK takes a mark at the beginning of a valid +;;; headers line, sticks a space on the line in place of a "D", and frobs the +;;; line's deleted property. This assumes the headers buffer is modifiable. +;;; +(defun note-undeleted-message-at-mark (hmark) + (find-attribute hmark :digit) + (find-attribute hmark :digit #'zerop) + (character-offset hmark 2) + (setf (next-character hmark) #\space) + (setf (line-message-deleted (mark-line hmark)) nil)) + + +(defcommand "Expunge Messages" (p) + "Expunges messages marked for deletion. + This command prompts for a folder, invoking RMM on the \"hemlockdeleted\" + sequence after asking the user for confirmation. Setting \"Quit Headers + Confirm\" to nil inhibits prompting. The folder's message id's are packed + with FOLDER -pack. When in a headers buffer, uses that folder. When in a + message buffer, uses its folder, updating any associated headers buffer. + When \"Temporary Draft Folder\" is bound, this folder's messages are deleted + and expunged." + "Prompts for a folder, invoking RMM on the \"hemlockdeleted\" sequence and + packing the message id's with FOLDER -pack. When in a headers buffer, + uses that folder." + (declare (ignore p)) + (let* ((hinfo (value headers-information)) + (minfo (value message-information)) + (folder (cond (hinfo (headers-info-folder hinfo)) + (minfo (message-info-folder minfo)) + (t (prompt-for-folder)))) + (deleted-seq (mh-sequence-list folder "hemlockdeleted"))) + ;; + ;; Delete the messages if there are any. + ;; This deletes "hemlockdeleted" from sequence file; we don't have to. + (when (and deleted-seq + (or (not (value expunge-messages-confirm)) + (prompt-for-y-or-n + :prompt (list "Expunge messages and pack folder ~A? " + folder) + :default t + :default-string "Y"))) + (message "Deleting messages ...") + (mh "rmm" (list folder "hemlockdeleted")) + ;; + ;; Compact the message id's after deletion. + (let ((*standard-output* *mh-utility-bit-bucket*)) + (message "Compacting folder ...") + (mh "folder" (list folder "-fast" "-pack"))) + ;; + ;; Do a bunch of consistency maintenance. + (let ((new-buf-p (eq (current-buffer) *new-mail-buffer*))) + (message "Maintaining consistency ...") + (expunge-messages-fold-headers-buffers folder) + (expunge-messages-fix-draft-buffers folder) + (expunge-messages-fix-unseen-headers folder) + (when new-buf-p (change-to-buffer *new-mail-buffer*))) + (delete-and-expunge-temp-drafts)))) + +;;; EXPUNGE-MESSAGES-FOLD-HEADERS-BUFFERS deletes all headers buffers into the +;;; compacted folder. We can only update the headers buffers by installing all +;;; headers, so there may as well be only one such buffer. First we get a list +;;; of the buffers since DO-HEADERS-BUFFERS is trying to iterate over a list +;;; being destructively modified by buffer deletions. +;;; +(defun expunge-messages-fold-headers-buffers (folder) + (let (hbufs) + (declare (list hbufs)) + (do-headers-buffers (b folder) + (unless (eq b *new-mail-buffer*) + (push b hbufs))) + (unless (zerop (length hbufs)) + (dolist (b hbufs) + (delete-headers-buffer-and-message-buffers-command nil b)) + (new-message-headers folder (list "all"))))) + +;;; EXPUNGE-MESSAGES-FIX-DRAFT-BUFFERS finds any draft buffer that was set up +;;; as a reply to some message in folder, removing this relationship in case +;;; that message id does not exist after expunge folder compaction. +;;; +(defun expunge-messages-fix-draft-buffers (folder) + (declare (simple-string folder)) + (dolist (b *buffer-list*) + (when (hemlock-bound-p 'draft-information :buffer b) + (let* ((dinfo (variable-value 'draft-information :buffer b)) + (reply-folder (draft-info-replied-to-folder dinfo))) + (when (and reply-folder + (string= (the simple-string reply-folder) folder)) + (setf (draft-info-replied-to-folder dinfo) nil) + (setf (draft-info-replied-to-msg dinfo) nil)))))) + +;;; EXPUNGE-MESSAGES-FIX-UNSEEN-HEADERS specially handles the unseen headers +;;; buffer apart from the other headers buffers into the same folder when +;;; messages have been expunged. We must delete the associated message buffers +;;; since REVAMP-HEADERS-BUFFER does not, and these potentially reference bad +;;; message id's. When doing this we must copy the other-msg-bufs list since +;;; the delete buffer cleanup hook for them is destructive. Then we check for +;;; more unseen messages. +;;; +(defun expunge-messages-fix-unseen-headers (folder) + (declare (simple-string folder)) + (when *new-mail-buffer* + (let ((hinfo (variable-value 'headers-information + :buffer *new-mail-buffer*))) + (when (string= (the simple-string (headers-info-folder hinfo)) + folder) + (let ((other-bufs (copy-list (headers-info-other-msg-bufs hinfo)))) + (dolist (b other-bufs) (delete-buffer-if-possible b))) + (with-writable-buffer (*new-mail-buffer*) + (revamp-headers-buffer *new-mail-buffer* hinfo) + ;; Restore the name in case someone used "Pick Headers". + (setf (buffer-name *new-mail-buffer*) + (format nil "Unseen Headers ~A" folder)) + (let ((region (maybe-get-new-mail-msg-hdrs folder))) + (when region + (insert-message-headers *new-mail-buffer* hinfo region)))))))) + +;;; MAYBE-GET-NEW-MAIL-MSG-HDRS returns a region suitable for a new mail buffer +;;; or nil. Folder is probed for unseen headers, and if there are some, then +;;; we call GET-NEW-MAIL-MSG-HDRS which also uses "Unseen Headers Message Spec". +;;; If there are no unseen headers, we only look for "Unseen Headers Message +;;; Spec" messages. We go through these contortions to keep MH from outputting +;;; errors. +;;; +(defun maybe-get-new-mail-msg-hdrs (folder) + (let ((unseen-seq-name (mh-profile-component "unseen-sequence"))) + (multiple-value-bind (unseen-seq foundp) + (mh-sequence-list folder unseen-seq-name) + (if (and foundp unseen-seq) + (get-new-mail-msg-hdrs folder unseen-seq-name) + (let ((spec (value unseen-headers-message-spec))) + (when spec + (message-headers-to-region + folder + (breakup-message-spec (string-trim '(#\space #\tab) spec))))))))) + + + + +;;;; Folders. + +(defvar *folder-name-table* nil) + +(defun check-folder-name-table () + (unless *folder-name-table* + (message "Finding folder names ...") + (setf *folder-name-table* (make-string-table)) + (let* ((output (with-output-to-string (*standard-output*) + (mh "folders" '("-fast")))) + (length (length output)) + (start 0)) + (declare (simple-string output)) + (loop + (when (> start length) (return)) + (let ((nl (position #\newline output :start start))) + (unless nl (return)) + (unless (= start nl) + (setf (getstring (subseq output start nl) *folder-name-table*) t)) + (setf start (1+ nl))))))) + +(defcommand "List Folders" (p) + "Pop up a list of folders at top-level." + "Pop up a list of folders at top-level." + (declare (ignore p)) + (check-folder-name-table) + (with-pop-up-display (s) + (do-strings (f ignore *folder-name-table*) + (declare (ignore ignore)) + (write-line f s)))) + +(defcommand "Create Folder" (p) + "Creates a folder. If the folder already exists, an error is signaled." + "Creates a folder. If the folder already exists, an error is signaled." + (declare (ignore p)) + (let ((folder (prompt-for-folder :must-exist nil))) + (when (folder-existsp folder) + (editor-error "Folder already exists -- ~S!" folder)) + (create-folder folder))) + +(defcommand "Delete Folder" (p) + "Prompts for a folder and uses RMF to delete it." + "Prompts for a folder and uses RMF to delete it." + (declare (ignore p)) + (let* ((folder (prompt-for-folder)) + (*standard-output* *mh-utility-bit-bucket*)) + (mh "rmf" (list folder)) + ;; RMF doesn't recognize this documented switch. + ;; "-nointeractive")))) + (check-folder-name-table) + (delete-string (strip-folder-name folder) *folder-name-table*))) + + +(defvar *refile-default-destination* nil) + +(defcommand "Refile Message" (p) + "Prompts for a source folder, messages, pick expression, and a destination + folder to refile the messages." + "Prompts for a source folder, messages, pick expression, and a destination + folder to refile the messages." + (declare (ignore p)) + (let* ((src-folder (prompt-for-folder :prompt "Source folder: ")) + (hinfo (value headers-information)) + (temp-msgs (prompt-for-message + :folder src-folder + :messages + (if (and hinfo + (string= src-folder + (the simple-string + (headers-info-folder hinfo)))) + (headers-info-msg-strings hinfo)) + :prompt "MH messages to pick from: ")) + (pick-exp (prompt-for-pick-expression)) + ;; Return pick result or temp-msgs individually specified in a list. + (msgs (pick-messages src-folder temp-msgs pick-exp))) + (declare (simple-string src-folder)) + (refile-message src-folder msgs + (prompt-for-folder :must-exist nil + :prompt "Destination folder: " + :default *refile-default-destination*)))) + +(defcommand "Headers Refile Message" (p) + "Refile the current message. + When in a headers buffer, refiles the message on the current line, and when + in a message buffer, refiles that message, prompting for a destination + folder." + "When in a headers buffer, refiles the message on the current line, and when + in a message buffer, refiles that message, prompting for a destination + folder." + (declare (ignore p)) + (let ((hinfo (value headers-information)) + (minfo (value message-information))) + (cond (hinfo + (multiple-value-bind (cur-msg cur-mark) + (headers-current-message hinfo) + (unless cur-msg (editor-error "Not on a header line.")) + (delete-mark cur-mark) + (refile-message (headers-info-folder hinfo) cur-msg + (prompt-for-folder + :must-exist nil + :prompt "Destination folder: " + :default *refile-default-destination*)))) + (minfo + (refile-message + (message-info-folder minfo) (message-info-msgs minfo) + (prompt-for-folder :must-exist nil + :prompt "Destination folder: " + :default *refile-default-destination*)) + (message "Message refiled.")) + (t + (editor-error "Not in a headers or message buffer."))))) + +;;; REFILE-MESSAGE refiles msg from src-folder to dst-folder. If dst-buffer +;;; doesn't exist, the user is prompted for creating it. All headers buffers +;;; concerning src-folder are updated. When msg is a list, we did a general +;;; message prompt, and we cannot know which headers lines to delete. +;;; +(defun refile-message (src-folder msg dst-folder) + (unless (folder-existsp dst-folder) + (cond ((prompt-for-y-or-n + :prompt "Destination folder doesn't exist. Create it? " + :default t :default-string "Y") + (create-folder dst-folder)) + (t (editor-error "Not refiling message.")))) + (mh "refile" `(,@(if (listp msg) msg (list msg)) + "-src" ,src-folder ,dst-folder)) + (setf *refile-default-destination* (strip-folder-name dst-folder)) + (if (listp msg) + (do-headers-buffers (hbuf src-folder hinfo) + (do-headers-lines (hbuf :line-var line :mark-var hmark) + (when (member (line-message-id line) msg :test #'string=) + (delete-headers-buffer-line hinfo hmark)))) + (do-headers-buffers (hbuf src-folder hinfo) + (with-headers-mark (hmark hbuf msg) + (delete-headers-buffer-line hinfo hmark))))) + + + + +;;;; Miscellaneous commands. + +(defcommand "Mark Message" (p) + "Prompts for a folder, message, and sequence. By default the message is + added, but if an argument is supplied, the message is deleted. When in + a headers buffer or message buffer, only a sequence is prompted for." + "Prompts for a folder, message, and sequence. By default the message is + added, but if an argument is supplied, the message is deleted. When in + a headers buffer or message buffer, only a sequence is prompted for." + (let* ((hinfo (value headers-information)) + (minfo (value message-information))) + (cond (hinfo + (multiple-value-bind (cur-msg cur-mark) + (headers-current-message hinfo) + (unless cur-msg (editor-error "Not on a header line.")) + (delete-mark cur-mark) + (let ((seq-name (prompt-for-string :prompt "Sequence name: " + :trim t))) + (declare (simple-string seq-name)) + (when (string= "" seq-name) + (editor-error "Sequence name cannot be empty.")) + (mark-one-message (headers-info-folder hinfo) + cur-msg seq-name (if p :delete :add))))) + (minfo + (let ((msgs (message-info-msgs minfo)) + (seq-name (prompt-for-string :prompt "Sequence name: " + :trim t))) + (declare (simple-string seq-name)) + (when (string= "" seq-name) + (editor-error "Sequence name cannot be empty.")) + (mark-one-message (message-info-folder minfo) + (if (consp msgs) (car msgs) msgs) + seq-name (if p :delete :add)))) + (t + (let ((folder (prompt-for-folder)) + (seq-name (prompt-for-string :prompt "Sequence name: " + :trim t))) + (declare (simple-string seq-name)) + (when (string= "" seq-name) + (editor-error "Sequence name cannot be empty.")) + (mh "mark" `(,folder ,@(prompt-for-message :folder folder) + "-sequence" ,seq-name + ,(if p "-delete" "-add")))))))) + + +(defcommand "List Mail Buffers" (p) + "Show a list of all mail associated buffers. + If the buffer has an associated message buffer, it is displayed to the right + of the buffer name. If there is no message buffer, but the buffer is + associated with a headers buffer, then it is displayed. If the buffer is + modified then a * is displayed before the name." + "Display the names of all buffers in a with-random-typeout window." + (declare (ignore p)) + (let ((buffers nil)) + (declare (list buffers)) + (do-strings (n b *buffer-names*) + (declare (ignore n)) + (unless (eq b *echo-area-buffer*) + (cond ((hemlock-bound-p 'message-buffer :buffer b) + ;; Catches draft buffers associated with message buffers first. + (push (cons b (variable-value 'message-buffer :buffer b)) + buffers)) + ((hemlock-bound-p 'headers-buffer :buffer b) + ;; Then draft or message buffers associated with headers buffers. + (push (cons b (variable-value 'headers-buffer :buffer b)) + buffers)) + ((or (hemlock-bound-p 'draft-information :buffer b) + (hemlock-bound-p 'message-information :buffer b) + (hemlock-bound-p 'headers-information :buffer b)) + (push b buffers))))) + (with-pop-up-display (s :height (length buffers)) + (dolist (ele (nreverse buffers)) + (let* ((association (if (consp ele) (cdr ele))) + (b (if association (car ele) ele)) + (buffer-pathname (buffer-pathname b)) + (buffer-name (buffer-name b))) + (write-char (if (buffer-modified b) #\* #\space) s) + (if buffer-pathname + (format s "~A ~A~:[~;~50T~:*~A~]~%" + (file-namestring buffer-pathname) + (directory-namestring buffer-pathname) + (if association (buffer-name association))) + (format s "~A~:[~;~50T~:*~A~]~%" + buffer-name + (if association (buffer-name association))))))))) + + +(defcommand "Message Help" (p) + "Show this help." + "Show this help." + (declare (ignore p)) + (describe-mode-command nil "Message")) + +(defcommand "Headers Help" (p) + "Show this help." + "Show this help." + (declare (ignore p)) + (describe-mode-command nil "Headers")) + +(defcommand "Draft Help" (p) + "Show this help." + "Show this help." + (declare (ignore p)) + (describe-mode-command nil "Draft")) + + + + +;;;; Prompting. + +;;; Folder prompting. +;;; + +(defun prompt-for-folder (&key (must-exist t) (prompt "MH Folder: ") + (default (mh-current-folder))) + "Prompts for a folder, using MH's idea of the current folder as a default. + The result will have a leading + in the name." + (check-folder-name-table) + (let ((folder (prompt-for-keyword (list *folder-name-table*) + :must-exist must-exist :prompt prompt + :default default :default-string default + :help "Enter folder name."))) + (declare (simple-string folder)) + (when (string= folder "") (editor-error "Must supply folder!")) + (let ((name (coerce-folder-name folder))) + (when (and must-exist (not (folder-existsp name))) + (editor-error "Folder does not exist -- ~S." name)) + name))) + +(defun coerce-folder-name (folder) + (if (char= (schar folder 0) #\+) + folder + (concatenate 'simple-string "+" folder))) + +(defun strip-folder-name (folder) + (if (char= (schar folder 0) #\+) + (subseq folder 1) + folder)) + + +;;; Message prompting. +;;; + +(defun prompt-for-message (&key (folder (mh-current-folder)) + (prompt "MH messages: ") + messages) + "Prompts for a message spec, using messages as a default. If messages is + not supplied, then the current message for folder is used. The result is + a list of strings which are the message ids, intervals, and/or sequence + names the user entered." + (let* ((cur-msg (cond ((not messages) (mh-current-message folder)) + ((stringp messages) messages) + ((consp messages) + (if (= (length (the list messages)) 1) + (car messages) + (format nil "~{~A~^ ~}" messages)))))) + (breakup-message-spec (prompt-for-string :prompt prompt + :default cur-msg + :default-string cur-msg + :trim t + :help "Enter MH message id(s).")))) + +(defun breakup-message-spec (msgs) + (declare (simple-string msgs)) + (let ((start 0) + (result nil)) + (loop + (let ((end (position #\space msgs :start start :test #'char=))) + (unless end + (return (if (zerop start) + (list msgs) + (nreverse (cons (subseq msgs start) result))))) + (push (subseq msgs start end) result) + (setf start (1+ end)))))) + + +;;; PICK expression prompting. +;;; + +(defhvar "MH Lisp Expression" + "When this is set (the default), MH expression prompts are read in a Lisp + syntax. Otherwise, the input is as if it had been entered on a shell + command line." + :value t) + +;;; This is dynamically bound to nil for argument processing routines. +;;; +(defvar *pick-expression-strings* nil) + +(defun prompt-for-pick-expression () + "Prompts for an MH PICK-like expression that is converted to a list of + strings suitable for EXT:RUN-PROGRAM. As a second value, the user's + expression is as typed in is returned." + (let ((exp (prompt-for-string :prompt "MH expression: " + :help "Expression to PICK over mail messages." + :trim t)) + (*pick-expression-strings* nil)) + (if (value mh-lisp-expression) + (let ((exp (let ((*package* *keyword-package*)) + (read-from-string exp)))) + (if exp + (if (consp exp) + (lisp-to-pick-expression exp) + (editor-error "Lisp PICK expressions cannot be atomic.")))) + (expand-mh-pick-spec exp)) + (values (nreverse *pick-expression-strings*) + exp))) + +(defun lisp-to-pick-expression (exp) + (ecase (car exp) + (:and (lpe-and/or exp "-and")) + (:or (lpe-and/or exp "-or")) + (:not (push "-not" *pick-expression-strings*) + (let ((nexp (cadr exp))) + (unless (consp nexp) (editor-error "Bad expression -- ~S" nexp)) + (lisp-to-pick-expression nexp))) + + (:cc (lpe-output-and-go exp "-cc")) + (:date (lpe-output-and-go exp "-date")) + (:from (lpe-output-and-go exp "-from")) + (:search (lpe-output-and-go exp "-search")) + (:subject (lpe-output-and-go exp "-subject")) + (:to (lpe-output-and-go exp "-to")) + (:-- (lpe-output-and-go (cdr exp) + (concatenate 'simple-string + "--" (string (cadr exp))))) + + (:before (lpe-after-and-before exp "-before")) + (:after (lpe-after-and-before exp "-after")) + (:datefield (lpe-output-and-go exp "-datefield")))) + +(defun lpe-after-and-before (exp op) + (let ((operand (cadr exp))) + (when (numberp operand) + (setf (cadr exp) + (if (plusp operand) + (number-string (- operand)) + (number-string operand))))) + (lpe-output-and-go exp op)) + +(defun lpe-output-and-go (exp op) + (push op *pick-expression-strings*) + (let ((operand (cadr exp))) + (etypecase operand + (string (push operand *pick-expression-strings*)) + (symbol (push (symbol-name operand) + *pick-expression-strings*))))) + +(defun lpe-and/or (exp op) + (push "-lbrace" *pick-expression-strings*) + (dolist (ele (cdr exp)) + (lisp-to-pick-expression ele) + (push op *pick-expression-strings*)) + (pop *pick-expression-strings*) ;Clear the extra "-op" arg. + (push "-rbrace" *pick-expression-strings*)) + +;;; EXPAND-MH-PICK-SPEC takes a string of "words" assumed to be separated +;;; by single spaces. If a "word" starts with a quotation mark, then +;;; everything is grabbed up to the next one and used as a single word. +;;; Currently, this does not worry about extra spaces (or tabs) between +;;; "words". +;;; +(defun expand-mh-pick-spec (spec) + (declare (simple-string spec)) + (let ((start 0)) + (loop + (let ((end (position #\space spec :start start :test #'char=))) + (unless end + (if (zerop start) + (setf *pick-expression-strings* (list spec)) + (push (subseq spec start) *pick-expression-strings*)) + (return)) + (cond ((char= #\" (schar spec start)) + (setf end (position #\" spec :start (1+ start) :test #'char=)) + (unless end (editor-error "Bad quoting syntax.")) + (push (subseq spec (1+ start) end) *pick-expression-strings*) + (setf start (+ end 2))) + (t (push (subseq spec start end) *pick-expression-strings*) + (setf start (1+ end)))))))) + + +;;; Password prompting. +;;; + +(defun prompt-for-password (&optional (prompt "Password: ")) + "Prompts for password with prompt." + (let ((hi::*parse-verification-function* #'(lambda (string) (list string)))) + (let ((hi::*parse-prompt* prompt)) + (hi::display-prompt-nicely)) + (let ((start-window (current-window))) + (move-mark *parse-starting-mark* (buffer-point *echo-area-buffer*)) + (setf (current-window) *echo-area-window*) + (unwind-protect + (use-buffer *echo-area-buffer* + (let ((result ())) + (declare (list result)) + (loop + (let ((key-event (get-key-event *editor-input*))) + (ring-pop hi::*key-event-history*) + (cond ((eq key-event #k"return") + (return (prog1 (coerce (nreverse result) + 'simple-string) + (fill result nil)))) + ((or (eq key-event #k"control-u") + (eq key-event #k"control-U")) + (setf result nil)) + (t (push (ext:key-event-char key-event) result))))))) + (setf (current-window) start-window))))) + + + + + +;;;; Making mail buffers. + +;;; MAYBE-MAKE-MH-BUFFER looks up buffer with name, returning it if it exists +;;; after cleaning it up to a state "good as new". Currently, we don't +;;; believe it is possible to try to make two draft buffers with the same name +;;; since that would mean that composition, draft folder interaction, and +;;; draft folder current message didn't do what we expected -- or some user +;;; was modifying the draft folder in some evil way. +;;; +(defun maybe-make-mh-buffer (name use) + (let ((buf (getstring name *buffer-names*))) + (cond ((not buf) + (ecase use + (:headers (make-buffer name + :modes '("Headers") + :delete-hook '(cleanup-headers-buffer))) + + (:message + (make-buffer name :modes '("Message") + :modeline-fields + (value default-message-modeline-fields) + :delete-hook '(cleanup-message-buffer))) + + (:draft + (let ((buf (make-buffer + name :delete-hook '(cleanup-draft-buffer)))) + (setf (buffer-minor-mode buf "Draft") t) + buf)))) + ((hemlock-bound-p 'headers-information :buffer buf) + (setf (buffer-writable buf) t) + (delete-region (buffer-region buf)) + (cleanup-headers-buffer buf) + (delete-variable 'headers-information :buffer buf) + buf) + ((hemlock-bound-p 'message-information :buffer buf) + (setf (buffer-writable buf) t) + (delete-region (buffer-region buf)) + (cleanup-message-buffer buf) + (delete-variable 'message-information :buffer buf) + buf) + ((hemlock-bound-p 'draft-information :buffer buf) + (error "Attempt to create multiple draft buffers to same draft ~ + folder message -- ~S" + name))))) + + + +;;;; Message buffer modeline fields. + +(make-modeline-field + :name :deleted-message :width 2 + :function + #'(lambda (buffer window) + "Returns \"D \" when message in buffer is deleted." + (declare (ignore window)) + (let* ((minfo (variable-value 'message-information :buffer buffer)) + (hmark (message-info-headers-mark minfo))) + (cond ((not hmark) + (let ((msgs (message-info-msgs minfo))) + (if (and (value virtual-message-deletion) + (mh-sequence-member-p + (if (consp msgs) (car msgs) msgs) + (mh-sequence-list (message-info-folder minfo) + "hemlockdeleted"))) + "D " + ""))) + ((line-message-deleted (mark-line hmark)) + "D ") + (t ""))))) + +(make-modeline-field + :name :replied-to-message :width 1 + :function + #'(lambda (buffer window) + "Returns \"A\" when message in buffer is deleted." + (declare (ignore window)) + (let* ((minfo (variable-value 'message-information :buffer buffer)) + (hmark (message-info-headers-mark minfo))) + (cond ((not hmark) + ;; Could do something nasty here to figure out the right value. + "") + (t + (mark-to-note-replied-msg hmark) + (if (char= (next-character hmark) #\A) + "A" + "")))))) + +;;; MARK-TO-NOTE-REPLIED-MSG moves the headers-buffer mark to a line position +;;; suitable for checking or setting the next character with respect to noting +;;; that a message has been replied to. +;;; +(defun mark-to-note-replied-msg (hmark) + (line-start hmark) + (find-attribute hmark :digit) + (find-attribute hmark :digit #'zerop) + (character-offset hmark 1)) + + +(defhvar "Default Message Modeline Fields" + "This is the default list of modeline-field objects for message buffers." + :value + (list (modeline-field :hemlock-literal) (modeline-field :package) + (modeline-field :modes) (modeline-field :buffer-name) + (modeline-field :replied-to-message) (modeline-field :deleted-message) + (modeline-field :buffer-pathname) (modeline-field :modifiedp))) + + + + +;;;; MH interface. + +;;; Running an MH utility. +;;; + +(defhvar "MH Utility Pathname" + "MH utility names are merged with this. The default is + \"/usr/misc/.mh/bin/\"." + :value (pathname "/usr/misc/.mh/bin/")) + +(defvar *signal-mh-errors* t + "This is the default value for whether MH signals errors. It is useful to + bind this to nil when using PICK-MESSAGES with the \"Incorporate New Mail + Hook\".") + +(defvar *mh-error-output* (make-string-output-stream)) + +(defun mh (utility args &key (errorp *signal-mh-errors*) environment) + "Runs the MH utility with the list of args (suitable for EXT:RUN-PROGRAM), + outputting to *standard-output*. Environment is a list of strings + appended with ext:*environment-list*. This returns t, unless there is + an error. When errorp, this reports any MH errors in the echo area as + an editor error, and this does not return; otherwise, nil and the error + output from the MH utility are returned." + (fresh-line) + (let* ((utility + (namestring + (or (probe-file (merge-pathnames utility + (value mh-utility-pathname))) + utility))) + (proc (ext:run-program + utility args + :output *standard-output* + :error *mh-error-output* + :env (append environment ext:*environment-list*)))) + (fresh-line) + (ext:process-close proc) + (cond ((zerop (ext:process-exit-code proc)) + (values t nil)) + (errorp + (editor-error "MH Error -- ~A" + (get-output-stream-string *mh-error-output*))) + (t (values nil (get-output-stream-string *mh-error-output*)))))) + + + +;;; Draft folder name and pathname. +;;; + +(defun mh-draft-folder () + (let ((drafts (mh-profile-component "draft-folder"))) + (unless drafts + (error "There must be a draft-folder component in your profile.")) + drafts)) + +(defun mh-draft-folder-pathname () + "Returns the pathname of the MH draft folder directory." + (let ((drafts (mh-profile-component "draft-folder"))) + (unless drafts + (error "There must be a draft-folder component in your profile.")) + (merge-relative-pathnames drafts (mh-directory-pathname)))) + + +;;; Current folder name. +;;; + +(defun mh-current-folder () + "Returns the current MH folder from the context file." + (mh-profile-component "current-folder" (mh-context-pathname))) + + +;;; Current message name. +;;; + +(defun mh-current-message (folder) + "Returns the current MH message from the folder's sequence file." + (declare (simple-string folder)) + (let ((folder (strip-folder-name folder))) + (mh-profile-component + "cur" + (merge-pathnames ".mh_sequences" + (merge-relative-pathnames folder + (mh-directory-pathname)))))) + + +;;; Context pathname. +;;; + +(defvar *mh-context-pathname* nil) + +(defun mh-context-pathname () + "Returns the pathname of the MH context file." + (or *mh-context-pathname* + (setf *mh-context-pathname* + (merge-pathnames (or (mh-profile-component "context") "context") + (mh-directory-pathname))))) + + +;;; MH directory pathname. +;;; + +(defvar *mh-directory-pathname* nil) + +;;; MH-DIRECTORY-PATHNAME fetches the "path" MH component and bashes it +;;; appropriately to get an absolute directory pathname. +;;; +(defun mh-directory-pathname () + "Returns the pathname of the MH directory." + (if *mh-directory-pathname* + *mh-directory-pathname* + (let ((path (mh-profile-component "path"))) + (unless path (error "MH profile does not contain a Path component.")) + (setf *mh-directory-pathname* + (truename (merge-relative-pathnames path + (user-homedir-pathname))))))) + +;;; Profile components. +;;; + +(defun mh-profile-component (name &optional (pathname (mh-profile-pathname)) + (error-on-open t)) + "Returns the trimmed string value for the MH profile component name. If + the component is not present, nil is returned. This may be used on MH + context and sequence files as well due to their having the same format. + Error-on-open indicates that errors generated by OPEN should not be ignored, + which is the default. When opening a sequence file, it is better to supply + this as nil since the file may not exist or be readable in another user's + MH folder, and returning nil meaning the sequence could not be found is just + as useful." + (with-open-stream (s (if error-on-open + (open pathname) + (ignore-errors (open pathname)))) + (if s + (loop + (multiple-value-bind (line eofp) (read-line s nil :eof) + (when (eq line :eof) (return nil)) + (let ((colon (position #\: (the simple-string line) :test #'char=))) + (unless colon + (error "Bad record ~S in file ~S." line (namestring pathname))) + (when (string-equal name line :end2 colon) + (return (string-trim '(#\space #\tab) + (subseq line (1+ colon)))))) + (when eofp (return nil))))))) + + +;;; Profile pathname. +;;; + +(defvar *mh-profile-pathname* nil) + +(defun mh-profile-pathname () + "Returns the pathname of the MH profile." + (or *mh-profile-pathname* + (setf *mh-profile-pathname* + (merge-pathnames (or (cdr (assoc :mh ext:*environment-list*)) + ".mh_profile") + (truename (user-homedir-pathname)))))) + + + + +;;;; Sequence handling. + +(declaim (optimize (speed 2))); byte compile off + +(defun mark-one-message (folder msg sequence add-or-delete) + "Msg is added or deleted to the sequence named sequence in the folder's + \".mh_sequence\" file. Add-or-delete is either :add or :delete." + (let ((seq-list (mh-sequence-list folder sequence))) + (ecase add-or-delete + (:add + (write-mh-sequence folder sequence (mh-sequence-insert msg seq-list))) + (:delete + (when (mh-sequence-member-p msg seq-list) + (write-mh-sequence folder sequence + (mh-sequence-delete msg seq-list))))))) + + +(defun mh-sequence-list (folder name) + "Returns a list representing the messages and ranges of id's for the + sequence name in folder from the \".mh_sequences\" file. A second value + is returned indicating whether the sequence was found or not." + (declare (simple-string folder)) + (let* ((folder (strip-folder-name folder)) + (seq-string (mh-profile-component + name + (merge-pathnames ".mh_sequences" + (merge-relative-pathnames + folder (mh-directory-pathname))) + nil))) + (if (not seq-string) + (values nil nil) + (let ((length (length (the simple-string seq-string))) + (result ()) + (intervalp nil) + (start 0)) + (declare (fixnum length start)) + (loop + (multiple-value-bind (msg index) + (parse-integer seq-string + :start start :end length + :junk-allowed t) + (unless msg (return)) + (cond ((or (= index length) + (char/= (schar seq-string index) #\-)) + (if intervalp + (setf (cdar result) msg) + (push (cons msg msg) result)) + (setf intervalp nil) + (setf start index)) + (t + (push (cons msg nil) result) + (setf intervalp t) + (setf start (1+ index))))) + (when (>= start length) (return))) + (values (nreverse result) t))))) + +(defun write-mh-sequence (folder name seq-list) + "Writes seq-list to folder's \".mh_sequences\" file. If seq-list is nil, + the sequence is removed from the file." + (declare (simple-string folder)) + (let* ((folder (strip-folder-name folder)) + (input (merge-pathnames ".mh_sequences" + (merge-relative-pathnames + folder (mh-directory-pathname)))) + (input-dir (pathname (directory-namestring input))) + (output (loop (let* ((sym (gensym)) + (f (merge-pathnames + (format nil "sequence-file-~A.tmp" sym) + input-dir))) + (unless (probe-file f) (return f))))) + (found nil)) + (cond ((not (hemlock-ext:file-writable output)) + (loud-message "Cannot write sequence temp file ~A.~%~ + Aborting output of ~S sequence." + name (namestring output))) + (t + (with-open-file (in input) + (with-open-file (out output :direction :output) + (loop + (multiple-value-bind (line eofp) (read-line in nil :eof) + (when (eq line :eof) + (return nil)) + (let ((colon (position #\: (the simple-string line) + :test #'char=))) + (unless colon + (error "Bad record ~S in file ~S." + line (namestring input))) + (cond ((and (not found) (string-equal name line + :end2 colon)) + (sub-write-mh-sequence + out (subseq line 0 colon) seq-list) + (setf found t)) + (t (write-line line out)))) + (when eofp (return)))) + (unless found + (fresh-line out) + (sub-write-mh-sequence out name seq-list)))) + (hacking-rename-file output input))))) + +(defun sub-write-mh-sequence (stream name seq-list) + (when seq-list + (write-string name stream) + (write-char #\: stream) + (let ((*print-base* 10)) + (dolist (range seq-list) + (write-char #\space stream) + (let ((low (car range)) + (high (cdr range))) + (declare (fixnum low high)) + (cond ((= low high) + (prin1 low stream)) + (t (prin1 low stream) + (write-char #\- stream) + (prin1 high stream)))))) + (terpri stream))) + + +;;; MH-SEQUENCE-< keeps SORT from consing rest args when FUNCALL'ing #'<. +;;; +(defun mh-sequence-< (x y) + (< x y)) + +(defun mh-sequence-insert (item seq-list) + "Inserts item into an mh sequence list. Item can be a string (\"23\"), + number (23), or a cons of two numbers ((23 . 23) or (3 . 5))." + (let ((range (typecase item + (string (let ((id (parse-integer item))) + (cons id id))) + (cons item) + (number (cons item item))))) + (cond (seq-list + (setf seq-list (sort (cons range seq-list) + #'mh-sequence-< :key #'car)) + (coelesce-mh-sequence-ranges seq-list)) + (t (list range))))) + +(defun coelesce-mh-sequence-ranges (seq-list) + (when seq-list + (let* ((current seq-list) + (next (cdr seq-list)) + (current-range (car current)) + (current-end (cdr current-range))) + (declare (fixnum current-end)) + (loop + (unless next + (setf (cdr current-range) current-end) + (setf (cdr current) nil) + (return)) + (let* ((next-range (car next)) + (next-start (car next-range)) + (next-end (cdr next-range))) + (declare (fixnum next-start next-end)) + (cond ((<= (1- next-start) current-end) + ;; + ;; Extend the current range since the next one overlaps. + (when (> next-end current-end) + (setf current-end next-end))) + (t + ;; + ;; Update the current range since the next one doesn't overlap. + (setf (cdr current-range) current-end) + ;; + ;; Make the next range succeed current. Then make it current. + (setf (cdr current) next) + (setf current next) + (setf current-range next-range) + (setf current-end next-end)))) + (setf next (cdr next)))) + seq-list)) + + +(defun mh-sequence-delete (item seq-list) + "Inserts item into an mh sequence list. Item can be a string (\"23\"), + number (23), or a cons of two numbers ((23 . 23) or (3 . 5))." + (let ((range (typecase item + (string (let ((id (parse-integer item))) + (cons id id))) + (cons item) + (number (cons item item))))) + (when seq-list + (do ((id (car range) (1+ id)) + (end (cdr range))) + ((> id end)) + (setf seq-list (sub-mh-sequence-delete id seq-list))) + seq-list))) + +(defun sub-mh-sequence-delete (id seq-list) + (do ((prev nil seq) + (seq seq-list (cdr seq))) + ((null seq)) + (let* ((range (car seq)) + (low (car range)) + (high (cdr range))) + (cond ((> id high)) + ((< id low) + (return)) + ((= id low) + (cond ((/= low high) + (setf (car range) (1+ id))) + (prev + (setf (cdr prev) (cdr seq))) + (t (setf seq-list (cdr seq-list)))) + (return)) + ((= id high) + (setf (cdr range) (1- id)) + (return)) + ((< low id high) + (setf (cdr range) (1- id)) + (setf (cdr seq) (cons (cons (1+ id) high) (cdr seq))) + (return))))) + seq-list) + + +(defun mh-sequence-member-p (item seq-list) + "Returns to or nil whether item is in the mh sequence list. Item can be a + string (\"23\") or a number (23)." + (let ((id (typecase item + (string (parse-integer item)) + (number item)))) + (dolist (range seq-list nil) + (let ((low (car range)) + (high (cdr range))) + (when (<= low id high) (return t)))))) + + +(defun mh-sequence-strings (seq-list) + "Returns a list of strings representing the ranges and messages id's in + seq-list." + (let ((result nil)) + (dolist (range seq-list) + (let ((low (car range)) + (high (cdr range))) + (if (= low high) + (push (number-string low) result) + (push (format nil "~D-~D" low high) result)))) + (nreverse result))) + +(declaim (optimize (speed 0))); byte compile again. + + +;;;; CMU Common Lisp support. + +;;; HACKING-RENAME-FILE renames old to new. This is used instead of Common +;;; Lisp's RENAME-FILE because it merges new pathname with old pathname, +;;; which loses when old has a name and type, and new has only a type (a +;;; Unix-oid "dot" file). +;;; +(defun hacking-rename-file (old new) + (let ((ses-name1 (namestring old)) + (ses-name2 (namestring new))) + (multiple-value-bind (res err) (unix:unix-rename ses-name1 ses-name2) + (unless res + (error "Failed to rename ~A to ~A: ~A." + ses-name1 ses-name2 (unix:get-unix-error-msg err)))))) + + +;;; Folder existence and creation. +;;; + +(defun folder-existsp (folder) + "Returns t if the directory for folder exists. Folder is a simple-string + specifying a folder name relative to the MH mail directoy." + (declare (simple-string folder)) + (let* ((folder (strip-folder-name folder)) + (pathname (merge-relative-pathnames folder (mh-directory-pathname))) + (pf (probe-file pathname))) + (and pf + (null (pathname-name pf)) + (null (pathname-type pf))))) + +(defun create-folder (folder) + "Creates folder directory with default protection #o711 but considers the + MH profile for the \"Folder-Protect\" component. Folder is a simple-string + specifying a folder name relative to the MH mail directory." + (declare (simple-string folder)) + (let* ((folder (strip-folder-name folder)) + (pathname (merge-relative-pathnames folder (mh-directory-pathname))) + (ses-name (namestring pathname)) + (length-1 (1- (length ses-name))) + (name (if (= (position #\/ ses-name :test #'char= :from-end t) + length-1) + (subseq ses-name 0 (1- (length ses-name))) + ses-name)) + (protection (mh-profile-component "folder-protect"))) + (when protection + (setf protection + (parse-integer protection :radix 8 :junk-allowed t))) + (multiple-value-bind (winp err) + (unix:unix-mkdir name (or protection #o711)) + (unless winp + (error "Couldn't make directory ~S: ~A" + name + (unix:get-unix-error-msg err))) + (check-folder-name-table) + (setf (getstring folder *folder-name-table*) t)))) + + +;;; Checking for mail. +;;; + +(defvar *mailbox* nil) + +(defun new-mail-p () + (unless *mailbox* + (setf *mailbox* + (probe-file (or (cdr (assoc :mail ext:*environment-list*)) + (cdr (assoc :maildrop ext:*environment-list*)) + (mh-profile-component "MailDrop") + (merge-pathnames + (cdr (assoc :user ext:*environment-list*)) + "/usr/spool/mail/"))))) + (when *mailbox* + (multiple-value-bind (success dev ino mode nlink uid gid rdev size + atime) + (unix:unix-stat (namestring *mailbox*)) + (declare (ignore dev ino nlink uid gid rdev atime)) + (and success + (plusp (logand unix:s-ifreg mode)) + (not (zerop size)))))) + + + Index: /branches/ide-1.0/ccl/hemlock/src/archive/netnews.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/archive/netnews.lisp (revision 6567) +++ /branches/ide-1.0/ccl/hemlock/src/archive/netnews.lisp (revision 6567) @@ -0,0 +1,2407 @@ +;;; -*- Package: Hemlock; Log: hemlock.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Written by Blaine Burks +;;; +;;; This file implements the reading of bulletin boards from within Hemlock +;;; via a known NNTP server. Something should probably be done so that +;;; when the server is down Hemlock doesn't hang as I suspect it will. +;;; +;;; Warning: Throughout this file, it may appear I should have bound +;;; the nn-info-stream and nn-info-header-stream slots instead +;;; of making multiple structure accesses. This was done on +;;; purpose because we don't find out if NNTP timed us out until +;;; we make an attempt to execute another command. This code +;;; recovers by resetting the header-stream and stream slots in +;;; the nn-info structure to new streams. If the structure +;;; access were not made again and NNTP had timed us out, we +;;; would be making requests on a defunct stream. +;;; + +(in-package :hemlock) + + + + +;;;; Netnews data structures. + +(defparameter default-netnews-headers-length 1000 + "How long the header-cache and message-ids arrays should be made on startup.") + +(defstruct (netnews-info + (:conc-name nn-info-) + (:print-function + (lambda (nn s d) + (declare (ignore nn d)) + (write-string "#" s)))) + (updatep (ext:required-argument) :type (or null t)) + (from-end-p nil :type (or null t)) + ;; + ;; The string name of the current group. + (current (ext:required-argument) :type simple-string) + ;; + ;; The number of the latest message read in the current group. + (latest nil :type (or null fixnum)) + ;; + ;; The cache of header info for the current group. Each element contains + ;; an association list of header fields to contents of those fields. Indexed + ;; by id offset by the first message in the group. + (header-cache nil :type (or null simple-vector)) + ;; + ;; The number of HEAD requests currently waiting on the header stream. + (batch-count nil :type (or null fixnum)) + ;; + ;; The list of newsgroups to read. + (groups (ext:required-argument) :type cons) + ;; + ;; A vector of message ids indexed by buffer-line for this headers buffer. + (message-ids nil :type (or null vector)) + ;; + ;; Where to insert the next batch of headers. + mark + ;; + ;; The message buffer used to view article bodies. + buffer + ;; + ;; A list of message buffers that have been marked as undeletable by the user. + (other-buffers nil :type (or null cons)) + ;; + ;; The window used to display buffer when \"Netnews Read Style\" is :multiple. + message-window + ;; + ;; The window used to display headers when \"Netnews Read Style\" is + ;; :multiple. + headers-window + ;; + ;; How long the message-ids and header-cache arrays are. Reuse this array, + ;; but don't break if there are more messages than we can handle. + (array-length default-netnews-headers-length :type fixnum) + ;; + ;; The id of the first message in the current group. + (first nil :type (or null fixnum)) + ;; + ;; The id of the last message in the current-group. + (last nil :type (or null fixnum)) + ;; + ;; Article number of the first visible header. + (first-visible nil :type (or null fixnum)) + ;; + ;; Article number of the last visible header. + (last-visible nil :type (or null fixnum)) + ;; + ;; Number of the message that is currently displayed in buffer. Initialize + ;; to -1 so I don't have to constantly check for the nullness of it. + (current-displayed-message -1 :type (or null fixnum)) + ;; + ;; T if the last batch of headers is waiting on the header stream. + ;; This is needed so NN-WRITE-HEADERS-TO-MARK can set the messages-waiting + ;; slot to nil. + (last-batch-p nil :type (or null t)) + ;; + ;; T if there are more headers in the current group. Nil otherwise. + (messages-waiting nil :type (or null t)) + ;; + ;; The stream on which we request headers from NNTP. + header-stream + ;; + ;; The stream on which we request everything but headers from NNTP. + stream) + +(defmode "News-Headers" :major-p t) + + + + +;;;; The netnews-message-info and post-info structures. + +(defstruct (netnews-message-info + (:conc-name nm-info-) + (:print-function + (lambda (nn s d) + (declare (ignore nn d)) + (write-string "#" s)))) + ;; The headers buffer (if there is one) associated with this message buffer. + headers-buffer + ;; The draft buffer (if there is one) associated with this message buffer. + draft-buffer + ;; The post buffer (if there is one) associated with this message buffer. + post-buffer + ;; This is need because we want to display what message this is in the + ;; modeline field of a message buffer. + (message-number nil :type (or null fixnum)) + ;; Set to T when we do not want to reuse this buffer. + keep-p) + +(defstruct (post-info + (:print-function + (lambda (nn s d) + (declare (ignore nn d)) + (write-string "#" s)))) + ;; The NNTP stream over which to send this post. + stream + ;; When replying in another window, the reply window. + reply-window + ;; When replying in another window, the message window. + message-window + ;; The message buffer associated with this post. + message-buffer + ;; The Headers buffer associated with this post. + headers-buffer) + + + + +;;;; Command Level Implementation of "News-Headers" mode. + +(defhvar "Netnews Database File" + "This value is merged with your home directory to get a path to your netnews + pointers file." + :value ".hemlock-netnews") + +(defhvar "Netnews Read Style" + "How you like to read netnews. A value of :single will cause netnews + mode to use a single window for headers and messages, and a value of + :multiple will cause the current window to be split so that Headers take + up \"Netnews Headers Proportion\" of what was the current window, and a + message bodies buffer the remaining portion. Changing the value of this + variable dynamically affects netnews reading." + :value :multiple) + +(unless (modeline-field :netnews-message) + (make-modeline-field + :name :netnews-message + :width 14 + :function #'(lambda (buffer window) + (declare (ignore window)) + (let* ((nm-info (variable-value 'netnews-message-info + :buffer buffer)) + (nn-info (variable-value 'netnews-info + :buffer (nm-info-headers-buffer + nm-info)))) + (format nil "~D of ~D" + (nm-info-message-number nm-info) + (1+ (- (nn-info-last nn-info) + (nn-info-first nn-info)))))))) + +(unless (modeline-field :netnews-header-info) + (make-modeline-field + :name :netnews-header-info + :width 24 + :function + #'(lambda (buffer window) + (declare (ignore window)) + (let ((nn-info (variable-value 'netnews-info :buffer buffer))) + (format nil "~D before, ~D after" + (- (nn-info-first-visible nn-info) (nn-info-first nn-info)) + (- (nn-info-last nn-info) (nn-info-last-visible nn-info))))))) + +(defvar *nn-headers-buffer* nil + "If \"Netnews\" was invoked without an argument an not exited, this + holds the headers buffer for reading netnews.") + +(defvar *netnews-kill-strings* nil) + +(defhvar "Netnews Kill File" + "This value is merged with your home directory to get the pathname of + your netnews kill file. If any of the strings in this file (one per + line) appear in a subject header while reading netnews, they will have a + \"K\" in front of them, and \"Netnews Next Line\" and \"Netnews Previous + Line\" will never land you on one. Use \"Next Line\" and \"Previous + Line\" to read Killed messages. Defaults to \".hemlock-kill\"." + :value ".hemlock-kill") + +(defhvar "Netnews New Group Style" + "Determines what happend when you read a group that you have never read + before. When :from-start, \"Netnews\" will read from the beginning of a + new group forward. When :from-end, the default, \"Netnews\" will read + from the end backward group. Otherwise this variable is a number + indicating that \"Netnews\" should start that many messages from the end + of the group and read forward from there." + :value :from-end) + +(defhvar "Netnews Start Over Threshold" + "If you have read a group before, and the number of new messages exceeds + this number, Hemlock asks whether you want to start reading from the end + of this group. The default is 300." + :value 300) + +(defcommand "Netnews" (p &optional group-name from-end-p browse-buf (updatep t)) + "Enter a headers buffer and read groups from \"Netnews Group File\". + With an argument prompts for a group and reads it." + "Enter a headers buffer and read groups from \"Netnews Group File\". + With an argument prompts for a group and reads it." + (cond + ((and *nn-headers-buffer* (not p) (not group-name)) + (change-to-buffer *nn-headers-buffer*)) + (t + (let* ((single-group (if p (prompt-for-string :prompt "Group to read: " + :help "Type the name of ~ + the group you want ~ + to scan." + :trim t))) + (groups (cond + (group-name (list group-name)) + (single-group (list single-group)) + (t + (let ((group-file (merge-pathnames + (value netnews-group-file) + (user-homedir-pathname)))) + (when (probe-file group-file) + (let ((res nil)) + (with-open-file (s group-file :direction :input) + (loop + (let ((group (read-line s nil nil))) + (unless group (return (nreverse res))) + (pushnew group res))))))))))) + (unless (or p groups) + (editor-error "No groups to read. See \"Netnews Group File\" and ~ + \"Netnews Browse\".")) + (when updatep (nn-assure-database-exists)) + (nn-parse-kill-file) + (multiple-value-bind (stream header-stream) (streams-for-nntp) + (multiple-value-bind + (buffer-name clashp) + (nn-unique-headers-name (car groups)) + (if (and (or p group-name) clashp) + (change-to-buffer (getstring clashp *buffer-names*)) + (let* ((buffer (make-buffer + buffer-name + :modes '("News-Headers") + :modeline-fields + (append (value default-modeline-fields) + (list (modeline-field + :netnews-header-info))) + :delete-hook + (list #'netnews-headers-delete-hook))) + (nn-info (make-netnews-info + :current (car groups) + :groups groups + :updatep updatep + :headers-window (current-window) + :mark (copy-mark (buffer-point buffer)) + :header-stream header-stream + :stream stream))) + (unless (or p group-name) (setf *nn-headers-buffer* buffer)) + (when (and clashp (not (or p group-name))) + (message "Buffer ~S also contains headers for ~A" + clashp (car groups))) + (defhvar "Netnews Info" + "A structure containing the current group, a list of + groups, a book-keeping mark, a stream we get headers on, + and the stream on which we request articles." + :buffer buffer + :value nn-info) + (setf (buffer-writable buffer) nil) + (defhvar "Netnews Browse Buffer" + "This variable is the associated \"News-Browse\" buffer + in a \"News-Headers\" buffer created from + \"News-Browse\" mode." + :buffer buffer + :value browse-buf) + (setup-group (car groups) nn-info buffer from-end-p))))))))) + + +(defun nn-parse-kill-file () + (let ((filename (merge-pathnames (value netnews-kill-file) + (user-homedir-pathname)))) + (when (probe-file filename) + (with-open-file (s filename :direction :input) + (loop + (let ((kill-string (read-line s nil nil))) + (unless kill-string (return)) + (pushnew kill-string *netnews-kill-strings*))))))) + +;;; NETNEWS-HEADERS-DELETE-HOOK closes the stream slots in netnews-info, +;;; deletes the bookkeeping mark into buffer, sets the headers slots of any +;;; associated post-info or netnews-message-info structures to nil so +;;; "Netnews Go To Headers Buffer" will not land you in a buffer that does +;;; not exist, and sets *nn-headers-buffer* to nil so next time we invoke +;;; "Netnews" it will start over. +;;; +(defun netnews-headers-delete-hook (buffer) + (let ((nn-info (variable-value 'netnews-info :buffer buffer))) + ;; Disassociate all message buffers. + ;; + (dolist (buf (nn-info-other-buffers nn-info)) + (setf (nm-info-headers-buffer (variable-value 'netnews-message-info + :buffer buf)) + nil)) + (let ((message-buffer (nn-info-buffer nn-info))) + (when message-buffer + (setf (nm-info-headers-buffer (variable-value 'netnews-message-info + :buffer message-buffer)) + nil))) + (close (nn-info-stream nn-info)) + (close (nn-info-header-stream nn-info)) + (delete-mark (nn-info-mark nn-info)) + (when (eq *nn-headers-buffer* buffer) + (setf *nn-headers-buffer* nil)))) + +(defun nn-unique-headers-name (group-name) + (let ((original-name (concatenate 'simple-string "Netnews " group-name))) + (if (getstring original-name *buffer-names*) + (let ((name nil) + (number 0)) + (loop + (setf name (format nil "Netnews ~A ~D" group-name (incf number))) + (unless (getstring name *buffer-names*) + (return (values name original-name))))) + (values original-name nil)))) + +;;; NN-ASSURE-DATABASE-EXISTS does just that. If the file determined by the +;;; value of "Netnews Database Filename" does not exist, then it gets +;;; created. +;;; +(defun nn-assure-database-exists () + (let ((filename (merge-pathnames (value netnews-database-file) + (user-homedir-pathname)))) + (unless (probe-file filename) + (message "Creating netnews database file.") + (close (open filename :direction :output :if-does-not-exist :create))))) + +(defhvar "Netnews Fetch All Headers" + "When NIL, all netnews reading commands will fetch headers in batches for + increased efficiency. Any other value will cause these commands to fetch + all the headers. This will take a long time if there are a lot." + :value nil) + +(defcommand "Netnews Look at Newsgroup" (p) + "Prompts for the name of a newsgroup and reads it, regardless of what is + in and not modifying the \"Netnews Database File\"." + "Prompts for the name of a newsgroup and reads it, regardless of what is + in and not modifying the \"Netnews Database File\"." + (declare (ignore p)) + (netnews-command nil (prompt-for-string :prompt "Group to look at: " + :help "Type the name of ~ + the group you want ~ + to look at." + :trim t) + nil nil nil)) + +;;; SETUP-GROUP is the guts of this group reader. It sets up a headers +;;; buffer in buffer for group group-name. This consists of sending a group +;;; command to both the header-stream and normal stream and then getting the +;;; last message read in group-name from the database file and setting the +;;; appropriate slots in the nn-info structure. The first batch of messages +;;; is then requested and inserted, and room for message-ids is allocated. +;;; +(defun setup-group (group-name nn-info buffer &optional from-end-p) + ;; Do not bind stream or header-stream because if a timeout has occurred + ;; before these calls are invoked, they would be bogus. + ;; + (nntp-group group-name (nn-info-stream nn-info) + (nn-info-header-stream nn-info)) + (process-status-response (nn-info-stream nn-info) nn-info) + (let ((response (process-status-response (nn-info-header-stream nn-info) + nn-info))) + (cond ((not response) + (message "~A is not the name of a netnews group.~%" + (nn-info-current nn-info)) + (change-to-next-group nn-info buffer)) + (t + (multiple-value-bind (number first last) + (group-response-args response) + (declare (ignore first)) + (message "Setting up ~A" group-name) + ;; If nn-info-updatep is nil, then we fool ourselves into + ;; thinking we've never read this group before by making + ;; last-read nil. We determine first here because the first + ;; that NNTP gives us is way way out of line. + ;; + (let ((last-read (if (nn-info-updatep nn-info) + (nn-last-read-message-number group-name))) + (first (1+ (- last number)))) + ;; Make sure there is at least one new message in this group. + (cond + ((and last-read (= last-read last)) + (message "No new messages in ~A" group-name) + (setf (nn-info-latest nn-info) last) + (change-to-next-group nn-info buffer)) + ((zerop number) + (message "No messages AVAILABLE in ~A" group-name) + (setf (nn-info-latest nn-info) last) + (change-to-next-group nn-info buffer)) + (t + (let ((latest (if (and last-read (> last-read first)) + last-read + first))) + (if (or (and (eq (value netnews-new-group-style) :from-end) + (or (= latest first) + (and (> (- last latest) + (value + netnews-start-over-threshold)) + (prompt-for-y-or-n + :prompt + `("There are ~D new messages. ~ + Read from the end of this ~ + group? " ,(- last latest)) + :default "Y" + :default-string "Y" + :help "Y starts reading from the ~ + end. N starts reading where ~ + you left off many messages ~ + back.")))) + from-end-p) + (setf (nn-info-from-end-p nn-info) t)) + + (cond ((nn-info-from-end-p nn-info) + (setf (nn-info-first-visible nn-info) nil) + (setf (nn-info-last-visible nn-info) last)) + (t + ; (setf (nn-info-first-visible nn-info) latest) + (setf (nn-info-first-visible nn-info) (1+ latest)) + (setf (nn-info-last-visible nn-info) nil))) + (setf (nn-info-first nn-info) first) + (setf (nn-info-last nn-info) last) + (setf (nn-info-latest nn-info) latest)) + ;; + ;; Request the batch before setting message-ids so they start + ;; coming before we need them. + (nn-request-next-batch nn-info + (value netnews-fetch-all-headers)) + (let ((message-ids (nn-info-message-ids nn-info)) + (header-cache (nn-info-header-cache nn-info)) + (length (1+ (- last first)))) + (multiple-value-setq + (message-ids header-cache) + (cond ((> length (nn-info-array-length nn-info)) + (setf (nn-info-array-length nn-info) length) + (values (make-array length :fill-pointer 0) + (make-array length + :initial-element nil))) + (message-ids + (setf (fill-pointer message-ids) 0) + (values message-ids header-cache)) + (t + (values (make-array (nn-info-array-length nn-info) + :fill-pointer 0) + (make-array (nn-info-array-length nn-info) + :initial-element nil))))) + (setf (nn-info-message-ids nn-info) message-ids) + (setf (nn-info-header-cache nn-info) header-cache)) + (nn-write-headers-to-mark nn-info buffer) + (change-to-buffer buffer))))))))) + +;;; NN-LAST-READ-MESSAGE-NUMBER reads the last read message in group-name +;;; from the value of "Netnews Database File". It is SETF'able and the +;;; SETF method is %SET-LAST-READ-MESSAGE-NUMBER. +;;; +(defun nn-last-read-message-number (group-name) + (with-open-file (s (merge-pathnames (value netnews-database-file) + (user-homedir-pathname)) + :direction :input :if-does-not-exist :error) + (loop + (let ((read-group-name (read-line s nil nil))) + (unless read-group-name (return nil)) + (when (string-equal read-group-name group-name) + (let ((last-read (read-line s nil nil))) + (if last-read + (return (parse-integer last-read)) + (error "Should have been a message number ~ + following ~S in database file." + group-name)))))))) + +(defun %set-nn-last-read-message-number (group-name new-value) + (with-open-file (s (merge-pathnames (value netnews-database-file) + (user-homedir-pathname)) + :direction :io :if-does-not-exist :error + :if-exists :overwrite) + (unless (loop + (let ((read-group-name (read-line s nil nil))) + (unless read-group-name (return nil)) + (when (string-equal read-group-name group-name) + ;; File descriptor streams do not do the right thing with + ;; :io/:overwrite streams, so work around it by setting it + ;; explicitly. + ;; + (file-position s (file-position s)) + ;; Justify the number so that if the number of digits in it + ;; changes, we won't overwrite the next group name. + ;; + (format s "~14D~%" new-value) + (return t)))) + (write-line group-name s) + (format s "~14D~%" new-value)))) + +(defsetf nn-last-read-message-number %set-nn-last-read-message-number) + +(defconstant nntp-eof ". +" + "NNTP marks the end of a textual response with this. NNTP also recognizes + this as the end of a post.") + +;;; This macro binds a variable to each successive line of input from NNTP +;;; and exits when it sees the NNTP end-of-file-marker, a period by itself on +;;; a line. +;;; +(defmacro with-input-from-nntp ((var stream) &body body) + "Body is executed with var bound to successive lines of input from nntp. + Exits at the end of a response, returning whatever the last execution of + Body returns, or nil if there was no input. + Take note: this is only to be used for textual responses. Status responses + are of an entirely different nature." + (let ((return-value (gensym))) + `(let ((,return-value nil) + (,var "")) + (declare (simple-string ,var)) + (loop + (setf ,var (read-line ,stream)) + (when (string= ,var nntp-eof) (return ,return-value)) + (setf ,return-value (progn ,@body)))))) + + +;;; Writing the date, from, and subject fields to a mark. + +(defhvar "Netnews Before Date Field Pad" + "How many spaces should be inserted before the date in Netnews. The default + is 1." + :value 1) + +(defhvar "Netnews Date Field Length" + "How long the date field should be in \"News-Headers\" buffers. The + default is 6" + :value 6) + +(defhvar "Netnews Line Field Length" + "How long the line field should be in \"News-Headers\" buffers. The + default is 3" + :value 3) + +(defhvar "Netnews From Field Length" + "How long the from field should be in \"News-Headers\" buffers. The + default is 20." + :value 20) + +(defhvar "Netnews Subject Field Length" + "How long the subject field should be in \"News-Headers\" buffers. The + default is 43." + :value 43) + +(defhvar "Netnews Field Padding" + "How many spaces should be left between the netnews date, from, lines, and + subject fields. The default is 2." + :value 2) + +;;; +(defconstant netnews-space-string + (make-string 70 :initial-element #\space)) +;;; +(defconstant missing-message (cons nil nil) + "Use this as a marker so nn-write-headers-to-mark doesn't try to insert + a message that is not really there.") + +;;; NN-CACHE-HEADER-INFO stashes all header information into an array for +;;; later use. +;;; +(defun nn-cache-header-info (nn-info howmany use-header-stream-p) + (let* ((cache (nn-info-header-cache nn-info)) + (message-ids (nn-info-message-ids nn-info)) + (stream (if use-header-stream-p + (nn-info-header-stream nn-info) + (nn-info-stream nn-info))) + (from-end-p (nn-info-from-end-p nn-info)) + (old-count 0)) + (declare (fixnum old-count)) + (when from-end-p + (setf old-count (length message-ids)) + (do ((i (length message-ids) (1- i))) + ((minusp i) nil) + (setf (aref message-ids (+ i howmany)) (aref message-ids i))) + (setf (fill-pointer message-ids) 0)) + (let ((missing-message-count 0) + (offset (nn-info-first nn-info))) + (dotimes (i howmany) + (let ((response (process-status-response stream))) + (if response + (let* ((id (head-response-args response)) + (index (- id offset))) + (vector-push id message-ids) + (setf (svref cache index) nil) + (with-input-from-nntp (string stream) + (let ((colonpos (position #\: string))) + (when colonpos + (push (cons (subseq string 0 colonpos) + (subseq string + (+ colonpos 2))) + (svref cache index)))))) + (incf missing-message-count)))) + (when from-end-p + (when (plusp missing-message-count) + (dotimes (i old-count) + (setf (aref message-ids (- (+ i howmany) missing-message-count)) + (aref message-ids (+ i howmany))))) + (setf (fill-pointer message-ids) + (- (+ old-count howmany) missing-message-count)))))) + +(defconstant netnews-field-na "NA" + "This string gets inserted when NNTP doesn't find a field.") + +(defconstant netnews-field-na-length (length netnews-field-na) + "The length of netnews-field-na") + +(defun nn-write-headers-to-mark (nn-info buffer &optional fetch-rest-p + out-of-order-p) + (let* ((howmany (nn-info-batch-count nn-info)) + (from-end-p (nn-info-from-end-p nn-info)) + (cache (nn-info-header-cache nn-info)) + (old-point (copy-mark (buffer-point buffer) (if from-end-p + :left-inserting + :right-inserting))) + (messages-waiting (nn-info-messages-waiting nn-info)) + (mark (nn-info-mark nn-info))) + (unless messages-waiting + (return-from nn-write-headers-to-mark nil)) + (if from-end-p + (buffer-start mark) + (buffer-end mark)) + (nn-cache-header-info nn-info howmany (not out-of-order-p)) + (with-writable-buffer (buffer) + (with-mark ((check-point mark :right-inserting)) + (macrolet ((mark-to-pos (mark pos) + `(insert-string ,mark netnews-space-string + 0 (- ,pos (mark-column ,mark)))) + (insert-field (mark field-string field-length) + `(if ,field-string + (insert-string ,mark ,field-string + 0 (min ,field-length + (1- (length ,field-string)))) + (insert-string ,mark netnews-field-na + 0 (min ,field-length + netnews-field-na-length))))) + (let* ((line-start (+ (value netnews-before-date-field-pad) + (value netnews-date-field-length) + (value netnews-field-padding))) + (from-start (+ line-start + (value netnews-line-field-length) + (value netnews-field-padding))) + (subject-start (+ from-start + (value netnews-from-field-length) + (value netnews-field-padding))) + (start (- messages-waiting (nn-info-first nn-info))) + (end (1- (+ start howmany)))) + (do ((i start (1+ i))) + ((> i end)) + (let ((assoc-list (svref cache i))) + (unless (null assoc-list) + (insert-string mark netnews-space-string + 0 (value netnews-before-date-field-pad)) + (let* ((date-field (cdr (assoc "date" assoc-list + :test #'string-equal))) + (universal-date (if date-field + (ext:parse-time date-field + :end (1- (length date-field)))))) + (insert-field + mark + (if universal-date + (string-capitalize + (format-universal-time nil universal-date + :style :government + :print-weekday nil)) + date-field) + (value netnews-date-field-length))) + (mark-to-pos mark line-start) + (insert-field mark (cdr (assoc "lines" assoc-list + :test #'string-equal)) + (value netnews-line-field-length)) + (mark-to-pos mark from-start) + (insert-field mark (cdr (assoc "from" assoc-list + :test #'string-equal)) + (value netnews-from-field-length)) + (mark-to-pos mark subject-start) + (insert-field mark (cdr (assoc "subject" assoc-list + :test #'string-equal)) + (value netnews-subject-field-length)) + (insert-character mark #\newline)))))) + (cond (out-of-order-p + (setf (nn-info-first-visible nn-info) messages-waiting)) + (t + (if (nn-info-from-end-p nn-info) + (setf (nn-info-first-visible nn-info) messages-waiting) + (setf (nn-info-last-visible nn-info) + (1- (+ messages-waiting howmany)))) + (if (nn-info-last-batch-p nn-info) + (setf (nn-info-messages-waiting nn-info) nil) + (nn-request-next-batch nn-info fetch-rest-p)))) + (when (mark= mark check-point) + (message "All messages in last batch were missing, getting more.")) + (move-mark (buffer-point buffer) old-point) + (delete-mark old-point))))) + +;;; NN-MAYBE-GET-MORE-HEADERS gets more headers if the point of the headers +;;; buffer is on an empty line and there are some. Returns whether it got more +;;; headers, i.e., if it is time to go on to the next group. +;;; +(defun nn-maybe-get-more-headers (nn-info) + (let ((headers-buffer (line-buffer (mark-line (nn-info-mark nn-info))))) + (when (empty-line-p (buffer-point headers-buffer)) + (cond ((and (nn-info-messages-waiting nn-info) + (not (nn-info-from-end-p nn-info))) + (nn-write-headers-to-mark nn-info headers-buffer) + t) + (t :go-on))))) + +(defhvar "Netnews Batch Count" + "Determines how many headers the Netnews facility will fetch at a time. + The default is 50." + :value 50) + +;;; NN-REQUEST-NEXT-BATCH requests the next batch of messages in a group. +;;; For safety, don't do anything if there is no next-batch start. +;;; +(defun nn-request-next-batch (nn-info &optional fetch-rest-p) + (if (nn-info-from-end-p nn-info) + (nn-request-backward nn-info fetch-rest-p) + (nn-request-forward nn-info fetch-rest-p))) + +(defun nn-request-forward (nn-info fetch-rest-p) + (let* ((last-visible (nn-info-last-visible nn-info)) + (last (nn-info-last nn-info)) + (batch-start (if last-visible + (1+ (nn-info-last-visible nn-info)) + (1+ (nn-info-latest nn-info)))) + (header-stream (nn-info-header-stream nn-info)) + (batch-end (if fetch-rest-p + last + (1- (+ batch-start (value netnews-batch-count)))))) + ;; If this is the last batch, adjust batch-end appropriately. + ;; + (when (>= batch-end last) + (setf batch-end last) + (setf (nn-info-last-batch-p nn-info) t)) + (setf (nn-info-batch-count nn-info) (1+ (- batch-end batch-start))) + (setf (nn-info-messages-waiting nn-info) batch-start) + (nn-send-many-head-requests header-stream batch-start batch-end nil))) + +(defun nn-request-backward (nn-info fetch-rest-p + &optional (use-header-stream-p t)) + (let* ((first-visible (nn-info-first-visible nn-info)) + (batch-end (if first-visible + (1- (nn-info-first-visible nn-info)) + (nn-info-last nn-info))) + (stream (if use-header-stream-p + (nn-info-header-stream nn-info) + (nn-info-stream nn-info))) + (first (nn-info-first nn-info)) + (batch-start (if fetch-rest-p + first + (1+ (- batch-end (value netnews-batch-count)))))) + ;; If this is the last batch, adjust batch-end appropriately. + ;; + (when (<= batch-start first) + (setf batch-start first) + (setf (nn-info-last-batch-p nn-info) t)) + (setf (nn-info-batch-count nn-info) (1+ (- batch-end batch-start))) + (setf (nn-info-messages-waiting nn-info) batch-start) + (nn-send-many-head-requests stream batch-start batch-end + (not use-header-stream-p)))) + +;;; NN-REQUEST-OUT-OF-ORDER is called when the user is reading a group normally +;;; and decides he wants to see some messages before the first one visible. +;;; To accomplish this without disrupting the normal flow of things, we fool +;;; ourselves into thinking we are reading the group from the end, remembering +;;; several slots that could be modified in requesting thesse messages. +;;; When we are done, return state to what it was for reading a group forward. +;;; +(defun nn-request-out-of-order (nn-info headers-buffer) + (let ((messages-waiting (nn-info-messages-waiting nn-info)) + (batch-count (nn-info-batch-count nn-info)) + (last-batch-p (nn-info-last-batch-p nn-info))) + (nn-request-backward nn-info nil nil) + (setf (nn-info-from-end-p nn-info) t) + (nn-write-headers-to-mark nn-info headers-buffer nil t) + (setf (nn-info-messages-waiting nn-info) messages-waiting) + (setf (nn-info-batch-count nn-info) batch-count) + (setf (nn-info-last-batch-p nn-info) last-batch-p) + (setf (nn-info-from-end-p nn-info) nil))) + +(declaim (special *nn-last-command-issued*)) + +(defun nn-send-many-head-requests (stream first last out-of-order-p) + (do ((i first (1+ i))) + ((> i last)) + (nntp-head i stream)) + (setf *nn-last-command-issued* + (list (if out-of-order-p :out-of-order :header) + first last out-of-order-p))) + +(defvar nn-minimum-header-batch-count 30 + "The minimum number of headers to fetch at any given time.") + + + + +;;;; "News-Message" mode. + +(defmode "News-Message" :major-p t) + + + + +;;;; Commands for viewing articles. + +(defcommand "Netnews Show Article" (p) + "Show the message the point is on. If it is the same message that is + already in the message buffer and \"Netnews Read Style\" is :multiple, + then just scroll the window down prefix argument lines" + "Show the message the point is on. If it is the same message that is + already in the message buffer and \"Netnews Read Style\" is :multiple, + then just scroll the window down prefix argument lines" + (nn-show-article (value netnews-info) p)) + +(defcommand "Netnews Next Article" (p) + "Show the next article in the current newsgroup." + "Shows the article on the line preceeding the point in the headers buffer." + (declare (ignore p)) + (let* ((what-next (netnews-next-line-command nil (nn-get-headers-buffer)))) + (when (and (not (eq what-next :done)) + (or (eq what-next t) + (eq (value netnews-last-header-style) :next-article))) + ;; Reget the headers buffer because the call to netnews-next-line-command + ;; might have moved us into a different buffer. + ;; + (nn-show-article (variable-value 'netnews-info + :buffer (nn-get-headers-buffer)) + t)))) + +(defcommand "Netnews Previous Article" (p) + "Show the previous article in the current newsgroup." + "Shows the article on the line after the point in the headers buffer." + (declare (ignore p)) + (let ((buffer (nn-get-headers-buffer))) + (netnews-previous-line-command nil buffer) + (nn-show-article (variable-value 'netnews-info :buffer buffer) t))) + +;;; NN-SHOW-ARTICLE checks first to see if we need to get more headers. If +;;; NN-MAYBE-GET-MORE-HEADERS returns nil then don't do anything because we +;;; changed to the next group. Then see if the message the user has +;;; requested is already in the message buffer. If the it isn't, put it +;;; there. If it is, and maybe-scroll-down is t, then scroll the window +;;; down p lines in :multiple mode, or just change to the buffer in :single +;;; mode. I use scroll-window down becuase this function is called by +;;; "Netnews Show Article", "Netnews Next Article", and "Netnews Previous +;;; Article". It doesn't make sense to scroll the window down if the guy +;;; just read a message, moved the point up one line and invoked "Netnews +;;; Next Article". He expects to see the article again, not the second +;;; page of it. Also check to make sure there is a message under the +;;; point. If there is not, then get some more headers. If there are no +;;; more headers, then go on to the next group. I can read and write. Hi +;;; Bill. Are you having fun grokking my code? Hope so -- Dude. Nothing +;;; like stream of consciousness is there? Come to think of it, this is +;;; kind of like recursive stream of conscious because I'm writing down my +;;; stream of conscious which is about my stream of conscious. I think I'm +;;; insane. In fact I know I am. +;;; +(defun nn-show-article (nn-info dont-scroll-down &optional p) + (let ((headers-buffer (nn-get-headers-buffer)) + (message-buffer (nn-info-buffer nn-info))) + (cond + ((eq (nn-maybe-get-more-headers nn-info) :go-on) + (case (value netnews-last-header-style) + (:this-headers (change-to-buffer headers-buffer) + (buffer-start (buffer-point headers-buffer)) + (editor-error "Last header.")) + (:next-headers (change-to-next-group nn-info headers-buffer)) + (:next-article (change-to-next-group nn-info headers-buffer) + (netnews-show-article-command nil)))) + (t + (cond ((and (not dont-scroll-down) + (= (nn-info-current-displayed-message nn-info) + (array-element-from-mark (buffer-point headers-buffer) + (nn-info-message-ids nn-info)))) + (ecase (value netnews-read-style) + (:single (buffer-start (buffer-point message-buffer)) + (change-to-buffer message-buffer)) + (:multiple + (multiple-value-bind + (headers-window message-window newp) + (nn-assure-multi-windows nn-info) + (nn-put-buffers-in-windows headers-buffer message-buffer + headers-window message-window + :headers) + ;; If both windows were visible to start with, just scroll + ;; down. If they weren't, then show the message over + ;; again. + ;; + (cond (newp (buffer-start (buffer-point message-buffer)) + (buffer-start (window-point message-window))) + (t (netnews-message-scroll-down-command + p message-buffer message-window))))))) + (t + (nn-put-article-in-buffer nn-info headers-buffer) + (setf message-buffer (nn-info-buffer nn-info)) + (multiple-value-bind + (headers-window message-window) + (ecase (value netnews-read-style) ; Only need windows in + (:single (values nil nil)) ; :multiple mode. + (:multiple (nn-assure-multi-windows nn-info))) + (ecase (value netnews-read-style) + (:multiple + ;; When there is only one window displaying the headers + ;; buffer, move the window point of that buffer to the + ;; buffer-point. + (when (= (length (buffer-windows headers-buffer)) 1) + (move-mark (window-point headers-window) + (buffer-point headers-buffer))) + (buffer-start (window-point message-window)) + (nn-put-buffers-in-windows headers-buffer message-buffer + headers-window message-window + :headers)) + (:single (change-to-buffer message-buffer)))))))))) + +(defcommand "Netnews Message Quit" (p) + "Destroy this message buffer, and pop back to the associated headers buffer." + "Destroy this message buffer, and pop back to the associated headers buffer." + (declare (ignore p)) + (unless (hemlock-bound-p 'netnews-message-info) + (editor-error "Not in a News-Message Buffer")) + (let ((message-buffer (current-buffer))) + (change-to-buffer (nn-get-headers-buffer)) + (delete-buffer-if-possible message-buffer))) + +(defhvar "Netnews Message Header Fields" + "When NIL, the default, all available fields are displayed in the header + of a message. Otherwise, this variable should containt a list of fields + that should be included in the message header when a message is + displayed. Any string name is acceptable. Fields that do not exist are + ignored. If an element of this list is an atom, then it should be the + string name of a field. If it is a cons, then the car should be the + string name of a field, and the cdr should be the length to which this + field should be limited." + :value nil) + + +(defcommand "Netnews Show Whole Header" (p) + "This command will display the entire header of the message currently + being read." + "This command will display the entire header of the message currently + being read." + (declare (ignore p)) + (let* ((headers-buffer (nn-get-headers-buffer)) + (nn-info (variable-value 'netnews-info :buffer headers-buffer)) + (buffer (nn-get-message-buffer nn-info))) + (with-writable-buffer (buffer) + (delete-region (buffer-region buffer)) + (nn-put-article-in-buffer nn-info headers-buffer t)))) + +;;; NN-PUT-ARTICLE-IN-BUFFER puts the article under the point into the +;;; associated message buffer if it is not there already. Uses value of +;;; "Netnews Message Header Fields" to determine what fields should appear +;;; in the message header. Returns the number of the article under the +;;; point. +;;; +(defun nn-put-article-in-buffer (nn-info headers-buffer &optional override) + (let ((stream (nn-info-stream nn-info)) + (article-number (array-element-from-mark + (buffer-point headers-buffer) + (nn-info-message-ids nn-info))) + (message-buffer (nn-get-message-buffer nn-info))) + (setf (nm-info-message-number (variable-value 'netnews-message-info + :buffer message-buffer)) + (1+ (- article-number (nn-info-first nn-info)))) + (cond ((and (= (nn-info-current-displayed-message nn-info) article-number) + (not override)) + (buffer-start (buffer-point message-buffer))) + (t + ;; Request article as soon as possible to avoid waiting for reply. + ;; + (nntp-body article-number stream) + (setf (nn-info-current-displayed-message nn-info) article-number) + (process-status-response stream nn-info) + (with-writable-buffer (message-buffer) + (let ((point (buffer-point message-buffer)) + (info (svref (nn-info-header-cache nn-info) + (- article-number (nn-info-first nn-info)))) + (message-fields (value netnews-message-header-fields)) + key field-length) + (cond ((and message-fields + (not override)) + (dolist (ele message-fields) + (etypecase ele + (atom (setf key ele field-length nil)) + (cons (setf key (car ele) field-length (cdr ele)))) + (let ((field-string (cdr (assoc key info + :test #'string-equal)))) + (when field-string + (insert-string point (string-capitalize key)) + (insert-string point ": ") + (insert-string point field-string + 0 + (max + (if field-length + (min field-length + (1- (length field-string))) + (1- (length field-string))) + 0)) + (insert-character point #\newline))))) + (t + (dolist (ele info) + (insert-string point (string-capitalize (car ele))) + (insert-string point ": ") + (insert-string point (cdr ele) + 0 (max 0 (1- (length (cdr ele))))) + (insert-character point #\newline)))) + (insert-character point #\newline) + (nntp-insert-textual-response point (nn-info-stream nn-info)))) + (buffer-start (buffer-point message-buffer)) + (when (> article-number (nn-info-latest nn-info)) + (setf (nn-info-latest nn-info) article-number)))) + article-number)) + +;;; NN-PUT-BUFFERS-IN-WINDOWS makes sure the message buffer goes in the message +;;; window and the headers buffer in the headers window. If which-current +;;; is :headers, the headers buffer/window will be made current, if it is +;;; :message, the message buffer/window will be made current. +;;; +(defun nn-put-buffers-in-windows (headers-buffer message-buffer headers-window + message-window which-current) + (setf (window-buffer message-window) message-buffer + (window-buffer headers-window) headers-buffer) + (setf (current-window) (ecase which-current + (:headers headers-window) + (:message message-window)) + (current-buffer) (case which-current + (:headers headers-buffer) + (:message message-buffer)))) + +(defhvar "Netnews Headers Proportion" + "Determines how much of the current window will display headers when + \"Netnews Read Style\" is :multiple. Defaults to .25" + :value .25) + +(defun nn-assure-multi-windows (nn-info) + (let ((newp nil)) + (unless (and (member (nn-info-message-window nn-info) *window-list*) + (member (nn-info-headers-window nn-info) *window-list*)) + (setf newp t) + (setf (nn-info-message-window nn-info) (current-window) + (nn-info-headers-window nn-info) + (make-window (buffer-start-mark (nn-get-headers-buffer)) + :proportion (value netnews-headers-proportion)))) + (values (nn-info-headers-window nn-info) + (nn-info-message-window nn-info) + newp))) + +;;; NN-GET-MESSAGE-BUFFER returns the message buffer for an nn-info structure. +;;; If there is not one, this function makes it and sets the slot in nn-info. +;;; +(defun nn-get-message-buffer (nn-info) + (let* ((message-buffer (nn-info-buffer nn-info)) + (nm-info (if message-buffer + (variable-value 'netnews-message-info + :buffer message-buffer)))) + (cond ((and message-buffer (not (nm-info-keep-p nm-info))) + (with-writable-buffer (message-buffer) + (delete-region (buffer-region message-buffer))) + message-buffer) + (t + (let ((buf (make-buffer (nn-unique-message-buffer-name + (nn-info-current nn-info)) + :modeline-fields + (append (value default-modeline-fields) + (list (modeline-field + :netnews-message))) + :modes '("News-Message") + :delete-hook + (list #'nn-message-buffer-delete-hook)))) + (setf (nn-info-buffer nn-info) buf) + (defhvar "Netnews Message Info" + "Structure that keeps track of buffers in \"News-Message\" + mode." + :value (make-netnews-message-info + :headers-buffer (current-buffer)) + :buffer buf) + buf))))) + +;;; The usual. Clean everything up. +;;; +(defun nn-message-buffer-delete-hook (buffer) + (let* ((headers-buffer (nm-info-headers-buffer + (variable-value 'netnews-message-info + :buffer buffer))) + (nn-info (variable-value 'netnews-info :buffer headers-buffer)) + (nm-info (variable-value 'netnews-message-info :buffer buffer))) + (setf (nn-info-buffer nn-info) nil) + (setf (nn-info-current-displayed-message nn-info) -1) + (let ((post-buffer (nm-info-post-buffer nm-info))) + (when post-buffer + (setf (post-info-message-buffer (variable-value + 'post-info :buffer post-buffer)) + nil))))) + + +;;; NN-UNIQUE-MESSAGE-BUFFER-NAME likes to have a simple name, i.e. +;;; "Netnews Message for rec.music.synth". When there is already a buffer +;;; by this name, however, we start counting until the name is unique. +;;; +(defun nn-unique-message-buffer-name (group) + (let ((name (concatenate 'simple-string "Netnews Message for " group)) + (number 0)) + (loop + (unless (getstring name *buffer-names*) (return name)) + (setf name (format nil "Netnews Message ~D" number)) + (incf number)))) + +;;; INSERT-TEXTUAL-RESPONSE inserts a textual response from nntp at mark. +;;; +(defun nntp-insert-textual-response (mark stream) + (with-input-from-nntp (string stream) + (insert-string mark string 0 (1- (length string))) + (insert-character mark #\newline))) + +;;; NN-GET-HEADERS-BUFFER returns the headers buffer if we are in a message or +;;; headers buffer. +;;; +(defun nn-get-headers-buffer () + (cond ((hemlock-bound-p 'netnews-info) + (current-buffer)) + ((hemlock-bound-p 'netnews-message-info) + (nm-info-headers-buffer (value netnews-message-info))) + ((hemlock-bound-p 'post-info) + (post-info-headers-buffer (value post-info))) + (t nil))) + + +(defcommand "Netnews Previous Line" (p &optional + (headers-buffer (current-buffer))) + "Moves the point to the last header before the point that is not in your + kill file. If you move off the end of the buffer and there are more + headers, then get them. Otherwise go on to the next group in \"Netnews + Groups\"." + "Moves the point to the last header before the point that is not in your + kill file. If you move off the end of the buffer and there are more + headers, then get them. Otherwise go on to the next group in \"Netnews + Groups\"." + (declare (ignore p)) + (let ((point (buffer-point headers-buffer)) + (nn-info (variable-value 'netnews-info :buffer headers-buffer))) + (with-mark ((original-position point) + (start point) + (end point)) + (loop + (unless (line-offset point -1) + (cond ((and (nn-info-from-end-p nn-info) + (nn-info-messages-waiting nn-info)) + (nn-write-headers-to-mark nn-info headers-buffer) + (netnews-previous-line-command nil headers-buffer)) + (t + (cond ((= (nn-info-first-visible nn-info) + (nn-info-first nn-info)) + (move-mark point original-position) + (editor-error "No previous unKilled headers.")) + (t + (message "Requesting backward...") + (nn-request-out-of-order nn-info headers-buffer) + (netnews-previous-line-command nil headers-buffer)))))) + (line-start (move-mark start point)) + (character-offset (move-mark end start) 1) + (unless (string= (region-to-string (region start end)) "K") + (return)))))) + +(defhvar "Netnews Last Header Style" + "When you read the last message in a newsgroup, this variable determines + what will happen next. Takes one of three values: :this-headers, + :next-headers, or :next-article. :this-headers, the default means put me + in the headers buffer for this newsgroup. :next-headers means go to the + next newsgroup and put me in that headers buffer. :next-article means go + on to the next newsgroup and show me the first unread article." + :value :next-headers) + +(defcommand "Netnews Next Line" + (p &optional (headers-buffer (current-buffer))) + "Moves the point to the next header that is not in your kill file. If you + move off the end of the buffer and there are more headers, then get them. + Otherwise go on to the next group in \"Netnews Groups\"." + "Moves the point to the next header that is not in your kill file. If you + move off the end of the buffer and there are more headers, then get them. + Otherwise go on to the next group in \"Netnews Groups\". + Returns nil if we have gone on to the next group, :done if there are no + more groups to read, or T if everything is normal." + (declare (ignore p)) + (let* ((nn-info (variable-value 'netnews-info :buffer headers-buffer)) + (point (buffer-point headers-buffer))) + (with-mark ((start point) + (end point)) + (loop + (line-offset point 1) + (cond ((eq (nn-maybe-get-more-headers nn-info) :go-on) + (cond ((eq (value netnews-last-header-style) :this-headers) + (let ((headers-buffer (nn-get-headers-buffer))) + (change-to-buffer headers-buffer)) + (editor-error "Last header.")) + (t + (return (change-to-next-group nn-info headers-buffer))))) + (t + (line-start (move-mark start point)) + (character-offset (move-mark end start) 1) + (unless (string= (region-to-string (region start end)) "K") + (return t)))))))) + +(defcommand "Netnews Headers Scroll Window Up" (p) + "Does what \"Scroll Window Up\" does, but fetches backward when the point + reaches the start of the headers buffer." + "Does what \"Scroll Window Up\" does, but fetches backward when the point + reaches the start of the headers buffer." + (scroll-window-up-command p) + (let ((headers-buffer (current-buffer)) + (nn-info (value netnews-info))) + (when (and (displayed-p (buffer-start-mark headers-buffer) + (current-window)) + (not (= (nn-info-first nn-info) + (nn-info-first-visible nn-info)))) + (buffer-start (current-point)) + (netnews-previous-line-command nil)))) + +(defcommand "Netnews Headers Scroll Window Down" (p) + "Does what \"Scroll Window Down\" does, but when the point reaches the end of + the headers buffer, pending headers are inserted." + "Does what \"Scroll Window Down\" does, but when the point reaches the end of + the headers buffer, pending headers are inserted." + (scroll-window-down-command p) + (let ((headers-buffer (current-buffer)) + (nn-info (value netnews-info))) + (when (and (displayed-p (buffer-end-mark headers-buffer) (current-window)) + (not (= (nn-info-last nn-info) (nn-info-last-visible nn-info)))) + (buffer-end (current-point)) + (netnews-next-line-command nil)))) + +(defcommand "Netnews Message Keep Buffer" (p) + "Specifies that you don't want Hemlock to reuse the current message buffer." + "Specifies that you don't want Hemlock to reuse the current message buffer." + (declare (ignore p)) + (unless (hemlock-bound-p 'netnews-message-info) + (editor-error "Not in a News-Message buffer.")) + (setf (nm-info-keep-p (value netnews-message-info)) t)) + +(defcommand "Netnews Goto Headers Buffer" (p) + "From \"Message Mode\", switch to the associated headers buffer." + "From \"Message Mode\", switch to the associated headers buffer." + (declare (ignore p)) + (unless (hemlock-bound-p 'netnews-message-info) + (editor-error "Not in a message buffer.")) + (let ((headers-buffer (nm-info-headers-buffer (value netnews-message-info)))) + (unless headers-buffer (editor-error "Headers buffer has been deleted")) + (change-to-buffer headers-buffer))) + +(defcommand "Netnews Goto Post Buffer" (p) + "Change to the associated \"Post\" buffer (if there is one) from a + \"News-Message\" buffer." + "Change to the associated \"Post\" buffer (if there is one) from a + \"News-Message\" buffer." + (declare (ignore p)) + (unless (hemlock-bound-p 'netnews-message-info) + (editor-error "Not in a News-Message buffer.")) + (let ((post-buffer (nm-info-post-buffer (value netnews-message-info)))) + (unless post-buffer (editor-error "No associated post buffer.")) + (change-to-buffer post-buffer))) + +(defcommand "Netnews Goto Draft Buffer" (p) + "Change to the associated \"Draft\" buffer (if there is one) from a + \"News-Message\" buffer." + "Change to the associated \"Draft\" buffer (if there is one) from a + \"News-Message\" buffer." + (declare (ignore p)) + (unless (hemlock-bound-p 'netnews-message-info) + (editor-error "Not in a News-Message buffer.")) + (let ((draft-buffer (nm-info-draft-buffer (value netnews-message-info)))) + (unless draft-buffer (editor-error "No associated post buffer.")) + (change-to-buffer draft-buffer))) + +(defcommand "Netnews Select Message Buffer" (p) + "Change to the associated message buffer (if there is one) in \"Post\" or + \"News-Headers\" modes." + "Change to the associated message buffer (if there is one) in \"Post\" or + \"News-Headers\" modes." + (declare (ignore p)) + (let* ((cbuf (current-buffer)) + (mbuf (cond ((hemlock-bound-p 'post-info :buffer cbuf) + (post-info-message-buffer (value post-info))) + ((hemlock-bound-p 'netnews-info :buffer cbuf) + (nn-info-buffer (value netnews-info))) + (t + (editor-error "Not in a \"Post\" or \"News-Headers\" ~ + buffer."))))) + (unless mbuf (editor-error "No assocated message buffer.")) + (change-to-buffer mbuf))) + +;;; CHANGE-TO-NEXT-GROUP deletes nn-info's headers buffer region and sets +;;; up the next group in that buffer. If there are no more groups to read, +;;; exits gracefully. +;;; +(defun change-to-next-group (nn-info headers-buffer) + (when (nn-info-updatep nn-info) + (nn-update-database-file (nn-info-latest nn-info) + (nn-info-current nn-info))) + (let ((next-group (cadr (member (nn-info-current nn-info) + (nn-info-groups nn-info) :test #'string=)))) + (cond (next-group + (message "Going on to ~A" next-group) + (force-output *echo-area-stream*) + (let ((message-buffer (nn-info-buffer nn-info))) + (when message-buffer + (setf (buffer-name message-buffer) + (nn-unique-message-buffer-name next-group)))) + (setf (buffer-name headers-buffer) + (nn-unique-headers-name next-group)) + (setf (nn-info-current nn-info) next-group) + (with-writable-buffer (headers-buffer) + (delete-region (buffer-region headers-buffer))) + (setup-group next-group nn-info headers-buffer) + nil) + (t + (if (eq headers-buffer *nn-headers-buffer*) + (message "This was your last group. Exiting Netnews.") + (message "Done with ~A. Exiting Netnews." + (nn-info-current nn-info))) + (netnews-exit-command nil t headers-buffer) + :done)))) + +(defun nn-update-database-file (latest group-name) + (when latest (setf (nn-last-read-message-number group-name) latest))) + + + + +;;;; More commands. + +(defhvar "Netnews Scroll Show Next Message" + "When non-nil, the default, Hemlock will show the next message in a group + when you scroll off the end of one. Otherwise Hemlock will editor error + that you are at the end of the buffer." + :value T) + +(defcommand "Netnews Message Scroll Down" (p &optional (buffer (current-buffer)) + (window (current-window))) + "Scrolls the current window down one screenful, checking to see if we need + to get the next message." + "Scrolls the current window down one screenful, checking to see if we need + to get the next message." + (if (displayed-p (buffer-end-mark buffer) window) + (if (value netnews-scroll-show-next-message) + (netnews-next-article-command nil) + (editor-error "At end of buffer.")) + (scroll-window-down-command p window))) + +(defcommand "Netnews Go to Next Group" (p) + "Goes on to the next group in \"Netnews Group File\", setting the group + pointer for this group to the the latest message read. With an argument + does not modify the group pointer." + "Goes on to the next group in \"Netnews Group File\", setting the group + pointer for this group to the the latest message read. With an argument + does not modify the group pointer." + (nn-punt-headers (if p :none :latest))) + +(defcommand "Netnews Group Punt Messages" (p) + "Go on to the next group in \"Netnews Group File\" setting the netnews + pointer for this group to the last message. With an argument, set the + pointer to the last visible message in this group." + "Go on to the next group in \"Netnews Group File\" setting the netnews + pointer for this group to the last message. With an argument, set the + pointer to the last visible message in this group." + (nn-punt-headers (if p :last-visible :punt))) + +(defcommand "Netnews Quit Starting Here" (p) + "Go on to the next group in \"Netnews Group File\", setting the group + pointer for this group to the message before the currently displayed one + or the message under the point if none is currently displayed." + "Go on to the next group in \"Netnews Group File\", setting the group + pointer for this group to the message before the currently displayed one + or the message under the point if none is currently displayed." + (declare (ignore p)) + (nn-punt-headers :this-one)) + +(defun nn-punt-headers (pointer-type) + (let* ((headers-buffer (nn-get-headers-buffer)) + (nn-info (variable-value 'netnews-info :buffer headers-buffer)) + (stream (nn-info-header-stream nn-info))) + (message "Exiting ~A" (nn-info-current nn-info)) + (setf (nn-info-latest nn-info) + (ecase pointer-type + (:latest (nn-info-latest nn-info)) + (:punt (nn-info-last nn-info)) + (:last-visible (nn-info-last-visible nn-info)) + (:this-one + (1- (if (minusp (nn-info-current-displayed-message nn-info)) + (array-element-from-mark (buffer-point headers-buffer) + (nn-info-message-ids nn-info)) + (nn-info-current-displayed-message nn-info)))) + (:none nil))) + ;; This clears out all headers that waiting on header-stream. + ;; Must process each response in case a message is not really there. + ;; If it isn't, then the call to WITH-INPUT-FROM-NNTP will gobble up + ;; the error message and the next real article. + ;; + (when (nn-info-messages-waiting nn-info) + (dotimes (i (nn-info-batch-count nn-info)) + (let ((response (process-status-response stream))) + (when response (with-input-from-nntp (string stream)))))) + (change-to-next-group nn-info headers-buffer))) + +(defcommand "Fetch All Headers" (p) + "Fetches the rest of the headers in the current group. + Warning: This will take a while if there are a lot." + "Fetches the rest of the headers in the current group. + Warning: This will take a while if there are a lot." + (declare (ignore p)) + (let* ((headers-buffer (nn-get-headers-buffer)) + (nn-info (variable-value 'netnews-info :buffer headers-buffer))) + (if (nn-info-messages-waiting nn-info) + (message "Fetching the rest of the headers for ~A" + (nn-info-current nn-info)) + (editor-error "All headers are in buffer.")) + ;; The first of these calls writes the headers that are waiting on the + ;; headers stream and requests the rest. The second inserts the rest, if + ;; there are any. + ;; + (nn-write-headers-to-mark nn-info headers-buffer t) + (nn-write-headers-to-mark nn-info headers-buffer))) + + +(defcommand "List All Groups" (p &optional buffer) + "Shows all available newsgroups in a buffer." + "Shows all available newsgroups in a buffer." + (declare (ignore p)) + (let* ((headers-buffer (nn-get-headers-buffer)) + (nn-info (if headers-buffer + (variable-value 'netnews-info :buffer headers-buffer))) + (stream (if headers-buffer + (nn-info-stream nn-info) + (connect-to-nntp)))) + (nntp-list stream) + (message "Fetching group list...") + (process-status-response stream) + (let* ((buffer (or buffer (make-buffer (nn-new-list-newsgroups-name)))) + (point (buffer-point buffer)) + (groups (make-array 1500 :fill-pointer 0 :adjustable t))) + (with-input-from-nntp (string (if headers-buffer + (nn-info-stream nn-info) + stream)) + (vector-push-extend string groups)) + (sort groups #'string<) + (dotimes (i (length groups)) + (let ((group (aref groups i))) + (multiple-value-bind (last first) (list-response-args group) + (declare (ignore first)) + (insert-string point group 0 (position #\space group)) + (insert-string point (format nil ": ~D~%" last))))) + (setf (buffer-modified buffer) nil) + (buffer-start point) + (change-to-buffer buffer)) + (unless headers-buffer (close stream)))) + +(defun nn-new-list-newsgroups-name () + (let ((name "Newsgroups List") + (number 0)) + (declare (simple-string name) + (fixnum number)) + (loop + (unless (getstring name *buffer-names*) (return name)) + (setf name (format nil "Newsgroups List ~D" number)) + (incf number)))) + +(defhvar "Netnews Message File" + "This value is merged with your home directory to get the pathname of the + file to which Hemlock will append messages." + :value "hemlock.messages") + +(defhvar "Netnews Exit Confirm" + "When non-nil, the default, \"Netnews Exit\" will ask you if you really + want to. If this variable is NIL, you will not be prompted." + :value T) + +(defcommand "Netnews Exit" (p &optional no-prompt-p + (headers-buf (nn-get-headers-buffer))) + "Exit Netnews from a netnews headers or netnews message buffer." + "Exit Netnews from a netnews headers or netnews message buffer." + (declare (ignore p)) + (let ((browse-buffer (variable-value 'netnews-browse-buffer + :buffer headers-buf))) + (when (or browse-buffer + no-prompt-p + (not (value netnews-exit-confirm)) + (prompt-for-y-or-n :prompt "Exit Netnews? " + :default "Y" + :default-string "Y" + :help "Yes exits netnews mode.")) + (let* ((nn-info (variable-value 'netnews-info :buffer headers-buf)) + (message-buffer (nn-info-buffer nn-info)) + (headers-window (nn-info-headers-window nn-info)) + (message-window (nn-info-message-window nn-info))) + (when (nn-info-updatep nn-info) + (nn-update-database-file (nn-info-latest nn-info) + (nn-info-current nn-info))) + (when (and (eq (value netnews-read-style) :multiple) + (member headers-window *window-list*) + (member message-window *window-list*)) + (delete-window message-window)) + (when message-buffer (delete-buffer-if-possible message-buffer)) + (delete-buffer-if-possible headers-buf) + (when browse-buffer (change-to-buffer browse-buffer)))))) + + + + +;;;; Commands to append messages to a file or file messages into mail folders. + +(defcommand "Netnews Append to File" (p) + "In a \"News-Headers\" buffer, appends the message under the point onto + the file named by \"Netnews Message File\". In a \"News-Message\" buffer, + appends the message in the current buffer to the same file." + "In a \"News-Headers\" buffer, appends the message under the point onto + the file named by \"Netnews Message File\". In a \"News-Message\" buffer, + appends the message in the current buffer to the same file." + (let* ((filename (merge-pathnames (value netnews-message-file) + (user-homedir-pathname))) + (file (prompt-for-file :prompt "Append to what file: " + :must-exist nil + :default filename + :default-string (namestring filename)))) + (when (and p (probe-file file)) + (delete-file file)) + (message "Appending message to ~S" (namestring file)) + (cond ((hemlock-bound-p 'netnews-info) + (let* ((nn-info (value netnews-info)) + (stream (nn-info-stream nn-info)) + (article-number (array-element-from-mark + (current-point) + (nn-info-message-ids nn-info) + "No header under point."))) + (with-open-file (file file :direction :output + :if-exists :append + :if-does-not-exist :create) + (nntp-article article-number stream) + (process-status-response stream) + (with-input-from-nntp (string (nn-info-stream nn-info)) + (write-line string file :end (1- (length string))))))) + (t + (write-file (buffer-region (current-buffer)) file))) + ;; Put a page separator and some whitespace between messages for + ;; readability when printing or scanning. + ;; + (with-open-file (f file :direction :output :if-exists :append) + (terpri f) + (terpri f) + (write-line " +" f) + (terpri f)))) + +(defcommand "Netnews Headers File Message" (p) + "Files the message under the point into a folder of your choice. If the + folder you select does not exist, it is created." + "Files the message under the point into a folder of your choice. If the + folder you select does not exist, it is created." + (declare (ignore p)) + (nn-file-message (value netnews-info) :headers)) + +(defcommand "Netnews Message File Message" (p) + "Files the message in the current buffer into a folder of your choice. If + folder you select does not exist, it is created." + "Files the message in the current buffer into a folder of your choice. If + folder you select does not exist, it is created." + (declare (ignore p)) + (nn-file-message (variable-value 'netnews-info + :buffer (nn-get-headers-buffer)) + :message)) + +(defun nn-file-message (nn-info kind) + (let ((article-number (array-element-from-mark (current-point) + (nn-info-message-ids nn-info) + "No header under point.")) + (folder (prompt-for-folder :prompt "MH Folder: " + :must-exist nil))) + (unless (folder-existsp folder) + (if (prompt-for-y-or-n + :prompt "Destination folder doesn't exist. Create it? " + :default t :default-string "Y") + (create-folder folder) + (editor-error "Not filing message."))) + (message "Filing message into ~A" folder) + (ecase kind + (:headers (nntp-article article-number (nn-info-stream nn-info)) + (process-status-response (nn-info-stream nn-info)) + (with-open-file (s "/tmp/temp.msg" :direction :output + :if-exists :rename-and-delete + :if-does-not-exist :create) + (with-input-from-nntp (string (nn-info-stream nn-info)) + (write-line string s :end (1- (length string)))))) + (:message (write-file (buffer-region (current-buffer)) "/tmp/temp.msg" + :keep-backup nil))) + (mh "inc" `(,folder "-silent" "-file" "/tmp/temp.msg")) + (message "Done."))) + + + + +;;;; "Post" Mode and supporting commands. + +(defmode "Post" :major-p nil) + +(defun nn-unique-post-buffer-name () + (let ((name "Post") + (number 0)) + (loop + (unless (getstring name *buffer-names*) (return name)) + (setf name (format nil "Post ~D" number)) + (incf number)))) + +;;; We usually know what the subject and newsgroups are, so keep these patterns +;;; around to make finding where to insert the information easy. +;;; +(defvar *draft-subject-pattern* + (new-search-pattern :string-insensitive :forward "Subject:")) + +(defvar *draft-newsgroups-pattern* + (new-search-pattern :string-insensitive :forward "Newsgroups:")) + +(defcommand "Netnews Post Message" (p) + "Set up a buffer for posting to netnews." + "Set up a buffer for posting to netnews." + (declare (ignore p)) + (let ((headers-buf (nn-get-headers-buffer)) + (post-buf (nn-make-post-buffer))) + ;; If we're in a "News-Headers" or "News-Message" buffer, fill in the + ;; newsgroups: slot in the header. + (when headers-buf + (insert-string-after-pattern (buffer-point post-buf) + *draft-newsgroups-pattern* + (nn-info-current + (variable-value + 'netnews-info :buffer headers-buf)))) + (nn-post-message nil post-buf))) + +(defcommand "Netnews Abort Post" (p) + "Abort the current post." + "Abort the current post." + (declare (ignore p)) + (delete-buffer-if-possible (current-buffer))) + +(defun foobie-frob (post-info buffer) + (declare (ignore post-info)) + (change-to-buffer buffer)) +#| + #'(lambda (post-info buffer) + (declare (ignore post-info)) + (print :changing) (force-output) + (change-to-buffer buffer) + (print :changed) (force-output)) +|# +(defvar *netnews-post-frob-windows-hook* #'foobie-frob + "This hook is FUNCALled in NN-POST-MESSAGE with a post-info structure and + the corresponding \"POST\" buffer before a post is done.") + +;;; NN-POST-MESSAGE sets up a buffer for posting. If message buffer is +;;; supplied, it is associated with the post-info structure for the post +;;; buffer. +;;; +(defun nn-post-message (message-buffer &optional (buffer (nn-make-post-buffer))) + (setf (buffer-modified buffer) nil) + (when message-buffer + (setf (nm-info-post-buffer (variable-value 'netnews-message-info + :buffer message-buffer)) + buffer)) + (let ((post-info (make-post-info :stream (connect-to-nntp) + :headers-buffer (nn-get-headers-buffer) + :message-buffer message-buffer))) + (defhvar "Post Info" + "Information needed to manipulate post buffers." + :buffer buffer + :value post-info) + (funcall *netnews-post-frob-windows-hook* post-info buffer))) + +(defun nn-make-post-buffer () + (let* ((buffer (make-buffer (nn-unique-post-buffer-name) + :delete-hook (list #'nn-post-buffer-delete-hook))) + (stream (make-hemlock-output-stream (buffer-point buffer)))) + (setf (buffer-minor-mode buffer "Post") t) + (write-line "Newsgroups: " stream) + (write-line "Subject: " stream) +; (write-string "Date: " stream) +; (format stream "~A~%" (string-capitalize +; (format-universal-time nil (get-universal-time) +; :style :government +; :print-weekday nil))) + (write-char #\newline stream) + (write-char #\newline stream) + buffer)) + +;;; The usual again. NULLify the appropriate stream slots in associated +;;; structures. Also call NN-REPLY-CLEANUP-SPLIT-WINDOWS to see if we +;;; need to delete one of the current windows. +;;; +(defun nn-post-buffer-delete-hook (buffer) + (when (hemlock-bound-p 'post-info) + (nn-reply-cleanup-split-windows buffer) + (let* ((post-info (variable-value 'post-info :buffer buffer)) + (message-buffer (post-info-message-buffer post-info))) + (close (post-info-stream post-info)) + (when message-buffer + (setf (nm-info-post-buffer (variable-value 'netnews-message-info + :buffer message-buffer)) + nil))))) + +;;; NN-REPLY-USING-CURRENT-WINDOW makes sure there is only one window for a +;;; normal reply. *netnews-post-frob-windows-hook* is bound to this when +;;; "Netnews Reply to Group" is invoked." +;;; +(defun nn-reply-using-current-window (post-info buffer) + (declare (ignore post-info)) + ;; Make sure there is only one window in :multiple mode. + ;; + (let* ((nn-info (variable-value 'netnews-info + :buffer (nn-get-headers-buffer))) + (headers-window (nn-info-headers-window nn-info)) + (message-window (nn-info-message-window nn-info))) + (when (and (eq (value netnews-read-style) :multiple) + (member message-window *window-list*) + (member headers-window *window-list*)) + (setf (current-window) message-window) + (delete-window headers-window)) + (change-to-buffer buffer))) + +;;; NN-REPLY-IN-OTHER-WINDOW-HOOK does what NN-REPLY-USING-CURRENT-WINDOW +;;; does, but in addition splits the current window in half, displaying the +;;; message buffer on top, and the reply buffer on the bottom. Also set some +;;; slots in the post info structure so the cleanup function knowd to delete +;;; one of the two windows we've created. +;;; +(defun nn-reply-in-other-window-hook (post-info buffer) + (nn-reply-using-current-window post-info buffer) + (let* ((message-window (current-window)) + (reply-window (make-window (buffer-start-mark buffer)))) + (setf (window-buffer message-window) (post-info-message-buffer post-info) + (current-window) reply-window + (post-info-message-window post-info) message-window + (post-info-reply-window post-info) reply-window))) + +;;; NN-REPLY-CLEANUP-SPLIT-WINDOWS just deletes one of the windows that +;;; "Netnews Reply to Group in Other Window" created, if they still exist. +;;; +(defun nn-reply-cleanup-split-windows (post-buffer) + (let* ((post-info (variable-value 'post-info :buffer post-buffer)) + (message-window (post-info-message-window post-info))) + (when (and (member (post-info-reply-window post-info) *window-list*) + (member message-window *window-list*)) + (delete-window message-window)))) + +(defcommand "Netnews Reply to Group" (p) + "Set up a POST buffer and insert the proper newgroups: and subject: fields. + Should be invoked from a \"News-Message\" or \"News-Headers\" buffer. + In a message buffer, reply to the message in that buffer, in a headers + buffer, reply to the message under the point." + "Set up a POST buffer and insert the proper newgroups: and subject: fields. + Should be invoked from a \"News-Message\" or \"News-Headers\" buffer. + In a message buffer, reply to the message in that buffer, in a headers + buffer, reply to the message under the point." + (declare (ignore p)) + (let ((*netnews-post-frob-windows-hook* #'nn-reply-using-current-window)) + (nn-reply-to-message))) + +(defcommand "Netnews Reply to Group in Other Window" (p) + "Does exactly what \"Netnews Reply to Group\" does, but makes two windows. + One of the windows displays the message being replied to, and the other + displays the reply." + "Does exactly what \"Netnews Reply to Group\" does, but makes two windows. + One of the windows displays the message being replied to, and the other + displays the reply." + (declare (ignore p)) + (let ((*netnews-post-frob-windows-hook* #'nn-reply-in-other-window-hook)) + (nn-reply-to-message))) + + +(defun nn-setup-for-reply-by-mail () + (let* ((headers-buffer (nn-get-headers-buffer)) + (nn-info (variable-value 'netnews-info :buffer headers-buffer)) + (message-buffer (nn-info-buffer nn-info)) + (nm-info (variable-value 'netnews-message-info :buffer message-buffer)) + (draft-buffer (sub-setup-message-draft "comp" :to-field)) + (dinfo (variable-value 'draft-information :buffer draft-buffer))) + (setf (buffer-delete-hook draft-buffer) + (list #'cleanup-netnews-draft-buffer)) + (when (nm-info-draft-buffer nm-info) + (delete-variable 'message-buffer :buffer (nm-info-draft-buffer nm-info))) + (setf (nm-info-draft-buffer nm-info) draft-buffer) + (when headers-buffer + (defhvar "Headers Buffer" + "This is bound in message and draft buffers to their associated + headers-buffer" + :value headers-buffer :buffer draft-buffer)) + (setf (draft-info-headers-mark dinfo) + (copy-mark (buffer-point headers-buffer))) + (defhvar "Message Buffer" + "This is bound in draft buffers to their associated message buffer." + :value message-buffer :buffer draft-buffer) + (values draft-buffer message-buffer))) + + +(defcommand "Netnews Forward Message" (p) + "Creates a Draft buffer and places a copy of the current message in + it, delimited by forwarded message markers." + "Creates a Draft buffer and places a copy of the current message in + it, delimited by forwarded message markers." + (declare (ignore p)) + (multiple-value-bind (draft-buffer message-buffer) + (nn-setup-for-reply-by-mail) + (with-mark ((mark (buffer-point draft-buffer) :left-inserting)) + (buffer-end mark) + (insert-string mark (format nil "~%------- Forwarded Message~%~%")) + (insert-string mark (format nil "~%------- End of Forwarded Message~%")) + (line-offset mark -2 0) + (insert-region mark (buffer-region message-buffer))) + (nn-reply-using-current-window nil draft-buffer))) + + +(defun nn-reply-to-sender () + (let* ((headers-buffer (nn-get-headers-buffer)) + (nn-info (variable-value 'netnews-info :buffer headers-buffer)) + (article (if (and (hemlock-bound-p 'netnews-info) + (minusp (nn-info-current-displayed-message + nn-info))) + (nn-put-article-in-buffer nn-info headers-buffer) + (nn-info-current-displayed-message nn-info)))) + (multiple-value-bind (draft-buffer message-buffer) + (nn-setup-for-reply-by-mail) + (let ((point (buffer-point draft-buffer)) + (to-field (or (nn-get-one-field nn-info "Reply-To" article) + (nn-get-one-field nn-info "From" article)))) + (insert-string-after-pattern point + *draft-to-pattern* + to-field + :end (1- (length to-field))) + (let ((subject-field (nn-subject-replyify + (nn-get-one-field nn-info "Subject" article)))) + (insert-string-after-pattern point + *draft-subject-pattern* + subject-field + :end (1- (length subject-field))))) + (nn-reply-using-current-window nil draft-buffer) + (values draft-buffer message-buffer)))) + +(defcommand "Netnews Reply to Sender" (p) + "Reply to the sender of a message via mail using the Hemlock mailer." + "Reply to the sender of a message via mail using the Hemlock mailer." + (declare (ignore p)) + (nn-reply-to-sender)) + +(defcommand "Netnews Reply to Sender in Other Window" (p) + "Reply to the sender of a message via mail using the Hemlock mailer. The + screen will be split in half, displaying the post and the draft being + composed." + "Reply to the sender of a message via mail using the Hemlock mailer. The + screen will be split in half, displaying the post and the draft being + composed." + (declare (ignore p)) + (multiple-value-bind (draft-buffer message-buffer) + (nn-reply-to-sender) + (let* ((message-window (current-window)) + (reply-window (make-window (buffer-start-mark draft-buffer)))) + (defhvar "Split Window Draft" + "Indicates window needs to be cleaned up for draft." + :value t :buffer draft-buffer) + (setf (window-buffer message-window) message-buffer + (current-window) reply-window)))) + +;;; CLEANUP-NETNEWS-DRAFT-BUFFER replaces the normal draft buffer delete hook +;;; because the generic one tries to set some slots in the related message-info +;;; structure which doesn't exist. This function just sets the draft buffer +;;; slot of netnews-message-info to nil so it won't screw you when you try +;;; to change to the associated draft buffer. +;;; +(defun cleanup-netnews-draft-buffer (buffer) + (when (hemlock-bound-p 'message-buffer :buffer buffer) + (setf (nm-info-draft-buffer + (variable-value 'netnews-message-info + :buffer (variable-value 'message-buffer + :buffer buffer))) + nil))) + +;;; NN-REPLYIFY-SUBJECT simply adds "Re: " to the front of a string if it is +;;; not already there. +;;; +(defun nn-subject-replyify (subject) + (if (>= (length subject) 3) + (if (not (string= subject "Re:" :end1 3 :end2 3)) + (concatenate 'simple-string "Re: " subject) + subject) + (concatenate 'simple-string "Re: " subject))) + +(defun insert-string-after-pattern (mark search-pattern string + &key (start 0) (end (length string))) + (buffer-start mark) + (when (and (plusp end) + (find-pattern mark search-pattern)) + (insert-string (line-end mark) string start end)) + (buffer-end mark)) + +(defun nn-reply-to-message () + (let* ((headers-buffer (nn-get-headers-buffer)) + (nn-info (variable-value 'netnews-info :buffer headers-buffer)) + (article (if (and (hemlock-bound-p 'netnews-info) + (minusp (nn-info-current-displayed-message nn-info))) + (nn-put-article-in-buffer nn-info headers-buffer) + (nn-info-current-displayed-message nn-info))) + (post-buffer (nn-make-post-buffer)) + (point (buffer-point post-buffer))) + + (let ((groups-field (nn-get-one-field nn-info "Newsgroups" article))) + (insert-string-after-pattern point + *draft-newsgroups-pattern* + groups-field + :end (1- (length groups-field)))) + (let ((subject-field (nn-subject-replyify + (nn-get-one-field nn-info "Subject" article)))) + (insert-string-after-pattern point + *draft-subject-pattern* + subject-field + :end (1- (length subject-field)))) + (nn-post-message (nn-info-buffer nn-info) post-buffer))) + +(defun nn-get-one-field (nn-info field article) + (cdr (assoc field (svref (nn-info-header-cache nn-info) + (- article (nn-info-first nn-info))) + :test #'string-equal))) + +(defvar *nntp-timeout-handler* 'nn-recover-from-timeout + "This function gets FUNCALled when NNTP times out on us with the note passed + to PROCESS-STATUS-RESPONSE. The default assumes the note is an NN-INFO + structure and tries to recover from the timeout.") + +(defvar *nn-last-command-issued* nil + "The last string issued to one of the NNTP streams. Used to recover from + a nntp timeout.") + +;;; NN-RECOVER-FROM-POSTING-TIMEOUT is the recover method used when posting. +;;; It just resets the value of \"NNTP Stream\" and issues the last command +;;; again. +;;; +(defun nn-recover-from-posting-timeout (ignore) + (declare (ignore ignore)) + (let ((stream (connect-to-nntp))) + (setf (post-info-stream (value post-info)) stream) + (write-nntp-command *nn-last-command-issued* stream :recover) + (process-status-response stream))) + +(defhvar "Netnews Reply Address" + "What the From: field will be when you post messages. If this is nil, + the From: field will be determined using the association of :USER + in *environment-list* and your machine name." + :value NIL) + +(defhvar "Netnews Signature Filename" + "This value is merged with your home directory to get the pathname your + signature, which is appended to every post you make." + :value ".hemlock-sig") + +(defhvar "Netnews Deliver Post Confirm" + "This determines whether Netnews Deliver Post will ask for confirmation + before posting the current message." + :value t) + +(defcommand "Netnews Deliver Post" (p) + "Deliver the current Post buffer to the NNTP server. If the file named by + the value of \"Netnews Signature Filename\" exists, it is appended to the + end of the message after adding a newline." + "Deliver the current Post buffer to the NNTP server, cleaning up any windows + we need and landing us in the headers buffer if this was a reply." + (declare (ignore p)) + (when (or (not (value netnews-deliver-post-confirm)) + (prompt-for-y-or-n :prompt "Post message? " :default t)) + (let* ((*nntp-timeout-handler* #'nn-recover-from-posting-timeout) + (stream (post-info-stream (value post-info)))) + (nntp-post stream) + (let ((winp (process-status-response stream)) + ;; Rebind stream here because the stream may have been pulled out + ;; from under us by an NNTP timeout. The recover method for posting + ;; resets the Hemlock Variable. + (stream (post-info-stream (value post-info)))) + (unless winp (editor-error "Posting prohibited in this group.")) + (let ((buffer (current-buffer)) + (username (value netnews-reply-address))) + (nn-write-line (format nil "From: ~A" + (if username + username + (string-downcase + (format nil "~A@~A" + (cdr (assoc :user + ext:*environment-list*)) + (machine-instance))))) + stream) + (filter-region #'(lambda (string) + (when (string= string ".") + (write-char #\. stream)) + (nn-write-line string stream)) + (buffer-region buffer)) + ;; Append signature + ;; + (let ((filename (merge-pathnames (value netnews-signature-filename) + (user-homedir-pathname)))) + (when (probe-file filename) + (with-open-file (istream filename :direction :input) + (loop + (let ((line (read-line istream nil nil))) + (unless line (return)) + (nn-write-line line stream)))))) + (write-line nntp-eof stream) + (delete-buffer-if-possible buffer) + (let ((headers-buffer (nn-get-headers-buffer))) + (when headers-buffer (change-to-buffer headers-buffer))) + (message "Message Posted.")))))) + +(defun nn-write-line (line stream) + (write-string line stream) + (write-char #\return stream) + (write-char #\newline stream) + line) + + + + +;;;; News-Browse mode. + +(defmode "News-Browse" :major-p t) + +(defhvar "Netnews Group File" + "If the value of \"Netnews Groups\" is nil, \"Netnews\" merges this + variable with your home directory and looks there for a list of newsgroups + (one per line) to read. Groups may be added using \"Netnews Browse\ and + related commands, or by editing this file." + :value ".hemlock-groups") + +(defcommand "Netnews Browse" (p) + "Puts all netnews groups in a buffer and provides commands for reading them + and adding them to the file specified by the merge of \"Netnews Group File\" + and your home directory." + "Puts all netnews groups in a buffer and provides commands for reading them + and adding them to the file specified by the merge of \"Netnews Group File\" + and your home directory." + (declare (ignore p)) + (let ((buffer (make-buffer "Netnews Browse"))) + (cond (buffer + (list-all-groups-command nil buffer) + (setf (buffer-major-mode buffer) "News-Browse") + (setf (buffer-writable buffer) nil)) + (t (change-to-buffer (getstring "Netnews Browse" *buffer-names*)))))) + +(defcommand "Netnews Quit Browse" (p) + "Exit News-Browse Mode." + "Exit News-Browse Mode." + (declare (ignore p)) + (delete-buffer-if-possible (current-buffer))) + +(defcommand "Netnews Browse Read Group" (p &optional (mark (current-point))) + "Read the group on the line under the current point paying no attention to + the \"Hemlock Database File\" entry for this group. With an argument, use + and modify the database file." + "Read the group on the line under the current point paying no attention to + the \"Hemlock Database File\" entry for this group. With an argument, use + and modify the database file." + (let ((group-info-string (line-string (mark-line mark)))) + (netnews-command nil (subseq group-info-string + 0 (position #\: group-info-string)) + nil (current-buffer) p))) + +(defcommand "Netnews Browse Pointer Read Group" (p) + "Read the group on the line where you just clicked paying no attention to the + \"Hemlock Databse File\" entry for this group. With an argument, use and + modify the databse file." + "Read the group on the line where you just clicked paying no attention to the + \"Hemlock Databse File\" entry for this group. With an argument, use and + modify the databse file." + (multiple-value-bind (x y window) (last-key-event-cursorpos) + (unless window (editor-error "Couldn't figure out where last click was.")) + (unless y (editor-error "There is no group in the modeline.")) + (netnews-browse-read-group-command p (cursorpos-to-mark x y window)))) + +(defcommand "Netnews Browse Add Group to File" (p &optional + (mark (current-point))) + "Append the newsgroup on the line under the point to the file specified by + \"Netnews Group File\". With an argument, delete all groups that were + there to start with." + "Append the newsgroup on the line under the point to the file specified by + \"Netnews Group File\". With an argument, delete all groups that were + there to start with." + (declare (ignore p)) + (let* ((group-info-string (line-string (mark-line mark))) + (group (subseq group-info-string 0 (position #\: group-info-string)))) + (with-open-file (s (merge-pathnames (value netnews-group-file) + (user-homedir-pathname)) + :direction :output + :if-exists :append + :if-does-not-exist :create) + (write-line group s)) + (message "Adding ~S to newsgroup file." group))) + +(defcommand "Netnews Browse Pointer Add Group to File" (p) + "Append the newsgroup you just clicked on to the file specified by + \"Netnews Group File\"." + "Append the newsgroup you just clicked on to the file specified by + \"Netnews Group File\"." + (declare (ignore p)) + (multiple-value-bind (x y window) (last-key-event-cursorpos) + (unless window (editor-error "Couldn't figure out where last click was.")) + (unless y (editor-error "There is no group in the modeline.")) + (netnews-browse-add-group-to-file-command + nil (cursorpos-to-mark x y window)))) + + + + +;;;; Low-level stream operations. + +(defun streams-for-nntp () + (clear-echo-area) + (format *echo-area-stream* "Connecting to NNTP...~%") + (force-output *echo-area-stream*) + (values (connect-to-nntp) (connect-to-nntp))) + + +(defparameter *nntp-port* 119 + "The nntp port number for NNTP as specified in RFC977.") + +(defhvar "Netnews NNTP Server" + "The hostname of the NNTP server to use for reading Netnews." + :value "netnews.srv.cs.cmu.edu") + +(defhvar "Netnews NNTP Timeout Period" + "The number of seconds to wait before timing out when trying to connect + to the NNTP server." + :value 30) + +(defun raw-connect-to-nntp () + (let ((stream (system:make-fd-stream + (ext:connect-to-inet-socket (value netnews-nntp-server) + *nntp-port*) + :input t :output t :buffering :line :name "NNTP" + :timeout (value netnews-nntp-timeout-period)))) + (process-status-response stream) + stream)) + +(defun connect-to-nntp () + (handler-case + (raw-connect-to-nntp) + (io-timeout () + (editor-error "Connection to NNTP timed out. Try again later.")))) + +(defvar *nn-last-command-type* nil + "Used to recover from a nntp timeout.") + +(defun write-nntp-command (command stream type) + (setf *nn-last-command-type* type) + (setf *nn-last-command-issued* command) + (write-string command stream) + (write-char #\return stream) + (write-char #\newline stream) + (force-output stream)) + + + + +;;;; PROCESS-STATUS-RESPONSE and NNTP error handling. + +(defconstant nntp-error-codes '(#\4 #\5) + "These codes signal that NNTP could not complete the request you asked for.") + +(defvar *nntp-error-handlers* nil) + +;;; PROCESS-STATUS-RESPONSE makes sure a response waiting at the server is +;;; valid. If the response code starts with a 4 or 5, then look it up in +;;; *nntp-error-handlers*. If an error handler is defined, then FUNCALL it +;;; on note. Otherwise editor error. If the response is not an error code, +;;; then just return what NNTP returned to us for parsing later. +;;; +(defun process-status-response (stream &optional note) + (let ((str (read-line stream))) + (if (member (schar str 0) nntp-error-codes :test #'char=) + (let ((error-handler (cdr (assoc str *nntp-error-handlers* + :test #'(lambda (string1 string2) + (string= string1 string2 + :end1 3 + :end2 3)))))) + (unless error-handler + (error "NNTP error -- ~A" (subseq str 4 (1- (length str))))) + (funcall error-handler note)) + str))) + +(defun nn-recover-from-timeout (nn-info) + (message "NNTP timed out, attempting to reconnect and continue...") + (let ((stream (nn-info-stream nn-info)) + (header-stream (nn-info-header-stream nn-info))) + ;; If some messages are waiting on the header stream, insert them. + ;; + (when (listen header-stream) + (nn-write-headers-to-mark nn-info (nn-get-headers-buffer))) + (close stream) + (close header-stream) + (setf stream (connect-to-nntp) + header-stream (connect-to-nntp) + (nn-info-stream nn-info) stream + (nn-info-header-stream nn-info) header-stream) + (let ((last-command *nn-last-command-issued*) + (last-command-type *nn-last-command-type*) + (current (nn-info-current nn-info))) + (nntp-group current stream header-stream) + (process-status-response stream) + (process-status-response header-stream) + (if (consp last-command) + (let ((stream-type (car last-command))) + (apply #'nn-send-many-head-requests + (cons (if (eq stream-type :header) header-stream stream) + (cdr last-command)))) + (ecase last-command-type + ((:list :article :body) + (write-nntp-command last-command stream :recover) + (process-status-response stream)) + ((:header-group :normal-group) + (write-nntp-command last-command stream :recover) + (write-nntp-command last-command header-stream :recover))))))) + +;;; DEF-NNTP-ERROR-HANDLER takes a code and a function and associates the two +;;; in *nntp-error-handlers*. If while PROCESSING a STATUS RESPONSE we come +;;; across one of these error codes, then FUNCALL the appropriate handler. +;;; +(defun def-nntp-error-handler (code function) + (pushnew (cons (format nil "~D" code) function) *nntp-error-handlers*)) + +;;; 503 is an NNTP timeout. The code I wrote reconnects and recovers +;;; completely. +;;; +(def-nntp-error-handler 503 #'(lambda (note) + (funcall *nntp-timeout-handler* note))) + +;;; 400 means NNTP is cutting us of for some reason. There is really nothing +;;; we can do. +;;; +(def-nntp-error-handler 400 #'(lambda (ignore) + (declare (ignore ignore)) + (editor-error "NNTP discontinued service. ~ + You should probably quit netnews and try ~ + again later."))) + +;;; Some functions just need to know that something went wrong so they can +;;; do something about it, so let them know by returning nil. +;;; +;;; 411 - The group you tried to read is not a netnews group. +;;; 423 - You requested a message that wasn't really there. +;;; 440 - Posting is not allowed. +;;; 441 - Posting is allowed, but the attempt failed for some other reason. +;;; +(flet ((nil-function (ignore) + (declare (ignore ignore)) + nil)) + (def-nntp-error-handler 423 #'nil-function) + (def-nntp-error-handler 411 #'nil-function) + (def-nntp-error-handler 440 #'nil-function) + (def-nntp-error-handler 441 #'nil-function)) + + + + +;;;; Implementation of NNTP response argument parsing. + +;;; DEF-NNTP-ARG-PARSER returns a form that parses a string for arguments +;;; corresponding to each element of types. For instance, if types is +;;; (:integer :string :integer :integer), this function returns a form that +;;; parses an integer, a string, and two more integers out of an nntp status +;;; response. +;;; +(defmacro def-nntp-arg-parser (types) + (let ((form (gensym)) + (start (gensym)) + (res nil)) + (do ((type types (cdr type))) + ((endp type) form) + (ecase (car type) + (:integer + (push `(parse-integer string :start ,start + :end (setf ,start + (position #\space string + :start (1+ ,start))) + :junk-allowed t) + res)) + (:string + (push `(subseq string (1+ ,start) + (position #\space string + :start (setf ,start (1+ ,start)))) + res)))) + `(let ((,start (position #\space string))) + (values ,@(nreverse res))))) + +(defun def-nntp-xhdr-arg-parser (string) + (let ((position (position #\space string))) + (values (subseq string (1+ position)) + (parse-integer string :start 0 :end position)))) + +(defun xhdr-response-args (string) + (def-nntp-xhdr-arg-parser string)) + +;;; GROUP-RESPONSE-ARGS, ARTICLER-RESPONSE-ARGS, HEAD-RESPONSE-ARGS, +;;; BODY-RESPONSE-ARGS, and STAT-RESPONSE-ARGS define NNTP argument parsers +;;; for the types of arguments each command will return. +;;; +(defun group-response-args (string) + "Group response args are an estimate of how many messages there are, the + number of the first message, the number of the last message, and \"y\" + or \"n\", indicating whether the user has rights to post in this group." + (def-nntp-arg-parser (:integer :integer :integer))) + +(defun list-response-args (string) + (def-nntp-arg-parser (:integer :integer))) + +(defun article-response-args (string) + "Article response args are the message number and the message ID." + (def-nntp-arg-parser (:integer :string))) + +(defun head-response-args (string) + "Head response args are the message number and the message ID." + (def-nntp-arg-parser (:integer :string))) + +(defun body-response-args (string) + "Body response args are the message number and the message ID." + (def-nntp-arg-parser (:integer :string))) + +(defun stat-response-args (string) + "Stat response args are the message number and the message ID." + (def-nntp-arg-parser (:integer :string))) + + + + +;;;; Functions that send standard NNTP commands. + +;;; NNTP-XHDR sends an XHDR command to the NNTP server. We think this is a +;;; local extension, but not using it is not pragmatic. It takes over three +;;; minutes to HEAD every message in a newsgroup. +;;; +(defun nntp-xhdr (field start end stream) + (write-nntp-command (format nil "xhdr ~A ~D-~D" + field + (if (numberp start) start (parse-integer start)) + (if (numberp end) end (parse-integer end))) + stream + :xhdr)) + +(defun nntp-group (group-name stream header-stream) + (let ((command (concatenate 'simple-string "group " group-name))) + (write-nntp-command command stream :normal-group) + (write-nntp-command command header-stream :header-group))) + +(defun nntp-list (stream) + (write-nntp-command "list" stream :list)) + +(defun nntp-head (article stream) + (write-nntp-command (format nil "head ~D" article) stream :head)) + +(defun nntp-article (number stream) + (write-nntp-command (format nil "article ~D" number) stream :article)) + +(defun nntp-body (number stream) + (write-nntp-command (format nil "body ~D" number) stream :body)) + +(defun nntp-post (stream) + (write-nntp-command "post" stream :post)) Index: /branches/ide-1.0/ccl/hemlock/src/archive/pascal.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/archive/pascal.lisp (revision 6567) +++ /branches/ide-1.0/ccl/hemlock/src/archive/pascal.lisp (revision 6567) @@ -0,0 +1,46 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Just barely enough to be a Pascal/C mode. Maybe more some day. +;;; +(in-package :hemlock) + +(defmode "Pascal" :major-p t) +(defcommand "Pascal Mode" (p) + "Put the current buffer into \"Pascal\" mode." + "Put the current buffer into \"Pascal\" mode." + (declare (ignore p)) + (setf (buffer-major-mode (current-buffer)) "Pascal")) + +(defhvar "Indent Function" + "Indentation function which is invoked by \"Indent\" command. + It must take one argument that is the prefix argument." + :value #'generic-indent + :mode "Pascal") + +(defhvar "Auto Fill Space Indent" + "When non-nil, uses \"Indent New Comment Line\" to break lines instead of + \"New Line\"." + :mode "Pascal" :value t) + +(defhvar "Comment Start" + "String that indicates the start of a comment." + :mode "Pascal" :value "(*") + +(defhvar "Comment End" + "String that ends comments. Nil indicates #\newline termination." + :mode "Pascal" :value " *)") + +(defhvar "Comment Begin" + "String that is inserted to begin a comment." + :mode "Pascal" :value "(* ") + +(shadow-attribute :scribe-syntax #\< nil "Pascal") Index: /branches/ide-1.0/ccl/hemlock/src/archive/rcs.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/archive/rcs.lisp (revision 6567) +++ /branches/ide-1.0/ccl/hemlock/src/archive/rcs.lisp (revision 6567) @@ -0,0 +1,526 @@ +;;; -*- Package: HEMLOCK; Mode: Lisp -*- +;;; +;;; $Header$ +;;; +;;; Various commands for dealing with RCS under Hemlock. +;;; +;;; Written by William Lott and Christopher Hoover. +;;; +(in-package :hemlock) + + + +;;;; + +(defun current-buffer-pathname () + (let ((pathname (buffer-pathname (current-buffer)))) + (unless pathname + (editor-error "The buffer has no pathname.")) + pathname)) + + +(defmacro in-directory (directory &body forms) + (let ((cwd (gensym))) + `(let ((,cwd (ext:default-directory))) + (unwind-protect + (progn + (setf (ext:default-directory) (directory-namestring ,directory)) + ,@forms) + (setf (ext:default-directory) ,cwd))))) + + +(defvar *last-rcs-command-name* nil) +(defvar *last-rcs-command-output-string* nil) +(defvar *rcs-output-stream* (make-string-output-stream)) + +(defmacro do-command (command &rest args) + `(progn + (setf *last-rcs-command-name* ',command) + (get-output-stream-string *rcs-output-stream*) + (let ((process (ext:run-program ',command ,@args + :error *rcs-output-stream*))) + (setf *last-rcs-command-output-string* + (get-output-stream-string *rcs-output-stream*)) + (case (ext:process-status process) + (:exited + (unless (zerop (ext:process-exit-code process)) + (editor-error "~A aborted with an error; ~ + use the ``RCS Last Command Output'' command for ~ + more information" ',command))) + (:signaled + (editor-error "~A killed with signal ~A~@[ (core dumped)]." + ',command + (ext:process-exit-code process) + (ext:process-core-dumped process))) + (t + (editor-error "~S still alive?" process)))))) + +(defun buffer-different-from-file (buffer filename) + (with-open-file (file filename) + (do ((buffer-line (mark-line (buffer-start-mark buffer)) + (line-next buffer-line)) + (file-line (read-line file nil nil) + (read-line file nil nil))) + ((and (or (null buffer-line) + (zerop (line-length buffer-line))) + (null file-line)) + nil) + (when (or (null buffer-line) + (null file-line) + (string/= (line-string buffer-line) file-line)) + (return t))))) + +(defun turn-auto-save-off (buffer) + (setf (buffer-minor-mode buffer "Save") nil) + ;; + ;; William's personal hack + (when (getstring "Ckp" *mode-names*) + (setf (buffer-minor-mode buffer "Ckp") nil))) + + +(defhvar "RCS Lock File Hook" + "RCS Lock File Hook" + :value nil) + +(defun rcs-lock-file (buffer pathname) + (message "Locking ~A ..." (namestring pathname)) + (in-directory pathname + (let ((file (file-namestring pathname))) + (do-command "rcs" `("-l" ,file)) + (multiple-value-bind (won dev ino mode) (unix:unix-stat file) + (declare (ignore ino)) + (cond (won + (unix:unix-chmod file (logior mode unix:writeown))) + (t + (editor-error "UNIX:UNIX-STAT lost in RCS-LOCK-FILE: ~A" + (unix:get-unix-error-msg dev))))))) + (invoke-hook rcs-lock-file-hook buffer pathname)) + + +(defhvar "RCS Unlock File Hook" + "RCS Unlock File Hook" + :value nil) + +(defun rcs-unlock-file (buffer pathname) + (message "Unlocking ~A ..." (namestring pathname)) + (in-directory pathname + (do-command "rcs" `("-u" ,(file-namestring pathname)))) + (invoke-hook rcs-unlock-file-hook buffer pathname)) + + + +;;;; Check In + +(defhvar "RCS Check In File Hook" + "RCS Check In File Hook" + :value nil) + +(defhvar "RCS Keep Around After Unlocking" + "If non-NIL (the default) keep the working file around after unlocking it. + When NIL, the working file and buffer are deleted." + :value t) + +(defun rcs-check-in-file (buffer pathname keep-lock) + (let ((old-buffer (current-buffer)) + (allow-delete nil) + (log-buffer nil)) + (unwind-protect + (when (block in-recursive-edit + (do ((i 0 (1+ i))) + ((not (null log-buffer))) + (setf log-buffer + (make-buffer + (format nil "RCS Log Entry ~D for ~S" i + (file-namestring pathname)) + :modes '("Text") + :delete-hook + (list #'(lambda (buffer) + (declare (ignore buffer)) + (unless allow-delete + (return-from in-recursive-edit t))))))) + (turn-auto-save-off log-buffer) + (change-to-buffer log-buffer) + (do-recursive-edit) + + (message "Checking in ~A~:[~; keeping the lock~] ..." + (namestring pathname) keep-lock) + (let ((log-stream (make-hemlock-region-stream + (buffer-region log-buffer)))) + (sub-check-in-file pathname buffer keep-lock log-stream)) + (invoke-hook rcs-check-in-file-hook buffer pathname) + nil) + (editor-error "Someone deleted the RCS Log Entry buffer.")) + (when (member old-buffer *buffer-list*) + (change-to-buffer old-buffer)) + (setf allow-delete t) + (delete-buffer-if-possible log-buffer)))) + +(defun sub-check-in-file (pathname buffer keep-lock log-stream) + (let* ((filename (file-namestring pathname)) + (rcs-filename (concatenate 'simple-string + "./RCS/" filename ",v")) + (keep-working-copy (or keep-lock + (not (hemlock-bound-p + 'rcs-keep-around-after-unlocking + :buffer buffer)) + (variable-value + 'rcs-keep-around-after-unlocking + :buffer buffer)))) + (in-directory pathname + (do-command "ci" `(,@(if keep-lock '("-l")) + ,@(if keep-working-copy '("-u")) + ,filename) + :input log-stream) + (if keep-working-copy + ;; + ;; Set the times on the user's file to be equivalent to that of + ;; the rcs file. + #-(or hpux svr4) + (multiple-value-bind + (dev ino mode nlink uid gid rdev size atime mtime) + (unix:unix-stat rcs-filename) + (declare (ignore mode nlink uid gid rdev size)) + (cond (dev + (multiple-value-bind + (wonp errno) + (unix:unix-utimes filename atime 0 mtime 0) + (unless wonp + (editor-error "UNIX:UNIX-UTIMES failed: ~A" + (unix:get-unix-error-msg errno))))) + (t + (editor-error "UNIX:UNIX-STAT failed: ~A" + (unix:get-unix-error-msg ino))))) + (delete-buffer-if-possible buffer))))) + + + + +;;;; Check Out + +(defhvar "RCS Check Out File Hook" + "RCS Check Out File Hook" + :value nil) + +(defvar *translate-file-names-before-locking* nil) + +(defun maybe-rcs-check-out-file (buffer pathname lock always-overwrite-p) + (when (and lock *translate-file-names-before-locking*) + (multiple-value-bind (unmatched-dir new-dirs file-name) + (maybe-translate-definition-file pathname) + (when new-dirs + (let ((new-name (translate-definition-file unmatched-dir + (car new-dirs) + file-name))) + (when (probe-file (directory-namestring new-name)) + (setf pathname new-name)))))) + (cond + ((and (not always-overwrite-p) + (let ((pn (probe-file pathname))) + (and pn (hemlock-ext:file-writable pn)))) + ;; File exists and is writable so check and see if the user really + ;; wants to check it out. + (command-case (:prompt + (format nil "The file ~A is writable. Overwrite? " + (file-namestring pathname)) + :help + "Type one of the following single-character commands:") + ((:yes :confirm) + "Overwrite the file." + (rcs-check-out-file buffer pathname lock)) + (:no + "Don't check it out after all.") + ((#\r #\R) + "Rename the file before checking it out." + (let ((new-pathname (prompt-for-file + :prompt "New Filename: " + :default (buffer-default-pathname + (current-buffer)) + :must-exist nil))) + (rename-file pathname new-pathname) + (rcs-check-out-file buffer pathname lock))))) + (t + (rcs-check-out-file buffer pathname lock))) + pathname) + +(defun rcs-check-out-file (buffer pathname lock) + (message "Checking out ~A~:[~; with a lock~] ..." (namestring pathname) lock) + (in-directory pathname + (let* ((file (file-namestring pathname)) + (backup (if (probe-file file) + (lisp::pick-backup-name file)))) + (when backup (rename-file file backup)) + (do-command "co" `(,@(if lock '("-l")) ,file)) + (invoke-hook rcs-check-out-file-hook buffer pathname) + (when backup (delete-file backup))))) + + + +;;;; Last Command Output + +(defcommand "RCS Last Command Output" (p) + "Print the full output of the last RCS command." + "Print the full output of the last RCS command." + (declare (ignore p)) + (unless (and *last-rcs-command-name* *last-rcs-command-output-string*) + (editor-error "No RCS commands have executed!")) + (with-pop-up-display (s :buffer-name "*RCS Command Output*") + (format s "Output from ``~A'':~%~%" *last-rcs-command-name*) + (write-line *last-rcs-command-output-string* s))) + + + +;;;; Commands for Checking In / Checking Out and Locking / Unlocking + +(defun pick-temp-file (defaults) + (let ((index 0)) + (loop + (let ((name (merge-pathnames (format nil ",rcstmp-~D" index) defaults))) + (cond ((probe-file name) + (incf index)) + (t + (return name))))))) + +(defcommand "RCS Lock Buffer File" (p) + "Attempt to lock the file in the current buffer." + "Attempt to lock the file in the current buffer." + (declare (ignore p)) + (let ((file (current-buffer-pathname)) + (buffer (current-buffer)) + (name (pick-temp-file "/tmp/"))) + (rcs-lock-file buffer file) + (unwind-protect + (progn + (in-directory file + (do-command "co" `("-p" ,(file-namestring file)) + :output (namestring name))) + (when (buffer-different-from-file buffer name) + (message + "RCS file is different; be sure to merge in your changes.")) + (setf (buffer-writable buffer) t) + (message "Buffer is now writable.")) + (when (probe-file name) + (delete-file name))))) + +(defcommand "RCS Lock File" (p) + "Prompt for a file, and attempt to lock it." + "Prompt for a file, and attempt to lock it." + (declare (ignore p)) + (rcs-lock-file nil (prompt-for-file :prompt "File to lock: " + :default (buffer-default-pathname + (current-buffer)) + :must-exist nil))) + +(defcommand "RCS Unlock Buffer File" (p) + "Unlock the file in the current buffer." + "Unlock the file in the current buffer." + (declare (ignore p)) + (rcs-unlock-file (current-buffer) (current-buffer-pathname)) + (setf (buffer-writable (current-buffer)) nil) + (message "Buffer is no longer writable.")) + +(defcommand "RCS Unlock File" (p) + "Prompt for a file, and attempt to unlock it." + "Prompt for a file, and attempt to unlock it." + (declare (ignore p)) + (rcs-unlock-file nil (prompt-for-file :prompt "File to unlock: " + :default (buffer-default-pathname + (current-buffer)) + :must-exist nil))) + +(defcommand "RCS Check In Buffer File" (p) + "Checkin the file in the current buffer. With an argument, do not + release the lock." + "Checkin the file in the current buffer. With an argument, do not + release the lock." + (let ((buffer (current-buffer)) + (pathname (current-buffer-pathname))) + (when (buffer-modified buffer) + (save-file-command nil)) + (rcs-check-in-file buffer pathname p) + (when (member buffer *buffer-list*) + ;; If the buffer has not been deleted, make sure it is up to date + ;; with respect to the file. + (visit-file-command nil pathname buffer)))) + +(defcommand "RCS Check In File" (p) + "Prompt for a file, and attempt to check it in. With an argument, do + not release the lock." + "Prompt for a file, and attempt to check it in. With an argument, do + not release the lock." + (rcs-check-in-file nil (prompt-for-file :prompt "File to lock: " + :default + (buffer-default-pathname + (current-buffer)) + :must-exist nil) + p)) + +(defcommand "RCS Check Out Buffer File" (p) + "Checkout the file in the current buffer. With an argument, lock the + file." + "Checkout the file in the current buffer. With an argument, lock the + file." + (let* ((buffer (current-buffer)) + (pathname (current-buffer-pathname)) + (point (current-point)) + (lines (1- (count-lines (region (buffer-start-mark buffer) point))))) + (when (buffer-modified buffer) + (when (not (prompt-for-y-or-n :prompt "Buffer is modified, overwrite? ")) + (editor-error "Aborted."))) + (setf (buffer-modified buffer) nil) + (setf pathname (maybe-rcs-check-out-file buffer pathname p nil)) + (when p + (setf (buffer-writable buffer) t) + (message "Buffer is now writable.")) + (visit-file-command nil pathname) + (unless (line-offset point lines) + (buffer-end point)))) + +(defcommand "RCS Check Out File" (p) + "Prompt for a file and attempt to check it out. With an argument, + lock the file." + "Prompt for a file and attempt to check it out. With an argument, + lock the file." + (let ((pathname (prompt-for-file :prompt "File to check out: " + :default (buffer-default-pathname + (current-buffer)) + :must-exist nil))) + (setf pathname (maybe-rcs-check-out-file nil pathname p nil)) + (find-file-command nil pathname))) + + + +;;;; Log File + +(defhvar "RCS Log Entry Buffer" + "Name of the buffer to put RCS log entries into." + :value "RCS Log") + +(defhvar "RCS Log Buffer Hook" + "RCS Log Buffer Hook" + :value nil) + +(defun get-log-buffer () + (let ((buffer (getstring (value rcs-log-entry-buffer) *buffer-names*))) + (unless buffer + (setf buffer (make-buffer (value rcs-log-entry-buffer))) + (turn-auto-save-off buffer) + (invoke-hook rcs-log-buffer-hook buffer)) + buffer)) + +(defcommand "RCS Buffer File Log Entry" (p) + "Get the RCS Log for the file in the current buffer in a buffer." + "Get the RCS Log for the file in the current buffer in a buffer." + (declare (ignore p)) + (let ((buffer (get-log-buffer)) + (pathname (current-buffer-pathname))) + (delete-region (buffer-region buffer)) + (message "Extracting log info ...") + (with-mark ((mark (buffer-start-mark buffer) :left-inserting)) + (in-directory pathname + (do-command "rlog" (list (file-namestring pathname)) + :output (make-hemlock-output-stream mark)))) + (change-to-buffer buffer) + (buffer-start (current-point)) + (setf (buffer-modified buffer) nil))) + +(defcommand "RCS File Log Entry" (p) + "Prompt for a file and get its RCS log entry in a buffer." + "Prompt for a file and get its RCS log entry in a buffer." + (declare (ignore p)) + (let ((file (prompt-for-file :prompt "File to get log of: " + :default (buffer-default-pathname + (current-buffer)) + :must-exist nil)) + (buffer (get-log-buffer))) + (delete-region (buffer-region buffer)) + (message "Extracing log info ...") + (with-mark ((mark (buffer-start-mark buffer) :left-inserting)) + (in-directory file + (do-command "rlog" (list (file-namestring file)) + :output (make-hemlock-output-stream mark)))) + (change-to-buffer buffer) + (buffer-start (current-point)) + (setf (buffer-modified buffer) nil))) + + + +;;;; Status and Modeline Frobs. + +(defhvar "RCS Status" + "RCS status of this buffer. Either nil, :locked, :out-of-date, or + :unlocked." + :value nil) + +;;; +;;; Note: This doesn't behave correctly w/r/t to branched files. +;;; +(defun rcs-file-status (pathname) + (let* ((directory (directory-namestring pathname)) + (filename (file-namestring pathname)) + (rcs-file (concatenate 'simple-string directory + "RCS/" filename ",v"))) + (if (probe-file rcs-file) + ;; This is an RCS file + (let ((probe-file (probe-file pathname))) + (cond ((and probe-file (hemlock-ext:file-writable probe-file)) + :locked) + ((or (not probe-file) + (< (file-write-date pathname) + (file-write-date rcs-file))) + :out-of-date) + (t + :unlocked)))))) + +(defun rcs-update-buffer-status (buffer &optional tn) + (unless (hemlock-bound-p 'rcs-status :buffer buffer) + (defhvar "RCS Status" + "RCS Status of this buffer." + :buffer buffer + :value nil)) + (let ((tn (or tn (buffer-pathname buffer)))) + (setf (variable-value 'rcs-status :buffer buffer) + (if tn (rcs-file-status tn)))) + (hi::update-modelines-for-buffer buffer)) +;;; +(add-hook read-file-hook 'rcs-update-buffer-status) +(add-hook write-file-hook 'rcs-update-buffer-status) + +(defcommand "RCS Update All RCS Status Variables" (p) + "Update the ``RCS Status'' variable for all buffers." + "Update the ``RCS Status'' variable for all buffers." + (declare (ignore p)) + (dolist (buffer *buffer-list*) + (rcs-update-buffer-status buffer)) + (dolist (window *window-list*) + (update-modeline-fields (window-buffer window) window))) + +;;; +;;; Action Hooks +(defun rcs-action-hook (buffer pathname) + (cond (buffer + (rcs-update-buffer-status buffer)) + (t + (let ((pathname (probe-file pathname))) + (when pathname + (dolist (buffer *buffer-list*) + (let ((buffer-pathname (buffer-pathname buffer))) + (when (equal pathname buffer-pathname) + (rcs-update-buffer-status buffer))))))))) +;;; +(add-hook rcs-check-in-file-hook 'rcs-action-hook) +(add-hook rcs-check-out-file-hook 'rcs-action-hook) +(add-hook rcs-lock-file-hook 'rcs-action-hook) +(add-hook rcs-unlock-file-hook 'rcs-action-hook) + + +;;; +;;; RCS Modeline Field +(make-modeline-field + :name :rcs-status + :function #'(lambda (buffer window) + (declare (ignore buffer window)) + (ecase (value rcs-status) + (:out-of-date "[OLD] ") + (:locked "[LOCKED] ") + (:unlocked "[RCS] ") + ((nil) "")))) Index: /branches/ide-1.0/ccl/hemlock/src/archive/screen.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/archive/screen.lisp (revision 6567) +++ /branches/ide-1.0/ccl/hemlock/src/archive/screen.lisp (revision 6567) @@ -0,0 +1,204 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Written by Bill Chiles. +;;; +;;; Device independent screen management functions. +;;; + +(in-package :hemlock-internals) + + + +;;;; Screen management initialization. + +(declaim (special *echo-area-buffer*)) + +;;; %INIT-SCREEN-MANAGER creates the initial windows and sets up the data +;;; structures used by the screen manager. The "Main" and "Echo Area" buffer +;;; modelines are set here in case the user modified these Hemlock variables in +;;; his init file. Since these buffers don't have windows yet, these sets +;;; won't cause any updates to occur. This is called from %INIT-REDISPLAY. +;;; +(defun %init-screen-manager (display) + (setf (buffer-modeline-fields *current-buffer*) + (value hemlock::default-modeline-fields)) + (setf (buffer-modeline-fields *echo-area-buffer*) + (value hemlock::default-status-line-fields)) + (if (windowed-monitor-p) + (init-bitmap-screen-manager display) + (init-tty-screen-manager (get-terminal-name)))) + + + + +;;;; Window operations. + +(defun make-window (start &key (modelinep t) (device nil) window + (proportion .5) + (font-family *default-font-family*) + (ask-user nil) x y + (width (value hemlock::default-window-width)) + (height (value hemlock::default-window-height))) + "Make a window that displays text starting at the mark start. The default + action is to make the new window a proportion of the current window's height + to make room for the new window. + + Proportion determines what proportion of the current window's height + the new window will use. The current window retains whatever space left + after accommodating the new one. The default is to split the current window + in half. + + Modelinep specifies whether the window should display buffer modelines. + + Device is the Hemlock device to make the window on. If it is nil, then + the window is made on the same device as CURRENT-WINDOW. + + Window is an X window to be used with the Hemlock window. The supplied + window becomes the parent window for a new group of windows that behave + in a stack orientation as windows do on the terminal. + + Font-Family is the font-family used for displaying text in the window. + + If Ask-User is non-nil, Hemlock prompts the user for missing X, Y, Width, + and Height arguments to make a new group of windows that behave in a stack + orientation as windows do on the terminal. This occurs by invoking + hi::*create-window-hook*. X and Y are supplied as pixels, but Width and + Height are supplied in characters." + + (let* ((device (or device (device-hunk-device (window-hunk (current-window))))) + (window (funcall (device-make-window device) + device start modelinep window font-family + ask-user x y width height proportion))) + (unless window (editor-error "Could not make a window.")) + (invoke-hook hemlock::make-window-hook window) + window)) + +(defun delete-window (window) + "Make Window go away, removing it from the screen. This uses + hi::*delete-window-hook* to get rid of parent windows on a bitmap device + when you delete the last Hemlock window in a group." + (when (<= (length *window-list*) 2) + (error "Cannot kill the only window.")) + (invoke-hook hemlock::delete-window-hook window) + (setq *window-list* (delq window *window-list*)) + (funcall (device-delete-window (device-hunk-device (window-hunk window))) + window) + ;; + ;; Since the programmer's interface fails to allow users to determine if + ;; they're commands delete the current window, this primitive needs to + ;; make sure Hemlock doesn't get screwed. This inadequacy comes from the + ;; bitmap window groups and the vague descriptions of PREVIOUS-WINDOW and + ;; NEXT-WINDOW. + (when (eq window *current-window*) + (let ((window (find-if-not #'(lambda (w) (eq w *echo-area-window*)) + *window-list*))) + (setf (current-buffer) (window-buffer window) + (current-window) window)))) + +(defun next-window (window) + "Return the next window after Window, wrapping around if Window is the + bottom window." + (check-type window window) + (funcall (device-next-window (device-hunk-device (window-hunk window))) + window)) + +(defun previous-window (window) + "Return the previous window after Window, wrapping around if Window is the + top window." + (check-type window window) + (funcall (device-previous-window (device-hunk-device (window-hunk window))) + window)) + + + + +;;;; Random typeout support. + +;;; PREPARE-FOR-RANDOM-TYPEOUT -- Internal +;;; +;;; The WITH-POP-UP-DISPLAY macro calls this just before displaying output +;;; for the user. This goes to some effor to compute the height of the window +;;; in text lines if it is not supplied. Whether it is supplied or not, we +;;; add one to the height for the modeline, and we subtract one line if the +;;; last line is empty. Just before using the height, make sure it is at +;;; least two -- one for the modeline and one for text, so window making +;;; primitives don't puke. +;;; +(defun prepare-for-random-typeout (stream height) + (let* ((buffer (line-buffer (mark-line (random-typeout-stream-mark stream)))) + (real-height (1+ (or height (rt-count-lines buffer)))) + (device (device-hunk-device (window-hunk (current-window))))) + (funcall (device-random-typeout-setup device) device stream + (max (if (and (empty-line-p (buffer-end-mark buffer)) (not height)) + (1- real-height) + real-height) + 2)))) + +;;; RT-COUNT-LINES computes the correct height for a window. This includes +;;; taking wrapping line characters into account. Take the MARK-COLUMN at +;;; the end of each line. This is how many characters long hemlock thinks +;;; the line is. When it is displayed, however, end of line characters are +;;; added to the end of each line that wraps. The second INCF form adds +;;; these to the current line length. Then INCF the current height by the +;;; CEILING of the width of the random typeout window and the line length +;;; (with added line-end chars). Use CEILING because there is always at +;;; least one line. Finally, jump out of the loop if we're at the end of +;;; the buffer. +;;; +(defun rt-count-lines (buffer) + (with-mark ((mark (buffer-start-mark buffer))) + (let ((width (window-width (current-window))) + (count 0)) + (loop + (let* ((column (mark-column (line-end mark))) + (temp (ceiling (incf column (floor (1- column) width)) + width))) + ;; Lines with no characters yield zero temp. + (incf count (if (zerop temp) 1 temp)) + (unless (line-offset mark 1) (return count))))))) + + +;;; RANDOM-TYPEOUT-CLEANUP -- Internal +;;; +;;; Clean up after random typeout. This clears the area where the +;;; random typeout was and redisplays any affected windows. +;;; +(defun random-typeout-cleanup (stream &optional (degree t)) + (let* ((window (random-typeout-stream-window stream)) + (buffer (window-buffer window)) + (device (device-hunk-device (window-hunk window))) + (*more-prompt-action* :normal)) + (update-modeline-field buffer window :more-prompt) + (random-typeout-redisplay window) + (setf (buffer-windows buffer) (delete window (buffer-windows buffer))) + (funcall (device-random-typeout-cleanup device) stream degree) + (when (device-force-output device) + (funcall (device-force-output device))))) + +;;; *more-prompt-action* is bound in random typeout streams before +;;; redisplaying. +;;; +(defvar *more-prompt-action* :normal) +(defvar *random-typeout-ml-fields* + (list (make-modeline-field + :name :more-prompt + :function #'(lambda (buffer window) + (declare (ignore window)) + (ecase *more-prompt-action* + (:more "--More--") + (:flush "--Flush--") + (:empty "") + (:normal + (concatenate 'simple-string + "Random Typeout Buffer [" + (buffer-name buffer) + "]"))))))) Index: /branches/ide-1.0/ccl/hemlock/src/archive/scribe.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/archive/scribe.lisp (revision 6567) +++ /branches/ide-1.0/ccl/hemlock/src/archive/scribe.lisp (revision 6567) @@ -0,0 +1,501 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; + +(in-package :hemlock) + + + +;;;; Variables. + +(defvar *scribe-para-break-table* (make-hash-table :test #'equal) + "A table of the Scribe commands that should be paragraph delimiters.") +;;; +(dolist (todo '("begin" "newpage" "make" "device" "caption" "tag" "end" + "chapter" "section" "appendix" "subsection" "paragraph" + "unnumbered" "appendixsection" "prefacesection" "heading" + "majorheading" "subheading")) + (setf (gethash todo *scribe-para-break-table*) t)) + +(defhvar "Open Paren Character" + "The open bracket inserted by Scribe commands." + :value #\[) + +(defhvar "Close Paren Character" + "The close bracket inserted by Scribe commands." + :value #\]) + +(defhvar "Escape Character" + "The escape character inserted by Scribe commands." + :value #\@) + +(defhvar "Scribe Bracket Table" + "This table maps a Scribe brackets, open and close, to their opposing + brackets." + :value (make-array char-code-limit)) +;;; +(mapc #'(lambda (x y) + (setf (svref (value scribe-bracket-table) (char-code x)) y) + (setf (svref (value scribe-bracket-table) (char-code y)) x)) + '(#\( #\[ #\{ #\<) '(#\) #\] #\} #\>)) +;;; +(defun opposing-bracket (bracket) + (svref (value scribe-bracket-table) (char-code bracket))) + + + + +;;;; "Scribe Syntax" Attribute. + +(defattribute "Scribe Syntax" + "For Scribe Syntax, Possible types are: + :ESCAPE ; basically #\@. + :OPEN-PAREN ; Characters that open a Scribe paren: #\[, #\{, #\(, #\<. + :CLOSE-PAREN ; Characters that close a Scribe paren: #\], #\}, #\), #\>. + :SPACE ; Delimits end of a Scribe command. + :NEWLINE ; Delimits end of a Scribe command." + 'symbol nil) + +(setf (character-attribute :scribe-syntax #\)) :close-paren) +(setf (character-attribute :scribe-syntax #\]) :close-paren) +(setf (character-attribute :scribe-syntax #\}) :close-paren) +(setf (character-attribute :scribe-syntax #\>) :close-paren) + +(setf (character-attribute :scribe-syntax #\() :open-paren) +(setf (character-attribute :scribe-syntax #\[) :open-paren) +(setf (character-attribute :scribe-syntax #\{) :open-paren) +(setf (character-attribute :scribe-syntax #\<) :open-paren) + +(setf (character-attribute :scribe-syntax #\space) :space) +(setf (character-attribute :scribe-syntax #\newline) :newline) +(setf (character-attribute :scribe-syntax #\@) :escape) + + + + +;;;; "Scribe" mode and setup. + +(defmode "Scribe" :major-p t) + +(shadow-attribute :paragraph-delimiter #\@ 1 "Scribe") +(shadow-attribute :word-delimiter #\' 0 "Scribe") ;from Text Mode +(shadow-attribute :word-delimiter #\backspace 0 "Scribe") ;from Text Mode +(shadow-attribute :word-delimiter #\_ 0 "Scribe") ;from Text Mode + +(define-file-type-hook ("mss") (buffer type) + (declare (ignore type)) + (setf (buffer-major-mode buffer) "Scribe")) + + + + +;;;; Commands. + +(defcommand "Scribe Mode" (p) + "Puts buffer in Scribe mode. Sets up comment variables and has delimiter + matching. The definition of paragraphs is changed to know about scribe + commands." + "Puts buffer in Scribe mode." + (declare (ignore p)) + (setf (buffer-major-mode (current-buffer)) "Scribe")) + +(defcommand "Select Scribe Warnings" (p) + "Goes to the Scribe Warnings buffer if it exists." + "Goes to the Scribe Warnings buffer if it exists." + (declare (ignore p)) + (let ((buffer (getstring "Scribe Warnings" *buffer-names*))) + (if buffer + (change-to-buffer buffer) + (editor-error "There is no Scribe Warnings buffer.")))) + +(defcommand "Add Scribe Paragraph Delimiter" + (p &optional + (word (prompt-for-string + :prompt "Scribe command: " + :help "Name of Scribe command to make delimit paragraphs." + :trim t))) + "Prompts for a name to add to the table of commands that delimit paragraphs + in Scribe mode. If a prefix argument is supplied, then the command name is + removed from the table." + "Add or remove Word in the *scribe-para-break-table*, depending on P." + (setf (gethash word *scribe-para-break-table*) (not p))) + +(defcommand "List Scribe Paragraph Delimiters" (p) + "Pops up a display of the Scribe commands that delimit paragraphs." + "Pops up a display of the Scribe commands that delimit paragraphs." + (declare (ignore p)) + (let (result) + (maphash #'(lambda (k v) + (declare (ignore v)) + (push k result)) + *scribe-para-break-table*) + (setf result (sort result #'string<)) + (with-pop-up-display (s :height (length result)) + (dolist (ele result) (write-line ele s))))) + +(defcommand "Scribe Insert Bracket" (p) + "Inserts a the bracket it is bound to and then shows the matching bracket." + "Inserts a the bracket it is bound to and then shows the matching bracket." + (declare (ignore p)) + (scribe-insert-paren (current-point) + (hemlock-ext:key-event-char *last-key-event-typed*))) + + +(defhvar "Scribe Command Table" + "This is a character dispatching table indicating which Scribe command or + environment to use." + :value (make-hash-table) + :mode "Scribe") + +(defvar *scribe-directive-type-table* + (make-string-table :initial-contents + '(("Command" . :command) + ("Environment" . :environment)))) + +(defcommand "Add Scribe Directive" (p &optional + (command-name nil command-name-p) + type key-event mode) + "Adds a new scribe function to put into \"Scribe Command Table\"." + "Adds a new scribe function to put into \"Scribe Command Table\"." + (declare (ignore p)) + (let ((command-name (if command-name-p + command-name + (or command-name + (prompt-for-string :help "Directive Name" + :prompt "Directive: "))))) + (multiple-value-bind (ignore type) + (if type + (values nil type) + (prompt-for-keyword + (list *scribe-directive-type-table*) + :help "Enter Command or Environment." + :prompt "Command or Environment: ")) + (declare (ignore ignore)) + (let ((key-event (or key-event + (prompt-for-key-event :prompt + "Dispatch Character: ")))) + (setf (gethash key-event + (cond (mode + (variable-value 'scribe-command-table :mode mode)) + ((hemlock-bound-p 'scribe-command-table) + (value scribe-command-table)) + (t (editor-error + "Could not find \"Scribe Command Table\".")))) + (cons type command-name)))))) + +(defcommand "Insert Scribe Directive" (p) + "Prompts for a character to dispatch on. Some indicate \"commands\" versus + \"environments\". Commands are wrapped around the previous or current word. + If there is no previous word, the command is insert, leaving point between + the brackets. Environments are wrapped around the next or current + paragraph, but when the region is active, this wraps the environment around + the region. Each uses \"Open Paren Character\" and \"Close Paren + Character\"." + "Wrap some text with some stuff." + (declare (ignore p)) + (loop + (let ((key-event (prompt-for-key-event :prompt "Dispatch Character: "))) + (if (logical-key-event-p key-event :help) + (directive-help) + (let ((table-entry (gethash key-event (value scribe-command-table)))) + (ecase (car table-entry) + (:command + (insert-scribe-directive (current-point) (cdr table-entry)) + (return)) + (:environment + (enclose-with-environment (current-point) (cdr table-entry)) + (return)) + ((nil) (editor-error "Unknown dispatch character.")))))))) + + + + +;;;; "Insert Scribe Directive" support. + +(defun directive-help () + (let ((commands ()) + (environments ())) + (declare (list commands environments)) + (maphash #'(lambda (k v) + (if (eql (car v) :command) + (push (cons k (cdr v)) commands) + (push (cons k (cdr v)) environments))) + (value scribe-command-table)) + (setf commands (sort commands #'string< :key #'cdr)) + (setf environments (sort environments #'string< :key #'cdr)) + (with-pop-up-display (s :height (1+ (max (length commands) + (length environments)))) + (format s "~2TCommands~47TEnvironments~%") + (do ((commands commands (rest commands)) + (environments environments (rest environments))) + ((and (endp commands) (endp environments))) + (let* ((command (first commands)) + (environment (first environments)) + (cmd-char (first command)) + (cmd-name (rest command)) + (env-char (first environment)) + (env-name (rest environment))) + (write-string " " s) + (when cmd-char + (hemlock-ext:print-pretty-key-event cmd-char s) + (format s "~7T") + (write-string (or cmd-name "") s)) + (when env-char + (format s "~47T") + (hemlock-ext:print-pretty-key-event env-char s) + (format s "~51T") + (write-string (or env-name "") s)) + (terpri s)))))) + +;;; +;;; Inserting and extending :command directives. +;;; + +(defhvar "Insert Scribe Directive Function" + "\"Insert Scribe Directive\" calls this function when the directive type + is :command. The function takes four arguments: a mark pointing to the word + start, the formatting command string, the open-paren character to use, and a + mark pointing to the word end." + :value 'scribe-insert-scribe-directive-fun + :mode "Scribe") + +(defun scribe-insert-scribe-directive-fun (word-start command-string + open-paren-char word-end) + (insert-character word-start (value escape-character)) + (insert-string word-start command-string) + (insert-character word-start open-paren-char) + (insert-character word-end (value close-paren-character))) + +(defhvar "Extend Scribe Directive Function" + "\"Insert Scribe Directive\" calls this function when the directive type is + :command to extend the the commands effect. This function takes a string + and three marks: the first on pointing before the open-paren character for + the directive. The string is the command-string to selected by the user + which this function uses to determine if it is actually extending a command + or inserting a new one. The function must move the first mark before any + command text for the directive and the second mark to the end of any command + text. It moves the third mark to the previous word's start where the + command region should be. If this returns non-nil \"Insert Scribe + Directive\" moves the command region previous one word, and otherwise it + inserts the directive." + :value 'scribe-extend-scribe-directive-fun + :mode "Scribe") + +(defun scribe-extend-scribe-directive-fun (command-string + command-end command-start word-start) + (word-offset (move-mark command-start command-end) -1) + (when (string= (the simple-string (region-to-string + (region command-start command-end))) + command-string) + (mark-before command-start) + (mark-after command-end) + (word-offset (move-mark word-start command-start) -1))) + +;;; INSERT-SCRIBE-DIRECTIVE first looks for the current or previous word at +;;; mark. Word-p says if we found one. If mark is immediately before a word, +;;; we use that word instead of the previous. This is because if mark +;;; corresponds to the CURRENT-POINT, the Hemlock cursor is displayed on the +;;; first character of the word making users think the mark is in the word +;;; instead of before it. If we find a word, then we see if it already has +;;; the given command-string, and if it does, we extend the use of the command- +;;; string to the previous word. At the end, if we hadn't found a word, we +;;; backup the mark one character to put it between the command brackets. +;;; +(defun insert-scribe-directive (mark &optional command-string) + (with-mark ((word-start mark :left-inserting) + (word-end mark :left-inserting)) + (let ((open-paren-char (value open-paren-character)) + (word-p (if (and (zerop (character-attribute + :word-delimiter + (next-character word-start))) + (= (character-attribute + :word-delimiter + (previous-character word-start)) + 1)) + word-start + (word-offset word-start -1))) + (command-string (or command-string + (prompt-for-string + :trim t :prompt "Environment: " + :help "Name of environment to enclose with.")))) + (declare (simple-string command-string)) + (cond + (word-p + (word-offset (move-mark word-end word-start) 1) + (if (test-char (next-character word-end) :scribe-syntax + :close-paren) + (with-mark ((command-start word-start :left-inserting) + (command-end word-end :left-inserting)) + ;; Move command-end from word-end to open-paren of command. + (balance-paren (mark-after command-end)) + (if (funcall (value extend-scribe-directive-function) + command-string command-end command-start word-start) + (let ((region (delete-and-save-region + (region command-start command-end)))) + (word-offset (move-mark word-start command-start) -1) + (ninsert-region word-start region)) + (funcall (value insert-scribe-directive-function) + word-start command-string open-paren-char + word-end))) + (funcall (value insert-scribe-directive-function) + word-start command-string open-paren-char word-end))) + (t + (funcall (value insert-scribe-directive-function) + word-start command-string open-paren-char word-end) + (mark-before mark)))))) + +;;; +;;; Inserting :environment directives. +;;; + +(defun enclose-with-environment (mark &optional environment) + (if (region-active-p) + (let ((region (current-region))) + (with-mark ((top (region-start region) :left-inserting) + (bottom (region-end region) :left-inserting)) + (get-and-insert-environment top bottom environment))) + (with-mark ((bottom-mark mark :left-inserting)) + (let ((paragraphp (paragraph-offset bottom-mark 1))) + (unless (or paragraphp + (and (last-line-p bottom-mark) + (end-line-p bottom-mark) + (not (blank-line-p (mark-line bottom-mark))))) + (editor-error "No paragraph to enclose.")) + (with-mark ((top-mark bottom-mark :left-inserting)) + (paragraph-offset top-mark -1) + (cond ((not (blank-line-p (mark-line top-mark))) + (insert-character top-mark #\Newline) + (mark-before top-mark)) + (t + (insert-character top-mark #\Newline))) + (cond ((and (last-line-p bottom-mark) + (not (blank-line-p (mark-line bottom-mark)))) + (insert-character bottom-mark #\Newline)) + (t + (insert-character bottom-mark #\Newline) + (mark-before bottom-mark))) + (get-and-insert-environment top-mark bottom-mark environment)))))) + +(defun get-and-insert-environment (top-mark bottom-mark environment) + (let ((environment (or environment + (prompt-for-string + :trim t :prompt "Environment: " + :help "Name of environment to enclose with.")))) + (insert-environment top-mark "begin" environment) + (insert-environment bottom-mark "end" environment))) + +(defun insert-environment (mark command environment) + (let ((esc-char (value escape-character)) + (open-paren (value open-paren-character)) + (close-paren (value close-paren-character))) + (insert-character mark esc-char) + (insert-string mark command) + (insert-character mark open-paren) + (insert-string mark environment) + (insert-character mark close-paren))) + + +(add-scribe-directive-command nil nil :Environment #k"Control-l" "Scribe") +(add-scribe-directive-command nil nil :Command #k"Control-w" "Scribe") +(add-scribe-directive-command nil "Begin" :Command #k"b" "Scribe") +(add-scribe-directive-command nil "End" :Command #k"e" "Scribe") +(add-scribe-directive-command nil "Center" :Environment #k"c" "Scribe") +(add-scribe-directive-command nil "Description" :Environment #k"d" "Scribe") +(add-scribe-directive-command nil "Display" :Environment #k"Control-d" "Scribe") +(add-scribe-directive-command nil "Enumerate" :Environment #k"n" "Scribe") +(add-scribe-directive-command nil "Example" :Environment #k"x" "Scribe") +(add-scribe-directive-command nil "FileExample" :Environment #k"y" "Scribe") +(add-scribe-directive-command nil "FlushLeft" :Environment #k"l" "Scribe") +(add-scribe-directive-command nil "FlushRight" :Environment #k"r" "Scribe") +(add-scribe-directive-command nil "Format" :Environment #k"f" "Scribe") +(add-scribe-directive-command nil "Group" :Environment #k"g" "Scribe") +(add-scribe-directive-command nil "Itemize" :Environment #k"Control-i" "Scribe") +(add-scribe-directive-command nil "Multiple" :Environment #k"m" "Scribe") +(add-scribe-directive-command nil "ProgramExample" :Environment #k"p" "Scribe") +(add-scribe-directive-command nil "Quotation" :Environment #k"q" "Scribe") +(add-scribe-directive-command nil "Text" :Environment #k"t" "Scribe") +(add-scribe-directive-command nil "i" :Command #k"i" "Scribe") +(add-scribe-directive-command nil "b" :Command #k"Control-b" "Scribe") +(add-scribe-directive-command nil "-" :Command #k"\-" "Scribe") +(add-scribe-directive-command nil "+" :Command #k"+" "Scribe") +(add-scribe-directive-command nil "u" :Command #k"Control-j" "Scribe") +(add-scribe-directive-command nil "p" :Command #k"Control-p" "Scribe") +(add-scribe-directive-command nil "r" :Command #k"Control-r" "Scribe") +(add-scribe-directive-command nil "t" :Command #k"Control-t" "Scribe") +(add-scribe-directive-command nil "g" :Command #k"Control-a" "Scribe") +(add-scribe-directive-command nil "un" :Command #k"Control-n" "Scribe") +(add-scribe-directive-command nil "ux" :Command #k"Control-x" "Scribe") +(add-scribe-directive-command nil "c" :Command #k"Control-k" "Scribe") + + + + +;;;; Scribe paragraph delimiter function. + +(defhvar "Paragraph Delimiter Function" + "Scribe Mode's way of delimiting paragraphs." + :mode "Scribe" + :value 'scribe-delim-para-function) + +(defun scribe-delim-para-function (mark) + "Returns whether there is a paragraph delimiting Scribe command on the + current line. Add or remove commands for this purpose with the command + \"Add Scribe Paragraph Delimiter\"." + (let ((next-char (next-character mark))) + (when (paragraph-delimiter-attribute-p next-char) + (if (eq (character-attribute :scribe-syntax next-char) :escape) + (with-mark ((begin mark) + (end mark)) + (mark-after begin) + (if (scan-char end :scribe-syntax (or :space :newline :open-paren)) + (gethash (nstring-downcase (region-to-string (region begin end))) + *scribe-para-break-table*) + (editor-error "Unable to find Scribe command ending."))) + t)))) + + + + +;;;; Bracket matching. + +(defun scribe-insert-paren (mark bracket-char) + (insert-character mark bracket-char) + (with-mark ((m mark)) + (if (balance-paren m) + (when (value paren-pause-period) + (unless (show-mark m (current-window) (value paren-pause-period)) + (clear-echo-area) + (message "~A" (line-string (mark-line m))))) + (editor-error)))) + +;;; BALANCE-PAREN moves the mark to the matching open paren character, or +;;; returns nil. The mark must be after the closing paren. +;;; +(defun balance-paren (mark) + (with-mark ((m mark)) + (when (rev-scan-char m :scribe-syntax (or :open-paren :close-paren)) + (mark-before m) + (let ((paren-count 1) + (first-paren (next-character m))) + (loop + (unless (rev-scan-char m :scribe-syntax (or :open-paren :close-paren)) + (return nil)) + (if (test-char (previous-character m) :scribe-syntax :open-paren) + (setq paren-count (1- paren-count)) + (setq paren-count (1+ paren-count))) + (when (< paren-count 0) (return nil)) + (when (= paren-count 0) + ;; OPPOSING-BRACKET calls VALUE (each time around the loop) + (cond ((char= (opposing-bracket (previous-character m)) first-paren) + (mark-before (move-mark mark m)) + (return t)) + (t (editor-error "Scribe paren mismatch.")))) + (mark-before m)))))) Index: /branches/ide-1.0/ccl/hemlock/src/archive/shell.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/archive/shell.lisp (revision 6567) +++ /branches/ide-1.0/ccl/hemlock/src/archive/shell.lisp (revision 6567) @@ -0,0 +1,558 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Hemlock command level support for processes. +;;; +;;; Written by Blaine Burks. +;;; + +(in-package :hemlock) + + +(defun setup-process-buffer (buffer) + (let ((mark (copy-mark (buffer-point buffer) :right-inserting))) + (defhvar "Buffer Input Mark" + "The buffer input mark for this buffer." + :buffer buffer + :value mark) + (defhvar "Process Output Stream" + "The process structure for this buffer." + :buffer buffer + :value (make-hemlock-output-stream mark :full)) + (defhvar "Interactive History" + "A ring of the regions input to an interactive mode (Eval or Typescript)." + :buffer buffer + :value (make-ring (value interactive-history-length))) + (defhvar "Interactive Pointer" + "Pointer into \"Interactive History\"." + :buffer buffer + :value 0) + (defhvar "Searching Interactive Pointer" + "Pointer into \"Interactive History\"." + :buffer buffer + :value 0) + (unless (buffer-modeline-field-p buffer :process-status) + (setf (buffer-modeline-fields buffer) + (nconc (buffer-modeline-fields buffer) + (list (modeline-field :process-status))))))) + +(defmode "Process" :major-p nil :setup-function #'setup-process-buffer) + + + + +;;;; Shell-filter streams. + +;;; We use shell-filter-streams to capture text going from the shell process to +;;; a Hemlock output stream. They pass character and misc operations through +;;; to the attached hemlock-output-stream. The string output function scans +;;; the string for ^A_____^B, denoting a change of directory. +;;; +;;; The following aliases in a .cshrc file are required for using filename +;;; completion: +;;; alias cd 'cd \!* ; echo ""`pwd`"/"' +;;; alias popd 'popd \!* ; echo ""`pwd`"/"' +;;; alias pushd 'pushd \!* ; echo ""`pwd`"/"' +;;; + +(defstruct (shell-filter-stream + (:include sys:lisp-stream + (:out #'shell-filter-out) + (:sout #'shell-filter-string-out) + (:misc #'shell-filter-output-misc)) + (:print-function print-shell-filter-stream) + (:constructor + make-shell-filter-stream (buffer hemlock-stream))) + ;; The buffer where output will be going + buffer + ;; The Hemlock stream to which output will be directed + hemlock-stream) + + +;;; PRINT-SHELL-FILTER-STREAM -- Internal +;;; +;;; Function for printing a shell-filter-stream. +;;; +(defun print-shell-filter-stream (s stream d) + (declare (ignore d s)) + (write-string "#" stream)) + + +;;; SHELL-FILTER-OUT -- Internal +;;; +;;; This is the character-out handler for the shell-filter-stream. +;;; It writes the character it is given to the underlying +;;; hemlock-output-stream. +;;; +(defun shell-filter-out (stream character) + (write-char character (shell-filter-stream-hemlock-stream stream))) + + +;;; SHELL-FILTER-OUTPUT-MISC -- Internal +;;; +;;; This will also simply pass the output request on the the +;;; attached hemlock-output-stream. +;;; +(defun shell-filter-output-misc (stream operation &optional arg1 arg2) + (let ((hemlock-stream (shell-filter-stream-hemlock-stream stream))) + (funcall (hi::hemlock-output-stream-misc hemlock-stream) + hemlock-stream operation arg1 arg2))) + + +;;; CATCH-CD-STRING -- Internal +;;; +;;; Scans String for the sequence ^A...^B. Returns as multiple values +;;; the breaks in the string. If the second start/end pair is nil, there +;;; was no cd sequence. +;;; +(defun catch-cd-string (string start end) + (declare (simple-string string)) + (let ((cd-start (position (code-char 1) string :start start :end end))) + (if cd-start + (let ((cd-end (position (code-char 2) string :start cd-start :end end))) + (if cd-end + (values start cd-start cd-end end) + (values start end nil nil))) + (values start end nil nil)))) + +;;; SHELL-FILTER-STRING-OUT -- Internal +;;; +;;; The string output function for shell-filter-stream's. +;;; Any string containing a ^A...^B is caught and assumed to be +;;; the path-name of the new current working directory. This is +;;; removed from the orginal string and the result is passed along +;;; to the Hemlock stream. +;;; +(defun shell-filter-string-out (stream string start end) + (declare (simple-string string)) + (let ((hemlock-stream (shell-filter-stream-hemlock-stream stream)) + (buffer (shell-filter-stream-buffer stream))) + + (multiple-value-bind (start1 end1 start2 end2) + (catch-cd-string string start end) + (write-string string hemlock-stream :start start1 :end end1) + (when start2 + (write-string string hemlock-stream :start (+ 2 start2) :end end2) + (let ((cd-string (subseq string (1+ end1) start2))) + (setf (variable-value 'current-working-directory :buffer buffer) + (pathname cd-string))))))) + + +;;; FILTER-TILDES -- Internal +;;; +;;; Since COMPLETE-FILE does not seem to deal with ~'s in the filename +;;; this function expands them to a full path name. +;;; +(defun filter-tildes (name) + (declare (simple-string name)) + (if (char= (schar name 0) #\~) + (concatenate 'simple-string + (if (or (= (length name) 1) + (char= (schar name 1) #\/)) + (cdr (assoc :home *environment-list*)) + "/usr/") + (subseq name 1)) + name)) + + + + +;;;; Support for handling input before the prompt in process buffers. + +(defun unwedge-process-buffer () + (buffer-end (current-point)) + (deliver-signal-to-process :SIGINT (value process)) + (editor-error "Aborted.")) + +(defhvar "Unwedge Interactive Input Fun" + "Function to call when input is confirmed, but the point is not past the + input mark." + :value #'unwedge-process-buffer + :mode "Process") + +(defhvar "Unwedge Interactive Input String" + "String to add to \"Point not past input mark. \" explaining what will + happen if the the user chooses to be unwedged." + :value "Interrupt and throw to end of buffer?" + :mode "Process") + + + + +;;;; Some Global Variables. + +(defhvar "Current Shell" + "The shell to which \"Select Shell\" goes." + :value nil) + +(defhvar "Ask about Old Shells" + "When set (the default), Hemlock prompts for an existing shell buffer in + preference to making a new one when there is no \"Current Shell\"." + :value t) + +(defhvar "Kill Process Confirm" + "When set, Hemlock prompts for confirmation before killing a buffer's process." + :value t) + +(defhvar "Shell Utility" + "The \"Shell\" command uses this as the default command line." + :value "/bin/csh") + +(defhvar "Shell Utility Switches" + "This is a string containing the default command line arguments to the + utility in \"Shell Utility\". This is a string since the utility is + typically \"/bin/csh\", and this string can contain I/O redirection and + other shell directives." + :value "") + + + + +;;;; The Shell, New Shell, and Set Current Shell Commands. + +(defvar *shell-names* (make-string-table) + "A string-table of the string-name of all process buffers and corresponding + buffer structures.") + +(defcommand "Set Current Shell" (p) + "Sets the value of \"Current Shell\", which the \"Shell\" command uses." + "Sets the value of \"Current Shell\", which the \"Shell\" command uses." + (declare (ignore p)) + (set-current-shell)) + +;;; SET-CURRENT-SHELL -- Internal. +;;; +;;; This prompts for a known shell buffer to which it sets "Current Shell". +;;; It signals an error if there are none. +;;; +(defun set-current-shell () + (let ((old-buffer (value current-shell)) + (first-old-shell (do-strings (var val *shell-names* nil) + (declare (ignore val)) + (return var)))) + (when (and (not old-buffer) (not first-old-shell)) + (editor-error "Nothing to set current shell to.")) + (let ((default-shell (if old-buffer + (buffer-name old-buffer) + first-old-shell))) + (multiple-value-bind + (new-buffer-name new-buffer) + (prompt-for-keyword (list *shell-names*) + :must-exist t + :default default-shell + :default-string default-shell + :prompt "Existing Shell: " + :help "Enter the name of an existing shell.") + (declare (ignore new-buffer-name)) + (setf (value current-shell) new-buffer))))) + +(defcommand "Shell" (p) + "This spawns a shell in a buffer. If there already is a \"Current Shell\", + this goes to that buffer. If there is no \"Current Shell\", there are + shell buffers, and \"Ask about Old Shells\" is set, this prompts for one + of them, setting \"Current Shell\" to that shell. Supplying an argument + forces the creation of a new shell buffer." + "This spawns a shell in a buffer. If there already is a \"Current Shell\", + this goes to that buffer. If there is no \"Current Shell\", there are + shell buffers, and \"Ask about Old Shells\" is set, this prompts for one + of them, setting \"Current Shell\" to that shell. Supplying an argument + forces the creation of a new shell buffer." + (let ((shell (value current-shell)) + (no-shells-p (do-strings (var val *shell-names* t) + (declare (ignore var val)) + (return nil)))) + (cond (p (make-new-shell nil no-shells-p)) + (shell (change-to-buffer shell)) + ((and (value ask-about-old-shells) (not no-shells-p)) + (set-current-shell) + (change-to-buffer (value current-shell))) + (t (make-new-shell nil))))) + +(defcommand "Shell Command Line in Buffer" (p) + "Prompts the user for a process and a buffer in which to run the process." + "Prompts the user for a process and a buffer in which to run the process." + (declare (ignore p)) + (make-new-shell t)) + +;;; MAKE-NEW-SHELL -- Internal. +;;; +;;; This makes new shells for us dealing with prompting for various things and +;;; setting "Current Shell" according to user documentation. +;;; +(defun make-new-shell (prompt-for-command-p &optional (set-current-shell-p t) + (command-line (get-command-line) clp)) + (let* ((command (or (and clp command-line) + (if prompt-for-command-p + (prompt-for-string + :default command-line :trim t + :prompt "Command to execute: " + :help "Shell command line to execute.") + command-line))) + (buffer-name (if prompt-for-command-p + (prompt-for-string + :default + (concatenate 'simple-string command " process") + :trim t + :prompt `("Buffer in which to execute ~A? " + ,command) + :help "Where output from this process will appear.") + (new-shell-name))) + (temp (make-buffer + buffer-name + :modes '("Fundamental" "Process") + :delete-hook + (list #'(lambda (buffer) + (when (eq (value current-shell) buffer) + (setf (value current-shell) nil)) + (delete-string (buffer-name buffer) *shell-names*) + (kill-process (variable-value 'process + :buffer buffer)))))) + (buffer (or temp (getstring buffer-name *buffer-names*))) + (stream (variable-value 'process-output-stream :buffer buffer)) + (output-stream + ;; If we re-used an old shell buffer, this isn't necessary. + (if (hemlock-output-stream-p stream) + (setf (variable-value 'process-output-stream :buffer buffer) + (make-shell-filter-stream buffer stream)) + stream))) + (buffer-end (buffer-point buffer)) + (defhvar "Process" + "The process for Shell and Process buffers." + :buffer buffer + :value (ext::run-program "/bin/sh" (list "-c" command) + :wait nil + :pty output-stream + :env (frob-environment-list + (car (buffer-windows buffer))) + :status-hook #'(lambda (process) + (declare (ignore process)) + (update-process-buffer buffer)) + :input t :output t)) + (defhvar "Current Working Directory" + "The pathname of the current working directory for this buffer." + :buffer buffer + :value (default-directory)) + (setf (getstring buffer-name *shell-names*) buffer) + (update-process-buffer buffer) + (when (and (not (value current-shell)) set-current-shell-p) + (setf (value current-shell) buffer)) + (change-to-buffer buffer))) + +;;; GET-COMMAND-LINE -- Internal. +;;; +;;; This just conses up a string to feed to the shell. +;;; +(defun get-command-line () + (concatenate 'simple-string (value shell-utility) " " + (value shell-utility-switches))) + +;;; FROB-ENVIRONMENT-LIST -- Internal. +;;; +;;; This sets some environment variables so the shell will be in the proper +;;; state when it comes up. +;;; +(defun frob-environment-list (window) + (list* (cons :termcap (concatenate 'simple-string + "emacs:co#" + (if window + (lisp::quick-integer-to-string + (window-width window)) + "") + ":tc=unkown:")) + (cons :emacs "t") (cons :term "emacs") + (remove-if #'(lambda (keyword) + (member keyword '(:termcap :emacs :term) + :test #'(lambda (cons keyword) + (eql (car cons) keyword)))) + ext:*environment-list*))) + +;;; NEW-SHELL-NAME -- Internal. +;;; +;;; This returns a unique buffer name for a shell by incrementing the value of +;;; *process-number* until "Process <*process-number*> is not already the name +;;; of a buffer. Perhaps this is being overly cautious, but I've seen some +;;; really stupid users. +;;; +(defvar *process-number* 0) +;;; +(defun new-shell-name () + (loop + (let ((buffer-name (format nil "Shell ~D" (incf *process-number*)))) + (unless (getstring buffer-name *buffer-names*) (return buffer-name))))) + + + +;;;; Modeline support. + +(defun modeline-process-status (buffer window) + (declare (ignore window)) + (when (hemlock-bound-p 'process :buffer buffer) + (let ((process (variable-value 'process :buffer buffer))) + (ecase (ext:process-status process) + (:running "running") + (:stopped "stopped") + (:signaled "killed by signal ~D" (unix:unix-signal-name + (ext:process-exit-code process))) + (:exited (format nil "exited with status ~D" + (ext:process-exit-code process))))))) + + +(make-modeline-field :name :process-status + :function #'modeline-process-status) + +(defun update-process-buffer (buffer) + (when (buffer-modeline-field-p buffer :process-status) + (dolist (window (buffer-windows buffer)) + (update-modeline-field buffer window :process-status))) + (let ((process (variable-value 'process :buffer buffer))) + (unless (ext:process-alive-p process) + (ext:process-close process) + (when (eq (value current-shell) buffer) + (setf (value current-shell) nil))))) + + + +;;;; Supporting Commands. + +(defcommand "Confirm Process Input" (p) + "Evaluate Process Mode input between the point and last prompt." + "Evaluate Process Mode input between the point and last prompt." + (declare (ignore p)) + (unless (hemlock-bound-p 'process :buffer (current-buffer)) + (editor-error "Not in a process buffer.")) + (let* ((process (value process)) + (stream (ext:process-pty process))) + (case (ext:process-status process) + (:running) + (:stopped (editor-error "The process has been stopped.")) + (t (editor-error "The process is dead."))) + (let ((input-region (get-interactive-input))) + (write-line (region-to-string input-region) stream) + (force-output (ext:process-pty process)) + (insert-character (current-point) #\newline) + ;; Move "Buffer Input Mark" to end of buffer. + (move-mark (region-start input-region) (region-end input-region))))) + +(defcommand "Shell Complete Filename" (p) + "Attempts to complete the filename immediately preceding the point. + It will beep if the result of completion is not unique." + "Attempts to complete the filename immediately preceding the point. + It will beep if the result of completion is not unique." + (declare (ignore p)) + (unless (hemlock-bound-p 'current-working-directory) + (editor-error "Shell filename completion only works in shells.")) + (let ((point (current-point))) + (with-mark ((start point)) + (pre-command-parse-check start) + (unless (form-offset start -1) (editor-error "Can't grab filename.")) + (when (member (next-character start) '(#\" #\' #\< #\>)) + (mark-after start)) + (let* ((name-region (region start point)) + (fragment (filter-tildes (region-to-string name-region))) + (dir (default-directory)) + (shell-dir (value current-working-directory))) + (multiple-value-bind (filename unique) + (unwind-protect + (progn + (setf (default-directory) shell-dir) + (complete-file fragment :defaults shell-dir)) + (setf (default-directory) dir)) + (cond (filename + (delete-region name-region) + (insert-string point (namestring filename)) + (when (not unique) + (editor-error))) + (t (editor-error "No such file exists.")))))))) + +(defcommand "Kill Main Process" (p) + "Kills the process in the current buffer." + "Kills the process in the current buffer." + (declare (ignore p)) + (unless (hemlock-bound-p 'process :buffer (current-buffer)) + (editor-error "Not in a process buffer.")) + (when (or (not (value kill-process-confirm)) + (prompt-for-y-or-n :default nil + :prompt "Really blow away shell? " + :default nil + :default-string "no")) + (kill-process (value process)))) + +(defcommand "Stop Main Process" (p) + "Stops the process in the current buffer. With an argument use :SIGSTOP + instead of :SIGTSTP." + "Stops the process in the current buffer. With an argument use :SIGSTOP + instead of :SIGTSTP." + (unless (hemlock-bound-p 'process :buffer (current-buffer)) + (editor-error "Not in a process buffer.")) + (deliver-signal-to-process (if p :SIGSTOP :SIGTSTP) (value process))) + +(defcommand "Continue Main Process" (p) + "Continues the process in the current buffer." + "Continues the process in the current buffer." + (declare (ignore p)) + (unless (hemlock-bound-p 'process :buffer (current-buffer)) + (editor-error "Not in a process buffer.")) + (deliver-signal-to-process :SIGCONT (value process))) + +(defun kill-process (process) + "Self-explanatory." + (deliver-signal-to-process :SIGKILL process)) + +(defun deliver-signal-to-process (signal process) + "Delivers a signal to a process." + (ext:process-kill process signal :process-group)) + +(defcommand "Send EOF to Process" (p) + "Sends a Ctrl-D to the process in the current buffer." + "Sends a Ctrl-D to the process in the current buffer." + (declare (ignore p)) + (unless (hemlock-bound-p 'process :buffer (current-buffer)) + (editor-error "Not in a process buffer.")) + (let ((stream (ext:process-pty (value process)))) + (write-char (code-char 4) stream) + (force-output stream))) + +(defcommand "Interrupt Buffer Subprocess" (p) + "Stop the subprocess currently executing in this shell." + "Stop the subprocess currently executing in this shell." + (declare (ignore p)) + (unless (hemlock-bound-p 'process :buffer (current-buffer)) + (editor-error "Not in a process buffer.")) + (buffer-end (current-point)) + (buffer-end (value buffer-input-mark)) + (deliver-signal-to-subprocess :SIGINT (value process))) + +(defcommand "Kill Buffer Subprocess" (p) + "Kill the subprocess currently executing in this shell." + "Kill the subprocess currently executing in this shell." + (declare (ignore p)) + (unless (hemlock-bound-p 'process :buffer (current-buffer)) + (editor-error "Not in a process buffer.")) + (deliver-signal-to-subprocess :SIGKILL (value process))) + +(defcommand "Quit Buffer Subprocess" (p) + "Quit the subprocess currently executing int his shell." + "Quit the subprocess currently executing int his shell." + (declare (ignore p)) + (unless (hemlock-bound-p 'process :buffer (current-buffer)) + (editor-error "Not in a process buffer.")) + (deliver-signal-to-subprocess :SIGQUIT (value process))) + +(defcommand "Stop Buffer Subprocess" (p) + "Stop the subprocess currently executing in this shell." + "Stop the subprocess currently executing in this shell." + (unless (hemlock-bound-p 'process :buffer (current-buffer)) + (editor-error "Not in a process buffer.")) + (deliver-signal-to-subprocess (if p :SIGSTOP :SIGTSTP) (value process))) + +(defun deliver-signal-to-subprocess (signal process) + "Delivers a signal to a subprocess of a shell." + (ext:process-kill process signal :pty-process-group)) Index: /branches/ide-1.0/ccl/hemlock/src/archive/spell-aug.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/archive/spell-aug.lisp (revision 6567) +++ /branches/ide-1.0/ccl/hemlock/src/archive/spell-aug.lisp (revision 6567) @@ -0,0 +1,237 @@ +;;; -*- Log: hemlock.log; Package: Spell -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Written by Bill Chiles +;;; Designed by Bill Chiles and Rob Maclachlan +;;; +;;; This file contains the code to grow the spelling dictionary in system +;;; space by reading a text file of entries or adding one at a time. This +;;; code relies on implementation dependent code found in Spell-RT.Lisp. + + +(in-package "SPELL") + + + +;;;; Converting Flags to Masks + +(defconstant flag-names-to-masks + `((#\V . ,V-mask) (#\N . ,N-mask) (#\X . ,X-mask) + (#\H . ,H-mask) (#\Y . ,Y-mask) (#\G . ,G-mask) + (#\J . ,J-mask) (#\D . ,D-mask) (#\T . ,T-mask) + (#\R . ,R-mask) (#\Z . ,Z-mask) (#\S . ,S-mask) + (#\P . ,P-mask) (#\M . ,M-mask))) + +(defvar *flag-masks* + (make-array 128 :element-type '(unsigned-byte 16) :initial-element 0) + "This holds the masks for character flags, which is used when reading + a text file of dictionary words. Illegal character flags hold zero.") + +(eval-when (:compile-toplevel :execute) +(defmacro flag-mask (char) + `(aref *flag-masks* (char-code ,char))) +) ;eval-when + +(dolist (e flag-names-to-masks) + (let ((char (car e)) + (mask (cdr e))) + (setf (flag-mask char) mask) + (setf (flag-mask (char-downcase char)) mask))) + + + + +;;;; String and Hashing Macros + +(eval-when (:compile-toplevel :execute) + +(defmacro string-table-replace (src-string dst-start length) + `(sap-replace *string-table* ,src-string 0 ,dst-start (+ ,dst-start ,length))) + +;;; HASH-ENTRY is used in SPELL-ADD-ENTRY to find a dictionary location for +;;; adding a new entry. If a location contains a zero, then it has never been +;;; used, and no entries have ever been "hashed past" it. If a location +;;; contains SPELL-DELETED-ENTRY, then it once contained an entry that has +;;; since been deleted. +;;; +(defmacro hash-entry (entry entry-len) + (let ((loop-loc (gensym)) (loc-contents (gensym)) + (hash (gensym)) (loc (gensym))) + `(let* ((,hash (string-hash ,entry ,entry-len)) + (,loc (rem ,hash (the fixnum *dictionary-size*))) + (,loc-contents (dictionary-ref ,loc))) + (declare (fixnum ,loc ,loc-contents)) + (if (or (zerop ,loc-contents) (= ,loc-contents spell-deleted-entry)) + ,loc + (hash2-loop (,loop-loc ,loc-contents) ,loc ,hash + ,loop-loc nil t))))) + +) ;eval-when + + + + +;;;; Top Level Stuff + +(defun spell-read-dictionary (filename) + "Add entries to dictionary from lines in the file filename." + (with-open-file (s filename :direction :input) + (loop (multiple-value-bind (entry eofp) (read-line s nil nil) + (declare (type (or simple-string null) entry)) + (unless entry (return)) + (spell-add-entry entry) + (if eofp (return)))))) + + +;;; This is used to break up an 18 bit string table index into two parts +;;; for storage in a word descriptor unit. See the documentation at the +;;; top of Spell-Correct.Lisp. +;;; +(defconstant whole-index-low-byte (byte 16 0)) + +(defun spell-add-entry (line &optional + (word-end (or (position #\/ line :test #'char=) + (length line)))) + "Line is of the form \"entry/flag1/flag2\" or \"entry\". It is parsed and + added to the spelling dictionary. Line is desstructively modified." + (declare (simple-string line) (fixnum word-end)) + (nstring-upcase line :end word-end) + (when (> word-end max-entry-length) + (return-from spell-add-entry nil)) + (let ((entry (lookup-entry line word-end))) + (when entry + (add-flags (+ entry 2) line word-end) + (return-from spell-add-entry nil))) + (let* ((hash-loc (hash-entry line word-end)) + (string-ptr *string-table-size*) + (desc-ptr *descriptors-size*) + (desc-ptr+1 (1+ desc-ptr)) + (desc-ptr+2 (1+ desc-ptr+1))) + (declare (fixnum string-ptr)) + (when (not hash-loc) (error "Dictionary Overflow!")) + (when (> 3 *free-descriptor-elements*) (grow-descriptors)) + (when (> word-end *free-string-table-bytes*) (grow-string-table)) + (decf *free-descriptor-elements* 3) + (incf *descriptors-size* 3) + (decf *free-string-table-bytes* word-end) + (incf *string-table-size* word-end) + (setf (dictionary-ref hash-loc) desc-ptr) + (setf (descriptor-ref desc-ptr) + (dpb (the fixnum (ldb new-hash-byte (string-hash line word-end))) + stored-hash-byte + word-end)) + (setf (descriptor-ref desc-ptr+1) + (ldb whole-index-low-byte string-ptr)) + (setf (descriptor-ref desc-ptr+2) + (dpb (the fixnum (ldb whole-index-high-byte string-ptr)) + stored-index-high-byte + 0)) + (add-flags desc-ptr+2 line word-end) + (string-table-replace line string-ptr word-end)) + t) + +(defun add-flags (loc line word-end) + (declare (simple-string line) (fixnum word-end)) + (do ((flag (1+ word-end) (+ 2 flag)) + (line-end (length line))) + ((>= flag line-end)) + (declare (fixnum flag line-end)) + (let ((flag-mask (flag-mask (schar line flag)))) + (declare (fixnum flag-mask)) + (unless (zerop flag-mask) + (setf (descriptor-ref loc) + (logior flag-mask (descriptor-ref loc))))))) + +;;; SPELL-REMOVE-ENTRY destructively uppercases entry in removing it from +;;; the dictionary. First entry is looked up, and if it is found due to a +;;; flag, the flag is cleared in the descriptor table. If entry is a root +;;; word in the dictionary (that is, looked up without the use of a flag), +;;; then the root and all its derivitives are deleted by setting its +;;; dictionary location to spell-deleted-entry. +;;; +(defun spell-remove-entry (entry) + "Removes entry from the dictionary, so it will be an unknown word. Entry + is a simple string and is destructively modified. If entry is a root + word, then all words derived with entry and its flags will also be deleted." + (declare (simple-string entry)) + (nstring-upcase entry) + (let ((entry-len (length entry))) + (declare (fixnum entry-len)) + (when (<= 2 entry-len max-entry-length) + (multiple-value-bind (index flagp) + (spell-try-word entry entry-len) + (when index + (if flagp + (setf (descriptor-ref (+ 2 index)) + (logandc2 (descriptor-ref (+ 2 index)) flagp)) + (let* ((hash (string-hash entry entry-len)) + (hash-and-len (dpb (the fixnum (ldb new-hash-byte hash)) + stored-hash-byte + (the fixnum entry-len))) + (loc (rem hash (the fixnum *dictionary-size*))) + (loc-contents (dictionary-ref loc))) + (declare (fixnum hash hash-and-len loc)) + (cond ((zerop loc-contents) nil) + ((found-entry-p loc-contents entry entry-len hash-and-len) + (setf (dictionary-ref loc) spell-deleted-entry)) + (t + (hash2-loop (loop-loc loc-contents) loc hash + nil + (when (found-entry-p loc-contents entry + entry-len hash-and-len) + (setf (dictionary-ref loop-loc) + spell-deleted-entry) + (return spell-deleted-entry)))))))))))) + +(defun spell-root-flags (index) + "Return the flags associated with the root word corresponding to a + dictionary entry at index." + (let ((desc-word (descriptor-ref (+ 2 index))) + (result ())) + (declare (fixnum desc-word)) + (dolist (ele flag-names-to-masks result) + (unless (zerop (logand (the fixnum (cdr ele)) desc-word)) + (push (car ele) result))))) + + + + +;;;; Growing Dictionary Structures + +;;; GROW-DESCRIPTORS grows the descriptors vector by 10%. +;;; +(defun grow-descriptors () + (let* ((old-size (+ (the fixnum *descriptors-size*) + (the fixnum *free-descriptor-elements*))) + (new-size (truncate (* old-size 1.1))) + (new-bytes (* new-size 2)) + (new-sap (allocate-bytes new-bytes))) + (declare (fixnum new-size old-size)) + (sap-replace new-sap *descriptors* 0 0 + (* 2 (the fixnum *descriptors-size*))) + (deallocate-bytes (system-address *descriptors*) (* 2 old-size)) + (setf *free-descriptor-elements* + (- new-size (the fixnum *descriptors-size*))) + (setf *descriptors* new-sap))) + +;;; GROW-STRING-TABLE grows the string table by 10%. +;;; +(defun grow-string-table () + (let* ((old-size (+ (the fixnum *string-table-size*) + (the fixnum *free-string-table-bytes*))) + (new-size (truncate (* old-size 1.1))) + (new-sap (allocate-bytes new-size))) + (declare (fixnum new-size old-size)) + (sap-replace new-sap *string-table* 0 0 *string-table-size*) + (setf *free-string-table-bytes* + (- new-size (the fixnum *string-table-size*))) + (deallocate-bytes (system-address *string-table*) old-size) + (setf *string-table* new-sap))) Index: /branches/ide-1.0/ccl/hemlock/src/archive/spell-corr.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/archive/spell-corr.lisp (revision 6567) +++ /branches/ide-1.0/ccl/hemlock/src/archive/spell-corr.lisp (revision 6567) @@ -0,0 +1,816 @@ +;;; -*- Log: hemlock.log; Package: Spell -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Written by Bill Chiles +;;; Designed by Bill Chiles and Rob Maclachlan +;;; + +;;; This is the file that deals with checking and correcting words +;;; using a dictionary read in from a binary file. It has been written +;;; from the basic ideas used in Ispell (on DEC-20's) which originated as +;;; Spell on the ITS machines at MIT. There are flags which have proper +;;; uses defined for them that indicate permissible suffixes to entries. +;;; This allows for about three times as many known words than are actually +;;; stored. When checking the spelling of a word, first it is looked up; +;;; if this fails, then possible roots are looked up, and if any has the +;;; appropriate suffix flag, then the word is considered to be correctly +;;; spelled. For an unknown word, the following rules define "close" words +;;; which are possible corrections: +;;; 1] two adjacent letters are transposed to form a correct spelling; +;;; 2] one letter is changed to form a correct spelling; +;;; 3] one letter is added to form a correct spelling; and/or +;;; 4] one letter is removed to form a correct spelling. +;;; There are two restrictions on the length of a word in regards to its +;;; worthiness of recognition: it must be at least more than two letters +;;; long, and if it has a suffix, then it must be at least four letters +;;; long. More will be said about this when the flags are discussed. +;;; This is implemented in as tense a fashion as possible, and it uses +;;; implementation dependent code from Spell-RT.Lisp to accomplish this. +;;; In general the file I/O and structure accesses encompass the system +;;; dependencies. + +;;; This next section will discuss the storage of the dictionary +;;; information. There are three data structures that "are" the +;;; dictionary: a hash table, descriptors table, and a string table. The +;;; hash table is a vector of type '(unsigned-byte 16), whose elements +;;; point into the descriptors table. This is a cyclic hash table to +;;; facilitate dumping it to a file. The descriptors table (also of type +;;; '(unsigned-byte 16)) dedicates three elements to each entry in the +;;; dictionary. Each group of three elements has the following organization +;;; imposed on them: +;;; ---------------------------------------------- +;;; | 15..5 hash code | 4..0 length | +;;; ---------------------------------------------- +;;; | 15..0 character index | +;;; ---------------------------------------------- +;;; | 15..14 character index | 13..0 flags | +;;; ---------------------------------------------- +;;; "Length" is the number of characters in the entry; "hash code" is some +;;; eleven bits from the hash code to allow for quicker lookup, "flags" +;;; indicate possible suffixes for the basic entry, and "character index" +;;; is the index of the start of the entry in the string table. +;;; This was originally adopted due to the Perq's word size (can you guess? +;;; 16 bits, that's right). Note the constraint that is placed on the number +;;; of the entries, 21845, because the hash table could not point to more +;;; descriptor units (16 bits of pointer divided by three). Since a value of +;;; zero as a hash table element indicates an empty location, the zeroth element +;;; of the descriptors table must be unused (it cannot be pointed to). + + +;;; The following is a short discussion with examples of the correct +;;; use of the suffix flags. Let # and @ be symbols that can stand for any +;;; single letter. Upper case letters are constants. "..." stands for any +;;; string of zero or more letters, but note that no word may exist in the +;;; dictionary which is not at least 2 letters long, so, for example, FLY +;;; may not be produced by placing the "Y" flag on "F". Also, no flag is +;;; effective unless the word that it creates is at least 4 letters long, +;;; so, for example, WED may not be produced by placing the "D" flag on +;;; "WE". These flags and examples are from the Ispell documentation with +;;; only slight modifications. Here are the correct uses of the flags: +;;; +;;; "V" flag: +;;; ...E => ...IVE as in create => creative +;;; if # .ne. E, then ...# => ...#IVE as in prevent => preventive +;;; +;;; "N" flag: +;;; ...E => ...ION as in create => creation +;;; ...Y => ...ICATION as in multiply => multiplication +;;; if # .ne. E or Y, then ...# => ...#EN as in fall => fallen +;;; +;;; "X" flag: +;;; ...E => ...IONS as in create => creations +;;; ...Y => ...ICATIONS as in multiply => multiplications +;;; if # .ne. E or Y, ...# => ...#ENS as in weak => weakens +;;; +;;; "H" flag: +;;; ...Y => ...IETH as in twenty => twentieth +;;; if # .ne. Y, then ...# => ...#TH as in hundred => hundredth +;;; +;;; "Y" FLAG: +;;; ... => ...LY as in quick => quickly +;;; +;;; "G" FLAG: +;;; ...E => ...ING as in file => filing +;;; if # .ne. E, then ...# => ...#ING as in cross => crossing +;;; +;;; "J" FLAG" +;;; ...E => ...INGS as in file => filings +;;; if # .ne. E, then ...# => ...#INGS as in cross => crossings +;;; +;;; "D" FLAG: +;;; ...E => ...ED as in create => created +;;; if @ .ne. A, E, I, O, or U, +;;; then ...@Y => ...@IED as in imply => implied +;;; if # = Y, and @ = A, E, I, O, or U, +;;; then ...@# => ...@#ED as in convey => conveyed +;;; if # .ne. E or Y, then ...# => ...#ED as in cross => crossed +;;; +;;; "T" FLAG: +;;; ...E => ...EST as in late => latest +;;; if @ .ne. A, E, I, O, or U, +;;; then ...@Y => ...@IEST as in dirty => dirtiest +;;; if # = Y, and @ = A, E, I, O, or U, +;;; then ...@# => ...@#EST as in gray => grayest +;;; if # .ne. E or Y, then ...# => ...#EST as in small => smallest +;;; +;;; "R" FLAG: +;;; ...E => ...ER as in skate => skater +;;; if @ .ne. A, E, I, O, or U, +;;; then ...@Y => ...@IER as in multiply => multiplier +;;; if # = Y, and @ = A, E, I, O, or U, +;;; then ...@# => ...@#ER as in convey => conveyer +;;; if # .ne. E or Y, then ...# => ...#ER as in build => builder +;;; + +;;; "Z FLAG: +;;; ...E => ...ERS as in skate => skaters +;;; if @ .ne. A, E, I, O, or U, +;;; then ...@Y => ...@IERS as in multiply => multipliers +;;; if # = Y, and @ = A, E, I, O, or U, +;;; then ...@# => ...@#ERS as in slay => slayers +;;; if # .ne. E or Y, then ...@# => ...@#ERS as in build => builders +;;; +;;; "S" FLAG: +;;; if @ .ne. A, E, I, O, or U, +;;; then ...@Y => ...@IES as in imply => implies +;;; if # .eq. S, X, Z, or H, +;;; then ...# => ...#ES as in fix => fixes +;;; if # .ne. S, X, Z, H, or Y, +;;; then ...# => ...#S as in bat => bats +;;; if # = Y, and @ = A, E, I, O, or U, +;;; then ...@# => ...@#S as in convey => conveys +;;; +;;; "P" FLAG: +;;; if # .ne. Y, or @ = A, E, I, O, or U, +;;; then ...@# => ...@#NESS as in late => lateness and +;;; gray => grayness +;;; if @ .ne. A, E, I, O, or U, +;;; then ...@Y => ...@INESS as in cloudy => cloudiness +;;; +;;; "M" FLAG: +;;; ... => ...'S as in DOG => DOG'S + +(in-package "SPELL") + + + +;;;; Some Constants + +(eval-when (:compile-toplevel :execute :load-toplevel) + +(defconstant spell-deleted-entry #xFFFF) + +;;; The next number (using 6 bits) is 63, and that's pretty silly because +;;; "supercalafragalistic" is less than 31 characters long. +;;; +(defconstant max-entry-length 31 + "This the maximum number of characters an entry may have.") + +;;; These are the flags (described above), and an entry is allowed a +;;; certain suffix if the appropriate bit is on in the third element of +;;; its descriptor unit (described above). +;;; +(defconstant V-mask (ash 1 13)) +(defconstant N-mask (ash 1 12)) +(defconstant X-mask (ash 1 11)) +(defconstant H-mask (ash 1 10)) +(defconstant Y-mask (ash 1 9)) +(defconstant G-mask (ash 1 8)) +(defconstant J-mask (ash 1 7)) +(defconstant D-mask (ash 1 6)) +(defconstant T-mask (ash 1 5)) +(defconstant R-mask (ash 1 4)) +(defconstant Z-mask (ash 1 3)) +(defconstant S-mask (ash 1 2)) +(defconstant P-mask (ash 1 1)) +(defconstant M-mask 1) + + +;;; These are the eleven bits of a computed hash that are stored as part of +;;; an entries descriptor unit. The shifting constant is how much the +;;; eleven bits need to be shifted to the right, so they take up the upper +;;; eleven bits of one 16-bit element in a descriptor unit. +;;; +(defconstant new-hash-byte (byte 11 13)) +(defconstant stored-hash-byte (byte 11 5)) + + +;;; The next two constants are used to extract information from an entry's +;;; descriptor unit. The first is the two most significant bits of 18 +;;; bits that hold an index into the string table where the entry is +;;; located. If this is confusing, regard the diagram of the descriptor +;;; units above. +;;; +(defconstant whole-index-high-byte (byte 2 16)) +(defconstant stored-index-high-byte (byte 2 14)) +(defconstant stored-length-byte (byte 5 0)) + + +); eval-when (:compile-toplevel :execute :load-toplevel) + + + +;;;; Some Specials and Accesses + +;;; *spell-aeiou* will have bits on that represent the capital letters +;;; A, E, I, O, and U to be used to determine if some word roots are legal +;;; for looking up. +;;; +(defvar *aeiou* + (make-array 128 :element-type 'bit :initial-element 0)) + +(setf (aref *aeiou* (char-code #\A)) 1) +(setf (aref *aeiou* (char-code #\E)) 1) +(setf (aref *aeiou* (char-code #\I)) 1) +(setf (aref *aeiou* (char-code #\O)) 1) +(setf (aref *aeiou* (char-code #\U)) 1) + + +;;; *sxzh* will have bits on that represent the capital letters +;;; S, X, Z, and H to be used to determine if some word roots are legal for +;;; looking up. +;;; +(defvar *sxzh* + (make-array 128 :element-type 'bit :initial-element 0)) + +(setf (aref *sxzh* (char-code #\S)) 1) +(setf (aref *sxzh* (char-code #\X)) 1) +(setf (aref *sxzh* (char-code #\Z)) 1) +(setf (aref *sxzh* (char-code #\H)) 1) + + +;;; SET-MEMBER-P will be used with *aeiou* and *sxzh* to determine if a +;;; character is in the specified set. +;;; +(eval-when (:compile-toplevel :execute) +(defmacro set-member-p (char set) + `(not (zerop (the fixnum (aref (the simple-bit-vector ,set) + (char-code ,char)))))) +) ;eval-when + + +(defvar *dictionary*) +(defvar *dictionary-size*) +(defvar *descriptors*) +(defvar *descriptors-size*) +(defvar *string-table*) +(defvar *string-table-size*) + + +(eval-when (:compile-toplevel :execute) + +;;; DICTIONARY-REF and DESCRIPTOR-REF are references to implementation +;;; dependent structures. *dictionary* and *descriptors* are "system +;;; area pointers" as a result of the way the binary file is opened for +;;; fast access. +;;; +(defmacro dictionary-ref (idx) + `(sapref *dictionary* ,idx)) + +(defmacro descriptor-ref (idx) + `(sapref *descriptors* ,idx)) + + +;;; DESCRIPTOR-STRING-START access an entry's (indicated by idx) +;;; descriptor unit (described at the beginning of the file) and returns +;;; the start index of the entry in the string table. The second of three +;;; words in the descriptor holds the 16 least significant bits of 18, and +;;; the top two bits of the third word are the 2 most significant bits. +;;; These 18 bits are the index into the string table. +;;; +(defmacro descriptor-string-start (idx) + `(dpb (the fixnum (ldb stored-index-high-byte + (the fixnum (descriptor-ref (+ 2 ,idx))))) + whole-index-high-byte + (the fixnum (descriptor-ref (1+ ,idx))))) + +) ;eval-when + + + + +;;;; Top level Checking/Correcting + +;;; CORRECT-SPELLING can be called from top level to check/correct a words +;;; spelling. It is not used for any other purpose. +;;; +(defun correct-spelling (word) + "Check/correct the spelling of word. Output is done to *standard-output*." + (setf word (coerce word 'simple-string)) + (let ((word (string-upcase (the simple-string word))) + (word-len (length (the simple-string word)))) + (declare (simple-string word) (fixnum word-len)) + (maybe-read-spell-dictionary) + (when (= word-len 1) + (error "Single character words are not in the dictionary.")) + (when (> word-len max-entry-length) + (error "~A is too long for the dictionary." word)) + (multiple-value-bind (idx used-flag-p) + (spell-try-word word word-len) + (if idx + (format t "Found it~:[~; because of ~A~]." used-flag-p + (spell-root-word idx)) + (let ((close-words (spell-collect-close-words word))) + (if close-words + (format *standard-output* + "The possible correct spelling~[~; is~:;s are~]:~ + ~:*~[~; ~{~A~}~;~{ ~A~^ and~}~:;~ + ~{~#[~; and~] ~A~^,~}~]." + (length close-words) + close-words) + (format *standard-output* "Word not found."))))))) + + +(defvar *dictionary-read-p* nil) + +;;; MAYBE-READ-SPELL-DICTIONARY -- Public +;;; +(defun maybe-read-spell-dictionary () + "Read the spelling dictionary if it has not be read already." + (unless *dictionary-read-p* (read-dictionary))) + + +(defun spell-root-word (index) + "Return the root word corresponding to a dictionary entry at index." + (let* ((start (descriptor-string-start index)) + (len (the fixnum (ldb stored-length-byte + (the fixnum (descriptor-ref index))))) + (result (make-string len))) + (declare (fixnum start len) + (simple-string result)) + (sap-replace result (the system-area-pointer *string-table*) + start 0 len) + result)) + + +(eval-when (:compile-toplevel :execute) +(defmacro check-closeness (word word-len closeness-list) + `(if (spell-try-word ,word ,word-len) + (pushnew (subseq ,word 0 ,word-len) ,closeness-list :test #'string=))) +) ;eval-when + +(defconstant spell-alphabet + (list #\A #\B #\C #\D #\E #\F #\G #\H + #\I #\J #\K #\L #\M #\N #\O #\P + #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z)) + +;;; SPELL-COLLECT-CLOSE-WORDS Returns a list of all "close" correctly spelled +;;; words. The definition of "close" is at the beginning of the file, and +;;; there are four sections to this function which collect each of the four +;;; different kinds of close words. +;;; +(defun spell-collect-close-words (word) + "Returns a list of all \"close\" correctly spelled words. This has the + same contraints as SPELL-TRY-WORD, which you have probably already called + if you are calling this." + (declare (simple-string word)) + (let* ((word-len (length word)) + (word-len--1 (1- word-len)) + (word-len-+1 (1+ word-len)) + (result ()) + (correcting-buffer (make-string max-entry-length))) + (declare (simple-string correcting-buffer) + (fixnum word-len word-len--1 word-len-+1)) + (replace correcting-buffer word :end1 word-len :end2 word-len) + + ;; Misspelled because one letter is different. + (dotimes (i word-len) + (do ((save-char (schar correcting-buffer i)) + (alphabet spell-alphabet (cdr alphabet))) + ((null alphabet) + (setf (schar correcting-buffer i) save-char)) + (setf (schar correcting-buffer i) (car alphabet)) + (check-closeness correcting-buffer word-len result))) + + ;; Misspelled because two adjacent letters are transposed. + (dotimes (i word-len--1) + (rotatef (schar correcting-buffer i) (schar correcting-buffer (1+ i))) + (check-closeness correcting-buffer word-len result) + (rotatef (schar correcting-buffer i) (schar correcting-buffer (1+ i)))) + + ;; Misspelled because of extraneous letter. + (replace correcting-buffer word + :start2 1 :end1 word-len--1 :end2 word-len) + (check-closeness correcting-buffer word-len--1 result) + (dotimes (i word-len--1) + (setf (schar correcting-buffer i) (schar word i)) + (replace correcting-buffer word + :start1 (1+ i) :start2 (+ i 2) :end1 word-len--1 :end2 word-len) + (check-closeness correcting-buffer word-len--1 result)) + + ;; Misspelled because a letter is missing. + (replace correcting-buffer word + :start1 1 :end1 word-len-+1 :end2 word-len) + (dotimes (i word-len-+1) + (do ((alphabet spell-alphabet (cdr alphabet))) + ((null alphabet) + (rotatef (schar correcting-buffer i) + (schar correcting-buffer (1+ i)))) + (setf (schar correcting-buffer i) (car alphabet)) + (check-closeness correcting-buffer word-len-+1 result))) + result)) + +;;; SPELL-TRY-WORD The literal 4 is not a constant defined somewhere since it +;;; is part of the definition of the function of looking up words. +;;; TRY-WORD-ENDINGS relies on the guarantee that word-len is at least 4. +;;; +(defun spell-try-word (word word-len) + "See if the word or an appropriate root is in the spelling dicitionary. + Word-len must be inclusively in the range 2..max-entry-length." + (or (lookup-entry word word-len) + (if (>= (the fixnum word-len) 4) + (try-word-endings word word-len)))) + + + + +;;;; Divining Correct Spelling + +(eval-when (:compile-toplevel :execute) + +(defmacro setup-root-buffer (word buffer root-len) + `(replace ,buffer ,word :end1 ,root-len :end2 ,root-len)) + +(defmacro try-root (word root-len flag-mask) + (let ((result (gensym))) + `(let ((,result (lookup-entry ,word ,root-len))) + (if (and ,result (descriptor-flag ,result ,flag-mask)) + (return (values ,result ,flag-mask)))))) + +;;; TRY-MODIFIED-ROOT is used for root words that become truncated +;;; when suffixes are added (e.g., skate => skating). Char-idx is the last +;;; character in the root that has to typically be changed from a #\I to a +;;; #\Y or #\E. +;;; +(defmacro try-modified-root (word buffer root-len flag-mask char-idx new-char) + (let ((root-word (gensym))) + `(let ((,root-word (setup-root-buffer ,word ,buffer ,root-len))) + (setf (schar ,root-word ,char-idx) ,new-char) + (try-root ,root-word ,root-len ,flag-mask)))) + +) ;eval-when + + +(defvar *rooting-buffer* (make-string max-entry-length)) + +;;; TRY-WORD-ENDINGS takes a word that is at least of length 4 and +;;; returns multiple values on success (the index where the word's root's +;;; descriptor starts and :used-flag), otherwise nil. It looks at +;;; characters from the end to the beginning of the word to determine if it +;;; has any known suffixes. This is a VERY simple finite state machine +;;; where all of the suffixes are narrowed down to one possible one in at +;;; most two state changes. This is a PROG form for speed, and in some sense, +;;; readability. The states of the machine are the flag names that denote +;;; suffixes. The two points of branching to labels are the very beginning +;;; of the PROG and the S state. This is a fairly straight forward +;;; implementation of the flag rules presented at the beginning of this +;;; file, with char-idx checks, so we do not index the string below zero. + +(defun try-word-endings (word word-len) + (declare (simple-string word) + (fixnum word-len)) + (prog* ((char-idx (1- word-len)) + (char (schar word char-idx)) + (rooting-buffer *rooting-buffer*) + flag-mask) + (declare (simple-string rooting-buffer) + (fixnum char-idx)) + (case char + (#\S (go S)) ;This covers over half of the possible endings + ;by branching off the second to last character + ;to other flag states that have plural endings. + (#\R (setf flag-mask R-mask) ;"er" and "ier" + (go D-R-Z-FLAG)) + (#\T (go T-FLAG)) ;"est" and "iest" + (#\D (setf flag-mask D-mask) ;"ed" and "ied" + (go D-R-Z-FLAG)) + (#\H (go H-FLAG)) ;"th" and "ieth" + (#\N (setf flag-mask N-mask) ;"ion", "ication", and "en" + (go N-X-FLAG)) + (#\G (setf flag-mask G-mask) ;"ing" + (go G-J-FLAG)) + (#\Y (go Y-FLAG)) ;"ly" + (#\E (go V-FLAG))) ;"ive" + (return nil) + + S + (setf char-idx (1- char-idx)) + (setf char (schar word char-idx)) + (if (char= char #\Y) + (if (set-member-p (schar word (1- char-idx)) *aeiou*) + (try-root word (1+ char-idx) S-mask) + (return nil)) + (if (not (set-member-p char *sxzh*)) + (try-root word (1+ char-idx) S-mask))) + (case char + (#\E (go S-FLAG)) ;"es" and "ies" + (#\R (setf flag-mask Z-mask) ;"ers" and "iers" + (go D-R-Z-FLAG)) + (#\G (setf flag-mask J-mask) ;"ings" + (go G-J-FLAG)) + (#\S (go P-FLAG)) ;"ness" and "iness" + (#\N (setf flag-mask X-mask) ;"ions", "ications", and "ens" + (go N-X-FLAG)) + (#\' (try-root word char-idx M-mask))) + (return nil) + + S-FLAG + (setf char-idx (1- char-idx)) + (setf char (schar word char-idx)) + (if (set-member-p char *sxzh*) + (try-root word (1+ char-idx) S-mask)) + (if (and (char= char #\I) + (not (set-member-p (schar word (1- char-idx)) *aeiou*))) + (try-modified-root word rooting-buffer (1+ char-idx) + S-mask char-idx #\Y)) + (return nil) + + D-R-Z-FLAG + (if (char/= (schar word (1- char-idx)) #\E) (return nil)) + (try-root word char-idx flag-mask) + (if (<= (setf char-idx (- char-idx 2)) 0) (return nil)) + (setf char (schar word char-idx)) + (if (char= char #\Y) + (if (set-member-p (schar word (1- char-idx)) *aeiou*) + (try-root word (1+ char-idx) flag-mask) + (return nil)) + (if (char/= (schar word char-idx) #\E) + (try-root word (1+ char-idx) flag-mask))) + (if (and (char= char #\I) + (not (set-member-p (schar word (1- char-idx)) *aeiou*))) + (try-modified-root word rooting-buffer (1+ char-idx) + flag-mask char-idx #\Y)) + (return nil) + + P-FLAG + (if (or (char/= (schar word (1- char-idx)) #\E) + (char/= (schar word (- char-idx 2)) #\N)) + (return nil)) + (if (<= (setf char-idx (- char-idx 3)) 0) (return nil)) + (setf char (schar word char-idx)) + (if (char= char #\Y) + (if (set-member-p (schar word (1- char-idx)) *aeiou*) + (try-root word (1+ char-idx) P-mask) + (return nil))) + (try-root word (1+ char-idx) P-mask) + (if (and (char= char #\I) + (not (set-member-p (schar word (1- char-idx)) *aeiou*))) + (try-modified-root word rooting-buffer (1+ char-idx) + P-mask char-idx #\Y)) + (return nil) + + G-J-FLAG + (if (< char-idx 3) (return nil)) + (setf char-idx (- char-idx 2)) + (setf char (schar word char-idx)) + (if (or (char/= char #\I) (char/= (schar word (1+ char-idx)) #\N)) + (return nil)) + (if (char/= (schar word (1- char-idx)) #\E) + (try-root word char-idx flag-mask)) + (try-modified-root word rooting-buffer (1+ char-idx) + flag-mask char-idx #\E) + (return nil) + + N-X-FLAG + (setf char-idx (1- char-idx)) + (setf char (schar word char-idx)) + (cond ((char= char #\E) + (setf char (schar word (1- char-idx))) + (if (and (char/= char #\Y) (char/= char #\E)) + (try-root word char-idx flag-mask)) + (return nil)) + ((char= char #\O) + (if (char= (schar word (1- char-idx)) #\I) + (try-modified-root word rooting-buffer char-idx + flag-mask (1- char-idx) #\E) + (return nil)) + (if (< char-idx 5) (return nil)) + (if (or (char/= (schar word (- char-idx 2)) #\T) + (char/= (schar word (- char-idx 3)) #\A) + (char/= (schar word (- char-idx 4)) #\C) + (char/= (schar word (- char-idx 5)) #\I)) + (return nil) + (setf char-idx (- char-idx 4))) + (try-modified-root word rooting-buffer char-idx + flag-mask (1- char-idx) #\Y)) + (t (return nil))) + + T-FLAG + (if (or (char/= (schar word (1- char-idx)) #\S) + (char/= (schar word (- char-idx 2)) #\E)) + (return nil) + (setf char-idx (1- char-idx))) + (try-root word char-idx T-mask) + (if (<= (setf char-idx (- char-idx 2)) 0) (return nil)) + (setf char (schar word char-idx)) + (if (char= char #\Y) + (if (set-member-p (schar word (1- char-idx)) *aeiou*) + (try-root word (1+ char-idx) T-mask) + (return nil)) + (if (char/= (schar word char-idx) #\E) + (try-root word (1+ char-idx) T-mask))) + (if (and (char= char #\I) + (not (set-member-p (schar word (1- char-idx)) *aeiou*))) + (try-modified-root word rooting-buffer (1+ char-idx) + T-mask char-idx #\Y)) + (return nil) + + H-FLAG + (setf char-idx (1- char-idx)) + (setf char (schar word char-idx)) + (if (char/= char #\T) (return nil)) + (if (char/= (schar word (1- char-idx)) #\Y) + (try-root word char-idx H-mask)) + (if (and (char= (schar word (1- char-idx)) #\E) + (char= (schar word (- char-idx 2)) #\I)) + (try-modified-root word rooting-buffer (1- char-idx) + H-mask (- char-idx 2) #\Y)) + (return nil) + + Y-FLAG + (setf char-idx (1- char-idx)) + (setf char (schar word char-idx)) + (if (char= char #\L) + (try-root word char-idx Y-mask)) + (return nil) + + V-FLAG + (setf char-idx (- char-idx 2)) + (setf char (schar word char-idx)) + (if (or (char/= char #\I) (char/= (schar word (1+ char-idx)) #\V)) + (return nil)) + (if (char/= (schar word (1- char-idx)) #\E) + (try-root word char-idx V-mask)) + (try-modified-root word rooting-buffer (1+ char-idx) + V-mask char-idx #\E) + (return nil))) + + + +;;; DESCRIPTOR-FLAG returns t or nil based on whether the flag is on. +;;; From the diagram at the beginning of the file, we see that the flags +;;; are stored two words off of the first word in the descriptor unit for +;;; an entry. +;;; +(defun descriptor-flag (descriptor-start flag-mask) + (not (zerop + (the fixnum + (logand + (the fixnum (descriptor-ref (+ 2 (the fixnum descriptor-start)))) + (the fixnum flag-mask)))))) + + + +;;;; Looking up Trials + +(eval-when (:compile-toplevel :execute) + +;;; SPELL-STRING= determines if string1 and string2 are the same. Before +;;; it is called it is known that they are both of (- end1 0) length, and +;;; string2 is in system space. This is used in FOUND-ENTRY-P. +;;; +(defmacro spell-string= (string1 string2 end1 start2) + (let ((idx1 (gensym)) + (idx2 (gensym))) + `(do ((,idx1 0 (1+ ,idx1)) + (,idx2 ,start2 (1+ ,idx2))) + ((= ,idx1 ,end1) t) + (declare (fixnum ,idx1 ,idx2)) + (unless (= (the fixnum (char-code (schar ,string1 ,idx1))) + (the fixnum (string-sapref ,string2 ,idx2))) + (return nil))))) + +;;; FOUND-ENTRY-P determines if entry is what is described at idx. +;;; Hash-and-length is 16 bits that look just like the first word of any +;;; entry's descriptor unit (see diagram at the beginning of the file). If +;;; the word stored at idx and entry have the same hash bits and length, +;;; then we compare characters to see if they are the same. +;;; +(defmacro found-entry-p (idx entry entry-len hash-and-length) + `(if (= (the fixnum (descriptor-ref ,idx)) + (the fixnum ,hash-and-length)) + (spell-string= ,entry *string-table* ,entry-len + (descriptor-string-start ,idx)))) + +(defmacro hash2-increment (hash) + `(- (the fixnum *dictionary-size*) + 2 + (the fixnum (rem ,hash (- (the fixnum *dictionary-size*) 2))))) + +(defmacro hash2-loop ((location-var contents-var) + loc hash zero-contents-form + &optional body-form (for-insertion-p nil)) + (let ((incr (gensym))) + `(let* ((,incr (hash2-increment ,hash)) + (,location-var ,loc) + (,contents-var 0)) + (declare (fixnum ,location-var ,contents-var ,incr)) + (loop (setf ,location-var + (rem (+ ,location-var ,incr) (the fixnum *dictionary-size*))) + (setf ,contents-var (dictionary-ref ,location-var)) + (if (zerop ,contents-var) (return ,zero-contents-form)) + ,@(if for-insertion-p + `((if (= ,contents-var spell-deleted-entry) + (return ,zero-contents-form)))) + (if (= ,location-var ,loc) (return nil)) + ,@(if body-form `(,body-form)))))) + +) ;eval-when + + +;;; LOOKUP-ENTRY returns the index of the first element of entry's +;;; descriptor unit on success, otherwise nil. +;;; +(defun lookup-entry (entry &optional len) + (declare (simple-string entry)) + (let* ((entry-len (or len (length entry))) + (hash (string-hash entry entry-len)) + (hash-and-len (dpb (the fixnum (ldb new-hash-byte hash)) + stored-hash-byte + (the fixnum entry-len))) + (loc (rem hash (the fixnum *dictionary-size*))) + (loc-contents (dictionary-ref loc))) + (declare (fixnum entry-len hash hash-and-len loc)) + (cond ((zerop loc-contents) nil) + ((found-entry-p loc-contents entry entry-len hash-and-len) + loc-contents) + (t + (hash2-loop (loop-loc loc-contents) loc hash + nil + (if (found-entry-p loc-contents entry entry-len hash-and-len) + (return loc-contents))))))) + + +;;;; Binary File Reading + +(defparameter default-binary-dictionary + "library:spell-dictionary.bin") + +;;; This is the first thing in a spell binary dictionary file to serve as a +;;; quick check of its proposed contents. This particular number is +;;; "BILLS" on a calculator held upside-down. +;;; +(defconstant magic-file-id 57718) + +;;; These constants are derived from the order things are written to the +;;; binary dictionary in Spell-Build.Lisp. +;;; +(defconstant magic-file-id-loc 0) +(defconstant dictionary-size-loc 1) +(defconstant descriptors-size-loc 2) +(defconstant string-table-size-low-byte-loc 3) +(defconstant string-table-size-high-byte-loc 4) +(defconstant file-header-bytes 10) + +;;; Initially, there are no free descriptor elements and string table bytes, +;;; but when these structures are grown, they are grown by more than that +;;; which is necessary. +;;; +(defvar *free-descriptor-elements* 0) +(defvar *free-string-table-bytes* 0) + +;;; READ-DICTIONARY opens the dictionary and sets up the global structures +;;; manifesting the spelling dictionary. When computing the start addresses +;;; of these structures, we multiply by two since their sizes are in 16bit +;;; lengths while the RT is 8bit-byte addressable. +;;; +(defun read-dictionary (&optional (f default-binary-dictionary)) + (when *dictionary-read-p* + (setf *dictionary-read-p* nil) + (deallocate-bytes (system-address *dictionary*) + (* 2 (the fixnum *dictionary-size*))) + (deallocate-bytes (system-address *descriptors*) + (* 2 (the fixnum + (+ (the fixnum *descriptors-size*) + (the fixnum *free-descriptor-elements*))))) + (deallocate-bytes (system-address *string-table*) + (+ (the fixnum *string-table-size*) + (the fixnum *free-string-table-bytes*)))) + (setf *free-descriptor-elements* 0) + (setf *free-string-table-bytes* 0) + (let* ((fd (open-dictionary f)) + (header-info (read-dictionary-structure fd file-header-bytes))) + (unless (= (sapref header-info magic-file-id-loc) magic-file-id) + (deallocate-bytes (system-address header-info) file-header-bytes) + (error "File is not a dictionary: ~S." f)) + (setf *dictionary-size* (sapref header-info dictionary-size-loc)) + (setf *descriptors-size* (sapref header-info descriptors-size-loc)) + (setf *string-table-size* (sapref header-info string-table-size-low-byte-loc)) + (setf (ldb (byte 12 16) (the fixnum *string-table-size*)) + (the fixnum (sapref header-info string-table-size-high-byte-loc))) + (deallocate-bytes (system-address header-info) file-header-bytes) + (setf *dictionary* + (read-dictionary-structure fd (* 2 (the fixnum *dictionary-size*)))) + (setf *descriptors* + (read-dictionary-structure fd (* 2 (the fixnum *descriptors-size*)))) + (setf *string-table* (read-dictionary-structure fd *string-table-size*)) + (setf *dictionary-read-p* t) + (close-dictionary fd))) Index: /branches/ide-1.0/ccl/hemlock/src/archive/spell-rt.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/archive/spell-rt.lisp (revision 6567) +++ /branches/ide-1.0/ccl/hemlock/src/archive/spell-rt.lisp (revision 6567) @@ -0,0 +1,107 @@ +;;; -*- Log: hemlock.log; Package: Spell -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Written by Bill Chiles +;;; +;;; This file contains system dependent primitives for the spelling checking/ +;;; correcting code in Spell-Correct.Lisp, Spell-Augment.Lisp, and +;;; Spell-Build.Lisp. + +(defpackage "SPELL" + (:use "LISP" "EXTENSIONS" "SYSTEM") + (:export spell-try-word spell-root-word spell-collect-close-words + maybe-read-spell-dictionary correct-spelling max-entry-length + spell-read-dictionary spell-add-entry spell-root-flags + spell-remove-entry)) + +(in-package "SPELL") + + + +;;;; System Area Referencing and Setting + +(eval-when (:compile-toplevel :execute) + +;;; MAKE-SAP returns pointers that *dictionary*, *descriptors*, and +;;; *string-table* are bound to. Address is in the system area. +;;; +(defmacro make-sap (address) + `(system:int-sap ,address)) + +(defmacro system-address (sap) + `(system:sap-int ,sap)) + + +(defmacro allocate-bytes (count) + `(system:allocate-system-memory ,count)) + +(defmacro deallocate-bytes (address byte-count) + `(system:deallocate-system-memory (int-sap ,address) ,byte-count)) + + +(defmacro sapref (sap offset) + `(system:sap-ref-16 ,sap (* ,offset 2))) + +(defsetf sapref (sap offset) (value) + `(setf (system:sap-ref-16 ,sap (* ,offset 2)) ,value)) + + +(defmacro sap-replace (dst-string src-string src-start dst-start dst-end) + `(%primitive byte-blt ,src-string ,src-start ,dst-string ,dst-start ,dst-end)) + +(defmacro string-sapref (sap index) + `(system:sap-ref-8 ,sap ,index)) + + + + +;;;; Primitive String Hashing + +;;; STRING-HASH employs the instruction SXHASH-SIMPLE-SUBSTRING which takes +;;; an end argument, so we do not have to use SXHASH. SXHASH would mean +;;; doing a SUBSEQ of entry. +;;; +(defmacro string-hash (string length) + `(ext:truly-the lisp::index + (%primitive sxhash-simple-substring + ,string + (the fixnum ,length)))) + +) ;eval-when + + + + +;;;; Binary Dictionary File I/O + +(defun open-dictionary (f) + (let* ((filename (ext:unix-namestring f)) + (kind (unix:unix-file-kind filename))) + (unless kind (error "Cannot find dictionary -- ~S." filename)) + (multiple-value-bind (fd err) + (unix:unix-open filename unix:o_rdonly 0) + (unless fd + (error "Opening ~S failed: ~A." filename err)) + (multiple-value-bind (winp dev-or-err) (unix:unix-fstat fd) + (unless winp (error "Opening ~S failed: ~A." filename dev-or-err)) + fd)))) + +(defun close-dictionary (fd) + (unix:unix-close fd)) + +(defun read-dictionary-structure (fd bytes) + (let* ((structure (allocate-bytes bytes))) + (multiple-value-bind (read-bytes err) + (unix:unix-read fd structure bytes) + (when (or (null read-bytes) (not (= bytes read-bytes))) + (deallocate-bytes (system-address structure) bytes) + (error "Reading dictionary structure failed: ~A." err)) + structure))) Index: /branches/ide-1.0/ccl/hemlock/src/archive/spellcoms.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/archive/spellcoms.lisp (revision 6567) +++ /branches/ide-1.0/ccl/hemlock/src/archive/spellcoms.lisp (revision 6567) @@ -0,0 +1,822 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Written by Bill Chiles and Rob Maclachlan. +;;; +;;; This file contains the code to implement commands using the spelling +;;; checking/correcting stuff in Spell-Corr.Lisp and the dictionary +;;; augmenting stuff in Spell-Augment.Lisp. + +(in-package :hemlock) + + + +(defstruct (spell-info (:print-function print-spell-info) + (:constructor make-spell-info (pathname))) + pathname ;Dictionary file. + insertions) ;Incremental insertions for this dictionary. + +(defun print-spell-info (obj str n) + (declare (ignore n)) + (let ((pn (spell-info-pathname obj))) + (format str "#" + (and pn (namestring pn))))) + + +(defattribute "Spell Word Character" + "One if the character is one that is present in the spell dictionary, + zero otherwise.") + +(do-alpha-chars (c :both) + (setf (character-attribute :spell-word-character c) 1)) +(setf (character-attribute :spell-word-character #\') 1) + + +(defvar *spelling-corrections* (make-hash-table :test #'equal) + "Mapping from incorrect words to their corrections.") + +(defvar *ignored-misspellings* (make-hash-table :test #'equal) + "A hashtable with true values for words that will be quietly ignored when + they appear.") + +(defhvar "Spell Ignore Uppercase" + "If true, then \"Check Word Spelling\" and \"Correct Buffer Spelling\" will + ignore unknown words that are all uppercase. This is useful for + abbreviations and cryptic formatter directives." + :value nil) + + + + +;;;; Basic Spelling Correction Command (Esc-$ in EMACS) + +(defcommand "Check Word Spelling" (p) + "Check the spelling of the previous word and offer possible corrections + if the word in unknown. To add words to the dictionary from a text file see + the command \"Augment Spelling Dictionary\"." + "Check the spelling of the previous word and offer possible correct + spellings if the word is known to be misspelled." + (declare (ignore p)) + (spell:maybe-read-spell-dictionary) + (let* ((region (spell-previous-word (current-point) nil)) + (word (if region + (region-to-string region) + (editor-error "No previous word."))) + (folded (string-upcase word))) + (message "Checking spelling of ~A." word) + (unless (check-out-word-spelling word folded) + (get-word-correction (region-start region) word folded)))) + + + +;;;; Auto-Spell mode: + +(defhvar "Check Word Spelling Beep" + "If true, \"Auto Check Word Spelling\" will beep when an unknown word is + found." + :value t) + +(defhvar "Correct Unique Spelling Immediately" + "If true, \"Auto Check Word Spelling\" will immediately attempt to correct any + unknown word, automatically making the correction if there is only one + possible." + :value t) + + +(defhvar "Default User Spelling Dictionary" + "This is the pathname of a dictionary to read the first time \"Spell\" mode + is entered in a given editing session. When \"Set Buffer Spelling + Dictionary\" or the \"dictionary\" file option is used to specify a + dictionary, this default one is read also. It defaults to nil." + :value nil) + +(defvar *default-user-dictionary-read-p* nil) + +(defun maybe-read-default-user-spelling-dictionary () + (let ((default-dict (value default-user-spelling-dictionary))) + (when (and default-dict (not *default-user-dictionary-read-p*)) + (spell:maybe-read-spell-dictionary) + (spell:spell-read-dictionary (truename default-dict)) + (setf *default-user-dictionary-read-p* t)))) + + +(defmode "Spell" + :transparent-p t :precedence 1.0 :setup-function 'spell-mode-setup) + +(defun spell-mode-setup (buffer) + (defhvar "Buffer Misspelled Words" + "This variable holds a ring of marks pointing to misspelled words." + :buffer buffer :value (make-ring 10 #'delete-mark)) + (maybe-read-default-user-spelling-dictionary)) + +(defcommand "Auto Spell Mode" (p) + "Toggle \"Spell\" mode in the current buffer. When in \"Spell\" mode, + the spelling of each word is checked after it is typed." + "Toggle \"Spell\" mode in the current buffer." + (declare (ignore p)) + (setf (buffer-minor-mode (current-buffer) "Spell") + (not (buffer-minor-mode (current-buffer) "Spell")))) + + +(defcommand "Auto Check Word Spelling" (p) + "Check the spelling of the previous word and display a message in the echo + area if the word is not in the dictionary. To add words to the dictionary + from a text file see the command \"Augment Spelling Dictionary\". If a + replacement for an unknown word has previously been specified, then the + replacement will be made immediately. If \"Correct Unique Spelling + Immediately\" is true, then this command will immediately correct words + which have a unique correction. If there is no obvious correction, then we + place the word in a ring buffer for access by the \"Correct Last Misspelled + Word\" command. If \"Check Word Spelling Beep\" is true, then this command + beeps when an unknown word is found, in addition to displaying the message." + "Check the spelling of the previous word, making obvious corrections, or + queuing the word in buffer-misspelled-words if we are at a loss." + (declare (ignore p)) + (unless (eq (last-command-type) :spell-check) + (spell:maybe-read-spell-dictionary) + (let ((region (spell-previous-word (current-point) t))) + (when region + (let* ((word (nstring-upcase (region-to-string region))) + (len (length word))) + (declare (simple-string word)) + (when (and (<= 2 len spell:max-entry-length) + (not (spell:spell-try-word word len))) + (let ((found (gethash word *spelling-corrections*)) + (save (region-to-string region))) + (cond (found + (undoable-replace-word (region-start region) save found) + (message "Corrected ~S to ~S." save found) + (when (value check-word-spelling-beep) (beep))) + ((and (value spell-ignore-uppercase) + (every #'upper-case-p save)) + (unless (gethash word *ignored-misspellings*) + (setf (gethash word *ignored-misspellings*) t) + (message "Ignoring ~S." save))) + (t + (let ((close (spell:spell-collect-close-words word))) + (cond ((and close + (null (rest close)) + (value correct-unique-spelling-immediately)) + (let ((fix (first close))) + (undoable-replace-word (region-start region) + save fix) + (message "Corrected ~S to ~S." save fix))) + (t + (ring-push (copy-mark (region-end region) + :right-inserting) + (value buffer-misspelled-words)) + (let ((nclose + (do ((i 0 (1+ i)) + (words close (cdr words)) + (nwords () (cons (list i (car words)) + nwords))) + ((null words) (nreverse nwords))))) + (message + "Word ~S not found.~ + ~@[ Corrections:~:{ ~D=~A~}~]" + save nclose))))) + (when (value check-word-spelling-beep) (beep)))))))))) + (setf (last-command-type) :spell-check)) + +(defcommand "Correct Last Misspelled Word" (p) + "Fix a misspelling found by \"Auto Check Word Spelling\". This prompts for + a single character command to determine which action to take to correct the + problem." + "Prompt for a single character command to determine how to fix up a + misspelling detected by Check-Word-Spelling-Command." + (declare (ignore p)) + (spell:maybe-read-spell-dictionary) + (do ((info (value spell-information))) + ((sub-correct-last-misspelled-word info)))) + +(defun sub-correct-last-misspelled-word (info) + (let* ((missed (value buffer-misspelled-words)) + (region (cond ((zerop (ring-length missed)) + (editor-error "No recently misspelled word.")) + ((spell-previous-word (ring-ref missed 0) t)) + (t (editor-error "No recently misspelled word.")))) + (word (region-to-string region)) + (folded (string-upcase word)) + (point (current-point)) + (save (copy-mark point)) + (res t)) + (declare (simple-string word)) + (unwind-protect + (progn + (when (check-out-word-spelling word folded) + (delete-mark (ring-pop missed)) + (return-from sub-correct-last-misspelled-word t)) + (move-mark point (region-end region)) + (command-case (:prompt "Action: " + :change-window nil + :help "Type a single character command to do something to the misspelled word.") + (#\c "Try to find a correction for this word." + (unless (get-word-correction (region-start region) word folded) + (reprompt))) + (#\i "Insert this word in the dictionary." + (spell:spell-add-entry folded) + (push folded (spell-info-insertions info)) + (message "~A inserted in the dictionary." word)) + (#\r "Prompt for a word to replace this word with." + (let ((s (prompt-for-string :prompt "Replace with: " + :default word + :help "Type a string to replace occurrences of this word with."))) + (delete-region region) + (insert-string point s) + (setf (gethash folded *spelling-corrections*) s))) + (:cancel "Ignore this word and go to the previous misspelled word." + (setq res nil)) + (:recursive-edit + "Go into a recursive edit and leave when it exits." + (do-recursive-edit)) + ((:exit #\q) "Exit and forget about this word.") + ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) + "Choose this numbered word as the correct spelling." + (let ((num (digit-char-p (ext:key-event-char *last-key-event-typed*))) + (close-words (spell:spell-collect-close-words folded))) + (cond ((> num (length close-words)) + (editor-error "Choice out of range.")) + (t (let ((s (nth num close-words))) + (setf (gethash folded *spelling-corrections*) s) + (undoable-replace-word (region-start region) + word s))))))) + (delete-mark (ring-pop missed)) + res) + (move-mark point save) + (delete-mark save)))) + +(defhvar "Spelling Un-Correct Prompt for Insert" + "When this is set, \"Undo Last Spelling Correction\" will prompt before + inserting the old word into the dictionary." + :value nil) + +(defcommand "Undo Last Spelling Correction" (p) + "Undo the last incremental spelling correction. + The \"correction\" is replaced with the old word, and the old word is + inserted in the dictionary. When \"Spelling Un-Correct Prompt for Insert\" + is set, the user is asked about inserting the old word. Any automatic + replacement for the old word is eliminated." + "Undo the last incremental spelling correction, nuking any undesirable + side-effects." + (declare (ignore p)) + (unless (hemlock-bound-p 'last-spelling-correction-mark) + (editor-error "No last spelling correction.")) + (let ((mark (value last-spelling-correction-mark)) + (words (value last-spelling-correction-words))) + (unless words + (editor-error "No last spelling correction.")) + (let* ((new (car words)) + (old (cdr words)) + (folded (string-upcase old))) + (declare (simple-string old new folded)) + (remhash folded *spelling-corrections*) + (delete-characters mark (length new)) + (insert-string mark old) + (setf (value last-spelling-correction-words) nil) + (when (or (not (value spelling-un-correct-prompt-for-insert)) + (prompt-for-y-or-n + :prompt (list "Insert ~A into spelling dictionary? " folded) + :default t + :default-string "Y")) + (push folded (spell-info-insertions (value spell-information))) + (spell:maybe-read-spell-dictionary) + (spell:spell-add-entry folded) + (message "Added ~S to spelling dictionary." old))))) + + +;;; Check-Out-Word-Spelling -- Internal +;;; +;;; Return Nil if Word is a candidate for correction, otherwise +;;; return T and message as to why it isn't. +;;; +(defun check-out-word-spelling (word folded) + (declare (simple-string word)) + (let ((len (length word))) + (cond ((= len 1) + (message "Single character words are not in the dictionary.") t) + ((> len spell:max-entry-length) + (message "~A is too long for the dictionary." word) t) + (t + (multiple-value-bind (idx flagp) (spell:spell-try-word folded len) + (when idx + (message "Found it~:[~; because of ~A~]." flagp + (spell:spell-root-word idx)) + t)))))) + +;;; Get-Word-Correction -- Internal +;;; +;;; Find all known close words to the either unknown or incorrectly +;;; spelled word we are checking. Word is the unmunged word, and Folded is +;;; the uppercased word. Mark is a mark which points to the beginning of +;;; the offending word. Return True if we successfully corrected the word. +;;; +(defun get-word-correction (mark word folded) + (let ((close-words (spell:spell-collect-close-words folded))) + (declare (list close-words)) + (if close-words + (with-pop-up-display (s :height 3) + (do ((i 0 (1+ i)) + (words close-words (cdr words))) + ((null words)) + (format s "~36R=~A " i (car words))) + (finish-output s) + (let* ((key-event (prompt-for-key-event + :prompt "Correction choice: ")) + (num (digit-char-p (ext:key-event-char key-event) 36))) + (cond ((not num) (return-from get-word-correction nil)) + ((> num (length close-words)) + (editor-error "Choice out of range.")) + (t + (let ((s (nth num close-words))) + (setf (gethash folded *spelling-corrections*) s) + (undoable-replace-word mark word s))))) + (return-from get-word-correction t)) + (with-pop-up-display (s :height 1) + (write-line "No corrections found." s) + nil)))) + + +;;; Undoable-Replace-Word -- Internal +;;; +;;; Like Spell-Replace-Word, but makes annotations in buffer local variables +;;; so that "Undo Last Spelling Correction" can undo it. +;;; +(defun undoable-replace-word (mark old new) + (unless (hemlock-bound-p 'last-spelling-correction-mark) + (let ((buffer (current-buffer))) + (defhvar "Last Spelling Correction Mark" + "This variable holds a park pointing to the last spelling correction." + :buffer buffer :value (copy-mark (buffer-start-mark buffer))) + (defhvar "Last Spelling Correction Words" + "The replacement done for the last correction: (new . old)." + :buffer buffer :value nil))) + (move-mark (value last-spelling-correction-mark) mark) + (setf (value last-spelling-correction-words) (cons new old)) + (spell-replace-word mark old new)) + + + +;;;; Buffer Correction + +(defvar *spell-word-characters* + (make-array char-code-limit :element-type 'bit :initial-element 0) + "Characters that are legal in a word for spelling checking purposes.") + +(do-alpha-chars (c :both) + (setf (sbit *spell-word-characters* (char-code c)) 1)) +(setf (sbit *spell-word-characters* (char-code #\')) 1) + + +(defcommand "Correct Buffer Spelling" (p) + "Correct spelling over whole buffer. A log of the found misspellings is + kept in the buffer \"Spell Corrections\". For each unknown word the + user may accept it, insert it in the dictionary, correct its spelling + with one of the offered possibilities, replace the word with a user + supplied word, or go into a recursive edit. Words may be added to the + dictionary in advance from a text file (see the command \"Augment + Spelling Dictionary\")." + "Correct spelling over whole buffer." + (declare (ignore p)) + (clrhash *ignored-misspellings*) + (let* ((buffer (current-buffer)) + (log (or (make-buffer "Spelling Corrections") + (getstring "Spelling Corrections" *buffer-names*))) + (point (buffer-end (buffer-point log))) + (*standard-output* (make-hemlock-output-stream point)) + (window (or (car (buffer-windows log)) (make-window point)))) + (format t "~&Starting spelling checking of buffer ~S.~2%" + (buffer-name buffer)) + (spell:maybe-read-spell-dictionary) + (correct-buffer-spelling buffer window) + (delete-window window) + (close *standard-output*))) + +;;; CORRECT-BUFFER-SPELLING scans through buffer a line at a time, grabbing the +;;; each line's string and breaking it up into words using the +;;; *spell-word-characters* mask. We try the spelling of each word, and if it +;;; is unknown, we call FIX-WORD and resynchronize when it returns. +;;; +(defun correct-buffer-spelling (buffer window) + (do ((line (mark-line (buffer-start-mark buffer)) (line-next line)) + (info (if (hemlock-bound-p 'spell-information :buffer buffer) + (variable-value 'spell-information :buffer buffer) + (value spell-information))) + (mask *spell-word-characters*) + (word (make-string spell:max-entry-length))) + ((null line)) + (declare (simple-bit-vector mask) (simple-string word)) + (block line + (let* ((string (line-string line)) + (length (length string))) + (declare (simple-string string)) + (do ((start 0 (or skip-apostrophes end)) + (skip-apostrophes nil nil) + end) + (nil) + ;; + ;; Find word start. + (loop + (when (= start length) (return-from line)) + (when (/= (bit mask (char-code (schar string start))) 0) (return)) + (incf start)) + ;; + ;; Find the end. + (setq end (1+ start)) + (loop + (when (= end length) (return)) + (when (zerop (bit mask (char-code (schar string end)))) (return)) + (incf end)) + (multiple-value-setq (end skip-apostrophes) + (correct-buffer-word-end string start end)) + ;; + ;; Check word. + (let ((word-len (- end start))) + (cond + ((= word-len 1)) + ((> word-len spell:max-entry-length) + (format t "Not checking ~S -- too long for dictionary.~2%" + word)) + (t + ;; + ;; Copy the word and uppercase it. + (do* ((i (1- end) (1- i)) + (j (1- word-len) (1- j))) + ((zerop j) + (setf (schar word 0) (char-upcase (schar string i)))) + (setf (schar word j) (char-upcase (schar string i)))) + (unless (spell:spell-try-word word word-len) + (move-to-position (current-point) start line) + (fix-word (subseq word 0 word-len) (subseq string start end) + window info) + (let ((point (current-point))) + (setq end (mark-charpos point) + line (mark-line point) + string (line-string line) + length (length string)))))))))))) + +;;; CORRECT-BUFFER-WORD-END takes a line string from CORRECT-BUFFER-SPELLING, a +;;; start, and a end. It places end to exclude from the word apostrophes used +;;; for quotation marks, possessives, and funny plurals (e.g., A's and AND's). +;;; Every word potentially can be followed by "'s", and any clown can use the +;;; `` '' Scribe ligature. This returns the value to use for end of the word +;;; and the value to use as the end when continuing to find the next word in +;;; string. +;;; +(defun correct-buffer-word-end (string start end) + (cond ((and (> (- end start) 2) + (char= (char-upcase (schar string (1- end))) #\S) + (char= (schar string (- end 2)) #\')) + ;; Use roots of possessives and funny plurals (e.g., A's and AND's). + (values (- end 2) end)) + (t + ;; Maybe backup over apostrophes used for quotation marks. + (do ((i (1- end) (1- i))) + ((= i start) (values end end)) + (when (char/= (schar string i) #\') + (return (values (1+ i) end))))))) + +;;; Fix-Word -- Internal +;;; +;;; Handles the case where the word has a known correction. If is does +;;; not then call Correct-Buffer-Word-Not-Found. In either case, the +;;; point is left at the place to resume checking. +;;; +(defun fix-word (word unfolded-word window info) + (declare (simple-string word unfolded-word)) + (let ((correction (gethash word *spelling-corrections*)) + (mark (current-point))) + (cond (correction + (format t "Replacing ~S with ~S.~%" unfolded-word correction) + (spell-replace-word mark unfolded-word correction)) + ((and (value spell-ignore-uppercase) + (every #'upper-case-p unfolded-word)) + (character-offset mark (length word)) + (unless (gethash word *ignored-misspellings*) + (setf (gethash word *ignored-misspellings*) t) + (format t "Ignoring ~S.~%" unfolded-word))) + (t + (correct-buffer-word-not-found word unfolded-word window info))))) + +(defun correct-buffer-word-not-found (word unfolded-word window info) + (declare (simple-string word unfolded-word)) + (let* ((close-words (spell:spell-collect-close-words word)) + (close-words-len (length (the list close-words))) + (mark (current-point)) + (wordlen (length word))) + (format t "Unknown word: ~A~%" word) + (cond (close-words + (format t "~[~;A~:;Some~]~:* possible correction~[~; is~:;s are~]: " + close-words-len) + (if (= close-words-len 1) + (write-line (car close-words)) + (let ((n 0)) + (dolist (w close-words (terpri)) + (format t "~36R=~A " n w) + (incf n))))) + (t + (write-line "No correction possibilities found."))) + (let ((point (buffer-point (window-buffer window)))) + (unless (displayed-p point window) + (center-window window point))) + (command-case + (:prompt "Action: " + :help "Type a single letter command, or help character for help." + :change-window nil) + (#\i "Insert unknown word into dictionary for future lookup." + (spell:spell-add-entry word) + (push word (spell-info-insertions info)) + (format t "~S added to dictionary.~2%" word)) + (#\c "Correct the unknown word with possible correct spellings." + (unless close-words + (write-line "There are no possible corrections.") + (reprompt)) + (let ((num (if (= close-words-len 1) 0 + (digit-char-p (ext:key-event-char + (prompt-for-key-event + :prompt "Correction choice: ")) + 36)))) + (unless num (reprompt)) + (when (> num close-words-len) + (beep) + (write-line "Response out of range.") + (reprompt)) + (let ((choice (nth num close-words))) + (setf (gethash word *spelling-corrections*) choice) + (spell-replace-word mark unfolded-word choice))) + (terpri)) + (#\a "Accept the word as correct (that is, ignore it)." + (character-offset mark wordlen)) + (#\r "Replace the unknown word with a supplied replacement." + (let ((s (prompt-for-string + :prompt "Replacement Word: " + :default unfolded-word + :help "String to replace the unknown word with."))) + (setf (gethash word *spelling-corrections*) s) + (spell-replace-word mark unfolded-word s)) + (terpri)) + (:recursive-edit + "Go into a recursive edit and resume correction where the point is left." + (do-recursive-edit))))) + +;;; Spell-Replace-Word -- Internal +;;; +;;; Replaces Old with New, starting at Mark. The case of Old is used +;;; to derive the new case. +;;; +(defun spell-replace-word (mark old new) + (declare (simple-string old new)) + (let ((res (cond ((lower-case-p (schar old 0)) + (string-downcase new)) + ((lower-case-p (schar old 1)) + (let ((res (string-downcase new))) + (setf (char res 0) (char-upcase (char res 0))) + res)) + (t + (string-upcase new))))) + (with-mark ((m mark :left-inserting)) + (delete-characters m (length old)) + (insert-string m res)))) + + + +;;;; User Spelling Dictionaries. + +(defvar *pathname-to-spell-info* (make-hash-table :test #'equal) + "This maps dictionary files to spelling information.") + +(defhvar "Spell Information" + "This is the information about a spelling dictionary and its incremental + insertions." + :value (make-spell-info nil)) + +(define-file-option "Dictionary" (buffer file) + (let* ((dict (merge-pathnames + file + (make-pathname :defaults (buffer-default-pathname buffer) + :type "dict"))) + (dictp (probe-file dict))) + (if dictp + (set-buffer-spelling-dictionary-command nil dictp buffer) + (loud-message "Couldn't find dictionary ~A." (namestring dict))))) + +;;; SAVE-DICTIONARY-ON-WRITE is on the "Write File Hook" in buffers with +;;; the "dictionary" file option. +;;; +(defun save-dictionary-on-write (buffer) + (when (hemlock-bound-p 'spell-information :buffer buffer) + (save-spelling-insertions + (variable-value 'spell-information :buffer buffer)))) + + +(defcommand "Save Incremental Spelling Insertions" (p) + "Append incremental spelling dictionary insertions to a file. The file + is prompted for unless \"Set Buffer Spelling Dictionary\" has been + executed in the buffer." + "Append incremental spelling dictionary insertions to a file." + (declare (ignore p)) + (let* ((info (value spell-information)) + (file (or (spell-info-pathname info) + (value default-user-spelling-dictionary) + (prompt-for-file + :prompt "Dictionary File: " + :default (dictionary-name-default) + :must-exist nil + :help + "Name of the dictionary file to append dictionary insertions to.")))) + (save-spelling-insertions info file) + (let* ((ginfo (variable-value 'spell-information :global)) + (insertions (spell-info-insertions ginfo))) + (when (and insertions + (prompt-for-y-or-n + :prompt + `("Global spelling insertions exist.~%~ + Save these to ~A also? " + ,(namestring file) + :default t + :default-string "Y")) + (save-spelling-insertions ginfo file)))))) + +(defun save-spelling-insertions (info &optional + (name (spell-info-pathname info))) + (when (spell-info-insertions info) + (with-open-file (stream name + :direction :output :element-type 'base-char + :if-exists :append :if-does-not-exist :create) + (dolist (w (spell-info-insertions info)) + (write-line w stream))) + (setf (spell-info-insertions info) ()) + (message "Incremental spelling insertions for ~A written." + (namestring name)))) + +(defcommand "Set Buffer Spelling Dictionary" (p &optional file buffer) + "Prompts for the dictionary file to associate with the current buffer. + If this file has not been read for any other buffer, then it is read. + Incremental spelling insertions from this buffer can be appended to + this file with \"Save Incremental Spelling Insertions\"." + "Sets the buffer's spelling dictionary and reads it if necessary." + (declare (ignore p)) + (maybe-read-default-user-spelling-dictionary) + (let* ((file (truename (or file + (prompt-for-file + :prompt "Dictionary File: " + :default (dictionary-name-default) + :help + "Name of the dictionary file to add into the current dictionary.")))) + (file-name (namestring file)) + (spell-info-p (gethash file-name *pathname-to-spell-info*)) + (spell-info (or spell-info-p (make-spell-info file))) + (buffer (or buffer (current-buffer)))) + (defhvar "Spell Information" + "This is the information about a spelling dictionary and its incremental + insertions." + :value spell-info :buffer buffer) + (add-hook write-file-hook 'save-dictionary-on-write) + (unless spell-info-p + (setf (gethash file-name *pathname-to-spell-info*) spell-info) + (read-spelling-dictionary-command nil file)))) + +(defcommand "Read Spelling Dictionary" (p &optional file) + "Adds entries to the dictionary from a file in the following format: + + entry1/flag1/flag2/flag3 + entry2 + entry3/flag1/flag2/flag3/flag4/flag5. + + The flags are single letter indicators of legal suffixes for the entry; + the available flags and their correct use may be found at the beginning + of spell-correct.lisp in the Hemlock sources. There must be exactly one + entry per line, and each line must be flushleft." + "Add entries to the dictionary from a text file in a specified format." + (declare (ignore p)) + (spell:maybe-read-spell-dictionary) + (spell:spell-read-dictionary + (or file + (prompt-for-file + :prompt "Dictionary File: " + :default (dictionary-name-default) + :help + "Name of the dictionary file to add into the current dictionary.")))) + +(defun dictionary-name-default () + (make-pathname :defaults (buffer-default-pathname (current-buffer)) + :type "dict")) + +(defcommand "Add Word to Spelling Dictionary" (p) + "Add the previous word to the spelling dictionary." + "Add the previous word to the spelling dictionary." + (declare (ignore p)) + (spell:maybe-read-spell-dictionary) + (let ((word (region-to-string (spell-previous-word (current-point) nil)))) + ;; + ;; SPELL:SPELL-ADD-ENTRY destructively uppercases word. + (when (spell:spell-add-entry word) + (message "Word ~(~S~) added to the spelling dictionary." word) + (push word (spell-info-insertions (value spell-information)))))) + +(defcommand "Remove Word from Spelling Dictionary" (p) + "Prompts for word to remove from the spelling dictionary." + "Prompts for word to remove from the spelling dictionary." + (declare (ignore p)) + (spell:maybe-read-spell-dictionary) + (let* ((word (prompt-for-string + :prompt "Word to remove from spelling dictionary: " + :trim t)) + (upword (string-upcase word))) + (declare (simple-string word)) + (multiple-value-bind (index flagp) + (spell:spell-try-word upword (length word)) + (unless index + (editor-error "~A not in dictionary." upword)) + (if flagp + (remove-spelling-word upword) + (let ((flags (spell:spell-root-flags index))) + (when (or (not flags) + (prompt-for-y-or-n + :prompt + `("Deleting ~A also removes words formed from this root and these flags: ~% ~ + ~S.~%~ + Delete word anyway? " + ,word ,flags) + :default t + :default-string "Y")) + (remove-spelling-word upword))))))) + +;;; REMOVE-SPELLING-WORD removes the uppercase word word from the spelling +;;; dictionary and from the spelling informations incremental insertions list. +;;; +(defun remove-spelling-word (word) + (let ((info (value spell-information))) + (spell:spell-remove-entry word) + (setf (spell-info-insertions info) + (delete word (spell-info-insertions info) :test #'string=)))) + +(defcommand "List Incremental Spelling Insertions" (p) + "Display the incremental spelling insertions for the current buffer's + associated spelling dictionary file." + "Display the incremental spelling insertions for the current buffer's + associated spelling dictionary file." + (declare (ignore p)) + (let* ((info (value spell-information)) + (file (spell-info-pathname info)) + (insertions (spell-info-insertions info))) + (declare (list insertions)) + (with-pop-up-display (s :height (1+ (length insertions))) + (if file + (format s "Incremental spelling insertions for dictionary ~A:~%" + (namestring file)) + (write-line "Global incremental spelling insertions:" s)) + (dolist (w insertions) + (write-line w s))))) + + + + +;;;; Utilities for above stuff. + +;;; SPELL-PREVIOUS-WORD returns as a region the current or previous word, using +;;; the spell word definition. If there is no such word, return nil. If end-p +;;; is non-nil, then mark ends the word even if there is a non-delimiter +;;; character after it. +;;; +;;; Actually, if mark is between the first character of a word and a +;;; non-spell-word characer, it is considered to be in that word even though +;;; that word is after the mark. This is because Hemlock's cursor is always +;;; displayed over the next character, so users tend to think of a cursor +;;; displayed on the first character of a word as being in that word instead of +;;; before it. +;;; +(defun spell-previous-word (mark end-p) + (with-mark ((point mark) + (mark mark)) + (cond ((or end-p + (zerop (character-attribute :spell-word-character + (next-character point)))) + (unless (reverse-find-attribute mark :spell-word-character) + (return-from spell-previous-word nil)) + (move-mark point mark) + (reverse-find-attribute point :spell-word-character #'zerop)) + (t + (find-attribute mark :spell-word-character #'zerop) + (reverse-find-attribute point :spell-word-character #'zerop))) + (cond ((and (> (- (mark-charpos mark) (mark-charpos point)) 2) + (char= (char-upcase (previous-character mark)) #\S) + (char= (prog1 (previous-character (mark-before mark)) + (mark-after mark)) + #\')) + ;; Use roots of possessives and funny plurals (e.g., A's and AND's). + (character-offset mark -2)) + (t + ;; Maybe backup over apostrophes used for quotation marks. + (loop + (when (mark= point mark) (return-from spell-previous-word nil)) + (when (char/= (previous-character mark) #\') (return)) + (mark-before mark)))) + (region point mark))) Index: /branches/ide-1.0/ccl/hemlock/src/archive/ts-buf.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/archive/ts-buf.lisp (revision 6567) +++ /branches/ide-1.0/ccl/hemlock/src/archive/ts-buf.lisp (revision 6567) @@ -0,0 +1,318 @@ +;;; -*- Package: Hemlock; Log: hemlock.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +(hemlock-ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; This file contains code for processing input to and output from slaves +;;; using typescript streams. It maintains the stuff that hacks on the +;;; typescript buffer and maintains its state. +;;; +;;; Written by William Lott. +;;; + +(in-package :hemlock) + + +(defhvar "Input Wait Alarm" + "When non-nil, the user is informed when a typescript buffer goes into + an input wait, and it is not visible. Legal values are :message, + :loud-message (the default), and nil." + :value :loud-message) + + + + +;;;; Structures. + +(defstruct (ts-data + (:print-function + (lambda (ts s d) + (declare (ignore ts d)) + (write-string "#" s))) + (:constructor + make-ts-data (buffer + &aux + (fill-mark (copy-mark (buffer-end-mark buffer) + :right-inserting))))) + buffer ; The buffer we are in + stream ; Stream in the slave. + wire ; Wire to slave + server ; Server info struct. + fill-mark ; Mark where output goes. This is actually the + ; "Buffer Input Mark" which is :right-inserting, + ; and we make sure it is :left-inserting for + ; inserting output. + ) + + + +;;;; Output routines. + +;;; TS-BUFFER-OUTPUT-STRING --- internal interface. +;;; +;;; Called by the slave to output stuff in the typescript. Can also be called +;;; by other random parts of hemlock when they want to output stuff to the +;;; buffer. Since this is called for value from the slave, we have to be +;;; careful about what values we return, so the result can be sent back. It is +;;; called for value only as a synchronization thing. +;;; +;;; Whenever the output is gratuitous, we want it to go behind the prompt. +;;; When it's gratuitous, and we're not at the line-start, then we can output +;;; it normally, but we also make sure we end the output in a newline for +;;; visibility's sake. +;;; +(defun ts-buffer-output-string (ts string &optional gratuitous-p) + "Outputs STRING to the typescript described with TS. The output is inserted + before the fill-mark and the current input." + (when (hemlock.wire:remote-object-p ts) + (setf ts (hemlock.wire:remote-object-value ts))) + (hemlock-ext:without-interrupts + (let ((mark (ts-data-fill-mark ts))) + (cond ((and gratuitous-p (not (start-line-p mark))) + (with-mark ((m mark :left-inserting)) + (line-start m) + (insert-string m string) + (unless (start-line-p m) + (insert-character m #\newline)))) + (t + (setf (mark-kind mark) :left-inserting) + (insert-string mark string) + (when (and gratuitous-p (not (start-line-p mark))) + (insert-character mark #\newline)) + (setf (mark-kind mark) :right-inserting))))) + (values)) + +;;; TS-BUFFER-FINISH-OUTPUT --- internal interface. +;;; +;;; Redisplays the windows. Used by ts-stream in order to finish-output. +;;; +(defun ts-buffer-finish-output (ts) + (declare (ignore ts)) + (redisplay) + nil) + +;;; TS-BUFFER-CHARPOS --- internal interface. +;;; +;;; Used by ts-stream in order to find the charpos. +;;; +(defun ts-buffer-charpos (ts) + (mark-charpos (ts-data-fill-mark (if (hemlock.wire:remote-object-p ts) + (hemlock.wire:remote-object-value ts) + ts)))) + +;;; TS-BUFFER-LINE-LENGTH --- internal interface. +;;; +;;; Used by ts-stream to find out the line length. Returns the width of the +;;; first window, or 80 if there are no windows. +;;; +(defun ts-buffer-line-length (ts) + (let* ((ts (if (hemlock.wire:remote-object-p ts) + (hemlock.wire:remote-object-value ts) + ts)) + (window (car (buffer-windows (ts-data-buffer ts))))) + (if window + (window-width window) + 80))) ; Seems like a good number to me. + + + +;;;; Input routines + +(defun ts-buffer-ask-for-input (remote) + (let* ((ts (hemlock.wire:remote-object-value remote)) + (buffer (ts-data-buffer ts))) + (unless (buffer-windows buffer) + (let ((input-wait-alarm + (if (hemlock-bound-p 'input-wait-alarm + :buffer buffer) + (variable-value 'input-wait-alarm + :buffer buffer) + (variable-value 'input-wait-alarm + :global)))) + (when input-wait-alarm + (when (eq input-wait-alarm :loud-message) + (beep)) + (message "Waiting for input in buffer ~A." + (buffer-name buffer)))))) + nil) + +(defun ts-buffer-clear-input (ts) + (let* ((ts (if (hemlock.wire:remote-object-p ts) + (hemlock.wire:remote-object-value ts) + ts)) + (buffer (ts-data-buffer ts)) + (mark (ts-data-fill-mark ts))) + (unless (mark= mark (buffer-end-mark buffer)) + (with-mark ((start mark)) + (line-start start) + (let ((prompt (region-to-string (region start mark))) + (end (buffer-end-mark buffer))) + (unless (zerop (mark-charpos end)) + (insert-character end #\Newline)) + (insert-string end "[Input Cleared]") + (insert-character end #\Newline) + (insert-string end prompt) + (move-mark mark end))))) + nil) + +(defun ts-buffer-set-stream (ts stream) + (let ((ts (if (hemlock.wire:remote-object-p ts) + (hemlock.wire:remote-object-value ts) + ts))) + (setf (ts-data-stream ts) stream) + (hemlock.wire:remote (ts-data-wire ts) + (ts-stream-set-line-length stream (ts-buffer-line-length ts)))) + nil) + + + +;;;; Typescript mode. + +(defun setup-typescript (buffer) + (let ((ts (make-ts-data buffer))) + (defhvar "Current Package" + "The package used for evaluation of Lisp in this buffer." + :buffer buffer + :value nil) + + (defhvar "Typescript Data" + "The ts-data structure for this buffer" + :buffer buffer + :value ts) + + (defhvar "Buffer Input Mark" + "Beginning of typescript input in this buffer." + :value (ts-data-fill-mark ts) + :buffer buffer) + + (defhvar "Interactive History" + "A ring of the regions input to the Hemlock typescript." + :buffer buffer + :value (make-ring (value interactive-history-length))) + + (defhvar "Interactive Pointer" + "Pointer into the Hemlock typescript input history." + :buffer buffer + :value 0) + + (defhvar "Searching Interactive Pointer" + "Pointer into \"Interactive History\"." + :buffer buffer + :value 0))) + +(defmode "Typescript" + :setup-function #'setup-typescript + :documentation "The Typescript mode is used to interact with slave lisps.") + + +;;; TYPESCRIPTIFY-BUFFER -- Internal interface. +;;; +;;; Buffer creation code for eval server connections calls this to setup a +;;; typescript buffer, tie things together, and make some local Hemlock +;;; variables. +;;; +(defun typescriptify-buffer (buffer server wire) + (setf (buffer-minor-mode buffer "Typescript") t) + (let ((info (variable-value 'typescript-data :buffer buffer))) + (setf (ts-data-server info) server) + (setf (ts-data-wire info) wire) + (defhvar "Server Info" + "Server-info structure for this buffer." + :buffer buffer :value server) + (defhvar "Current Eval Server" + "The Server-Info object for the server currently used for evaluation and + compilation." + :buffer buffer :value server) + info)) + +(defun ts-buffer-wire-died (ts) + (setf (ts-data-stream ts) nil) + (setf (ts-data-wire ts) nil) + (buffer-end (ts-data-fill-mark ts) (ts-data-buffer ts)) + (ts-buffer-output-string ts (format nil "~%~%Slave died!~%"))) + +(defun unwedge-typescript-buffer () + (typescript-slave-to-top-level-command nil) + (buffer-end (current-point) (current-buffer))) + +(defhvar "Unwedge Interactive Input Fun" + "Function to call when input is confirmed, but the point is not past the + input mark." + :value #'unwedge-typescript-buffer + :mode "Typescript") + +(defhvar "Unwedge Interactive Input String" + "String to add to \"Point not past input mark. \" explaining what will + happen if the the user chooses to be unwedged." + :value "Cause the slave to throw to the top level? " + :mode "Typescript") + +;;; TYPESCRIPT-DATA-OR-LOSE -- internal +;;; +;;; Return the typescript-data for the current buffer, or die trying. +;;; +(defun typescript-data-or-lose () + (if (hemlock-bound-p 'typescript-data) + (let ((ts (value typescript-data))) + (if ts + ts + (editor-error "Can't find the typescript data?"))) + (editor-error "Not in a typescript buffer."))) + +(defcommand "Confirm Typescript Input" (p) + "Send the current input to the slave typescript." + "Send the current input to the slave typescript." + (declare (ignore p)) + (let ((ts (typescript-data-or-lose))) + (let ((input (get-interactive-input))) + (when input + (let ((string (region-to-string input))) + (declare (simple-string string)) + (insert-character (current-point) #\NewLine) + (hemlock.wire:remote (ts-data-wire ts) + (ts-stream-accept-input (ts-data-stream ts) + (concatenate 'simple-string + string + (string #\newline)))) + (hemlock.wire:wire-force-output (ts-data-wire ts)) + (buffer-end (ts-data-fill-mark ts) + (ts-data-buffer ts))))))) + +(defcommand "Typescript Slave Break" (p) + "Interrupt the slave Lisp process associated with this interactive buffer, + causing it to invoke BREAK." + "Interrupt the slave Lisp process associated with this interactive buffer, + causing it to invoke BREAK." + (declare (ignore p)) + (send-oob-to-slave "B")) + +(defcommand "Typescript Slave to Top Level" (p) + "Interrupt the slave Lisp process associated with this interactive buffer, + causing it to throw to the top level REP loop." + "Interrupt the slave Lisp process associated with this interactive buffer, + causing it to throw to the top level REP loop." + (declare (ignore p)) + (send-oob-to-slave "T")) + +(defcommand "Typescript Slave Status" (p) + "Interrupt the slave and cause it to print status information." + "Interrupt the slave and cause it to print status information." + (declare (ignore p)) + (send-oob-to-slave "S")) + +#+NIL +(defun send-oob-to-slave (string) + (let* ((ts (typescript-data-or-lose)) + (wire (ts-data-wire ts)) + (socket (hemlock.wire:wire-fd wire))) + (unless socket + (editor-error "The slave is no longer alive.")) + (error "SEND-OOB-TO-SLAVE seeks an implementation.") + #+NIL + (hemlock-ext:send-character-out-of-band socket (schar string 0)))) Index: /branches/ide-1.0/ccl/hemlock/src/archive/ts-stream.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/archive/ts-stream.lisp (revision 6567) +++ /branches/ide-1.0/ccl/hemlock/src/archive/ts-stream.lisp (revision 6567) @@ -0,0 +1,422 @@ +;;; -*- Package: Hemlock; Log: hemlock.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +(hemlock-ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; This file implements typescript streams. +;;; +;;; A typescript stream is a bidirectional stream which uses remote +;;; function calls to interact with a Hemlock typescript buffer. That +;;; is: the code in this file is executed on the slave side. +;;; +;;; Written by William Lott. +;;; + +(in-package :hemlock) + + + +;;;; Ts-streams. + +(defconstant ts-stream-output-buffer-size 512) + +(defclass ts-stream (hi::fundamental-character-output-stream + hi::fundamental-character-input-stream) + ((wire + :initarg :wire + :initform nil + :accessor ts-stream-wire) + + (typescript + :initarg :typescript + :initform nil + :accessor ts-stream-typescript) + + (output-buffer + :initarg :output-buffer + :initform (make-string ts-stream-output-buffer-size) + :accessor ts-stream-output-buffer + :type simple-string) + + (output-buffer-index + :initarg :output-buffer-index + :initform 0 + :accessor ts-stream-output-buffer-index + :type fixnum) + + (char-pos + :initarg :char-pos + :initform 0 + :accessor ts-stream-char-pos + :type fixnum + :documentation "The current output character position on the line, returned by the :CHARPOS method.") + + (line-length + :initarg :line-length + :initform 80 + :accessor ts-stream-line-length + :documentation "The current length of a line of output. Returned by STREAM-LINE-LENGTH method.") + + (current-input + :initarg :current-input + :initform nil + :accessor ts-stream-current-input + :type list + :documentation "This is a list of strings and stream-commands whose order manifests the + input provided by remote procedure calls into the slave of + TS-STREAM-ACCEPT-INPUT.") + + (input-read-index + :initarg :input-read-index + :initform 0 + :accessor ts-stream-input-read-index + :type fixnum))) + +(defun make-ts-stream (wire typescript) + (make-instance 'ts-stream :wire wire :typescript typescript)) + + + +;;;; Conditions. + +(define-condition unexpected-stream-command (error) + ;; Context is a string to be plugged into the report text. + ((context :reader unexpected-stream-command-context :initarg :context)) + (:report (lambda (condition stream) + (format stream "~&Unexpected stream-command while ~A." + (unexpected-stream-command-context condition))))) + + + + +;;;; Editor remote calls into slave. + +;;; TS-STREAM-ACCEPT-INPUT -- Internal Interface. +;;; +;;; The editor calls this remotely in the slave to indicate that the user has +;;; provided input. Input is a string, symbol, or list. If it is a list, the +;;; the CAR names the command, and the CDR is the arguments. +;;; +(defun ts-stream-accept-input (remote input) + (let ((stream (hemlock.wire:remote-object-value remote))) + (hemlock-ext:without-interrupts + (hemlock-ext:without-gcing + (setf (ts-stream-current-input stream) + (nconc (ts-stream-current-input stream) + (list (etypecase input + (string + (let ((newline + (position #\newline input :from-end t))) + (setf (ts-stream-char-pos stream) + (if newline + (- (length input) newline 1) + (length input))) + input)) + #+NILGB + (cons + (ext:make-stream-command (car input) + (cdr input))) + #+NILGB + (symbol + (ext:make-stream-command input))))))))) + nil) + +;;; TS-STREAM-SET-LINE-LENGTH -- Internal Interface. +;;; +;;; This function is called by the editor to indicate that the line-length for +;;; a TS stream should now be Length. +;;; +(defun ts-stream-set-line-length (remote length) + (let ((stream (hemlock.wire:remote-object-value remote))) + (setf (ts-stream-line-length stream) length))) + + + + +;;;; Stream methods. + +;;; %TS-STREAM-LISTEN -- Internal. +;;; +;;; Determine if there is any input available. If we don't think so, process +;;; all pending events, and look again. +;;; +(defmethod hi::stream-listen ((stream ts-stream)) + (flet ((check () + (hemlock-ext:without-interrupts + (hemlock-ext:without-gcing + (loop + (let* ((current (ts-stream-current-input stream)) + (first (first current))) + (cond ((null current) + (return nil)) + #+NILGB + ((ext:stream-command-p first) + (return t)) + ((>= (ts-stream-input-read-index stream) + (length (the simple-string first))) + (pop (ts-stream-current-input stream)) + (setf (ts-stream-input-read-index stream) 0)) + (t + (return t))))))))) + (or (check) + (progn + #+NILGB (system:serve-all-events 0) + (check))))) + +;;; %TS-STREAM-IN -- Internal. +;;; +;;; The READ-CHAR stream method. +;;; +(defmethod hi::stream-read-char ((stream ts-stream)) + (hi::stream-force-output stream) + (wait-for-typescript-input stream) + (hemlock-ext:without-interrupts + (hemlock-ext:without-gcing + (let ((first (first (ts-stream-current-input stream)))) + (etypecase first + (string + (prog1 (schar first (ts-stream-input-read-index stream)) + (incf (ts-stream-input-read-index stream)))) + #+NILGB + (ext:stream-command + (error 'unexpected-stream-command + :context "in the READ-CHAR method"))))))) + +;;; %TS-STREAM-READ-LINE -- Internal. +;;; +;;; The READ-LINE stream method. Note: here we take advantage of the fact that +;;; newlines will only appear at the end of strings. +;;; + +(defmethod stream-read-line (stream) + (macrolet + ((next-str () + '(progn + (wait-for-typescript-input stream) + (hemlock-ext:without-interrupts + (hemlock-ext:without-gcing + (let ((first (first (ts-stream-current-input stream)))) + (etypecase first + (string + (prog1 (if (zerop (ts-stream-input-read-index stream)) + (pop (ts-stream-current-input stream)) + (subseq (pop (ts-stream-current-input stream)) + (ts-stream-input-read-index stream))) + (setf (ts-stream-input-read-index stream) 0))) + #+NILGB + (ext:stream-command + (error 'unexpected-stream-command + :context "in the READ-CHAR method"))))))))) + (do ((result (next-str) (concatenate 'simple-string result (next-str)))) + ((char= (schar result (1- (length result))) #\newline) + (values (subseq result 0 (1- (length result))) + nil)) + (declare (simple-string result))))) + +;;; WAIT-FOR-TYPESCRIPT-INPUT -- Internal. +;;; +;;; Keep calling server until some input shows up. +;;; +(defun wait-for-typescript-input (stream) + (unless (hi::stream-listen stream) ;for some reasons in CLISP CL:LISTEN calls STREAM-READ-CHAR :-/ + (let ((wire (ts-stream-wire stream)) + (ts (ts-stream-typescript stream))) + (hemlock-ext:without-interrupts + (hemlock-ext:without-gcing + (hemlock.wire:remote wire (ts-buffer-ask-for-input ts)) + (hemlock.wire:wire-force-output wire))) + (loop + #+:hemlock.serve-event (hemlock.wire::serve-all-events) + #-:hemlock.serve-event (hemlock.wire:wire-get-object wire) + #+NILGB (sleep .1) ;### + (when (hi::stream-listen stream) + (return)))))) + +;;; %TS-STREAM-FLSBUF --- internal. +;;; +;;; Flush the output buffer associated with stream. This should only be used +;;; inside a without-interrupts and without-gcing. +;;; +(defun %ts-stream-flsbuf (stream) + (when (and (ts-stream-wire stream) + (ts-stream-output-buffer stream) + (not (zerop (ts-stream-output-buffer-index stream)))) + (hemlock.wire:remote (ts-stream-wire stream) + (ts-buffer-output-string + (ts-stream-typescript stream) + (subseq (the simple-string (ts-stream-output-buffer stream)) + 0 + (ts-stream-output-buffer-index stream)))) + (setf (ts-stream-output-buffer-index stream) 0))) + +;;; %TS-STREAM-OUT --- internal. +;;; +;;; Output a single character to stream. +;;; +(defmethod hi::stream-write-char ((stream ts-stream) char) + (declare (base-char char)) + (hemlock-ext:without-interrupts + (hemlock-ext:without-gcing + (when (= (ts-stream-output-buffer-index stream) + ts-stream-output-buffer-size) + (%ts-stream-flsbuf stream)) + (setf (schar (ts-stream-output-buffer stream) + (ts-stream-output-buffer-index stream)) + char) + (incf (ts-stream-output-buffer-index stream)) + (incf (ts-stream-char-pos stream)) + (when (= (char-code char) + (char-code #\Newline)) + (%ts-stream-flsbuf stream) + (setf (ts-stream-char-pos stream) 0) + (hemlock.wire:wire-force-output (ts-stream-wire stream))) + char))) + +;;; %TS-STREAM-SOUT --- internal. +;;; +;;; Output a string to stream. +;;; +(defmethod hi::stream-write-string ((stream ts-stream) string &optional (start 0) (end (length string))) + ;; This can't be true generally: --GB + #+NIL (declare (simple-string string)) + (declare (fixnum start end)) + (let ((wire (ts-stream-wire stream)) + (newline (position #\Newline string :start start :end end :from-end t)) + (length (- end start))) + (when wire + (hemlock-ext:without-interrupts + (hemlock-ext:without-gcing + (let ((index (ts-stream-output-buffer-index stream))) + (cond ((> (+ index length) + ts-stream-output-buffer-size) + (%ts-stream-flsbuf stream) + (hemlock.wire:remote wire + (ts-buffer-output-string (ts-stream-typescript stream) + (subseq string start end))) + (when newline + (hemlock.wire:wire-force-output wire))) + (t + (replace (the simple-string (ts-stream-output-buffer stream)) + string + :start1 index + :end1 (+ index length) + :start2 start + :end2 end) + (incf (ts-stream-output-buffer-index stream) + length) + (when newline + (%ts-stream-flsbuf stream) + (hemlock.wire:wire-force-output wire))))) + (setf (ts-stream-char-pos stream) + (if newline + (- end newline 1) + (+ (ts-stream-char-pos stream) + length)))))))) + +;;; %TS-STREAM-UNREAD -- Internal. +;;; +;;; Unread a single character. +;;; +(defmethod hi::stream-unread-char ((stream ts-stream) char) + (hemlock-ext:without-interrupts + (hemlock-ext:without-gcing + (let ((first (first (ts-stream-current-input stream)))) + (cond ((and (stringp first) + (> (ts-stream-input-read-index stream) 0)) + (setf (schar first (decf (ts-stream-input-read-index stream))) + char)) + (t + (push (string char) (ts-stream-current-input stream)) + (setf (ts-stream-input-read-index stream) 0))))))) + +;;; %TS-STREAM-CLOSE --- internal. +;;; +;;; Can't do much, 'cause the wire is shared. +;;; +(defmethod close ((stream ts-stream) &key abort) + (unless abort + (force-output stream)) + #+NILGB (lisp::set-closed-flame stream) ;Hugh!? what is that? --GB + ) + +;;; %TS-STREAM-CLEAR-INPUT -- Internal. +;;; +;;; Pass the request to the editor and clear any buffered input. +;;; +(defmethod hi::stream-clear-input ((stream ts-stream)) + (hemlock-ext:without-interrupts + (hemlock-ext:without-gcing + (when (ts-stream-wire stream) + (hemlock.wire:remote-value (ts-stream-wire stream) + (ts-buffer-clear-input (ts-stream-typescript stream)))) + (setf (ts-stream-current-input stream) nil + (ts-stream-input-read-index stream) 0)))) + +(defmethod hi::stream-finish-output ((stream ts-stream)) + (when (ts-stream-wire stream) + (hemlock-ext:without-interrupts + (hemlock-ext:without-gcing + (%ts-stream-flsbuf stream) + ;; Note: for the return value to come back, + ;; all pending RPCs must have completed. + ;; Therefore, we know it has synced. + (hemlock.wire:remote-value (ts-stream-wire stream) + (ts-buffer-finish-output (ts-stream-typescript stream)))))) + t) + +(defmethod hi::stream-force-output ((stream ts-stream)) + (when (ts-stream-wire stream) + (hemlock-ext:without-interrupts + (hemlock-ext:without-gcing + (%ts-stream-flsbuf stream) + (hemlock.wire:wire-force-output (ts-stream-wire stream))))) + t) + +(defmethod hi::stream-line-column ((stream ts-stream)) + (ts-stream-char-pos stream)) + +(defmethod hi::stream-line-length ((stream ts-stream)) + (ts-stream-line-length stream)) + +#+NILGB ;; -- hmm. +(defmethod interactive-stream-p ((stream ts-stream)) + t) + +(defmethod hi::stream-clear-output ((stream ts-stream)) + (setf (ts-stream-output-buffer-index stream) 0)) + +;;; %TS-STREAM-MISC -- Internal. +;;; +;;; The misc stream method. +;;; +#+NILGB +(defun %ts-stream-misc (stream operation &optional arg1 arg2) + (case operation + (:get-command + (wait-for-typescript-input stream) + (hemlock-ext:without-interrupts + (hemlock-ext:without-gcing + (etypecase (first (ts-stream-current-input stream)) + (stream-command + (setf (ts-stream-input-read-index stream) 0) + (pop (ts-stream-current-input stream))) + (string nil))))) + )) + +;; $Log$ +;; Revision 1.1 2003/10/19 08:57:16 gb +;; Initial revision +;; +;; Revision 1.1.2.1 2003/08/10 19:11:40 gb +;; New files, imported from upstream CVS as of 03/08/09. +;; +;; Revision 1.3 2003/08/05 19:51:13 gilbert +;; initial slave lisp support, still not ready for prime time. +;; +;; Index: /branches/ide-1.0/ccl/hemlock/src/archive/unixcoms.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/archive/unixcoms.lisp (revision 6567) +++ /branches/ide-1.0/ccl/hemlock/src/archive/unixcoms.lisp (revision 6567) @@ -0,0 +1,258 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; +;;; This file contains Commands useful when running on a Unix box. Hopefully +;;; there are no CMU Unix dependencies though there are probably CMU Common +;;; Lisp dependencies, such as RUN-PROGRAM. +;;; +;;; Written by Christopher Hoover. + +(in-package :hemlock) + + + + +;;;; Region and File printing commands. + +(defhvar "Print Utility" + "UNIX(tm) program to invoke (via EXT:RUN-PROGRAM) to do printing. + The program should act like lpr: if a filename is given as an argument, + it should print that file, and if no name appears, standard input should + be assumed." + :value "lpr") + +(defhvar "Print Utility Switches" + "Switches to pass to the \"Print Utility\" program. This should be a list + of strings." + :value ()) + + +;;; PRINT-SOMETHING calls RUN-PROGRAM on the utility-name and args. Output +;;; and error output are done to the echo area, and errors are ignored for +;;; now. Run-program-keys are other keywords to pass to RUN-PROGRAM in +;;; addition to :wait, :output, and :error. +;;; +(defmacro print-something (&optional (run-program-keys) + (utility-name '(value print-utility)) + (args '(value print-utility-switches))) + (let ((pid (gensym)) + (error-code (gensym))) + `(multiple-value-bind (,pid ,error-code) + (ext:run-program ,utility-name ,args + ,@run-program-keys + :wait t + :output *echo-area-stream* + :error *echo-area-stream*) + (declare (ignore ,pid ,error-code)) + (force-output *echo-area-stream*) + ;; Keep the echo area from being cleared at the top of the command loop. + (setf (buffer-modified *echo-area-buffer*) nil)))) + + +;;; PRINT-REGION -- Interface +;;; +;;; Takes a region and outputs the text to the program defined by +;;; the hvar "Print Utility" with options form the hvar "Print +;;; Utility Options" using PRINT-SOMETHING. +;;; +(defun print-region (region) + (with-input-from-region (s region) + (print-something (:input s)))) + + +(defcommand "Print Buffer" (p) + "Prints the current buffer using the program defined by the hvar + \"Print Utility\" with the options from the hvar \"Print Utility + Options\". Errors appear in the echo area." + "Prints the contents of the buffer." + (declare (ignore p)) + (message "Printing buffer...~%") + (print-region (buffer-region (current-buffer)))) + +(defcommand "Print Region" (p) + "Prints the current region using the program defined by the hvar + \"Print Utility\" with the options from the hvar \"Print Utility + Options\". Errors appear in the echo area." + "Prints the current region." + (declare (ignore p)) + (message "Printing region...~%") + (print-region (current-region))) + +(defcommand "Print File" (p) + "Prompts for a file and prints it usings the program defined by + the hvar \"Print Utility\" with the options from the hvar \"Print + Utility Options\". Errors appear in the echo area." + "Prints a file." + (declare (ignore p)) + (let* ((pn (prompt-for-file :prompt "File to print: " + :help "Name of file to print." + :default (buffer-default-pathname (current-buffer)) + :must-exist t)) + (ns (namestring (truename pn)))) + (message "Printing file...~%") + (print-something () (value print-utility) + (append (value print-utility-switches) (list ns))))) + + + +;;;; Scribe. + +(defcommand "Scribe File" (p) + "Scribe a file with the default directory set to the directory of the + specified file. The output from running Scribe is sent to the + \"Scribe Warnings\" buffer. See \"Scribe Utility\" and \"Scribe Utility + Switches\"." + "Scribe a file with the default directory set to the directory of the + specified file." + (declare (ignore p)) + (scribe-file (prompt-for-file :prompt "Scribe file: " + :default + (buffer-default-pathname (current-buffer))))) + +(defhvar "Scribe Buffer File Confirm" + "When set, \"Scribe Buffer File\" prompts for confirmation before doing + anything." + :value t) + +(defcommand "Scribe Buffer File" (p) + "Scribe the file associated with the current buffer. The default directory + set to the directory of the file. The output from running Scribe is sent to + the \"Scribe Warnings\" buffer. See \"Scribe Utility\" and \"Scribe Utility + Switches\". Before doing anything the user is asked to confirm saving and + Scribe'ing the file. This prompting can be inhibited by with \"Scribe Buffer + File Confirm\"." + "Scribe a file with the default directory set to the directory of the + specified file." + (declare (ignore p)) + (let* ((buffer (current-buffer)) + (pathname (buffer-pathname buffer)) + (modified (buffer-modified buffer))) + (when (or (not (value scribe-buffer-file-confirm)) + (prompt-for-y-or-n + :default t :default-string "Y" + :prompt (list "~:[S~;Save and s~]cribe file ~A? " + modified (namestring pathname)))) + (when modified (write-buffer-file buffer pathname)) + (scribe-file pathname)))) + +(defhvar "Scribe Utility" + "Program name to invoke (via EXT:RUN-PROGRAM) to do text formatting." + :value "scribe") + +(defhvar "Scribe Utility Switches" + "Switches to pass to the \"Scribe Utility\" program. This should be a list + of strings." + :value ()) + +(defun scribe-file (pathname) + (let* ((pathname (truename pathname)) + (out-buffer (or (getstring "Scribe Warnings" *buffer-names*) + (make-buffer "Scribe Warnings"))) + (out-point (buffer-end (buffer-point out-buffer))) + (stream (make-hemlock-output-stream out-point :line)) + (orig-cwd (default-directory))) + (buffer-end out-point) + (insert-character out-point #\newline) + (insert-character out-point #\newline) + (unwind-protect + (progn + (setf (default-directory) (directory-namestring pathname)) + (ext:run-program (namestring (value scribe-utility)) + (list* (namestring pathname) + (value scribe-utility-switches)) + :output stream :error stream + :wait nil)) + (setf (default-directory) orig-cwd)))) + + + +;;;; UNIX Filter Region + +(defcommand "Unix Filter Region" (p) + "Unix Filter Region prompts for a UNIX program and then passes the current + region to the program as standard input. The standard output from the + program is used to replace the region. This command is undo-able." + "UNIX-FILTER-REGION-COMMAND is not intended to be called from normal + Hemlock commands; use UNIX-FILTER-REGION instead." + (declare (ignore p)) + (let* ((region (current-region)) + (filter-and-args (prompt-for-string + :prompt "Filter: " + :help "Unix program to filter the region through.")) + (filter-and-args-list (listify-unix-filter-string filter-and-args)) + (filter (car filter-and-args-list)) + (args (cdr filter-and-args-list)) + (new-region (unix-filter-region region filter args)) + (start (copy-mark (region-start region) :right-inserting)) + (end (copy-mark (region-end region) :left-inserting)) + (old-region (region start end)) + (undo-region (delete-and-save-region old-region))) + (ninsert-region end new-region) + (make-region-undo :twiddle "Unix Filter Region" old-region undo-region))) + +(defun unix-filter-region (region command args) + "Passes the region REGION as standard input to the program COMMAND + with arguments ARGS and returns the standard output as a freshly + cons'ed region." + (let ((new-region (make-empty-region))) + (with-input-from-region (input region) + (with-output-to-mark (output (region-end new-region) :full) + (ext:run-program command args + :input input + :output output + :error output))) + new-region)) + +(defun listify-unix-filter-string (str) + (declare (simple-string str)) + (let ((result nil) + (lastpos 0)) + (loop + (let ((pos (position #\Space str :start lastpos :test #'char=))) + (push (subseq str lastpos pos) result) + (unless pos + (return)) + (setf lastpos (1+ pos)))) + (nreverse result))) + + + + +;;;; Man pages. + +(defcommand "Manual Page" (p) + "Read the Unix manual pages in a View buffer. + If given an argument, this will put the man page in a Pop-up display." + "Read the Unix manual pages in a View buffer. + If given an argument, this will put the man page in a Pop-up display." + (let ((topic (prompt-for-string :prompt "Man topic: "))) + (if p + (with-pop-up-display (stream) + (execute-man topic stream)) + (let* ((buf-name (format nil "Man Page ~a" topic)) + (new-buffer (make-buffer buf-name :modes '("Fundamental" "View"))) + (buffer (or new-buffer (getstring buf-name *buffer-names*))) + (point (buffer-point buffer))) + (change-to-buffer buffer) + (when new-buffer + (setf (value view-return-function) #'(lambda ())) + (with-writable-buffer (buffer) + (with-output-to-mark (s point :full) + (execute-man topic s)))) + (buffer-start point buffer))))) + +(defun execute-man (topic stream) + (ext:run-program + "/bin/sh" + (list "-c" + (format nil "man ~a| ul -t adm3" topic)) + :output stream)) Index: /branches/ide-1.0/ccl/hemlock/src/archive/window.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/archive/window.lisp (revision 6567) +++ /branches/ide-1.0/ccl/hemlock/src/archive/window.lisp (revision 6567) @@ -0,0 +1,690 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; This file contains implementation independent code which implements +;;; the Hemlock window primitives and most of the code which defines +;;; other aspects of the interface to redisplay. +;;; +;;; Written by Bill Chiles and Rob MacLachlan. +;;; + +(in-package :hemlock-internals) + +(defconstant unaltered-bits #b000 + "This is the value of the dis-line-flags when a line is neither moved nor + changed nor new.") +(defconstant changed-bit #b001 + "This bit is set in the dis-line-flags when a line is found to be changed.") +(defconstant moved-bit #b010 + "This bit is set in the dis-line-flags when a line is found to be moved.") +(defconstant new-bit #b100 + "This bit is set in the dis-line-flags when a line is found to be new.") + + + +;;;; CURRENT-WINDOW. + +(defvar *current-window* nil "The current window object.") +(defvar *window-list* () "A list of all window objects.") + +(declaim (inline current-window)) + +(defun current-window () + "Return the current window. The current window is specially treated by + redisplay in several ways, the most important of which is that is does + recentering, ensuring that the Buffer-Point of the current window's + Window-Buffer is always displayed. This may be set with Setf." + *current-window*) + +(defun %set-current-window (new-window) + (invoke-hook hemlock::set-window-hook new-window) + (move-mark (window-point *current-window*) + (buffer-point (window-buffer *current-window*))) + (move-mark (buffer-point (window-buffer new-window)) + (window-point new-window)) + (setq *current-window* new-window)) + + + + +;;;; Window structure support. + +(defun %print-hwindow (obj stream depth) + (declare (ignore depth)) + (write-string "#" stream)) + + +(defun window-buffer (window) + "Return the buffer which is displayed in Window." + (window-%buffer window)) + +(defun %set-window-buffer (window new-buffer) + (unless (bufferp new-buffer) (error "~S is not a buffer." new-buffer)) + (unless (windowp window) (error "~S is not a window." window)) + (unless (eq new-buffer (window-buffer window)) + (invoke-hook hemlock::window-buffer-hook window new-buffer) + ;; + ;; Move the window's marks to the new start. + (let ((buffer (window-buffer window))) + (setf (buffer-windows buffer) (delete window (buffer-windows buffer))) + (move-mark (buffer-display-start buffer) (window-display-start window)) + (push window (buffer-windows new-buffer)) + (move-mark (window-point window) (buffer-point new-buffer)) + (move-mark (window-display-start window) (buffer-display-start new-buffer)) + (move-mark (window-display-end window) (buffer-display-start new-buffer))) + ;; + ;; Delete all the dis-lines, and nil out the line and chars so they get + ;; gc'ed. + (let ((first (window-first-line window)) + (last (window-last-line window)) + (free (window-spare-lines window))) + (unless (eq (cdr first) *the-sentinel*) + (shiftf (cdr last) free (cdr first) *the-sentinel*)) + (dolist (dl free) + (setf (dis-line-line dl) nil (dis-line-old-chars dl) nil)) + (setf (window-spare-lines window) free)) + ;; + ;; Set the last line and first&last changed so we know there's nothing there. + (setf (window-last-line window) *the-sentinel* + (window-first-changed window) *the-sentinel* + (window-last-changed window) *the-sentinel*) + ;; + ;; Make sure the window gets updated, and set the buffer. + (setf (window-tick window) -3) + (setf (window-%buffer window) new-buffer))) + + + + +;;; %INIT-REDISPLAY sets up redisplay's internal data structures. We create +;;; initial windows, setup some hooks to cause modeline recomputation, and call +;;; any device init necessary. This is called from ED. +;;; +(defun %init-redisplay (display) + (%init-screen-manager display) + (add-hook hemlock::buffer-major-mode-hook 'queue-buffer-change) + (add-hook hemlock::buffer-minor-mode-hook 'queue-buffer-change) + (add-hook hemlock::buffer-name-hook 'queue-buffer-change) + (add-hook hemlock::buffer-pathname-hook 'queue-buffer-change) + (add-hook hemlock::buffer-modified-hook 'queue-buffer-change) + (add-hook hemlock::window-buffer-hook 'queue-window-change) + (let ((device (device-hunk-device (window-hunk (current-window))))) + (funcall (device-init device) device)) + (center-window *current-window* (current-point))) + + + + +;;;; Modelines-field structure support. + +(defun print-modeline-field (obj stream ignore) + (declare (ignore ignore)) + (write-string "#" stream)) + +(defun print-modeline-field-info (obj stream ignore) + (declare (ignore ignore)) + (write-string "#" stream)) + + +(defvar *modeline-field-names* (make-hash-table)) + +(defun make-modeline-field (&key name width function) + "Returns a modeline-field object." + (unless (or (eq width nil) (and (integerp width) (plusp width))) + (error "Width must be nil or a positive integer.")) + (when (gethash name *modeline-field-names*) + (with-simple-restart (continue + "Use the new definition for this modeline field.") + (error "Modeline field ~S already exists." + (gethash name *modeline-field-names*)))) + (setf (gethash name *modeline-field-names*) + (%make-modeline-field name function width))) + +(defun modeline-field (name) + "Returns the modeline-field object named name. If none exists, return nil." + (gethash name *modeline-field-names*)) + + +(declaim (inline modeline-field-name modeline-field-width + modeline-field-function)) + +(defun modeline-field-name (ml-field) + "Returns the name of a modeline field object." + (modeline-field-%name ml-field)) + +(defun %set-modeline-field-name (ml-field name) + (check-type ml-field modeline-field) + (when (gethash name *modeline-field-names*) + (error "Modeline field ~S already exists." + (gethash name *modeline-field-names*))) + (remhash (modeline-field-%name ml-field) *modeline-field-names*) + (setf (modeline-field-%name ml-field) name) + (setf (gethash name *modeline-field-names*) ml-field)) + +(defun modeline-field-width (ml-field) + "Returns the width of a modeline field." + (modeline-field-%width ml-field)) + +(declaim (special *buffer-list*)) + +(defun %set-modeline-field-width (ml-field width) + (check-type ml-field modeline-field) + (unless (or (eq width nil) (and (integerp width) (plusp width))) + (error "Width must be nil or a positive integer.")) + (unless (eql width (modeline-field-%width ml-field)) + (setf (modeline-field-%width ml-field) width) + (dolist (b *buffer-list*) + (when (buffer-modeline-field-p b ml-field) + (dolist (w (buffer-windows b)) + (update-modeline-fields b w))))) + width) + +(defun modeline-field-function (ml-field) + "Returns the function of a modeline field object. It returns a string." + (modeline-field-%function ml-field)) + +(defun %set-modeline-field-function (ml-field function) + (check-type ml-field modeline-field) + (check-type function (or symbol function)) + (setf (modeline-field-%function ml-field) function) + (dolist (b *buffer-list*) + (when (buffer-modeline-field-p b ml-field) + (dolist (w (buffer-windows b)) + (update-modeline-field b w ml-field)))) + function) + + + + +;;;; Modelines maintenance. + +;;; Each window stores a modeline-buffer which is a string hunk-width-limit +;;; long. Whenever a field is updated, we must maintain a maximally long +;;; representation of the modeline in case the window is resized. Updating +;;; then first gets the modeline-buffer setup, and second blasts the necessary +;;; portion into the window's modeline-dis-line, setting the dis-line's changed +;;; flag. +;;; + +(defun update-modeline-fields (buffer window) + "Recompute all the fields of buffer's modeline for window, so the next + redisplay will reflect changes." + (let ((ml-buffer (window-modeline-buffer window))) + (declare (simple-string ml-buffer)) + (when ml-buffer + (let* ((ml-buffer-len + (do ((finfos (buffer-%modeline-fields buffer) (cdr finfos)) + (start 0 (blt-modeline-field-buffer + ml-buffer (car finfos) buffer window start))) + ((null finfos) start))) + (dis-line (window-modeline-dis-line window)) + (len (min (window-width window) ml-buffer-len))) + (replace (the simple-string (dis-line-chars dis-line)) ml-buffer + :end1 len :end2 len) + (setf (window-modeline-buffer-len window) ml-buffer-len) + (setf (dis-line-length dis-line) len) + (setf (dis-line-flags dis-line) changed-bit))))) + +;;; UPDATE-MODELINE-FIELD must replace the entire dis-line-chars with ml-buffer +;;; after blt'ing into buffer. Otherwise it has to do all the work +;;; BLT-MODELINE-FIELD-BUFFER to figure out how to adjust dis-line-chars. It +;;; isn't worth it. Since things could have shifted around, after calling +;;; BLT-MODELINE-FIELD-BUFFER, we get the last field's end to know how long +;;; the buffer is now. +;;; +(defun update-modeline-field (buffer window field) + "Recompute the field of the buffer's modeline for window, so the next + redisplay will reflect the change. Field is either a modeline-field object + or the name of one for buffer." + (let ((finfo (internal-buffer-modeline-field-p buffer field))) + (unless finfo + (error "~S is not a modeline-field or the name of one for buffer ~S." + field buffer)) + (let ((ml-buffer (window-modeline-buffer window)) + (dis-line (window-modeline-dis-line window))) + (declare (simple-string ml-buffer)) + (blt-modeline-field-buffer ml-buffer finfo buffer window + (ml-field-info-start finfo) t) + (let* ((ml-buffer-len (ml-field-info-end + (car (last (buffer-%modeline-fields buffer))))) + (dis-len (min (window-width window) ml-buffer-len))) + (replace (the simple-string (dis-line-chars dis-line)) ml-buffer + :end1 dis-len :end2 dis-len) + (setf (window-modeline-buffer-len window) ml-buffer-len) + (setf (dis-line-length dis-line) dis-len) + (setf (dis-line-flags dis-line) changed-bit))))) + +(defvar *truncated-field-char* #\!) + +;;; BLT-MODELINE-FIELD-BUFFER takes a Hemlock buffer, Hemlock window, the +;;; window's modeline buffer, a modeline-field-info object, a start in the +;;; modeline buffer, and an optional indicating whether a variable width field +;;; should be handled carefully. When the field is fixed-width, this is +;;; simple. When it is variable, we possibly have to shift all the text in the +;;; buffer right or left before storing the new string, updating all the +;;; finfo's after the one we're updating. It is an error for the +;;; modeline-field-function to return anything but a simple-string with +;;; standard-chars. This returns the end of the field blasted into ml-buffer. +;;; +(defun blt-modeline-field-buffer (ml-buffer finfo buffer window start + &optional fix-other-fields-p) + (declare (simple-string ml-buffer)) + (let* ((f (ml-field-info-field finfo)) + (width (modeline-field-width f)) + (string (funcall (modeline-field-function f) buffer window)) + (str-len (length string))) + (declare (simple-string string)) + (setf (ml-field-info-start finfo) start) + (setf (ml-field-info-end finfo) + (cond + ((not width) + (let ((end (min (+ start str-len) hunk-width-limit)) + (last-end (ml-field-info-end finfo))) + (when (and fix-other-fields-p (/= end last-end)) + (blt-ml-field-buffer-fix ml-buffer finfo buffer window + end last-end)) + (replace ml-buffer string :start1 start :end1 end :end2 str-len) + end)) + ((= str-len width) + (let ((end (min (+ start width) hunk-width-limit))) + (replace ml-buffer string :start1 start :end1 end :end2 width) + end)) + ((> str-len width) + (let* ((end (min (+ start width) hunk-width-limit)) + (end-1 (1- end))) + (replace ml-buffer string :start1 start :end1 end-1 :end2 width) + (setf (schar ml-buffer end-1) *truncated-field-char*) + end)) + (t + (let ((buf-replace-end (min (+ start str-len) hunk-width-limit)) + (buf-field-end (min (+ start width) hunk-width-limit))) + (replace ml-buffer string + :start1 start :end1 buf-replace-end :end2 str-len) + (fill ml-buffer #\space :start buf-replace-end :end buf-field-end) + buf-field-end)))))) + +;;; BLT-ML-FIELD-BUFFER-FIX shifts the contents of ml-buffer in the direction +;;; of last-end to end. finfo is a modeline-field-info structure in buffer's +;;; list of these. If there are none following finfo, then we simply store the +;;; new end of the buffer. After blt'ing the text around, we have to update +;;; all the finfos' starts and ends making sure nobody gets to stick out over +;;; the ml-buffer's end. +;;; +(defun blt-ml-field-buffer-fix (ml-buffer finfo buffer window end last-end) + (declare (simple-string ml-buffer)) + (let ((finfos (do ((f (buffer-%modeline-fields buffer) (cdr f))) + ((null f) (error "This field must be here.")) + (if (eq (car f) finfo) + (return (cdr f)))))) + (cond + ((not finfos) + (setf (window-modeline-buffer-len window) (min end hunk-width-limit))) + (t + (let ((buffer-len (window-modeline-buffer-len window))) + (replace ml-buffer ml-buffer + :start1 end + :end1 (min (+ end (- buffer-len last-end)) hunk-width-limit) + :start2 last-end :end2 buffer-len) + (let ((diff (- end last-end))) + (macrolet ((frob (f) + `(setf ,f (min (+ ,f diff) hunk-width-limit)))) + (dolist (f finfos) + (frob (ml-field-info-start f)) + (frob (ml-field-info-end f))) + (frob (window-modeline-buffer-len window))))))))) + + + + +;;;; Default modeline and update hooks. + +(make-modeline-field :name :hemlock-literal :width 8 + :function #'(lambda (buffer window) + "Returns \"Hemlock \"." + (declare (ignore buffer window)) + "Hemlock ")) + +(make-modeline-field + :name :package + :function #'(lambda (buffer window) + "Returns the value of buffer's \"Current Package\" followed + by a colon and two spaces, or a string with one space." + (declare (ignore window)) + (if (hemlock-bound-p 'hemlock::current-package :buffer buffer) + (let ((val (variable-value 'hemlock::current-package + :buffer buffer))) + (if val + (format nil "~A: " val) + " ")) + " "))) + +(make-modeline-field + :name :modes + :function #'(lambda (buffer window) + "Returns buffer's modes followed by one space." + (declare (ignore window)) + (format nil "~A " (buffer-modes buffer)))) + +(make-modeline-field + :name :modifiedp + :function #'(lambda (buffer window) + "Returns \"* \" if buffer is modified, or the empty string." + (declare (ignore window)) + (let ((modifiedp (buffer-modified buffer))) + (if modifiedp + "* " + "")))) + +(make-modeline-field + :name :buffer-name + :function #'(lambda (buffer window) + "Returns buffer's name followed by a colon and a space if the + name is not derived from the buffer's pathname, or the empty + string." + (declare (ignore window)) + (let ((pn (buffer-pathname buffer)) + (name (buffer-name buffer))) + (cond ((not pn) + (format nil "~A: " name)) + ((string/= (hemlock::pathname-to-buffer-name pn) name) + (format nil "~A: " name)) + (t ""))))) + + +;;; MAXIMUM-MODELINE-PATHNAME-LENGTH-HOOK is called whenever "Maximum Modeline +;;; Pathname Length" is set. +;;; +(defun maximum-modeline-pathname-length-hook (name kind where new-value) + (declare (ignore name new-value)) + (if (eq kind :buffer) + (hi::queue-buffer-change where) + (dolist (buffer *buffer-list*) + (when (and (buffer-modeline-field-p buffer :buffer-pathname) + (buffer-windows buffer)) + (hi::queue-buffer-change buffer))))) + +(defun buffer-pathname-ml-field-fun (buffer window) + "Returns the namestring of buffer's pathname if there is one. When + \"Maximum Modeline Pathname Length\" is set, and the namestring is too long, + return a truncated namestring chopping off leading directory specifications." + (declare (ignore window)) + (let ((pn (buffer-pathname buffer))) + (if pn + (let* ((name (namestring pn)) + (length (length name)) + ;; Prefer a buffer local value over the global one. + ;; Because variables don't work right, blow off looking for + ;; a value in the buffer's modes. In the future this will + ;; be able to get the "current" value as if buffer were current. + (max (if (hemlock-bound-p 'hemlock::maximum-modeline-pathname-length + :buffer buffer) + (variable-value 'hemlock::maximum-modeline-pathname-length + :buffer buffer) + (variable-value 'hemlock::maximum-modeline-pathname-length + :global)))) + (declare (simple-string name)) + (if (or (not max) (<= length max)) + name + (let* ((extra-chars (+ (- length max) 3)) + (slash (or (position #\/ name :start extra-chars) + ;; If no slash, then file-namestring is very + ;; long, and we should include all of it: + (position #\/ name :from-end t + :end extra-chars)))) + (if slash + (concatenate 'simple-string "..." (subseq name slash)) + name)))) + ""))) + +(make-modeline-field + :name :buffer-pathname + :function 'buffer-pathname-ml-field-fun) + + +(defvar *default-modeline-fields* + (list (modeline-field :hemlock-literal) + (modeline-field :package) + (modeline-field :modes) + (modeline-field :modifiedp) + (modeline-field :buffer-name) + (modeline-field :buffer-pathname)) + "This is the default value for \"Default Modeline Fields\".") + + + +;;; QUEUE-BUFFER-CHANGE is used for various buffer hooks (e.g., mode changes, +;;; name changes, etc.), so it takes some arguments to ignore. These hooks are +;;; invoked at a bad time to update the actual modeline-field, and user's may +;;; have fields that change as a function of the changes this function handles. +;;; This makes his update easier. It doesn't cost much update the entire line +;;; anyway. +;;; +(defun queue-buffer-change (buffer &optional something-else another-else) + (declare (ignore something-else another-else)) + (push (list #'update-modelines-for-buffer buffer) *things-to-do-once*)) + +(defun update-modelines-for-buffer (buffer) + (unless (eq buffer *echo-area-buffer*) + (dolist (w (buffer-windows buffer)) + (update-modeline-fields buffer w)))) + + +;;; QUEUE-WINDOW-CHANGE is used for the "Window Buffer Hook". We ignore the +;;; argument since this hook function is invoked before any changes are made, +;;; and the changes must be made before the fields can be set according to the +;;; window's buffer's properties. Therefore, we must queue the change to +;;; happen sometime before redisplay but after the change takes effect. +;;; +(defun queue-window-change (window &optional something-else) + (declare (ignore something-else)) + (push (list #'update-modeline-for-window window) *things-to-do-once*)) + +(defun update-modeline-for-window (window) + (update-modeline-fields (window-buffer window) window)) + + + + +;;;; Bitmap setting up new windows and modifying old. + +(defvar dummy-line (make-window-dis-line "") + "Dummy dis-line that we put at the head of window's dis-lines") +(setf (dis-line-position dummy-line) -1) + + +;;; WINDOW-FOR-HUNK makes a Hemlock window and sets up its dis-lines and marks +;;; to display starting at start. +;;; +(defun window-for-hunk (hunk start modelinep) + (check-type start mark) + (setf (bitmap-hunk-changed-handler hunk) #'window-changed) + (let ((buffer (line-buffer (mark-line start))) + (first (cons dummy-line *the-sentinel*)) + (width (bitmap-hunk-char-width hunk)) + (height (bitmap-hunk-char-height hunk))) + (when (or (< height minimum-window-lines) + (< width minimum-window-columns)) + (error "Window too small.")) + (unless buffer (error "Window start is not in a buffer.")) + (let ((window + (internal-make-window + :hunk hunk + :display-start (copy-mark start :right-inserting) + :old-start (copy-mark start :temporary) + :display-end (copy-mark start :right-inserting) + :%buffer buffer + :point (copy-mark (buffer-point buffer)) + :height height + :width width + :first-line first + :last-line *the-sentinel* + :first-changed *the-sentinel* + :last-changed first + :tick -1))) + (push window *window-list*) + (push window (buffer-windows buffer)) + ;; + ;; Make the dis-lines. + (do ((i (- height) (1+ i)) + (res () + (cons (make-window-dis-line (make-string width)) res))) + ((= i height) (setf (window-spare-lines window) res))) + ;; + ;; Make the image up to date. + (update-window-image window) + (setf (bitmap-hunk-start hunk) (cdr (window-first-line window))) + ;; + ;; If there is a modeline, set it up. + (when modelinep + (setup-modeline-image buffer window) + (setf (bitmap-hunk-modeline-dis-line hunk) + (window-modeline-dis-line window))) + window))) + +;;; SETUP-MODELINE-IMAGE sets up the modeline-dis-line for window using the +;;; modeline-fields list. This is used by tty redisplay too. +;;; +(defun setup-modeline-image (buffer window) + (setf (window-modeline-buffer window) (make-string hunk-width-limit)) + (setf (window-modeline-dis-line window) + (make-window-dis-line (make-string (window-width window)))) + (update-modeline-fields buffer window)) + +;;; Window-Changed -- Internal +;;; +;;; The bitmap-hunk changed handler for windows. This is only called if +;;; the hunk is not locked. We invalidate the window image and change its +;;; size, then do a full redisplay. +;;; +(defun window-changed (hunk) + (let ((window (bitmap-hunk-window hunk))) + ;; + ;; Nuke all the lines in the window image. + (unless (eq (cdr (window-first-line window)) *the-sentinel*) + (shiftf (cdr (window-last-line window)) + (window-spare-lines window) + (cdr (window-first-line window)) + *the-sentinel*)) + (setf (bitmap-hunk-start hunk) (cdr (window-first-line window))) + ;; + ;; Add some new spare lines if needed. If width is greater, + ;; reallocate the dis-line-chars. + (let* ((res (window-spare-lines window)) + (new-width (bitmap-hunk-char-width hunk)) + (new-height (bitmap-hunk-char-height hunk)) + (width (length (the simple-string (dis-line-chars (car res)))))) + (declare (list res)) + (when (> new-width width) + (setq width new-width) + (dolist (dl res) + (setf (dis-line-chars dl) (make-string new-width)))) + (setf (window-height window) new-height (window-width window) new-width) + (do ((i (- (* new-height 2) (length res)) (1- i))) + ((minusp i)) + (push (make-window-dis-line (make-string width)) res)) + (setf (window-spare-lines window) res) + ;; + ;; Force modeline update. + (let ((ml-buffer (window-modeline-buffer window))) + (when ml-buffer + (let ((dl (window-modeline-dis-line window)) + (chars (make-string new-width)) + (len (min new-width (window-modeline-buffer-len window)))) + (setf (dis-line-old-chars dl) nil) + (setf (dis-line-chars dl) chars) + (replace chars ml-buffer :end1 len :end2 len) + (setf (dis-line-length dl) len) + (setf (dis-line-flags dl) changed-bit))))) + ;; + ;; Prepare for redisplay. + (setf (window-tick window) (tick)) + (update-window-image window) + (when (eq window *current-window*) (maybe-recenter-window window)) + hunk)) + + + + +;;; EDITOR-FINISH-OUTPUT is used to synch output to a window with the rest of the +;;; system. +;;; +(defun editor-finish-output (window) + (let* ((device (device-hunk-device (window-hunk window))) + (finish-output (device-finish-output device))) + (when finish-output + (funcall finish-output device window)))) + + + + +;;;; Tty setting up new windows and modifying old. + +;;; setup-window-image -- Internal +;;; +;;; Set up the dis-lines and marks for Window to display starting +;;; at Start. Height and Width are the number of lines and columns in +;;; the window. +;;; +(defun setup-window-image (start window height width) + (check-type start mark) + (let ((buffer (line-buffer (mark-line start))) + (first (cons dummy-line *the-sentinel*))) + (unless buffer (error "Window start is not in a buffer.")) + (setf (window-display-start window) (copy-mark start :right-inserting) + (window-old-start window) (copy-mark start :temporary) + (window-display-end window) (copy-mark start :right-inserting) + (window-%buffer window) buffer + (window-point window) (copy-mark (buffer-point buffer)) + (window-height window) height + (window-width window) width + (window-first-line window) first + (window-last-line window) *the-sentinel* + (window-first-changed window) *the-sentinel* + (window-last-changed window) first + (window-tick window) -1) + (push window *window-list*) + (push window (buffer-windows buffer)) + ;; + ;; Make the dis-lines. + (do ((i (- height) (1+ i)) + (res () + (cons (make-window-dis-line (make-string width)) res))) + ((= i height) (setf (window-spare-lines window) res))) + ;; + ;; Make the image up to date. + (update-window-image window))) + +;;; change-window-image-height -- Internal +;;; +;;; Milkshake. +;;; +(defun change-window-image-height (window new-height) + ;; Nuke all the lines in the window image. + (unless (eq (cdr (window-first-line window)) *the-sentinel*) + (shiftf (cdr (window-last-line window)) + (window-spare-lines window) + (cdr (window-first-line window)) + *the-sentinel*)) + ;; Add some new spare lines if needed. + (let* ((res (window-spare-lines window)) + (width (length (the simple-string (dis-line-chars (car res)))))) + (declare (list res)) + (setf (window-height window) new-height) + (do ((i (- (* new-height 2) (length res)) (1- i))) + ((minusp i)) + (push (make-window-dis-line (make-string width)) res)) + (setf (window-spare-lines window) res))) Index: /branches/ide-1.0/ccl/hemlock/src/archive/winimage.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/archive/winimage.lisp (revision 6567) +++ /branches/ide-1.0/ccl/hemlock/src/archive/winimage.lisp (revision 6567) @@ -0,0 +1,327 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Written by Rob MacLachlan +;;; +;;; This file contains implementation independant functions that +;;; build window images from the buffer structure. +;;; +(in-package :hemlock-internals) + +(defvar *the-sentinel* + (list (make-window-dis-line "")) + "This dis-line, which has several interesting properties, is used to end + lists of dis-lines.") +(setf (dis-line-line (car *the-sentinel*)) + (make-line :number most-positive-fixnum :chars "")) +(setf (dis-line-position (car *the-sentinel*)) most-positive-fixnum) +(setf (dis-line-old-chars (car *the-sentinel*)) :unique-thing) + + + + + +;;; move-lines -- Internal +;;; +;;; This function is called by Maybe-Change-Window when it believes that +;;; a line needs to be inserted or deleted. When called it finishes the +;;; image-update for the entire rest of the window. Here and many other +;;; places the phrase "dis-line" is often used to mean a pointer into the +;;; window's list of dis-lines. +;;; +;;; Window - The window whose image needs to be updated. +;;; Changed - True if the first-changed line has already been set, if false +;;; we must set it. +;;; String - The overhang string to be added to the beginning of the first +;;; line image we build. If no overhang then this is NIL. +;;; Underhang - The number of trailing chars of String to use. +;;; Line - The line at which we are to continue building the image. This +;;; may be NIL, in which case we are at the end of the buffer. +;;; Offset - The charpos within Line to continue at. +;;; Current - The dis-line which caused Maybe-Change-Window to choke; it +;;; may be *the-sentinel*, it may not be the dummy line at head of the +;;; window's dis-lines. This is the dis-line at which Maybe-Change-Window +;;; turns over control, it should not be one whose image it built. +;;; Trail - This is the dis-line which immediately precedes Current in the +;;; dis-line list. It may be the dummy dis-line, it may not be the sentinel. +;;; Width - (window-width window) +(defun move-lines (window changed string underhang line offset trail current + width) + + (do* ((delta 0) + (cc (car current)) + (old-line (dis-line-line cc)) + ;; Can't use current, since might be *the-sentinel*. + (pos (1+ (dis-line-position (car trail)))) + ;; Are we on an extension line? + (is-wrapped (eq line (dis-line-line (car trail)))) + (last (window-last-line window)) + (last-line (dis-line-line (car last))) + (save trail) + (height (window-height window)) + (spare-lines (window-spare-lines window)) + ;; Make *the-sentinel* in this buffer so we don't delete it. + (buffer (setf (line-%buffer (dis-line-line (car *the-sentinel*))) + (window-buffer window))) + (start offset) new-num) + ((or (= pos height) (null line)) + ;; If we have run off the bottom or run out of lines then we are + ;; done. At this point Trail is the last line displayed and Current is + ;; whatever comes after it, possibly *the-sentinel*. + ;; We always say that last-changed is the last line so that we + ;; don't have to max in the old last-changed. + (setf (window-last-changed window) trail) + ;; If there are extra lines at the end that need to be deleted + ;; and haven't been already then link them into the free-list. + (unless (eq last trail) + ;; This test works, because if the old last line was either + ;; deleted or another line was inserted after it then it's + ;; cdr would be something else. + (when (eq (cdr last) *the-sentinel*) + (shiftf (cdr last) spare-lines (cdr trail) *the-sentinel*)) + (setf (window-last-line window) trail)) + (setf (window-spare-lines window) spare-lines) + ;; If first-changed has not been set then we set the first-changed + ;; to the first line we looked at if it does not come after the + ;; new position of the old first-changed. + (unless changed + (when (> (dis-line-position (car (window-first-changed window))) + (dis-line-position (car save))) + (setf (window-first-changed window) (cdr save))))) + + (setq new-num (line-number line)) + ;; If a line has been deleted, it's line-%buffer is smashed; we unlink + ;; any dis-line which displayed such a line. + (cond + ((neq (line-%buffer old-line) buffer) + (do ((ptr (cdr current) (cdr ptr)) + (prev current ptr)) + ((eq (line-%buffer (dis-line-line (car ptr))) buffer) + (setq delta (- pos (1+ (dis-line-position (car prev))))) + (shiftf (cdr trail) (cdr prev) spare-lines current ptr))) + (setq cc (car current) old-line (dis-line-line cc))) + ;; If the line-number of the old line is less than the line-number + ;; of the line we want to display then the old line must be off the top + ;; of the screen - delete it. *The-Sentinel* fails this test because + ;; it's line-number is most-positive-fixnum. + ((< (line-number old-line) new-num) + (do ((ptr (cdr current) (cdr ptr)) + (prev current ptr)) + ((>= (line-number (dis-line-line (car ptr))) new-num) + (setq delta (- pos (1+ (dis-line-position (car prev))))) + (shiftf (cdr trail) (cdr prev) spare-lines current ptr))) + (setq cc (car current) old-line (dis-line-line cc))) + ;; New line comes before old line, insert it, punting when + ;; we hit the bottom of the screen. + ((neq line old-line) + (do ((chars (unless is-wrapped (line-%chars line)) nil) new) + (()) + (setq new (car spare-lines)) + (setf (dis-line-old-chars new) chars + (dis-line-position new) pos + (dis-line-line new) line + (dis-line-delta new) 0 + (dis-line-flags new) new-bit) + (setq pos (1+ pos) delta (1+ delta)) + (multiple-value-setq (string underhang start) + (compute-line-image string underhang line start new width)) + (rotatef (cdr trail) spare-lines (cdr spare-lines)) + (setq trail (cdr trail)) + (cond ((= pos height) + (return nil)) + ((null underhang) + (setq start 0 line (line-next line)) + (return nil)))) + (setq is-wrapped nil)) + ;; The line is the same, possibly moved. We add in the delta and + ;; or in the moved bit so that if redisplay punts in the middle + ;; the information is not lost. + ((eq (line-%chars line) (dis-line-old-chars cc)) + ;; If the line is the old bottom line on the screen and it has moved and + ;; is full length, then mash the old-chars and quit so that the image + ;; will be recomputed the next time around the loop, since the line might + ;; have been wrapped off the bottom of the screen. + (cond + ((and (eq line last-line) + (= (dis-line-length cc) width) + (not (zerop delta))) + (setf (dis-line-old-chars cc) :another-unique-thing)) + (t + (do () + ((= pos height)) + (unless (zerop delta) + (setf (dis-line-position cc) pos) + (incf (dis-line-delta cc) delta) + (setf (dis-line-flags cc) (logior (dis-line-flags cc) moved-bit))) + (shiftf trail current (cdr current)) + (setq cc (car current) old-line (dis-line-line cc) pos (1+ pos)) + (when (not (eq old-line line)) + (setq start 0 line (line-next line)) + (return nil)))))) + ;; The line is changed, possibly moved. + (t + (do ((chars (line-%chars line) nil)) + (()) + (multiple-value-setq (string underhang start) + (compute-line-image string underhang line start cc width)) + (setf (dis-line-flags cc) (logior (dis-line-flags cc) changed-bit) + (dis-line-old-chars cc) chars + (dis-line-position cc) pos) + (unless (zerop delta) + (incf (dis-line-delta cc) delta) + (setf (dis-line-flags cc) (logior (dis-line-flags cc) moved-bit))) + (shiftf trail current (cdr current)) + (setq cc (car current) old-line (dis-line-line cc) pos (1+ pos)) + (cond ((= pos height) + (return nil)) + ((null underhang) + (setq start 0 line (line-next line)) + (return nil)) + ((not (eq old-line line)) + (setq is-wrapped t) + (return nil)))))))) + + + +;;; maybe-change-window -- Internal +;;; +;;; This macro is "Called" in update-window-image whenever it finds that +;;; the chars of the line and the dis-line don't match. This may happen for +;;; several reasons: +;;; +;;; 1] The previous line was unchanged, but wrapped, so the dis-line-chars +;;; are nil. In this case we just skip over the extension lines. +;;; +;;; 2] A line is changed but not moved; update the line noting whether the +;;; next line is moved because of this, and bugging out to Move-Lines if +;;; it is. +;;; +;;; 3] A line is deleted, off the top of the screen, or moved. Bug out +;;; to Move-Lines. +;;; +;;; There are two possible results, either we return NIL, and Line, +;;; Trail and Current are updated, or we return T, in which case +;;; Update-Window-Image should terminate immediately. Changed is true +;;; if a changed line changed lines has been found. +;;; +(eval-when (:compile-toplevel :execute) +(defmacro maybe-change-window (window changed line offset trail current width) + `(let* ((cc (car ,current)) + (old-line (dis-line-line cc))) + (cond + ;; We have run into a continuation line, skip over any. + ((and (null (dis-line-old-chars cc)) + (eq old-line (dis-line-line (car ,trail)))) + (do ((ptr (cdr ,current) (cdr ptr)) + (prev ,current ptr)) + ((not (eq (dis-line-line (car ptr)) old-line)) + (setq ,trail prev ,current ptr) nil))) + ;; A line is changed. + ((eq old-line ,line) + (unless ,changed + (when (< (dis-line-position cc) + (dis-line-position (car (window-first-changed ,window)))) + (setf (window-first-changed ,window) ,current) + (setq ,changed t))) + (do ((chars (line-%chars ,line) nil) + (start ,offset) string underhang) + (()) + (multiple-value-setq (string underhang start) + (compute-line-image string underhang ,line start cc ,width)) + (setf (dis-line-flags cc) (logior (dis-line-flags cc) changed-bit)) + (setf (dis-line-old-chars cc) chars) + (setq ,trail ,current ,current (cdr ,current) cc (car ,current)) + (cond + ((eq (dis-line-line cc) ,line) + (unless underhang + (move-lines ,window t nil 0 (line-next ,line) 0 ,trail ,current + ,width) + (return t))) + (underhang + (move-lines ,window t string underhang ,line start ,trail + ,current ,width) + (return t)) + (t + (setq ,line (line-next ,line)) + (when (> (dis-line-position (car ,trail)) + (dis-line-position (car (window-last-changed ,window)))) + (setf (window-last-changed ,window) ,trail)) + (return nil))))) + (t + (move-lines ,window ,changed nil 0 ,line ,offset ,trail ,current + ,width) + t)))) +); eval-when + + +;;; update-window-image -- Internal +;;; +;;; This is the function which redisplay calls when it wants to ensure that +;;; a window-image is up-to-date. The main loop here is just to zoom through +;;; the lines and dis-lines, bugging out to Maybe-Change-Window whenever +;;; something interesting happens. +;;; +(defun update-window-image (window) + (let* ((trail (window-first-line window)) + (current (cdr trail)) + (display-start (window-display-start window)) + (line (mark-line display-start)) + (width (window-width window)) changed) + (cond + ;; If the first line or its charpos has changed then bug out. + ((cond ((and (eq (dis-line-old-chars (car current)) (line-%chars line)) + (mark= display-start (window-old-start window))) + (setq trail current current (cdr current) line (line-next line)) + nil) + (t + ;; Force the line image to be invalid in case the start moved + ;; and the line wrapped onto the screen. If we started at the + ;; beginning of the line then we don't need to. + (unless (zerop (mark-charpos (window-old-start window))) + (unless (eq current *the-sentinel*) + (setf (dis-line-old-chars (car current)) :another-unique-thing))) + (let ((start-charpos (mark-charpos display-start))) + (move-mark (window-old-start window) display-start) + (maybe-change-window window changed line start-charpos + trail current width))))) + (t + (prog () + (go TOP) + STEP + (setf (dis-line-line (car current)) line) + (setq trail current current (cdr current) line (line-next line)) + TOP + (cond ((null line) + (go DONE)) + ((eq (line-%chars line) (dis-line-old-chars (car current))) + (go STEP))) + ;; + ;; We found a suspect line. + ;; See if anything needs to be updated, if we bugged out, punt. + (when (and (eq current *the-sentinel*) + (= (dis-line-position (car trail)) + (1- (window-height window)))) + (return nil)) + (when (maybe-change-window window changed line 0 trail current width) + (return nil)) + (go TOP) + + DONE + ;; + ;; We hit the end of the buffer. If lines need to be deleted bug out. + (unless (eq current *the-sentinel*) + (maybe-change-window window changed line 0 trail current width)) + (return nil)))) + ;; + ;; Update the display-end mark. + (let ((dl (car (window-last-line window)))) + (move-to-position (window-display-end window) (dis-line-end dl) + (dis-line-line dl))))) Index: anches/ide-1.0/ccl/hemlock/src/bit-display.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/bit-display.lisp (revision 6566) +++ (revision ) @@ -1,292 +1,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- -;;; -;;; ********************************************************************** -;;; This code was written as part of the CMU Common Lisp project at -;;; Carnegie Mellon University, and has been placed in the public domain. -;;; -#+CMU (ext:file-comment - "$Header$") -;;; -;;; ********************************************************************** -;;; -;;; Written by Rob MacLachlan -;;; Modified by Bill Chiles to run under X on IBM RT's. -;;; - -(in-package :hemlock-internals) - - - -;;; prepare-window-for-redisplay -- Internal -;;; -;;; Called by make-window to do whatever redisplay wants to set up -;;; a new window. -;;; -(defun prepare-window-for-redisplay (window) - (setf (window-old-lines window) 0)) - - - - -;;;; Dumb window redisplay. - -;;; DUMB-WINDOW-REDISPLAY redraws an entire window using dumb-line-redisplay. -;;; This assumes the cursor has been lifted if necessary. -;;; -(defun dumb-window-redisplay (window) - (let* ((hunk (window-hunk window)) - (first (window-first-line window))) - (hunk-reset hunk) - (do ((i 0 (1+ i)) - (dl (cdr first) (cdr dl))) - ((eq dl *the-sentinel*) - (setf (window-old-lines window) (1- i))) - (dumb-line-redisplay hunk (car dl))) - (setf (window-first-changed window) *the-sentinel* - (window-last-changed window) first) - (when (window-modeline-buffer window) - (hunk-replace-modeline hunk) - (setf (dis-line-flags (window-modeline-dis-line window)) - unaltered-bits)) - (setf (bitmap-hunk-start hunk) (cdr (window-first-line window))))) - - -;;; DUMB-LINE-REDISPLAY is used when the line is known to be cleared already. -;;; -(defun dumb-line-redisplay (hunk dl) - (hunk-write-line hunk dl) - (setf (dis-line-flags dl) unaltered-bits (dis-line-delta dl) 0)) - - - - -;;;; Smart window redisplay. - -;;; We scan through the changed dis-lines, and condense the information -;;; obtained into five categories: Unchanged lines moved down, unchanged -;;; lines moved up, lines that need to be cleared, lines that are in the -;;; same place (but changed), and new or moved-and-changed lines to write. -;;; Each such instance of a thing that needs to be done is remembered be -;;; throwing needed information on a stack specific to the thing to be -;;; done. We cannot do any of these things right away because each may -;;; confict with the previous. -;;; -;;; Each stack is represented by a simple-vector big enough to hold the -;;; worst-case number of entries and a pointer to the next free entry. The -;;; pointers are local variables returned from COMPUTE-CHANGES and used by -;;; SMART-WINDOW-REDISPLAY. Note that the order specified in these tuples -;;; is the order in which they were pushed. -;;; -(defvar *display-down-move-stack* (make-array (* hunk-height-limit 2)) - "This is the vector that we stash info about which lines moved down in - as (Start, End, Count) triples.") -(defvar *display-up-move-stack* (make-array (* hunk-height-limit 2)) - "This is the vector that we stash info about which lines moved up in - as (Start, End, Count) triples.") -(defvar *display-erase-stack* (make-array hunk-height-limit) - "This is the vector that we stash info about which lines need to be erased - as (Start, Count) pairs.") -(defvar *display-write-stack* (make-array hunk-height-limit) - "This is the vector that we stash dis-lines in that need to be written.") -(defvar *display-rewrite-stack* (make-array hunk-height-limit) - "This is the vector that we stash dis-lines in that need to be written. - with clear-to-end.") - -;;; Accessor macros to push and pop on the stacks: -;;; -(eval-when (:compile-toplevel :execute) - -(defmacro spush (thing stack stack-pointer) - `(progn - (setf (svref ,stack ,stack-pointer) ,thing) - (incf ,stack-pointer))) - -(defmacro spop (stack stack-pointer) - `(svref ,stack (decf ,stack-pointer))) - -(defmacro snext (stack stack-pointer) - `(prog1 (svref ,stack ,stack-pointer) (incf ,stack-pointer))) - -); eval-when - - -;;; SMART-WINDOW-REDISPLAY only re-writes lines which may have been changed, -;;; and updates them with smart-line-redisplay if not very much has changed. -;;; Lines which have moved are copied. We must be careful not to redisplay -;;; the window with the cursor down since it is not guaranteed to be out of -;;; the way just because we are in redisplay; LIFT-CURSOR is called just before -;;; the screen may be altered, and it takes care to know whether the cursor -;;; is lifted already or not. At the end, if the cursor had been down, -;;; DROP-CURSOR puts it back; it doesn't matter if LIFT-CURSOR was never called -;;; since it does nothing if the cursor is already down. -;;; -(defun smart-window-redisplay (window) - ;; This isn't actually called --GB - (let* ((hunk (window-hunk window)) - (liftp (and (eq *cursor-hunk* hunk) *cursor-dropped*))) - (when (bitmap-hunk-trashed hunk) - (when liftp (lift-cursor)) - (dumb-window-redisplay window) - (when liftp (drop-cursor)) - (return-from smart-window-redisplay nil)) - (let ((first-changed (window-first-changed window)) - (last-changed (window-last-changed window))) - ;; Is there anything to do? - (unless (eq first-changed *the-sentinel*) - (when liftp (lift-cursor)) - (if (and (eq first-changed last-changed) - (zerop (dis-line-delta (car first-changed)))) - ;; One line changed. - (smart-line-redisplay hunk (car first-changed)) - ;; More than one line changed. - (multiple-value-bind (up down erase write rewrite) - (compute-changes first-changed last-changed) - (do-down-moves hunk down) - (do-up-moves hunk up) - (do-erases hunk erase) - (do-writes hunk write) - (do-rewrites hunk rewrite))) - ;; Set the bounds so we know we displayed... - (setf (window-first-changed window) *the-sentinel* - (window-last-changed window) (window-first-line window)))) - ;; - ;; Clear any extra lines at the end of the window. - (let ((pos (dis-line-position (car (window-last-line window))))) - (when (< pos (window-old-lines window)) - (when liftp (lift-cursor)) - (hunk-clear-lines hunk (1+ pos) (- (window-height window) pos 1))) - (setf (window-old-lines window) pos)) - ;; - ;; Update the modeline if needed. - (when (window-modeline-buffer window) - (when (/= (dis-line-flags (window-modeline-dis-line window)) - unaltered-bits) - (hunk-replace-modeline hunk) - (setf (dis-line-flags (window-modeline-dis-line window)) - unaltered-bits))) - ;; - (setf (bitmap-hunk-start hunk) (cdr (window-first-line window))) - (when liftp (drop-cursor)))) - -;;; COMPUTE-CHANGES is used once in smart-window-redisplay, and it scans -;;; through the changed dis-lines in a window, computes the changes needed -;;; to bring the screen into corespondence, and throws the information -;;; needed to do the change onto the apropriate stack. The pointers into -;;; the stacks (up, down, erase, write, and rewrite) are returned. -;;; -;;; The algorithm is as follows: -;;; 1] If the line is moved-and-changed or new then throw the line on -;;; the write stack and increment the clear count. Repeat until no more -;;; such lines are found. -;;; 2] If the line is moved then flush any pending clear, find how many -;;; consecutive lines are moved the same amount, and put the numbers -;;; on the correct move stack. -;;; 3] If the line is changed and unmoved throw it on a write stack. -;;; If a clear is pending throw it in the write stack and bump the clear -;;; count, otherwise throw it on the rewrite stack. -;;; 4] The line is unchanged, do nothing. -;;; -(defun compute-changes (first-changed last-changed) - (let* ((dl first-changed) - (flags (dis-line-flags (car dl))) - (up 0) (down 0) (erase 0) (write 0) (rewrite 0) ;return values. - (clear-count 0) - prev clear-start) - (declare (fixnum up down erase write rewrite clear-count)) - (loop - (cond - ;; Line moved-and-changed or new. - ((> flags moved-bit) - (when (zerop clear-count) - (setq clear-start (dis-line-position (car dl)))) - (loop - (setf (dis-line-delta (car dl)) 0) - (spush (car dl) *display-write-stack* write) - (incf clear-count) - (setq prev dl dl (cdr dl) flags (dis-line-flags (car dl))) - (when (<= flags moved-bit) (return nil)))) - ;; Line moved, unchanged. - ((= flags moved-bit) - (unless (zerop clear-count) - (spush clear-count *display-erase-stack* erase) - (spush clear-start *display-erase-stack* erase) - (setq clear-count 0)) - (do ((delta (dis-line-delta (car dl))) - (end (dis-line-position (car dl))) - (count 1 (1+ count))) - (()) - (setf (dis-line-delta (car dl)) 0 - (dis-line-flags (car dl)) unaltered-bits) - (setq prev dl dl (cdr dl) flags (dis-line-flags (car dl))) - (when (or (/= (dis-line-delta (car dl)) delta) (/= flags moved-bit)) - ;; We push in different order because we pop in different order. - (cond - ((minusp delta) - (spush (- end delta) *display-up-move-stack* up) - (spush end *display-up-move-stack* up) - (spush count *display-up-move-stack* up)) - (t - (spush count *display-down-move-stack* down) - (spush end *display-down-move-stack* down) - (spush (- end delta) *display-down-move-stack* down))) - (return nil)))) - ;; Line changed, unmoved. - ((= flags changed-bit) - (cond ((zerop clear-count) - (spush (car dl) *display-rewrite-stack* rewrite)) - (t - (spush (car dl) *display-write-stack* write) - (incf clear-count))) - (setq prev dl dl (cdr dl) flags (dis-line-flags (car dl)))) - ;; Line unmoved, unchanged. - (t - (unless (zerop clear-count) - (spush clear-count *display-erase-stack* erase) - (spush clear-start *display-erase-stack* erase) - (setq clear-count 0)) - (setq prev dl dl (cdr dl) flags (dis-line-flags (car dl))))) - - (when (eq prev last-changed) - ;; If done flush any pending clear. - (unless (zerop clear-count) - (spush clear-count *display-erase-stack* erase) - (spush clear-start *display-erase-stack* erase)) - (return (values up down erase write rewrite)))))) - -(defun do-up-moves (hunk up) - (do ((i 0)) - ((= i up)) - (hunk-copy-lines hunk (snext *display-up-move-stack* i) - (snext *display-up-move-stack* i) - (snext *display-up-move-stack* i)))) - -(defun do-down-moves (hunk down) - (do () - ((zerop down)) - (hunk-copy-lines hunk (spop *display-down-move-stack* down) - (spop *display-down-move-stack* down) - (spop *display-down-move-stack* down)))) - -(defun do-erases (hunk erase) - (do () - ((zerop erase)) - (hunk-clear-lines hunk (spop *display-erase-stack* erase) - (spop *display-erase-stack* erase)))) - -(defun do-writes (hunk write) - (do ((i 0)) - ((= i write)) - (dumb-line-redisplay hunk (snext *display-write-stack* i)))) - -(defun do-rewrites (hunk rewrite) - (do () - ((zerop rewrite)) - (smart-line-redisplay hunk (spop *display-rewrite-stack* rewrite)))) - - -;;; SMART-LINE-REDISPLAY is called when the screen is mostly the same, -;;; clear to eol after we write it to avoid annoying flicker. -;;; -(defun smart-line-redisplay (hunk dl) - (hunk-replace-line hunk dl) - (setf (dis-line-flags dl) unaltered-bits (dis-line-delta dl) 0)) Index: anches/ide-1.0/ccl/hemlock/src/bit-screen.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/bit-screen.lisp (revision 6566) +++ (revision ) @@ -1,1873 +1,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- -;;; -;;; ********************************************************************** -;;; This code was written as part of the CMU Common Lisp project at -;;; Carnegie Mellon University, and has been placed in the public domain. -;;; -#+CMU (ext:file-comment - "$Header$") -;;; -;;; ********************************************************************** -;;; -;;; Screen allocation functions. -;;; -;;; This is the screen management and event handlers for Hemlock under X. -;;; -;;; Written by Bill Chiles, Rob MacLachlan, and Blaine Burks. -;;; - -(in-package :hemlock-internals) - -(declaim (special *echo-area-window*)) - -;;; We have an internal notion of window groups on bitmap devices. Every -;;; Hemlock window has a hunk slot which holds a structure with information -;;; about physical real-estate on some device. Bitmap-hunks have an X window -;;; and a window-group. The X window is a child of the window-group's window. -;;; The echo area, pop-up display window, and the initial window are all in -;;; their own group. -;;; -;;; MAKE-WINDOW splits the current window which is some child window in a group. -;;; If the user supplied an X window, it becomes the parent window of some new -;;; group, and we make a child for the Hemlock window. If the user supplies -;;; ask-user, we prompt for a group/parent window. We link the hunks for -;;; NEXT-WINDOW and PREVIOUS-WINDOW only within a group, so the group maintains -;;; a stack of windows that always fill the entire group window. -;;; - -;;; This is the object set for Hemlock windows. All types of incoming -;;; X events on standard editing windows have the same handlers via this set. -;;; We also include the group/parent windows in here, but they only handle -;;; :configure-notify events. -;;; -(defvar *hemlock-windows* - #+clx - (hemlock-ext:make-object-set "Hemlock Windows" #'hemlock-ext:default-clx-event-handler)) - - - - -;;;; Some window making parameters. - -;;; These could be parameters, but they have to be set after the display is -;;; opened. These are set in INIT-BITMAP-SCREEN-MANAGER. - -(defvar *default-background-pixel* nil - "Default background color. It defaults to white.") - -(defvar *default-foreground-pixel* nil - "Default foreground color. It defaults to black.") - -(defvar *foreground-background-xor* nil - "The LOGXOR of *default-background-pixel* and *default-foreground-pixel*.") - -(defvar *default-border-pixmap* nil - "This is the default color of X window borders. It defaults to a - grey pattern.") - -(defvar *highlight-border-pixmap* nil - "This is the color of the border of the current window when the mouse - cursor is over any Hemlock window.") - - - - -;;;; Exposed region handling. - -;;; :exposure events are sent because we selected them. :graphics-exposure -;;; events are generated because of a slot in our graphics contexts. These are -;;; generated from using XLIB:COPY-AREA when the source could not be generated. -;;; Also, :no-exposure events are sent when a :graphics-exposure event could -;;; have been sent but wasn't. -;;; -#| -;;; This is an old handler that doesn't do anything clever about multiple -;;; exposures. -(defun hunk-exposed-region (hunk &key y height &allow-other-keys) - (if (bitmap-hunk-lock hunk) - (setf (bitmap-hunk-trashed hunk) t) - (let ((liftp (and (eq *cursor-hunk* hunk) *cursor-dropped*))) - (when liftp (lift-cursor)) - ;; (hunk-draw-top-border hunk) - (let* ((font-family (bitmap-hunk-font-family hunk)) - (font-height (font-family-height font-family)) - (co (font-family-cursor-y-offset font-family)) - (start (truncate (- y hunk-top-border) font-height)) - (end (ceiling (- (+ y height) hunk-top-border) font-height)) - (start-bit (+ (* start font-height) co hunk-top-border)) - (nheight (- (* (- end start) font-height) co)) - (end-line (bitmap-hunk-end hunk))) - (declare (fixnum font-height co start end start-bit nheight)) - (xlib:clear-area (bitmap-hunk-xwindow hunk) :x 0 :y start-bit - :width (bitmap-hunk-width hunk) :height nheight) - (do ((dl (bitmap-hunk-start hunk) (cdr dl)) - (i 0 (1+ i))) - ((or (eq dl end-line) (= i start)) - (do ((i i (1+ i)) - (dl dl (cdr dl))) - ((or (eq dl end-line) (= i end))) - (declare (fixnum i)) - (hunk-write-line hunk (car dl) i))) - (declare (fixnum i))) - (when (and (bitmap-hunk-modeline-pos hunk) - (>= (the fixnum (+ nheight start-bit)) - (the fixnum (bitmap-hunk-modeline-pos hunk)))) - (hunk-replace-modeline hunk))) - (when liftp (drop-cursor))))) -|# - -;;; HUNK-EXPOSED-REGION redisplays the appropriate rectangle from the hunk -;;; dis-lines. Don't do anything if the hunk is trashed since redisplay is -;;; probably about to fix everything; specifically, this keeps new windows -;;; from getting drawn twice (once for the exposure and once for being trashed). -;;; -;;; Exposure and graphics-exposure events pass in a different number of -;;; arguments, with some the same but in a different order, so we just bind -;;; and ignore foo, bar, baz, and quux. -;;; -#+clx -(defun hunk-exposed-region (hunk event-key event-window x y width height - foo bar &optional baz quux) - (declare (ignore event-key event-window x width foo bar baz quux)) - (unless (bitmap-hunk-trashed hunk) - (let ((liftp (and (eq *cursor-hunk* hunk) *cursor-dropped*)) - (display (bitmap-device-display (device-hunk-device hunk)))) - (when liftp (lift-cursor)) - (multiple-value-bind (y-peek height-peek) - (exposed-region-peek-event display - (bitmap-hunk-xwindow hunk)) - (if y-peek - (let ((n (coelesce-exposed-regions hunk display - y height y-peek height-peek))) - (write-n-exposed-regions hunk n)) - (write-one-exposed-region hunk y height))) - (xlib:display-force-output display) - (when liftp (drop-cursor))))) -;;; -#+clx (hemlock-ext:serve-exposure *hemlock-windows* #'hunk-exposed-region) -#+clx (hemlock-ext:serve-graphics-exposure *hemlock-windows* #'hunk-exposed-region) - - -;;; HUNK-NO-EXPOSURE handles this bullshit event that gets sent without its -;;; being requested. -;;; -(defun hunk-no-exposure (hunk event-key event-window major minor send-event-p) - (declare (ignore hunk event-key event-window major minor send-event-p)) - t) -;;; -#+clx (hemlock-ext:serve-no-exposure *hemlock-windows* #'hunk-no-exposure) - - -;;; EXPOSED-REGION-PEEK-EVENT returns the position and height of an :exposure -;;; or :graphics-exposure event on win if one exists. If there are none, then -;;; nil and nil are returned. -;;; -#+clx -(defun exposed-region-peek-event (display win) - (xlib:display-finish-output display) - (let ((result-y nil) - (result-height nil)) - (xlib:process-event - display :timeout 0 - :handler #'(lambda (&key event-key event-window window y height - &allow-other-keys) - (cond ((and (or (eq event-key :exposure) - (eq event-key :graphics-exposure)) - (or (eq event-window win) (eq window win))) - (setf result-y y) - (setf result-height height) - t) - (t nil)))) - (values result-y result-height))) - -;;; COELESCE-EXPOSED-REGIONS insert sorts exposed region events from the X -;;; input queue into *coelesce-buffer*. Then the regions are merged into the -;;; same number or fewer regions that are vertically distinct -;;; (non-overlapping). When this function is called, one event has already -;;; been popped from the queue, the first event that caused HUNK-EXPOSED-REGION -;;; to be called. That information is passed in as y1 and height1. There is -;;; a second event that also has already been popped from the queue, the -;;; event resulting from peeking for multiple "exposure" events. That info -;;; is passed in as y2 and height2. -;;; -(defun coelesce-exposed-regions (hunk display y1 height1 y2 height2) - (let ((len 0)) - (declare (fixnum len)) - ;; - ;; Insert sort the exposeevents as we pick them off the event queue. - (let* ((font-family (bitmap-hunk-font-family hunk)) - (font-height (font-family-height font-family)) - (co (font-family-cursor-y-offset font-family)) - (xwindow (bitmap-hunk-xwindow hunk))) - ;; - ;; Insert the region the exposedregion handler was called on. - (multiple-value-bind (start-line start-bit end-line expanded-height) - (exposed-region-bounds y1 height1 co font-height) - (setf len - (coelesce-buffer-insert start-bit start-line - expanded-height end-line len))) - ;; - ;; Peek for exposedregion events on xwindow, inserting them into - ;; the buffer. - (let ((y y2) - (height height2)) - (loop - (multiple-value-bind (start-line start-bit end-line expanded-height) - (exposed-region-bounds y height co font-height) - (setf len - (coelesce-buffer-insert start-bit start-line - expanded-height end-line len))) - (multiple-value-setq (y height) - (exposed-region-peek-event display xwindow)) - (unless y (return))))) - (coelesce-exposed-regions-merge len))) - -;;; *coelesce-buffer* is a vector of records used to sort exposure events on a -;;; single hunk, so we can merge them into fewer, larger regions of exposure. -;;; COELESCE-BUFFER-INSERT places elements in this buffer, and each element -;;; is referenced with COELESCE-BUFFER-ELT. Each element of the coelescing -;;; buffer has the following accessors defined: -;;; COELESCE-BUFFER-ELT-START in pixels. -;;; COELESCE-BUFFER-ELT-START-LINE in dis-lines. -;;; COELESCE-BUFFER-ELT-HEIGHT in pixels. -;;; COELESCE-BUFFER-ELT-END-LINE in dis-lines. -;;; These are used by COELESCE-BUFFER-INSERT, COELESCE-EXPOSED-REGIONS-MERGE, -;;; and WRITE-N-EXPOSED-REGIONS. - -(defvar *coelesce-buffer-fill-ptr* 25) -(defvar *coelesce-buffer* (make-array *coelesce-buffer-fill-ptr*)) -(dotimes (i *coelesce-buffer-fill-ptr*) - (setf (svref *coelesce-buffer* i) (make-array 4))) - -(defmacro coelesce-buffer-elt-start (elt) - `(svref ,elt 0)) -(defmacro coelesce-buffer-elt-start-line (elt) - `(svref ,elt 1)) -(defmacro coelesce-buffer-elt-height (elt) - `(svref ,elt 2)) -(defmacro coelesce-buffer-elt-end-line (elt) - `(svref ,elt 3)) -(defmacro coelesce-buffer-elt (i) - `(svref *coelesce-buffer* ,i)) - -;;; COELESCE-BUFFER-INSERT inserts an exposed region record into -;;; *coelesce-buffer* such that start is less than all successive -;;; elements. Returns the new length of the buffer. -;;; -(defun coelesce-buffer-insert (start start-line height end-line len) - (declare (fixnum start start-line height end-line len)) - ;; - ;; Add element if len is to fill pointer. If fill pointer is to buffer - ;; length, then grow buffer. - (when (= len (the fixnum *coelesce-buffer-fill-ptr*)) - (when (= (the fixnum *coelesce-buffer-fill-ptr*) - (the fixnum (length (the simple-vector *coelesce-buffer*)))) - (let ((new (make-array (ash (length (the simple-vector *coelesce-buffer*)) - 1)))) - (replace (the simple-vector new) (the simple-vector *coelesce-buffer*) - :end1 *coelesce-buffer-fill-ptr* - :end2 *coelesce-buffer-fill-ptr*) - (setf *coelesce-buffer* new))) - (setf (coelesce-buffer-elt len) (make-array 4)) - (incf *coelesce-buffer-fill-ptr*)) - ;; - ;; Find point to insert record: start, start-line, height, and end-line. - (do ((i 0 (1+ i))) - ((= i len) - ;; Start is greater than all previous starts. Add it to the end. - (let ((region (coelesce-buffer-elt len))) - (setf (coelesce-buffer-elt-start region) start) - (setf (coelesce-buffer-elt-start-line region) start-line) - (setf (coelesce-buffer-elt-height region) height) - (setf (coelesce-buffer-elt-end-line region) end-line))) - (declare (fixnum i)) - (when (< start (the fixnum - (coelesce-buffer-elt-start (coelesce-buffer-elt i)))) - ;; - ;; Insert new element at i, using storage allocated at element len. - (let ((last (coelesce-buffer-elt len))) - (setf (coelesce-buffer-elt-start last) start) - (setf (coelesce-buffer-elt-start-line last) start-line) - (setf (coelesce-buffer-elt-height last) height) - (setf (coelesce-buffer-elt-end-line last) end-line) - ;; - ;; Shift elements after i (inclusively) to the right. - (do ((j (1- len) (1- j)) - (k len j) - (terminus (1- i))) - ((= j terminus)) - (declare (fixnum j k terminus)) - (setf (coelesce-buffer-elt k) (coelesce-buffer-elt j))) - ;; - ;; Stash element to insert at i. - (setf (coelesce-buffer-elt i) last)) - (return))) - (1+ len)) - - -;;; COELESCE-EXPOSED-REGIONS-MERGE merges/coelesces the regions in -;;; *coelesce-buffer*. It takes the number of elements and returns the new -;;; number of elements. The regions are examined one at a time relative to -;;; the current one. The current region remains so, with next advancing -;;; through the buffer, until a next region is found that does not overlap -;;; and is not adjacent. When this happens, the current values are stored -;;; in the current region, and the buffer's element after the current element -;;; becomes current. The next element that was found not to be in contact -;;; the old current element is stored in the new current element by copying -;;; its values there. The buffer's elements always stay in place, and their -;;; storage is re-used. After this process which makes the next region be -;;; the current region, the next pointer is incremented. -;;; -(defun coelesce-exposed-regions-merge (len) - (let* ((current 0) - (next 1) - (current-region (coelesce-buffer-elt 0)) - (current-height (coelesce-buffer-elt-height current-region)) - (current-end-line (coelesce-buffer-elt-end-line current-region)) - (current-end-bit (+ (the fixnum - (coelesce-buffer-elt-start current-region)) - current-height))) - (declare (fixnum current next current-height - current-end-line current-end-bit)) - (loop - (let* ((next-region (coelesce-buffer-elt next)) - (next-start (coelesce-buffer-elt-start next-region)) - (next-height (coelesce-buffer-elt-height next-region)) - (next-end-bit (+ next-start next-height))) - (declare (fixnum next-start next-height next-end-bit)) - (cond ((<= next-start current-end-bit) - (let ((extra-height (- next-end-bit current-end-bit))) - (declare (fixnum extra-height)) - ;; Maybe the next region is contained in the current. - (when (plusp extra-height) - (incf current-height extra-height) - (setf current-end-bit next-end-bit) - (setf current-end-line - (coelesce-buffer-elt-end-line next-region))))) - (t - ;; - ;; Update current record since next does not overlap - ;; with current. - (setf (coelesce-buffer-elt-height current-region) - current-height) - (setf (coelesce-buffer-elt-end-line current-region) - current-end-line) - ;; - ;; Move to new distinct region, copying data from next region. - (incf current) - (setf current-region (coelesce-buffer-elt current)) - (setf (coelesce-buffer-elt-start current-region) next-start) - (setf (coelesce-buffer-elt-start-line current-region) - (coelesce-buffer-elt-start-line next-region)) - (setf current-height next-height) - (setf current-end-bit next-end-bit) - (setf current-end-line - (coelesce-buffer-elt-end-line next-region))))) - (incf next) - (when (= next len) - (setf (coelesce-buffer-elt-height current-region) current-height) - (setf (coelesce-buffer-elt-end-line current-region) current-end-line) - (return))) - (1+ current))) - -;;; EXPOSED-REGION-BOUNDS returns as multiple values the first line affected, -;;; the first possible bit affected (accounting for the cursor), the end line -;;; affected, and the height of the region. -;;; -(defun exposed-region-bounds (y height cursor-offset font-height) - (declare (fixnum y height cursor-offset font-height)) - (let* ((start (truncate (the fixnum (- y hunk-top-border)) - font-height)) - (end (ceiling (the fixnum (- (the fixnum (+ y height)) - hunk-top-border)) - font-height))) - (values - start - (+ (the fixnum (* start font-height)) cursor-offset hunk-top-border) - end - (- (the fixnum (* (the fixnum (- end start)) font-height)) - cursor-offset)))) - -#+clx -(defun write-n-exposed-regions (hunk n) - (declare (fixnum n)) - (let* (;; Loop constants. - (end-dl (bitmap-hunk-end hunk)) - (xwindow (bitmap-hunk-xwindow hunk)) - (hunk-width (bitmap-hunk-width hunk)) - ;; Loop variables. - (dl (bitmap-hunk-start hunk)) - (i 0) - (region (coelesce-buffer-elt 0)) - (start-line (coelesce-buffer-elt-start-line region)) - (start (coelesce-buffer-elt-start region)) - (height (coelesce-buffer-elt-height region)) - (end-line (coelesce-buffer-elt-end-line region)) - (region-idx 0)) - (declare (fixnum i start start-line height end-line region-idx)) - (loop - (xlib:clear-area xwindow :x 0 :y start :width hunk-width :height height) - ;; Find this regions first line. - (loop - (when (or (eq dl end-dl) (= i start-line)) - (return)) - (incf i) - (setf dl (cdr dl))) - ;; Write this region's lines. - (loop - (when (or (eq dl end-dl) (= i end-line)) - (return)) - (hunk-write-line hunk (car dl) i) - (incf i) - (setf dl (cdr dl))) - ;; Get next region unless we're done. - (when (= (incf region-idx) n) (return)) - (setf region (coelesce-buffer-elt region-idx)) - (setf start (coelesce-buffer-elt-start region)) - (setf start-line (coelesce-buffer-elt-start-line region)) - (setf height (coelesce-buffer-elt-height region)) - (setf end-line (coelesce-buffer-elt-end-line region))) - ;; - ;; Check for modeline exposure. - (setf region (coelesce-buffer-elt (1- n))) - (setf start (coelesce-buffer-elt-start region)) - (setf height (coelesce-buffer-elt-height region)) - (when (and (bitmap-hunk-modeline-pos hunk) - (> (+ start height) - (- (bitmap-hunk-modeline-pos hunk) - (bitmap-hunk-bottom-border hunk)))) - (hunk-replace-modeline hunk) - (hunk-draw-bottom-border hunk)))) - -#+clx -(defun write-one-exposed-region (hunk y height) - (let* ((font-family (bitmap-hunk-font-family hunk)) - (font-height (font-family-height font-family)) - (co (font-family-cursor-y-offset font-family)) - (start-line (truncate (- y hunk-top-border) font-height)) - (end-line (ceiling (- (+ y height) hunk-top-border) font-height)) - (start-bit (+ (* start-line font-height) co hunk-top-border)) - (nheight (- (* (- end-line start-line) font-height) co)) - (hunk-end-line (bitmap-hunk-end hunk))) - (declare (fixnum font-height co start-line end-line start-bit nheight)) - (xlib:clear-area (bitmap-hunk-xwindow hunk) :x 0 :y start-bit - :width (bitmap-hunk-width hunk) :height nheight) - (do ((dl (bitmap-hunk-start hunk) (cdr dl)) - (i 0 (1+ i))) - ((or (eq dl hunk-end-line) (= i start-line)) - (do ((i i (1+ i)) - (dl dl (cdr dl))) - ((or (eq dl hunk-end-line) (= i end-line))) - (declare (fixnum i)) - (hunk-write-line hunk (car dl) i))) - (declare (fixnum i))) - (when (and (bitmap-hunk-modeline-pos hunk) - (> (+ start-bit nheight) - (- (bitmap-hunk-modeline-pos hunk) - (bitmap-hunk-bottom-border hunk)))) - (hunk-replace-modeline hunk) - (hunk-draw-bottom-border hunk)))) - - - - -;;;; Resized window handling. - -;;; :configure-notify events are sent because we select :structure-notify. -;;; This buys us a lot of events we have to write dummy handlers to ignore. -;;; - -;;; HUNK-RECONFIGURED -- Internal. -;;; -;;; This must note that the hunk changed to prevent certain redisplay problems -;;; with recentering the window that caused bogus lines to be drawn after the -;;; actual visible text in the window. We must also indicate the hunk is -;;; trashed to eliminate exposure event handling that comes after resizing. -;;; This also causes a full redisplay on the window which is the easiest and -;;; generally best looking thing. -;;; -(defun hunk-reconfigured (object event-key event-window window x y width - height border-width above-sibling - override-redirect-p send-event-p) - (declare (ignore event-key event-window window x y border-width - above-sibling override-redirect-p send-event-p)) - (typecase object - (bitmap-hunk - (when (or (/= width (bitmap-hunk-width object)) - (/= height (bitmap-hunk-height object))) - (hunk-changed object width height nil) - ;; Under X11, don't redisplay since an exposure event is coming next. - (setf (bitmap-hunk-trashed object) t))) - (window-group - (let ((old-width (window-group-width object)) - (old-height (window-group-height object))) - (when (or (/= width old-width) (/= height old-height)) - (window-group-changed object width height)))))) -;;; -#+clx (hemlock-ext:serve-configure-notify *hemlock-windows* #'hunk-reconfigured) - - -;;; HUNK-IGNORE-EVENT ignores the following unrequested events. They all take -;;; at least five arguments, but then there are up to four more optional. -;;; -(defun hunk-ignore-event (hunk event-key event-window window one - &optional two three four five) - (declare (ignore hunk event-key event-window window one two three four five)) - t) -;;; -#+clx (hemlock-ext:serve-destroy-notify *hemlock-windows* #'hunk-ignore-event) -#+clx (hemlock-ext:serve-unmap-notify *hemlock-windows* #'hunk-ignore-event) -#+clx (hemlock-ext:serve-map-notify *hemlock-windows* #'hunk-ignore-event) -#+clx (hemlock-ext:serve-reparent-notify *hemlock-windows* #'hunk-ignore-event) -#+clx (hemlock-ext:serve-gravity-notify *hemlock-windows* #'hunk-ignore-event) -#+clx (hemlock-ext:serve-circulate-notify *hemlock-windows* #'hunk-ignore-event) -#+clx (hemlock-ext:serve-client-message *hemlock-windows* #'hunk-ignore-event) - - - -;;;; Interface to X input events. - -;;; HUNK-KEY-INPUT and HUNK-MOUSE-INPUT. -;;; Each key and mouse event is turned into a character via -;;; HEMLOCK-EXT:TRANSLATE-CHARACTER or HEMLOCK-EXT:TRANSLATE-MOUSE-CHARACTER, either of which -;;; may return nil. Nil is returned for input that is considered uninteresting -;;; input; for example, shift and control. -;;; - -(defun hunk-key-input (hunk event-key event-window root child same-screen-p x y - root-x root-y modifiers time key-code send-event-p) - (declare (ignore event-key event-window root child same-screen-p root-x - root-y time send-event-p)) - (hunk-process-input hunk - (hemlock-ext:translate-key-event - (bitmap-device-display (device-hunk-device hunk)) - key-code modifiers) - x y)) -;;; -#+clx (hemlock-ext:serve-key-press *hemlock-windows* #'hunk-key-input) - -(defun hunk-mouse-input (hunk event-key event-window root child same-screen-p x y - root-x root-y modifiers time key-code send-event-p) - (declare (ignore event-window root child same-screen-p root-x root-y - time send-event-p)) - (hunk-process-input hunk - (hemlock-ext:translate-mouse-key-event key-code modifiers - event-key) - x y)) -;;; -#+clx (hemlock-ext:serve-button-press *hemlock-windows* #'hunk-mouse-input) -#+clx (hemlock-ext:serve-button-release *hemlock-windows* #'hunk-mouse-input) - -(defun hunk-process-input (hunk char x y) - (when char - (let* ((font-family (bitmap-hunk-font-family hunk)) - (font-width (font-family-width font-family)) - (font-height (font-family-height font-family)) - (ml-pos (bitmap-hunk-modeline-pos hunk)) - (height (bitmap-hunk-height hunk)) - (width (bitmap-hunk-width hunk)) - (handler (bitmap-hunk-input-handler hunk)) - (char-width (bitmap-hunk-char-width hunk))) - (cond ((not (and (< -1 x width) (< -1 y height))) - (funcall handler hunk char nil nil)) - ((and ml-pos (> y (- ml-pos (bitmap-hunk-bottom-border hunk)))) - (funcall handler hunk char - ;; (/ width x) doesn't handle ends of thumb bar - ;; and eob right, so do a bunch of truncating. - (min (truncate x (truncate width char-width)) - (1- char-width)) - nil)) - (t - (let* ((cx (truncate (- x hunk-left-border) font-width)) - (temp (truncate (- y hunk-top-border) font-height)) - (char-height (bitmap-hunk-char-height hunk)) - ;; Extra bits below bottom line and above modeline and - ;; thumb bar are considered part of the bottom line since - ;; we have already picked off the y=nil case. - (cy (if (< temp char-height) temp (1- char-height)))) - (if (and (< -1 cx char-width) - (< -1 cy)) - (funcall handler hunk char cx cy) - (funcall handler hunk char nil nil)))))))) - - - - -;;;; Handling boundary crossing events. - -;;; Entering and leaving a window are handled basically the same except that it -;;; is possible to get an entering event under X without getting an exiting -;;; event; specifically, when the mouse is in a Hemlock window that is over -;;; another window, and someone buries the top window, Hemlock only gets an -;;; entering event on the lower window (no exiting event for the buried -;;; window). -;;; -;;; :enter-notify and :leave-notify events are sent because we select -;;; :enter-window and :leave-window events. -;;; - -#+clx -(defun hunk-mouse-entered (hunk event-key event-window root child same-screen-p - x y root-x root-y state time mode kind send-event-p) - (declare (ignore event-key event-window child root same-screen-p - x y root-x root-y state time mode kind send-event-p)) - (when (and *cursor-dropped* (not *hemlock-listener*)) - (cursor-invert-center)) - (setf *hemlock-listener* t) - (let ((current-hunk (window-hunk (current-window)))) - (unless (and *current-highlighted-border* - (eq *current-highlighted-border* current-hunk)) - (setf (xlib:window-border (window-group-xparent - (bitmap-hunk-window-group current-hunk))) - *highlight-border-pixmap*) - (xlib:display-force-output - (bitmap-device-display (device-hunk-device current-hunk))) - (setf *current-highlighted-border* current-hunk))) - (let ((window (bitmap-hunk-window hunk))) - (when window (invoke-hook hemlock::enter-window-hook window)))) -;;; -#+clx (hemlock-ext:serve-enter-notify *hemlock-windows* #'hunk-mouse-entered) - -#+clx -(defun hunk-mouse-left (hunk event-key event-window root child same-screen-p - x y root-x root-y state time mode kind send-event-p) - (declare (ignore event-key event-window child root same-screen-p - x y root-x root-y state time mode kind send-event-p)) - (setf *hemlock-listener* nil) - (when *cursor-dropped* (cursor-invert-center)) - (when *current-highlighted-border* - (setf (xlib:window-border (window-group-xparent - (bitmap-hunk-window-group - *current-highlighted-border*))) - *default-border-pixmap*) - (xlib:display-force-output - (bitmap-device-display (device-hunk-device *current-highlighted-border*))) - (setf *current-highlighted-border* nil)) - (let ((window (bitmap-hunk-window hunk))) - (when window (invoke-hook hemlock::exit-window-hook window)))) -;;; -#+clx (hemlock-ext:serve-leave-notify *hemlock-windows* #'hunk-mouse-left) - - - - -;;;; Making a Window. - -(defparameter minimum-window-height 100 - "If the window created by splitting a window would be shorter than this, - then we create an overlapped window the same size instead.") - -;;; The width must be that of a tab for the screen image builder, and the -;;; height must be one line (two with a modeline). -;;; -(defconstant minimum-window-lines 2 - "Windows must have at least this many lines.") -(defconstant minimum-window-columns 10 - "Windows must be at least this many characters wide.") - -(eval-when (:compile-toplevel :execute :load-toplevel) -(defconstant xwindow-border-width 2 "X border around X windows") -(defconstant xwindow-border-width*2 (* xwindow-border-width 2)) -); eval-when - -;;; We must name windows (set the "name" property) to get around a bug in -;;; awm and twm. They will not handle menu clicks without a window having -;;; a name. We set the name to this silly thing. -;;; -(defvar *hemlock-window-count* 0) -;;; -(defun new-hemlock-window-name () - (let ((*print-base* 10)) - (format nil "Hemlock ~S" (incf *hemlock-window-count*)))) - -(declaim (inline surplus-window-height surplus-window-height-w/-modeline)) -;;; -(defun surplus-window-height (thumb-bar-p) - (+ hunk-top-border (if thumb-bar-p - hunk-thumb-bar-bottom-border - hunk-bottom-border))) -;;; -(defun surplus-window-height-w/-modeline (thumb-bar-p) - (+ (surplus-window-height thumb-bar-p) - hunk-modeline-top - hunk-modeline-bottom)) - - -;;; DEFAULT-CREATE-WINDOW-HOOK -- Internal. -;;; -;;; This is the default value for *create-window-hook*. It makes an X window -;;; for a new group/parent on the given display possibly prompting the user. -;;; -#+clx -(defun default-create-window-hook (display x y width height name font-family - &optional modelinep thumb-bar-p) - (maybe-prompt-user-for-window - (xlib:screen-root (xlib:display-default-screen display)) - x y width height font-family modelinep thumb-bar-p name)) - -#-clx -(defun default-create-window-hook (display x y width height name font-family - &optional modelinep thumb-bar-p) - (declare (ignore display x y width height name font-family - modelinep thumb-bar-p))) - -;;; MAYBE-PROMPT-USER-FOR-WINDOW -- Internal. -;;; -;;; This makes an X window and sets its standard properties according to -;;; supplied values. When some of these are nil, the window manager should -;;; prompt the user for those missing values when the window gets mapped. We -;;; use this when making new group/parent windows. Returns the window without -;;; mapping it. -;;; -(defun maybe-prompt-user-for-window (root x y width height font-family - modelinep thumb-bar-p icon-name) - (let ((font-height (font-family-height font-family)) - (font-width (font-family-width font-family)) - (extra-y (surplus-window-height thumb-bar-p)) - (extra-y-w/-modeline (surplus-window-height-w/-modeline thumb-bar-p))) - (create-window-with-properties - root x y - (if width (+ (* width font-width) hunk-left-border)) - (if height - (if modelinep - (+ (* (1+ height) font-height) extra-y-w/-modeline) - (+ (* height font-height) extra-y))) - font-width font-height icon-name - (+ (* minimum-window-columns font-width) hunk-left-border) - (if modelinep - (+ (* (1+ minimum-window-lines) font-height) extra-y-w/-modeline) - (+ (* minimum-window-lines font-height) extra-y)) - t))) - -(defvar *create-window-hook* #'default-create-window-hook - "Hemlock calls this function when it makes a new X window for a new group. - It passes as arguments the X display, x (from MAKE-WINDOW), y (from - MAKE-WINDOW), width (from MAKE-WINDOW), height (from MAKE-WINDOW), a name - for the window's icon-name, font-family (from MAKE-WINDOW), modelinep (from - MAKE-WINDOW), and whether the window will have a thumb-bar meter. The - function returns a window or nil.") - -;;; BITMAP-MAKE-WINDOW -- Internal. -;;; -#+clx -(defun bitmap-make-window (device start modelinep window font-family - ask-user x y width-arg height-arg proportion) - (let* ((display (bitmap-device-display device)) - (thumb-bar-p (value hemlock::thumb-bar-meter)) - (hunk (make-bitmap-hunk - :font-family font-family - :end *the-sentinel* :trashed t - :input-handler #'window-input-handler - :device device - :thumb-bar-p (and modelinep thumb-bar-p)))) - (multiple-value-bind - (xparent xwindow) - (maybe-make-x-window-and-parent window display start ask-user x y - width-arg height-arg font-family - modelinep thumb-bar-p proportion) - (unless xwindow (return-from bitmap-make-window nil)) - (let ((window-group (make-window-group xparent - (xlib:drawable-width xparent) - (xlib:drawable-height xparent)))) - (setf (bitmap-hunk-xwindow hunk) xwindow) - (setf (bitmap-hunk-window-group hunk) window-group) - (setf (bitmap-hunk-gcontext hunk) - (default-gcontext xwindow font-family)) - ;; - ;; Select input and enable event service before showing the window. - (setf (xlib:window-event-mask xwindow) child-interesting-xevents-mask) - (setf (xlib:window-event-mask xparent) group-interesting-xevents-mask) - (add-xwindow-object xwindow hunk *hemlock-windows*) - (add-xwindow-object xparent window-group *hemlock-windows*)) - (when xparent (xlib:map-window xparent)) - (xlib:map-window xwindow) - (xlib:display-finish-output display) - ;; A window is not really mapped until it is viewable. It is said to be - ;; mapped if a map request has been sent whether it is handled or not. - (loop (when (and (eq (xlib:window-map-state xwindow) :viewable) - (eq (xlib:window-map-state xparent) :viewable)) - (return))) - ;; - ;; Find out how big it is... - (xlib:with-state (xwindow) - (set-hunk-size hunk (xlib:drawable-width xwindow) - (xlib:drawable-height xwindow) modelinep))) - (setf (bitmap-hunk-window hunk) - (window-for-hunk hunk start modelinep)) - ;; If window is non-nil, then it is a new group/parent window, so don't - ;; link it into the current window's group. When ask-user is non-nil, - ;; we make a new group too. - (cond ((or window ask-user) - ;; This occurs when we make the world's first Hemlock window. - (unless *current-window* - (setq *current-window* (bitmap-hunk-window hunk))) - (setf (bitmap-hunk-previous hunk) hunk) - (setf (bitmap-hunk-next hunk) hunk)) - (t - (let ((h (window-hunk *current-window*))) - (shiftf (bitmap-hunk-next hunk) (bitmap-hunk-next h) hunk) - (setf (bitmap-hunk-previous (bitmap-hunk-next hunk)) hunk) - (setf (bitmap-hunk-previous hunk) h)))) - (push hunk (device-hunks device)) - (bitmap-hunk-window hunk))) - -;;; MAYBE-MAKE-X-WINDOW-AND-PARENT -- Internal. -;;; -;;; BITMAP-MAKE-WINDOW calls this. If xparent is non-nil, we clear it and -;;; return it with a child that fills it. If xparent is nil, and ask-user is -;;; non-nil, then we invoke *create-window-hook* to get a parent window and -;;; return it with a child that fills it. By default, we make a child in the -;;; CURRENT-WINDOW's parent. -;;; -#+clx -(defun maybe-make-x-window-and-parent (xparent display start ask-user x y width - height font-family modelinep thumb-p - proportion) - (let ((icon-name (buffer-name (line-buffer (mark-line start))))) - (cond (xparent - (check-type xparent xlib:window) - (let ((width (xlib:drawable-width xparent)) - (height (xlib:drawable-height xparent))) - (xlib:clear-area xparent :width width :height height) - (modify-parent-properties :set xparent modelinep thumb-p - (font-family-width font-family) - (font-family-height font-family)) - (values xparent (xwindow-for-xparent xparent icon-name)))) - (ask-user - (let ((xparent (funcall *create-window-hook* - display x y width height icon-name - font-family modelinep thumb-p))) - (values xparent (xwindow-for-xparent xparent icon-name)))) - (t - (let ((xparent (window-group-xparent - (bitmap-hunk-window-group - (window-hunk (current-window)))))) - (values xparent - (create-window-from-current - proportion font-family modelinep thumb-p xparent - icon-name))))))) - -;;; XWINDOW-FOR-XPARENT -- Internal. -;;; -;;; This returns a child of xparent that completely fills that parent window. -;;; We supply the font-width and font-height as nil because these are useless -;;; for child windows. -;;; -#+clx -(defun xwindow-for-xparent (xparent icon-name) - (xlib:with-state (xparent) - (create-window-with-properties xparent 0 0 - (xlib:drawable-width xparent) - (xlib:drawable-height xparent) - nil nil icon-name))) - -;;; CREATE-WINDOW-FROM-CURRENT -- Internal. -;;; -;;; This makes a child window on parent by splitting the current window. If -;;; the result will be too small, this returns nil. If the current window's -;;; height is odd, the extra pixel stays with it, and the new window is one -;;; pixel smaller. -;;; -#+clx -(defun create-window-from-current (proportion font-family modelinep thumb-p - parent icon-name) - (let* ((cur-hunk (window-hunk *current-window*)) - (cwin (bitmap-hunk-xwindow cur-hunk))) - ;; Compute current window's height and take a proportion of it. - (xlib:with-state (cwin) - (let* ((cw (xlib:drawable-width cwin)) - (ch (xlib:drawable-height cwin)) - (cy (xlib:drawable-y cwin)) - (new-ch (truncate (* ch (- 1 proportion)))) - (font-height (font-family-height font-family)) - (font-width (font-family-width font-family)) - (cwin-min (minimum-window-height - (font-family-height - (bitmap-hunk-font-family cur-hunk)) - (bitmap-hunk-modeline-pos cur-hunk) - (bitmap-hunk-thumb-bar-p cur-hunk))) - (new-min (minimum-window-height font-height modelinep - thumb-p))) - (declare (fixnum cw cy ch new-ch)) - ;; See if we have room for a new window. This should really - ;; check the current window and the new one against their - ;; relative fonts and the minimal window columns and line - ;; (including whether there is a modeline). - (if (and (> new-ch cwin-min) - (> (- ch new-ch) new-min)) - (let ((win (create-window-with-properties - parent 0 (+ cy new-ch) - cw (- ch new-ch) font-width font-height - icon-name))) - ;; No need to reshape current Hemlock window structure here - ;; since this call will send an appropriate event. - (setf (xlib:drawable-height cwin) new-ch) - ;; Set hints on parent, so the user can't resize it to be - ;; smaller than what will hold the current number of - ;; children. - (modify-parent-properties :add parent modelinep - thumb-p - (font-family-width font-family) - font-height) - win) - nil))))) - - -;;; MAKE-XWINDOW-LIKE-HWINDOW -- Interface. -;;; -;;; The window name is set to get around an awm and twm bug that inhibits menu -;;; clicks unless the window has a name; this could be used better. -;;; -#+clx -(defun make-xwindow-like-hwindow (window) - "This returns an group/parent xwindow with dimensions suitable for making a - Hemlock window like the argument window. The new window's position should - be the same as the argument window's position relative to the root. When - setting standard properties, we set x, y, width, and height to tell window - managers to put the window where we intend without querying the user." - (let* ((hunk (window-hunk window)) - (font-family (bitmap-hunk-font-family hunk)) - (xwin (bitmap-hunk-xwindow hunk))) - (multiple-value-bind (x y) - (window-root-xy xwin) - (create-window-with-properties - (xlib:screen-root (xlib:display-default-screen - (bitmap-device-display (device-hunk-device hunk)))) - x y (bitmap-hunk-width hunk) (bitmap-hunk-height hunk) - (font-family-width font-family) - (font-family-height font-family) - (buffer-name (window-buffer window)) - ;; When the user hands this window to MAKE-WINDOW, it will set the - ;; minimum width and height properties. - nil nil - t)))) - - - - -;;;; Deleting a window. - -;;; DEFAULT-DELETE-WINDOW-HOOK -- Internal. -;;; -#+clx -(defun default-delete-window-hook (xparent) - (xlib:destroy-window xparent)) -#-clx -(defun default-delete-window-hook (xparent) - (declare (ignore xparent))) -;;; -(defvar *delete-window-hook* #'default-delete-window-hook - "Hemlock calls this function to delete an X group/parent window. It passes - the X window as an argument.") - - -;;; BITMAP-DELETE-WINDOW -- Internal -;;; -;;; -#+clx -(defun bitmap-delete-window (window) - (let* ((hunk (window-hunk window)) - (xwindow (bitmap-hunk-xwindow hunk)) - (xparent (window-group-xparent (bitmap-hunk-window-group hunk))) - (display (bitmap-device-display (device-hunk-device hunk)))) - (remove-xwindow-object xwindow) - (setq *window-list* (delete window *window-list*)) - (when (eq *current-highlighted-border* hunk) - (setf *current-highlighted-border* nil)) - (when (and (eq *cursor-hunk* hunk) *cursor-dropped*) (lift-cursor)) - (xlib:display-force-output display) - (bitmap-delete-and-reclaim-window-space xwindow window) - (loop (unless (deleting-window-drop-event display xwindow) (return))) - (let ((device (device-hunk-device hunk))) - (setf (device-hunks device) (delete hunk (device-hunks device)))) - (cond ((eq hunk (bitmap-hunk-next hunk)) - ;; Is this the last window in the group? - (remove-xwindow-object xparent) - (xlib:display-force-output display) - (funcall *delete-window-hook* xparent) - (loop (unless (deleting-window-drop-event display xparent) - (return))) - (let ((window (find-if-not #'(lambda (window) - (eq window *echo-area-window*)) - *window-list*))) - (setf (current-buffer) (window-buffer window) - (current-window) window))) - (t - (modify-parent-properties :delete xparent - (bitmap-hunk-modeline-pos hunk) - (bitmap-hunk-thumb-bar-p hunk) - (font-family-width - (bitmap-hunk-font-family hunk)) - (font-family-height - (bitmap-hunk-font-family hunk))) - (let ((next (bitmap-hunk-next hunk)) - (prev (bitmap-hunk-previous hunk))) - (setf (bitmap-hunk-next prev) next) - (setf (bitmap-hunk-previous next) prev)))) - (let ((buffer (window-buffer window))) - (setf (buffer-windows buffer) (delete window (buffer-windows buffer))))) - nil) - -;;; BITMAP-DELETE-AND-RECLAIM-WINDOW-SPACE -- Internal. -;;; -;;; This destroys the X window after obtaining its necessary state information. -;;; If the previous or next window (in that order) is "stacked" over or under -;;; the target window, then it is grown to fill in the newly opened space. We -;;; fetch all the necessary configuration data up front, so we don't have to -;;; call XLIB:DESTROY-WINDOW while in the XLIB:WITH-STATE. -;;; -#+clx -(defun bitmap-delete-and-reclaim-window-space (xwindow hwindow) - (multiple-value-bind (y height) - (xlib:with-state (xwindow) - (values (xlib:drawable-y xwindow) - (xlib:drawable-height xwindow))) - (xlib:destroy-window xwindow) - (let ((hunk (window-hunk hwindow))) - (xlib:free-gcontext (bitmap-hunk-gcontext hunk)) - (unless (eq hunk (bitmap-hunk-next hunk)) - (unless (maybe-merge-with-previous-window hunk y height) - (merge-with-next-window hunk y height)))))) - -;;; MAYBE-MERGE-WITH-PREVIOUS-WINDOW -- Internal. -;;; -;;; This returns non-nil when it grows the previous hunk to include the -;;; argument hunk's screen space. -;;; -#+clx -(defun maybe-merge-with-previous-window (hunk y h) - (declare (fixnum y h)) - (let* ((prev (bitmap-hunk-previous hunk)) - (prev-xwin (bitmap-hunk-xwindow prev))) - (xlib:with-state (prev-xwin) - (if (< (xlib:drawable-y prev-xwin) y) - (incf (xlib:drawable-height prev-xwin) h))))) - -;;; MERGE-WITH-NEXT-WINDOW -- Internal. -;;; -;;; This trys to grow the next hunk's window to make use of the space created -;;; by deleting hunk's window. If this is possible, then we must also move the -;;; next window up to where hunk's window was. -;;; -;;; When we reconfigure the window, we must set the hunk trashed. This is a -;;; hack since twm is broken again and is sending exposure events before -;;; reconfigure notifications. Hemlock relies on the protocol's statement that -;;; reconfigures come before exposures to set the hunk trashed before getting -;;; the exposure. For now, we'll do it here too. -;;; -#+clx -(defun merge-with-next-window (hunk y h) - (declare (fixnum y h)) - (let* ((next (bitmap-hunk-next hunk)) - (next-xwin (bitmap-hunk-xwindow next))) - ;; Fetch height before setting y to save an extra round trip to the X - ;; server. - (let ((next-h (xlib:drawable-height next-xwin))) - (setf (xlib:drawable-y next-xwin) y) - (setf (xlib:drawable-height next-xwin) (+ next-h h))) - (setf (bitmap-hunk-trashed next) t) - (let ((hints (xlib:wm-normal-hints next-xwin))) - (setf (xlib:wm-size-hints-y hints) y) - (setf (xlib:wm-normal-hints next-xwin) hints)))) - - -;;; DELETING-WINDOW-DROP-EVENT -- Internal. -;;; -;;; This checks for any events on win. If there is one, remove it from the -;;; queue and return t. Otherwise, return nil. -;;; -#+clx -(defun deleting-window-drop-event (display win) - (xlib:display-finish-output display) - (let ((result nil)) - (xlib:process-event - display :timeout 0 - :handler #'(lambda (&key event-window window &allow-other-keys) - (if (or (eq event-window win) (eq window win)) - (setf result t) - nil))) - result)) - - -;;; MODIFY-PARENT-PROPERTIES -- Internal. -;;; -;;; This adds or deletes from xparent's min-height and min-width hints, so the -;;; window manager will hopefully prevent users from making a window group too -;;; small to hold all the windows in it. We add to the height when we split -;;; windows making additional ones, and we delete from it when we delete a -;;; window. -;;; -;;; NOTE, THIS FAILS TO MAINTAIN THE WIDTH CORRECTLY. We need to maintain the -;;; width as the MAX of all the windows' minimal widths. A window's minimal -;;; width is its font's width multiplied by minimum-window-columns. -;;; -#+clx -(defun modify-parent-properties (type xparent modelinep thumb-p - font-width font-height) - (let ((hints (xlib:wm-normal-hints xparent))) - (xlib:set-wm-properties - xparent - :resource-name "Hemlock" - :x (xlib:wm-size-hints-x hints) - :y (xlib:wm-size-hints-y hints) - :width (xlib:drawable-width xparent) - :height (xlib:drawable-height xparent) - :user-specified-position-p t - :user-specified-size-p t - :width-inc (xlib:wm-size-hints-width-inc hints) - :height-inc (xlib:wm-size-hints-height-inc hints) - :min-width (or (xlib:wm-size-hints-min-width hints) - (+ (* minimum-window-columns font-width) hunk-left-border)) - :min-height - (let ((delta (minimum-window-height font-height modelinep thumb-p))) - (ecase type - (:delete (- (xlib:wm-size-hints-min-height hints) delta)) - (:add (+ (or (xlib:wm-size-hints-min-height hints) 0) - delta)) - (:set delta)))))) - -;;; MINIMUM-WINDOW-HEIGHT -- Internal. -;;; -;;; This returns the minimum height necessary for a window given some of its -;;; parameters. This is the number of lines times font-height plus any extra -;;; pixels for aesthetics. -;;; -(defun minimum-window-height (font-height modelinep thumb-p) - (if modelinep - (+ (* (1+ minimum-window-lines) font-height) - (surplus-window-height-w/-modeline thumb-p)) - (+ (* minimum-window-lines font-height) - (surplus-window-height thumb-p)))) - - - - -;;;; Next and Previous windows. - -(defun bitmap-next-window (window) - "Return the next window after Window, wrapping around if Window is the - bottom window." - (check-type window window) - (bitmap-hunk-window (bitmap-hunk-next (window-hunk window)))) - -(defun bitmap-previous-window (window) - "Return the previous window after Window, wrapping around if Window is the - top window." - (check-type window window) - (bitmap-hunk-window (bitmap-hunk-previous (window-hunk window)))) - - - - -;;;; Setting window width and height. - -;;; %SET-WINDOW-WIDTH -- Internal -;;; -;;; Since we don't support non-full-width windows, this does nothing. -;;; -(defun %set-window-width (window new-value) - (declare (ignore window)) - new-value) - -;;; %SET-WINDOW-HEIGHT -- Internal -;;; -;;; Can't change window height either. -;;; -(defun %set-window-height (window new-value) - (declare (ignore window)) - new-value) - - - - -;;;; Random Typeout - -;;; Random typeout is done to a bitmap-hunk-output-stream -;;; (Bitmap-Hunk-Stream.Lisp). These streams have an associated hunk -;;; that is used for its font-family, foreground and background color, -;;; and X window pointer. The hunk is not associated with any Hemlock -;;; window, and the low level painting routines that use hunk dimensions -;;; are not used for output. The X window is resized as necessary with -;;; each use, but the hunk is only registered for input and boundary -;;; crossing event service; therefore, it never gets exposure or changed -;;; notifications. - -;;; These are set in INIT-BITMAP-SCREEN-MANAGER. -;;; -(defvar *random-typeout-start-x* 0 - "Where we put the the random typeout window.") -(defvar *random-typeout-start-y* 0 - "Where we put the the random typeout window.") -(defvar *random-typeout-start-width* 0 - "How wide the random typeout window is.") - - -;;; DEFAULT-RANDOM-TYPEOUT-HOOK -- Internal -;;; -;;; The default hook-function for random typeout. Nothing very fancy -;;; for now. If not given a window, makes one on top of the initial -;;; Hemlock window using specials set in INIT-BITMAP-SCREEN-MANAGER. If -;;; given a window, we will change the height subject to the constraint -;;; that the bottom won't be off the screen. Any resulting window has -;;; input and boundary crossing events selected, a hemlock cursor defined, -;;; and is mapped. -;;; -#+clx -(defun default-random-typeout-hook (device window height) - (declare (fixnum height)) - (let* ((display (bitmap-device-display device)) - (root (xlib:screen-root (xlib:display-default-screen display))) - (full-height (xlib:drawable-height root)) - (actual-height (if window - (multiple-value-bind (x y) (window-root-xy window) - (declare (ignore x) (fixnum y)) - (min (- full-height y xwindow-border-width*2) - height)) - (min (- full-height *random-typeout-start-y* - xwindow-border-width*2) - height))) - (win (cond (window - (setf (xlib:drawable-height window) actual-height) - window) - (t - (let ((win (xlib:create-window - :parent root - :x *random-typeout-start-x* - :y *random-typeout-start-y* - :width *random-typeout-start-width* - :height actual-height - :background *default-background-pixel* - :border-width xwindow-border-width - :border *default-border-pixmap* - :event-mask random-typeout-xevents-mask - :override-redirect :on :class :input-output - :cursor *hemlock-cursor*))) - (xlib:set-wm-properties - win :name "Pop-up Display" :icon-name "Pop-up Display" - :resource-name "Hemlock" - :x *random-typeout-start-x* - :y *random-typeout-start-y* - :width *random-typeout-start-width* - :height actual-height - :user-specified-position-p t :user-specified-size-p t - ;; Tell OpenLook pseudo-X11 server we want input. - :input :on) - win)))) - (gcontext (if (not window) (default-gcontext win)))) - (values win gcontext))) - -#-clx -(defun default-random-typeout-hook (device window height) - (declare (ignore device window height))) - -(defvar *random-typeout-hook* #'default-random-typeout-hook - "This function is called when a window is needed to display random typeout. - It is called with the Hemlock device, a pre-existing window or NIL, and the - number of pixels needed to display the number of lines requested in - WITH-RANDOM-TYPEOUT. It should return a window, and if a new window was - created, then a gcontext must be returned as the second value.") - -;;; BITMAP-RANDOM-TYPEOUT-SETUP -- Internal -;;; -;;; This function is called by the with-random-typeout macro to -;;; to set things up. It calls the *Random-Typeout-Hook* to get a window -;;; to work with, and then adjusts the random typeout stream's data-structures -;;; to match. -;;; -#+clx -(defun bitmap-random-typeout-setup (device stream height) - (let* ((*more-prompt-action* :empty) - (hwin-exists-p (random-typeout-stream-window stream)) - (hwindow (if hwin-exists-p - (change-bitmap-random-typeout-window hwin-exists-p height) - (setf (random-typeout-stream-window stream) - (make-bitmap-random-typeout-window - device - (buffer-start-mark - (line-buffer - (mark-line (random-typeout-stream-mark stream)))) - height))))) - (let ((xwindow (bitmap-hunk-xwindow (window-hunk hwindow))) - (display (bitmap-device-display device))) - (xlib:display-finish-output display) - (loop - (unless (xlib:event-case (display :timeout 0) - (:exposure (event-window) - (eq event-window xwindow)) - (t () nil)) - (return)))))) - -#+clx -(defun change-bitmap-random-typeout-window (hwindow height) - (update-modeline-field (window-buffer hwindow) hwindow :more-prompt) - (let* ((hunk (window-hunk hwindow)) - (xwin (bitmap-hunk-xwindow hunk))) - ;; - ;; *random-typeout-hook* sets the window's height to the right value. - (funcall *random-typeout-hook* (device-hunk-device hunk) xwin - (+ (* height (font-family-height (bitmap-hunk-font-family hunk))) - hunk-top-border (bitmap-hunk-bottom-border hunk) - hunk-modeline-top hunk-modeline-bottom)) - (xlib:with-state (xwin) - (hunk-changed hunk (xlib:drawable-width xwin) (xlib:drawable-height xwin) - nil)) - ;; - ;; We push this on here because we took it out the last time we cleaned up. - (push hwindow (buffer-windows (window-buffer hwindow))) - (setf (bitmap-hunk-trashed hunk) t) - (xlib:map-window xwin) - (setf (xlib:window-priority xwin) :above)) - hwindow) - -#+clx -(defun make-bitmap-random-typeout-window (device mark height) - (let* ((display (bitmap-device-display device)) - (hunk (make-bitmap-hunk - :font-family *default-font-family* - :end *the-sentinel* :trashed t - :input-handler #'window-input-handler - :device device :thumb-bar-p nil))) - (multiple-value-bind - (xwindow gcontext) - (funcall *random-typeout-hook* - device (bitmap-hunk-xwindow hunk) - (+ (* height (font-family-height *default-font-family*)) - hunk-top-border (bitmap-hunk-bottom-border hunk) - hunk-modeline-top hunk-modeline-bottom)) - ;; - ;; When gcontext, we just made the window, so tie some stuff together. - (when gcontext - (setf (xlib:gcontext-font gcontext) - (svref (font-family-map *default-font-family*) 0)) - (setf (bitmap-hunk-xwindow hunk) xwindow) - (setf (bitmap-hunk-gcontext hunk) gcontext) - ;; - ;; Select input and enable event service before showing the window. - (setf (xlib:window-event-mask xwindow) random-typeout-xevents-mask) - (add-xwindow-object xwindow hunk *hemlock-windows*)) - ;; - ;; Put the window on the screen so it's visible and we can know the size. - (xlib:map-window xwindow) - (xlib:display-finish-output display) - ;; A window is not really mapped until it is viewable (not visible). - ;; It is said to be mapped if a map request has been sent whether it - ;; is handled or not. - (loop (when (eq (xlib:window-map-state xwindow) :viewable) - (return))) - (xlib:with-state (xwindow) - (set-hunk-size hunk (xlib:drawable-width xwindow) - (xlib:drawable-height xwindow) t)) - ;; - ;; Get a Hemlock window and hide it from the rest of Hemlock. - (let ((hwin (window-for-hunk hunk mark *random-typeout-ml-fields*))) - (update-modeline-field (window-buffer hwin) hwin :more-prompt) - (setf (bitmap-hunk-window hunk) hwin) - (setf *window-list* (delete hwin *window-list*)) - hwin)))) - - -;;; RANDOM-TYPEOUT-CLEANUP -- Internal -;;; -;;; Clean up after random typeout. This just removes the window from -;;; the screen and sets the more-prompt action back to normal. -;;; -#+clx -(defun bitmap-random-typeout-cleanup (stream degree) - (when degree - (xlib:unmap-window (bitmap-hunk-xwindow - (window-hunk (random-typeout-stream-window stream)))))) - - - - -;;;; Initialization. - -;;; DEFAULT-CREATE-INITIAL-WINDOWS-HOOK makes the initial windows, main and -;;; echo. The main window is made according to "Default Initial Window X", -;;; "Default Initial Window Y", "Default Initial Window Width", and "Default -;;; Initial Window Height", prompting the user for any unspecified components. -;;; DEFAULT-CREATE-INITIAL-WINDOWS-ECHO is called to return the location and -;;; size of the echo area including how big its font is, and the main xwindow -;;; is potentially modified by this function. The window name is set to get -;;; around an awm and twm bug that inhibits menu clicks unless the window has a -;;; name; this could be used better. -;;; -#+clx -(defun default-create-initial-windows-hook (device) - (let ((root (xlib:screen-root (xlib:display-default-screen - (bitmap-device-display device))))) - (let* ((xwindow (maybe-prompt-user-for-window - root - (value hemlock::default-initial-window-x) - (value hemlock::default-initial-window-y) - (value hemlock::default-initial-window-width) - (value hemlock::default-initial-window-height) - *default-font-family* - t ;modelinep - (value hemlock::thumb-bar-meter) - "Hemlock"))) - (setf (xlib:window-border xwindow) *highlight-border-pixmap*) - (let ((main-win (make-window (buffer-start-mark *current-buffer*) - :device device - :window xwindow))) - (multiple-value-bind - (echo-x echo-y echo-width echo-height) - (default-create-initial-windows-echo - (xlib:drawable-height root) - (window-hunk main-win)) - (let ((echo-xwin (make-echo-xwindow root echo-x echo-y echo-width - echo-height))) - (setf *echo-area-window* - (hlet ((hemlock::thumb-bar-meter nil)) - (make-window - (buffer-start-mark *echo-area-buffer*) - :device device :modelinep t - :window echo-xwin))))) - (setf *current-window* main-win))))) - -#-clx -(defun default-create-initial-windows-hook (device) - (declare (ignore device))) - -;;; DEFAULT-CREATE-INITIAL-WINDOWS-ECHO makes the echo area window as wide as -;;; the main window and places it directly under it. If the echo area does not -;;; fit on the screen, we change the main window to make it fit. There is -;;; a problem in computing main-xwin's x and y relative to the root window -;;; which is where we line up the echo and main windows. Some losing window -;;; managers (awm and twm) reparent the window, so we have to make sure -;;; main-xwin's x and y are relative to the root and not some false parent. -;;; -#+clx -(defun default-create-initial-windows-echo (full-height hunk) - (declare (fixnum full-height)) - (let ((font-family (bitmap-hunk-font-family hunk)) - (xwindow (bitmap-hunk-xwindow hunk)) - (xparent (window-group-xparent (bitmap-hunk-window-group hunk)))) - (xlib:with-state (xwindow) - (let ((w (xlib:drawable-width xwindow)) - (h (xlib:drawable-height xwindow))) - (declare (fixnum w h)) - (multiple-value-bind (x y) - (window-root-xy xwindow - (xlib:drawable-x xwindow) - (xlib:drawable-y xwindow)) - (declare (fixnum x y)) - (let* ((ff-height (font-family-height font-family)) - (ff-width (font-family-width font-family)) - (echo-height (+ (* ff-height 4) - hunk-top-border hunk-bottom-border - hunk-modeline-top hunk-modeline-bottom))) - (declare (fixnum echo-height)) - (if (<= (+ y h echo-height xwindow-border-width*2) full-height) - (values x (+ y h xwindow-border-width*2) - w echo-height ff-width ff-height) - (let* ((newh (- full-height y echo-height xwindow-border-width*2 - ;; Since y is really the outside y, subtract - ;; two more borders, so the echo area's borders - ;; both appear on the screen. - xwindow-border-width*2))) - (setf (xlib:drawable-height xparent) newh) - (values x (+ y newh xwindow-border-width*2) - w echo-height ff-width ff-height))))))))) - -(defvar *create-initial-windows-hook* #'default-create-initial-windows-hook - "Hemlock uses this function when it initializes the screen manager to make - the first windows, typically the main and echo area windows. It takes a - Hemlock device as a required argument. It sets *current-window* and - *echo-area-window*.") - -(defun make-echo-xwindow (root x y width height) - (let* ((font-width (font-family-width *default-font-family*)) - (font-height (font-family-height *default-font-family*))) - (create-window-with-properties root x y width height - font-width font-height - "Echo Area" nil nil t))) - -#+clx -(defun init-bitmap-screen-manager (display) - ;; - ;; Setup stuff for X interaction. - (cond ((value hemlock::reverse-video) - (setf *default-background-pixel* - (xlib:screen-black-pixel (xlib:display-default-screen display))) - (setf *default-foreground-pixel* - (xlib:screen-white-pixel (xlib:display-default-screen display))) - (setf *cursor-background-color* (make-black-color)) - (setf *cursor-foreground-color* (make-white-color)) - (setf *hack-hunk-replace-line* nil)) - (t (setf *default-background-pixel* - (xlib:screen-white-pixel (xlib:display-default-screen display))) - (setf *default-foreground-pixel* - (xlib:screen-black-pixel (xlib:display-default-screen display))) - (setf *cursor-background-color* (make-white-color)) - (setf *cursor-foreground-color* (make-black-color)))) - (setf *foreground-background-xor* - (logxor *default-foreground-pixel* *default-background-pixel*)) - (setf *highlight-border-pixmap* *default-foreground-pixel*) - (setf *default-border-pixmap* (get-hemlock-grey-pixmap display)) - (get-hemlock-cursor display) - (add-hook hemlock::make-window-hook 'define-window-cursor) - ;; - ;; Make the device for the rest of initialization. - (let ((device (make-default-bitmap-device display))) - ;; - ;; Create initial windows. - (funcall *create-initial-windows-hook* device) - ;; - ;; Setup random typeout over the user's main window. - (let ((xwindow (bitmap-hunk-xwindow (window-hunk *current-window*)))) - (xlib:with-state (xwindow) - (multiple-value-bind (x y) - (window-root-xy xwindow (xlib:drawable-x xwindow) - (xlib:drawable-y xwindow)) - (setf *random-typeout-start-x* x) - (setf *random-typeout-start-y* y)) - (setf *random-typeout-start-width* (xlib:drawable-width xwindow))))) - (add-hook hemlock::window-buffer-hook 'set-window-name-for-window-buffer) - (add-hook hemlock::buffer-name-hook 'set-window-name-for-buffer-name) - (add-hook hemlock::set-window-hook 'set-window-hook-raise-fun) - (add-hook hemlock::buffer-modified-hook 'raise-echo-area-when-modified)) - -(defun make-default-bitmap-device (display) - (make-bitmap-device - :name "Windowed Bitmap Device" - :init #'init-bitmap-device - :exit #'exit-bitmap-device - :smart-redisplay #'smart-window-redisplay - :dumb-redisplay #'dumb-window-redisplay - :after-redisplay #'bitmap-after-redisplay - :clear nil - :note-read-wait #'frob-cursor - :put-cursor #'hunk-show-cursor - :show-mark #'bitmap-show-mark - :next-window #'bitmap-next-window - :previous-window #'bitmap-previous-window - :make-window #'bitmap-make-window - :delete-window #'bitmap-delete-window - :force-output #'bitmap-force-output - :finish-output #'bitmap-finish-output - :random-typeout-setup #'bitmap-random-typeout-setup - :random-typeout-cleanup #'bitmap-random-typeout-cleanup - :random-typeout-full-more #'do-bitmap-full-more - :random-typeout-line-more #'update-bitmap-line-buffered-stream - :beep #'bitmap-beep - :display display)) - -(defun init-bitmap-device (device) - (let ((display (bitmap-device-display device))) - (hemlock-ext:flush-display-events display) - (hemlock-window display t))) - -(defun exit-bitmap-device (device) - (hemlock-window (bitmap-device-display device) nil)) - -#+clx -(defun bitmap-finish-output (device window) - (declare (ignore window)) - (xlib:display-finish-output (bitmap-device-display device))) - -#+clx -(defun bitmap-force-output () - (xlib:display-force-output - (bitmap-device-display (device-hunk-device (window-hunk (current-window)))))) - -(defun bitmap-after-redisplay (device) - (let ((display (bitmap-device-display device))) - (loop (unless (hemlock-ext:object-set-event-handler display) (return))))) - - - - -;;;; Miscellaneous. - -;;; HUNK-RESET is called in redisplay to make sure the hunk is up to date. -;;; If the size is wrong, or it is trashed due to font changes, then we -;;; call HUNK-CHANGED. We also clear the hunk. -;;; -#+clx -(defun hunk-reset (hunk) - (let ((xwindow (bitmap-hunk-xwindow hunk)) - (trashed (bitmap-hunk-trashed hunk))) - (when trashed - (setf (bitmap-hunk-trashed hunk) nil) - (xlib:with-state (xwindow) - (let ((w (xlib:drawable-width xwindow)) - (h (xlib:drawable-height xwindow))) - (when (or (/= w (bitmap-hunk-width hunk)) - (/= h (bitmap-hunk-height hunk)) - (eq trashed :font-change)) - (hunk-changed hunk w h nil))))) - (xlib:clear-area xwindow :width (bitmap-hunk-width hunk) - :height (bitmap-hunk-height hunk)) - (hunk-draw-bottom-border hunk))) - -;;; HUNK-CHANGED -- Internal. -;;; -;;; HUNK-RESET and the changed window handler call this. Don't go through -;;; REDISPLAY-WINDOW-ALL since the window changed handler updates the window -;;; image. -;;; -(defun hunk-changed (hunk new-width new-height redisplay) - (set-hunk-size hunk new-width new-height) - (funcall (bitmap-hunk-changed-handler hunk) hunk) - (when redisplay (dumb-window-redisplay (bitmap-hunk-window hunk)))) - -;;; WINDOW-GROUP-CHANGED -- Internal. -;;; -;;; HUNK-RECONFIGURED calls this when the hunk was a window-group. This finds -;;; the windows in the changed group, sorts them by their vertical stacking -;;; order, and tries to resize the windows proportioned by their old sizes -;;; relative to the old group size. If that fails, this tries to make all the -;;; windows the same size, dividing up the new group's size. -;;; -#+clx -(defun window-group-changed (window-group new-width new-height) - (let ((xparent (window-group-xparent window-group)) - (affected-windows nil) - (count 0) - (old-xparent-height (window-group-height window-group))) - (setf (window-group-width window-group) new-width) - (setf (window-group-height window-group) new-height) - (dolist (window *window-list*) - (let ((test (window-group-xparent (bitmap-hunk-window-group - (window-hunk window))))) - (when (eq test xparent) - (push window affected-windows) - (incf count)))) - ;; Probably shoulds insertion sort them, but I'm lame. - ;; - (xlib:with-state (xparent) - (sort affected-windows #'< - :key #'(lambda (window) - (xlib:drawable-y - (bitmap-hunk-xwindow (window-hunk window)))))) - (let ((start 0)) - (declare (fixnum start)) - (do ((windows affected-windows (cdr windows))) - ((endp windows)) - (let* ((xwindow (bitmap-hunk-xwindow (window-hunk (car windows)))) - (new-child-height (round - (* new-height - (/ (xlib:drawable-height xwindow) - old-xparent-height)))) - (hunk (window-hunk (car windows)))) - ;; If there is not enough room for one of the windows, space them out - ;; evenly so there will be room. - ;; - (when (< new-child-height (minimum-window-height - (font-family-height - (bitmap-hunk-font-family hunk)) - (bitmap-hunk-modeline-pos hunk) - (bitmap-hunk-thumb-bar-p hunk))) - (reconfigure-windows-evenly affected-windows new-width new-height) - (return)) - (xlib:with-state (xwindow) - (setf (xlib:drawable-y xwindow) start - ;; Make the last window absorb or lose the number of pixels - ;; lost in rounding. - ;; - (xlib:drawable-height xwindow) (if (cdr windows) - new-child-height - (- new-height start)) - (xlib:drawable-width xwindow) new-width - start (+ start new-child-height 1)))))))) - -#+clx -(defun reconfigure-windows-evenly (affected-windows new-width new-height) - (let ((count (length affected-windows))) - (multiple-value-bind - (pixels-per-window remainder) - (truncate new-height count) - (let ((count-1 (1- count))) - (do ((windows affected-windows (cdr windows)) - (i 0 (1+ i))) - ((endp windows)) - (let ((xwindow (bitmap-hunk-xwindow (window-hunk (car windows))))) - (setf (xlib:drawable-y xwindow) (* i pixels-per-window)) - (setf (xlib:drawable-width xwindow) new-width) - (if (= i count-1) - (return (setf (xlib:drawable-height - (bitmap-hunk-xwindow - (window-hunk (car windows)))) - (+ pixels-per-window remainder))) - (setf (xlib:drawable-height xwindow) pixels-per-window)))))))) - -;;; SET-HUNK-SIZE -- Internal -;;; -;;; Given a pixel size for a bitmap hunk, set the char size. If the window -;;; is too small, we refuse to admit it; if the user makes unreasonably small -;;; windows, our only responsibity is to not blow up. X will clip any stuff -;;; that doesn't fit. -;;; -(defun set-hunk-size (hunk w h &optional modelinep) - (let* ((font-family (bitmap-hunk-font-family hunk)) - (font-width (font-family-width font-family)) - (font-height (font-family-height font-family))) - (setf (bitmap-hunk-height hunk) h) - (setf (bitmap-hunk-width hunk) w) - (setf (bitmap-hunk-char-width hunk) - (max (truncate (- w hunk-left-border) font-width) - minimum-window-columns)) - (let* ((h-minus-borders (- h hunk-top-border - (bitmap-hunk-bottom-border hunk))) - (hwin (bitmap-hunk-window hunk)) - (modelinep (or modelinep (and hwin (window-modeline-buffer hwin))))) - (setf (bitmap-hunk-char-height hunk) - (max (if modelinep - (1- (truncate (- h-minus-borders - hunk-modeline-top hunk-modeline-bottom) - font-height)) - (truncate h-minus-borders font-height)) - minimum-window-lines)) - (setf (bitmap-hunk-modeline-pos hunk) - (if modelinep (- h font-height - hunk-modeline-top hunk-modeline-bottom)))))) - -;;; BITMAP-HUNK-BOTTOM-BORDER -- Internal. -;;; -(defun bitmap-hunk-bottom-border (hunk) - (if (bitmap-hunk-thumb-bar-p hunk) - hunk-thumb-bar-bottom-border - hunk-bottom-border)) - - -;;; DEFAULT-GCONTEXT is used when making hunks. -;;; -#+clx -(defun default-gcontext (drawable &optional font-family) - (xlib:create-gcontext - :drawable drawable - :foreground *default-foreground-pixel* - :background *default-background-pixel* - :font (if font-family (svref (font-family-map font-family) 0)))) - - -;;; WINDOW-ROOT-XY returns the x and y coordinates for a window relative to -;;; its root. Some window managers reparent Hemlock's window, so we have -;;; to mess around possibly to get this right. If x and y are supplied, they -;;; are relative to xwin's parent. -;;; -#+clx -(defun window-root-xy (xwin &optional x y) - (multiple-value-bind (children parent root) - (xlib:query-tree xwin) - (declare (ignore children)) - (if (eq parent root) - (if (and x y) - (values x y) - (xlib:with-state (xwin) - (values (xlib:drawable-x xwin) (xlib:drawable-y xwin)))) - (multiple-value-bind - (tx ty) - (if (and x y) - (xlib:translate-coordinates parent x y root) - (xlib:with-state (xwin) - (xlib:translate-coordinates - parent (xlib:drawable-x xwin) (xlib:drawable-y xwin) root))) - (values (- tx xwindow-border-width) - (- ty xwindow-border-width)))))) - -;;; CREATE-WINDOW-WITH-PROPERTIES makes an X window with parent. X, y, w, and -;;; h are possibly nil, so we supply zero in this case. This would be used -;;; for prompting the user. Some standard properties are set to keep window -;;; managers in line. We name all windows because awm and twm window managers -;;; refuse to honor menu clicks over windows without names. Min-width and -;;; min-height are optional and only used for prompting the user for a window. -;;; -#+clx -(defun create-window-with-properties (parent x y w h font-width font-height - icon-name - &optional min-width min-height - window-group-p) - (let* ((win (xlib:create-window - :parent parent :x (or x 0) :y (or y 0) - :width (or w 0) :height (or h 0) - :background (if window-group-p :none *default-background-pixel*) - :border-width (if window-group-p xwindow-border-width 0) - :border (if window-group-p *default-border-pixmap* nil) - :class :input-output))) - (xlib:set-wm-properties - win :name (new-hemlock-window-name) :icon-name icon-name - :resource-name "Hemlock" - :x x :y y :width w :height h - :user-specified-position-p t :user-specified-size-p t - :width-inc font-width :height-inc font-height - :min-width min-width :min-height min-height - ;; Tell OpenLook pseudo-X11 server we want input. - :input :on) - win)) - - -;;; SET-WINDOW-HOOK-RAISE-FUN is a "Set Window Hook" function controlled by -;;; "Set Window Autoraise". When autoraising, check that it isn't only the -;;; echo area window that we autoraise; if it is only the echo area window, -;;; then see if window is the echo area window. -;;; -#+clx -(defun set-window-hook-raise-fun (window) - (let ((auto (value hemlock::set-window-autoraise))) - (when (and auto - (or (not (eq auto :echo-only)) - (eq window *echo-area-window*))) - (let* ((hunk (window-hunk window)) - (win (window-group-xparent (bitmap-hunk-window-group hunk)))) - (xlib:map-window win) - (setf (xlib:window-priority win) :above) - (xlib:display-force-output - (bitmap-device-display (device-hunk-device hunk))))))) - - -;;; REVERSE-VIDEO-HOOK-FUN is called when the variable "Reverse Video" is set. -;;; If we are running on a windowed bitmap, we first setup the default -;;; foregrounds and backgrounds. Having done that, we get a new cursor. Then -;;; we do over all the hunks, updating their graphics contexts, cursors, and -;;; backgrounds. The current window's border is given the new highlight pixmap. -;;; Lastly, we update the random typeout hunk and redisplay everything. -;;; - -#+clx -(defun reverse-video-hook-fun (name kind where new-value) - (declare (ignore name kind where)) - (when (windowed-monitor-p) - (let* ((current-window (current-window)) - (current-hunk (window-hunk current-window)) - (device (device-hunk-device current-hunk)) - (display (bitmap-device-display device))) - (cond - (new-value - (setf *default-background-pixel* - (xlib:screen-black-pixel (xlib:display-default-screen display))) - (setf *default-foreground-pixel* - (xlib:screen-white-pixel (xlib:display-default-screen display))) - (setf *cursor-background-color* (make-black-color)) - (setf *cursor-foreground-color* (make-white-color)) - (setf *hack-hunk-replace-line* nil)) - (t (setf *default-background-pixel* - (xlib:screen-white-pixel (xlib:display-default-screen display))) - (setf *default-foreground-pixel* - (xlib:screen-black-pixel (xlib:display-default-screen display))) - (setf *cursor-background-color* (make-white-color)) - (setf *cursor-foreground-color* (make-black-color)))) - (setf *highlight-border-pixmap* *default-foreground-pixel*) - (get-hemlock-cursor display) - (dolist (hunk (device-hunks device)) - (reverse-video-frob-hunk hunk)) - (dolist (rt-info *random-typeout-buffers*) - (reverse-video-frob-hunk - (window-hunk (random-typeout-stream-window (cdr rt-info))))) - (setf (xlib:window-border (bitmap-hunk-xwindow current-hunk)) - *highlight-border-pixmap*)) - (redisplay-all))) - -#-clx -(defun reverse-video-hook-fun (name kind where new-value) - (declare (ignore name kind where new-value))) - -#+clx -(defun reverse-video-frob-hunk (hunk) - (let ((gcontext (bitmap-hunk-gcontext hunk))) - (setf (xlib:gcontext-foreground gcontext) *default-foreground-pixel*) - (setf (xlib:gcontext-background gcontext) *default-background-pixel*)) - (let ((xwin (bitmap-hunk-xwindow hunk))) - (setf (xlib:window-cursor xwin) *hemlock-cursor*) - (setf (xlib:window-background xwin) *default-background-pixel*))) Index: anches/ide-1.0/ccl/hemlock/src/debug.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/debug.lisp (revision 6566) +++ (revision ) @@ -1,561 +1,0 @@ -;;; -*- Mode: Lisp; Package: ED; Log: hemlock.log -*- -;;; -;;; ********************************************************************** -;;; This code was written as part of the CMU Common Lisp project at -;;; Carnegie Mellon University, and has been placed in the public domain. -;;; -#+CMU (ext:file-comment - "$Header$") -;;; -;;; ********************************************************************** -;;; -;;; This contains commands for sending debugger commands to slaves in the -;;; debugger. -;;; -;;; Written by Bill Chiles. -;;; - -(in-package :hemlock) - - - - -;;;; DEFINE-DEBUGGER-COMMAND. - -(defmacro define-debugger-command (name doc cmd &key uses-argument) - `(defcommand ,(concatenate 'simple-string "Debug " name) (p) - ,doc ,doc - ,@(if uses-argument - nil - '((declare (ignore p)))) - (let* ((server-info (get-current-eval-server t)) - (wire (server-info-wire server-info))) - (wire:remote wire - (ts-stream-accept-input - (ts-data-stream (server-info-slave-info server-info)) - ,(if uses-argument - `(list ,cmd p) - cmd))) - (wire:wire-force-output wire)))) - - - - -;;;; Frame changing commands. - -(define-debugger-command "Up" - "Moves the \"Current Eval Server\" up one debugger frame." - :up) - -(define-debugger-command "Down" - "Moves the \"Current Eval Server\" down one debugger frame." - :down) - -(define-debugger-command "Top" - "Moves the \"Current Eval Server\" to the top of the debugging stack." - :top) - -(define-debugger-command "Bottom" - "Moves the \"Current Eval Server\" to the bottom of the debugging stack." - :bottom) - -(define-debugger-command "Frame" - "Moves the \"Current Eval Server\" to the absolute debugger frame number - indicated by the prefix argument." - :frame - :uses-argument t) - - - - -;;;; In and Out commands. - -(define-debugger-command "Quit" - "In the \"Current Eval Server\", throws to top level out of the debugger." - :quit) - -(define-debugger-command "Go" - "In the \"Current Eval Server\", tries the CONTINUE restart." - :go) - -(define-debugger-command "Abort" - "In the \"Current Eval Server\", execute the previous ABORT restart." - :abort) - -(define-debugger-command "Restart" - "In the \"Current Eval Server\", executes the restart indicated by the - prefix argument." - :restart - :uses-argument t) - - - - -;;;; Information commands. - -(define-debugger-command "Help" - "In the \"Current Eval Server\", prints the debugger's help text." - :help) - -(define-debugger-command "Error" - "In the \"Current Eval Server\", print the error condition and restart cases - upon entering the debugger." - :error) - -(define-debugger-command "Backtrace" - "Executes the debugger's BACKTRACE command." - :backtrace) - -(define-debugger-command "Print" - "In the \"Current Eval Server\", prints a representation of the debugger's - current frame." - :print) - -(define-debugger-command "Verbose Print" - "In the \"Current Eval Server\", prints a representation of the debugger's - current frame without elipsis." - :vprint) - -(define-debugger-command "List Locals" - "In the \"Current Eval Server\", prints the local variables for the debugger's - current frame." - :list-locals) - -(define-debugger-command "Source" - "In the \"Current Eval Server\", prints the source form for the debugger's - current frame." - :source) - -(define-debugger-command "Verbose Source" - "In the \"Current Eval Server\", prints the source form for the debugger's - current frame with surrounding forms for context." - :vsource) - - - - -;;;; Source editing. - -;;; "Debug Edit Source" -- Command. -;;; -;;; The :edit-source command in the slave debugger initiates a synchronous RPC -;;; into the editor via the wire in *terminal-io*, a typescript stream. This -;;; routine takes the necessary values, a file and source-path, and changes the -;;; editor's state to display that location. -;;; -;;; This command has to wait on SERVE-EVENT until some special is set by the -;;; RPC routine saying it is okay to return to the editor's top level. -;;; -(defvar *debug-editor-source-data* nil) -(defvar *in-debug-edit-source* nil) - -(defcommand "Debug Edit Source" (p) - "Given the \"Current Eval Server\"'s current debugger frame, place the user - at the location's source in the editor." - "Given the \"Current Eval Server\"'s current debugger frame, place the user - at the location's source in the editor." - (declare (ignore p)) - (let* ((server-info (get-current-eval-server t)) - (wire (server-info-wire server-info))) - ;; - ;; Tell the slave to tell the editor some source info. - (wire:remote wire - (ts-stream-accept-input - (ts-data-stream (server-info-slave-info server-info)) - :edit-source)) - (wire:wire-force-output wire) - ;; - ;; Wait for the source info. - (let ((*debug-editor-source-data* nil) - (*in-debug-edit-source* t)) - (catch 'blow-debug-edit-source - (loop - (system:serve-event) - (when *debug-editor-source-data* (return))))))) - -;;; EDIT-SOURCE-LOCATION -- Internal Interface. -;;; -;;; The slave calls this in the editor when the debugger gets an :edit-source -;;; command. This receives the information necessary to take the user in -;;; Hemlock to the source location, and does it. -;;; -(defun edit-source-location (name source-created-date tlf-offset - local-tlf-offset char-offset form-number) - (let ((pn (pathname name))) - (unless (probe-file pn) - (editor-error "Source file no longer exists: ~A." name)) - (multiple-value-bind (buffer newp) (find-file-buffer pn) - (let ((date (buffer-write-date buffer)) - (point (buffer-point buffer))) - (when newp (push-buffer-mark (copy-mark point) nil)) - (buffer-start point) - ;; - ;; Get to the top-level form in the buffer. - (cond ((buffer-modified buffer) - (loud-message "Buffer has been modified. Using form offset ~ - instead of character position.") - (dotimes (i local-tlf-offset) - (pre-command-parse-check point) - (form-offset point 1))) - ((not date) - (loud-message "Cannot compare write dates. Assuming source ~ - has not been modified -- ~A." - name) - (character-offset point char-offset)) - ((= source-created-date date) - (character-offset point char-offset)) - (t - (loud-message "File has been modified since reading the source. ~ - Using form offset instead of character position.") - (dotimes (i local-tlf-offset) - (pre-command-parse-check point) - (form-offset point 1)))) - ;; - ;; Read our form, get form-number translations, get the source-path, - ;; and make it usable. - ;; - ;; NOTE: Here READ is used in the editor lisp to look at a form - ;; that the compiler has digested in the slave lisp. The editor - ;; does not have the same environment at the slave so bad things - ;; can happen if READ hits a #. reader macro (like unknown package - ;; or undefined function errors) which can break the editor. This - ;; code basically inhibits the read-time eval. This doesn't always - ;; work right as the compiler may be seeing a different form structure - ;; and the compiler's version of PATH may not match the editor's. - ;; The main trouble seen in testing is that the 'form-number' - ;; supplied by the compiler was one more than what the vector - ;; returned by form-number-translations contained. For lack of a - ;; better solution, I (pw) just limit the form-number to legal range. - ;; This has worked ok on test code but may be off for some - ;; forms. At least the editor won't break. - - (let* ((vector (di:form-number-translations - (with-input-from-region - (s (region point (buffer-end-mark buffer))) - (let ((*read-suppress* t)) - (read s))) - tlf-offset)) - ;; Don't signal error on index overrun.It may be due - ;; to read-time eval getting form editing blind to - ;; editor - (index (min form-number (1- (length vector)))) - (path (nreverse (butlast (cdr (svref vector index)))))) - ;; - ;; Walk down to the form. Change to buffer in case we get an error - ;; while finding the form. - (change-to-buffer buffer) - (mark-to-debug-source-path point path))))) - (setf *debug-editor-source-data* t) - ;; - ;; While Hemlock was setting up the source edit, the user could have typed - ;; while looking at a buffer no longer current when the commands execute. - (clear-editor-input *editor-input*)) - -;;; CANNOT-EDIT-SOURCE-LOCATION -- Interface. -;;; -;;; The slave calls this when the debugger command "EDIT-SOURCE" runs, and the -;;; slave cannot give the editor source information. -;;; -(defun cannot-edit-source-location () - (loud-message "Can't edit source.") - (when *in-debug-edit-source* - (throw 'blow-debug-edit-source nil))) - - - -;;;; Breakpoints. - -;;; -;;; Breakpoint information for editor management. -;;; - -;;; This holds all the stuff we might want to know about a breakpoint in some -;;; slave. -;;; -(defstruct (breakpoint-info (:print-function print-breakpoint-info) - (:constructor make-breakpoint-info - (slave buffer remote-object name))) - (slave nil :type server-info) - (buffer nil :type buffer) - (remote-object nil :type wire:remote-object) - (name nil :type simple-string)) -;;; -(defun print-breakpoint-info (obj str n) - (declare (ignore n)) - (format str "#" (breakpoint-info-name obj))) - -(defvar *breakpoints* nil) - -(macrolet ((frob (name accessor) - `(defun ,name (key) - (let ((res nil)) - (dolist (bpt-info *breakpoints* res) - (when (eq (,accessor bpt-info) key) - (push bpt-info res))))))) - (frob slave-breakpoints breakpoint-info-slave) - (frob buffer-breakpoints breakpoint-info-buffer)) - -(defun delete-breakpoints-buffer-hook (buffer) - (let ((server-info (value current-eval-server))) - (when server-info - (let ((bpts (buffer-breakpoints buffer)) - (wire (server-info-wire server-info))) - (dolist (b bpts) - (setf *breakpoints* (delete b *breakpoints*)) - (when wire - (wire:remote wire - (di:delete-breakpoint (breakpoint-info-remote-object b)))) - (when wire - (wire:wire-force-output wire))))))) -;;; -(add-hook delete-buffer-hook 'delete-breakpoints-buffer-hook) - -;;; -;;; Setting breakpoints. -;;; - -;;; "Debug Breakpoint" uses this to prompt for :function-end and -;;; :function-start breakpoints. -;;; -(defvar *function-breakpoint-strings* - (make-string-table :initial-contents - '(("Start" . :function-start) ("End" . :function-end)))) -;;; -;;; Maybe this should use the wire level directly and hold onto remote-objects -;;; identifying the breakpoints. Then we could write commands to show where -;;; the breakpoints were and to individually deactivate or delete them. As it -;;; is now we probably have to delete all for a given function. What about -;;; setting user supplied breakpoint hook-functions, or Hemlock supplying a -;;; nice set such as something to simply print all locals at a certain -;;; location. -;;; -(defcommand "Debug Breakpoint" (p) - "This tries to set a breakpoint in the \"Current Eval Server\" at the - location designated by the current point. If there is no known code - location at the point, then this moves the point to the closest location - before the point. With an argument, this sets a breakpoint at the start - or end of the function, prompting the user for which one to use." - "This tries to set a breakpoint in the \"Current Eval Server\" at the - location designated by the current point. If there is no known code - location at the point, then this moves the point to the closest location - before the point. With an argument, this sets a breakpoint at the start - or end of the function, prompting the user for which one to use." - (let ((point (current-point))) - (pre-command-parse-check point) - (let ((name (find-defun-for-breakpoint point))) - (if p - (multiple-value-bind (str place) - (prompt-for-keyword - (list *function-breakpoint-strings*) - :prompt "Set breakpoint at function: " - :default :start :default-string "Start") - (declare (ignore str)) - (set-breakpoint-in-slave (get-current-eval-server t) name place)) - (let* ((path (find-path-for-breakpoint point)) - (server-info (get-current-eval-server t)) - (res (set-breakpoint-in-slave server-info name path))) - (cond ((not res) - (message "No code locations correspond with point.")) - ((wire:remote-object-p res) - (push (make-breakpoint-info server-info (current-buffer) - res name) - *breakpoints*) - (message "Breakpoint set.")) - (t - (resolve-ambiguous-breakpoint-location server-info - name res)))))))) - -;;; FIND-PATH-FOR-BREAKPOINT -- Internal. -;;; -;;; This walks up from point to the beginning of its containing DEFUN to return -;;; the pseudo source-path (no form-number, no top-level form offset, and in -;;; descent order from start of the DEFUN). -;;; -(defun find-path-for-breakpoint (point) - (with-mark ((m point) - (end point)) - (let ((path nil)) - (top-level-offset end -1) - (with-mark ((containing-form m)) - (loop - (when (mark= m end) (return)) - (backward-up-list containing-form) - (do ((count 0 (1+ count))) - ((mark= m containing-form) - ;; Count includes moving from the first form inside the - ;; containing-form paren to the outside of the containing-form - ;; paren -- one too many. - (push (1- count) path)) - (form-offset m -1)))) - path))) - -;;; SET-BREAKPOINT-IN-SLAVE -- Internal. -;;; -;;; This tells the slave to set a breakpoint for name. Path is a modified -;;; source-path (with no form-number or top-level-form offset) or a symbol -;;; (:function-start or :function-end). If the server dies while evaluating -;;; form, then this signals an editor-error. -;;; -(defun set-breakpoint-in-slave (server-info name path) - (when (server-info-notes server-info) - (editor-error "Server ~S is currently busy. See \"List Operations\"." - (server-info-name server-info))) - (multiple-value-bind (res error) - (wire:remote-value (server-info-wire server-info) - (di:set-breakpoint-for-editor (value current-package) - name path)) - (when error (editor-error "The server died before finishing.")) - res)) - -;;; RESOLVE-AMBIGUOUS-BREAKPOINT-LOCATION -- Internal. -;;; -;;; This helps the user select an ambiguous code location for "Debug -;;; Breakpoint". -;;; -(defun resolve-ambiguous-breakpoint-location (server-info name locs) - (declare (list locs)) - (let ((point (current-point)) - (loc-num (length locs)) - (count 1) - (cur-loc locs)) - (flet ((show-loc () - (top-level-offset point -1) - (mark-to-debug-source-path point (cdar cur-loc)))) - (show-loc) - (command-case (:prompt `("Ambiguous location ~D of ~D: " ,count ,loc-num) - :help "Pick a location to set a breakpoint." - :change-window nil) - (#\space "Move point to next possible location." - (setf cur-loc (cdr cur-loc)) - (cond (cur-loc - (incf count)) - (t - (setf cur-loc locs) - (setf count 1))) - (show-loc) - (reprompt)) - (:confirm "Choose the current location." - (let ((res (wire:remote-value (server-info-wire server-info) - (di:set-location-breakpoint-for-editor (caar cur-loc))))) - (unless (wire:remote-object-p res) - (editor-error "Couldn't set breakpoint from location?")) - (push (make-breakpoint-info server-info (current-buffer) res name) - *breakpoints*)) - (message "Breakpoint set.")))))) - -;;; MARK-TO-DEBUG-SOURCE-PATH -- Internal. -;;; -;;; This takes a mark at the beginning of a top-level form and modified debugger -;;; source-path. Path has no form number or top-level-form offset element, and -;;; it has been reversed to actually be usable. -;;; -(defun mark-to-debug-source-path (mark path) - (let ((quote-or-function nil)) - (pre-command-parse-check mark) - (dolist (n path) - (when quote-or-function - (editor-error - "Apparently settled on the symbol QUOTE or FUNCTION via their ~ - read macros, which is odd, but furthermore there seems to be ~ - more source-path left.")) - (unless (form-offset mark 1) - ;; Want to use the following and delete the next FORM-OFFSET -1. - ;; (scan-direction-valid mark t (or :open-paren :prefix)) - (editor-error - "Ran out of text in buffer with more source-path remaining.")) - (form-offset mark -1) - (ecase (next-character mark) - (#\( - (mark-after mark) - (form-offset mark n)) - (#\' - (case n - (0 (setf quote-or-function t)) - (1 (mark-after mark)) - (t (editor-error "Next form is QUOTE, but source-path index ~ - is other than zero or one.")))) - (#\# - (case (next-character (mark-after mark)) - (#\' - (case n - (0 (setf quote-or-function t)) - (1 (mark-after mark)) - (t (editor-error "Next form is FUNCTION, but source-path ~ - index is other than zero or one.")))) - (t (editor-error - "Can only parse ' and #' read macros.")))))) - ;; Get to the beginning of the form. - (form-offset mark 1) - (form-offset mark -1))) - -;;; -;;; Deleting breakpoints. -;;; - -(defhvar "Delete Breakpoints Confirm" - "This determines whether \"Debug Delete Breakpoints\" should ask for - confirmation before deleting breakpoints." - :value t) - -(defcommand "Debug Delete Breakpoints" (p) - "This deletes all breakpoints for the named DEFUN containing the point. - This affects the \"Current Eval Server\"." - "This deletes all breakpoints for the named DEFUN containing the point. - This affects the \"Current Eval Server\"." - (declare (ignore p)) - (let* ((server-info (get-current-eval-server t)) - (wire (server-info-wire server-info)) - (name (find-defun-for-breakpoint (current-point))) - (bpts (slave-breakpoints server-info))) - (cond ((not bpts) - (message "No breakpoints recorded for ~A." name)) - ((or (not (value delete-breakpoints-confirm)) - (prompt-for-y-or-n :prompt `("Delete breakpoints for ~A? " ,name) - :default t - :default-string "Y")) - (dolist (b bpts) - (when (string= name (breakpoint-info-name b)) - (setf *breakpoints* (delete b *breakpoints*)) - (wire:remote wire - (di:delete-breakpoint-for-editor - (breakpoint-info-remote-object b))))) - (wire:wire-force-output wire))))) - -;;; -;;; Breakpoint utilities. -;;; - -;;; FIND-DEFUN-FOR-BREAKPOINT -- Internal. -;;; -;;; This returns as a string the name of the DEFUN containing point. It -;;; signals any errors necessary to ensure "we are in good form". -;;; -(defun find-defun-for-breakpoint (point) - (with-mark ((m1 point) - (m2 point)) - (unless (top-level-offset m2 -1) - (editor-error "Must be inside a DEFUN.")) - ;; - ;; Check for DEFUN. - (mark-after (move-mark m1 m2)) - (unless (find-attribute m1 :whitespace #'zerop) - (editor-error "Must be inside a DEFUN.")) - (word-offset (move-mark m2 m1) 1) - (unless (string-equal (region-to-string (region m1 m2)) "defun") - (editor-error "Must be inside a DEFUN.")) - ;; - ;; Find name. - (unless (find-attribute m2 :whitespace #'zerop) - (editor-error "Function unnamed?")) - (form-offset (move-mark m1 m2) 1) - (region-to-string (region m2 m1)))) - - - - -;;;; Miscellaneous commands. - -(define-debugger-command "Flush Errors" - "In the \"Current Eval Server\", toggles whether the debugger ignores errors - or recursively enters itself." - :flush) Index: anches/ide-1.0/ccl/hemlock/src/dired.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/dired.lisp (revision 6566) +++ (revision ) @@ -1,701 +1,0 @@ -;;; -*- Log: hemlock.log; Package: dired -*- -;;; -;;; ********************************************************************** -;;; This code was written as part of the CMU Common Lisp project at -;;; Carnegie Mellon University, and has been placed in the public domain. -;;; -#+CMU (ext:file-comment - "$Header$") -;;; -;;; ********************************************************************** -;;; -;;; This file contains site dependent code for dired. -;;; Written by Bill Chiles. -;;; - -(defpackage "DIRED" - (:shadow "RENAME-FILE" "DELETE-FILE") - (:export "COPY-FILE" "RENAME-FILE" "FIND-FILE" "DELETE-FILE" - "MAKE-DIRECTORY" - "*UPDATE-DEFAULT*" "*CLOBBER-DEFAULT*" "*RECURSIVE-DEFAULT*" - "*REPORT-FUNCTION*" "*ERROR-FUNCTION*" "*YESP-FUNCTION*" - "PATHNAMES-FROM-PATTERN")) - -(in-package "DIRED") - - - -;;;; Exported parameters. - -(defparameter *update-default* nil - "Update arguments to utilities default to this value.") - -(defparameter *clobber-default* t - "Clobber arguments to utilities default to this value.") - -(defparameter *recursive-default* nil - "Recursive arguments to utilities default to this value.") - - - - -;;;; WILDCARDP - -(defconstant wildcard-char #\* - "Wildcard designator for file names will match any substring.") - -(defmacro wildcardp (file-namestring) - `(position wildcard-char (the simple-string ,file-namestring) :test #'char=)) - - - - -;;;; User interaction functions, variable declarations, and their defaults. - -(defun default-error-function (string &rest args) - (apply #'error string args)) -;;; -(defvar *error-function* #'default-error-function - "This function is called when an error is encountered in dired code.") - -(defun default-report-function (string &rest args) - (apply #'format t string args)) -;;; -(defvar *report-function* #'default-report-function - "This function is called when the user needs to be informed of something.") - -(defun default-yesp-function (string &rest args) - (apply #'format t string args) - (let ((answer (nstring-downcase (string-trim '(#\space #\tab) (read-line))))) - (declare (simple-string answer)) - (or (string= answer "") - (string= answer "y") - (string= answer "yes") - (string= answer "ye")))) -;;; -(defvar *yesp-function* #'default-yesp-function - "Function to query the user about clobbering an already existent file.") - - - - -;;;; Copy-File - -;;; WILD-MATCH objects contain information about wildcard matches. File is the -;;; Sesame namestring of the file matched, and substitute is a substring of the -;;; file-namestring of file. -;;; -(defstruct (wild-match (:print-function print-wild-match) - (:constructor make-wild-match (file substitute))) - file - substitute) - -(defun print-wild-match (obj str n) - (declare (ignore n)) - (format str "#" - (wild-match-file obj) (wild-match-substitute obj))) - - -(defun copy-file (spec1 spec2 &key (update *update-default*) - (clobber *clobber-default*) - (directory () directoryp)) - "Copy file spec1 to spec2. A single wildcard is acceptable, and directory - names may be used. If spec1 and spec2 are both directories, then a - recursive copy is done of the files and subdirectory structure of spec1; - if spec2 is in the subdirectory structure of spec1, the recursion will - not descend into it. Use spec1/* to copy only the files in spec1 to - directory spec2. If spec2 is a directory, and spec1 is a file, then - spec1 is copied into spec2 with the same pathname-name. Files are - copied maintaining the source's write date. If :update is non-nil, then - files are only copied if the source is newer than the destination, still - maintaining the source's write date; the user is not warned if the - destination is newer (not the same write date) than the source. If - :clobber and :update are nil, then if any file spec2 already exists, the - user will be asked whether it should be overwritten or not." - (cond - ((not directoryp) - (let* ((ses-name1 (ext:unix-namestring spec1 t)) - (exists1p (unix:unix-file-kind ses-name1)) - (ses-name2 (ext:unix-namestring spec2 nil)) - (pname1 (pathname ses-name1)) - (pname2 (pathname ses-name2)) - (dirp1 (directoryp pname1)) - (dirp2 (directoryp pname2)) - (wildp1 (wildcardp (file-namestring pname1))) - (wildp2 (wildcardp (file-namestring pname2)))) - (when (and dirp1 wildp1) - (funcall *error-function* - "Cannot have wildcards in directory names -- ~S." pname1)) - (when (and dirp2 wildp2) - (funcall *error-function* - "Cannot have wildcards in directory names -- ~S." pname2)) - (when (and dirp1 (not dirp2)) - (funcall *error-function* - "Cannot handle spec1 being a directory and spec2 a file.")) - (when (and wildp2 (not wildp1)) - (funcall *error-function* - "Cannot handle destination having wildcards without ~ - source having wildcards.")) - (when (and wildp1 (not wildp2) (not dirp2)) - (funcall *error-function* - "Cannot handle source with wildcards and destination ~ - without, unless destination is a directory.")) - (cond ((and dirp1 dirp2) - (unless (directory-existsp ses-name1) - (funcall *error-function* - "Directory does not exist -- ~S." pname1)) - (unless (directory-existsp ses-name2) - (enter-directory ses-name2)) - (recursive-copy pname1 pname2 update clobber pname2 - ses-name1 ses-name2)) - (dirp2 - ;; merge pname2 with pname1 to pick up a similar file-namestring. - (copy-file-1 pname1 wildp1 exists1p - (merge-pathnames pname2 pname1) - wildp1 update clobber)) - (t (copy-file-1 pname1 wildp1 exists1p - pname2 wildp2 update clobber))))) - (directory - (when (pathname-directory spec1) - (funcall *error-function* - "Spec1 is just a pattern when supplying directory -- ~S." - spec1)) - (let* ((pname2 (pathname (ext:unix-namestring spec2 nil))) - (dirp2 (directoryp pname2)) - (wildp1 (wildcardp spec1)) - (wildp2 (wildcardp (file-namestring pname2)))) - (unless wildp1 - (funcall *error-function* - "Pattern, ~S, does not contain a wildcard." - spec1)) - (when (and (not wildp2) (not dirp2)) - (funcall *error-function* - "Cannot handle source with wildcards and destination ~ - without, unless destination is a directory.")) - (copy-wildcard-files spec1 wildp1 - (if dirp2 (merge-pathnames pname2 spec1) pname2) - (if dirp2 wildp1 wildp2) - update clobber directory)))) - (values)) - -;;; RECURSIVE-COPY takes two pathnames that represent directories, and -;;; the files in pname1 are copied into pname2, recursively descending into -;;; subdirectories. If a subdirectory of pname1 does not exist in pname2, -;;; it is created. Pname1 is known to exist. Forbidden-dir is originally -;;; the same as pname2; this keeps us from infinitely recursing if pname2 -;;; is in the subdirectory structure of pname1. Returns t if some file gets -;;; copied. -;;; -(defun recursive-copy (pname1 pname2 update clobber - forbidden-dir ses-name1 ses-name2) - (funcall *report-function* "~&~S ==>~% ~S~%" ses-name1 ses-name2) - (dolist (spec (directory (directory-namestring pname1))) - (let ((spec-ses-name (namestring spec))) - (if (directoryp spec) - (unless (equal (pathname spec-ses-name) forbidden-dir) - (let* ((dir2-pname (merge-dirs spec pname2)) - (dir2-ses-name (namestring dir2-pname))) - (unless (directory-existsp dir2-ses-name) - (enter-directory dir2-ses-name)) - (recursive-copy spec dir2-pname update clobber forbidden-dir - spec-ses-name dir2-ses-name) - (funcall *report-function* "~&~S ==>~% ~S~%" ses-name1 - ses-name2))) - (copy-file-2 spec-ses-name - (namestring (merge-pathnames pname2 spec)) - update clobber))))) - -;;; MERGE-DIRS picks out the last directory name in the pathname pname1 and -;;; adds it to the end of the sequence of directory names from pname2, returning -;;; a pathname. -;;; -#| -(defun merge-dirs (pname1 pname2) - (let* ((dirs1 (pathname-directory pname1)) - (dirs2 (pathname-directory pname2)) - (dirs2-len (length dirs2)) - (new-dirs2 (make-array (1+ dirs2-len)))) - (declare (simple-vector dirs1 dirs2 new-dirs2)) - (replace new-dirs2 dirs2) - (setf (svref new-dirs2 dirs2-len) - (svref dirs1 (1- (length dirs1)))) - (make-pathname :directory new-dirs2 :device :absolute))) -|# - -(defun merge-dirs (pname1 pname2) - (let* ((dirs1 (pathname-directory pname1)) - (dirs2 (pathname-directory pname2)) - (dirs2-len (length dirs2)) - (new-dirs2 (make-list (1+ dirs2-len)))) - (replace new-dirs2 dirs2) - (setf (nth dirs2-len new-dirs2) - (nth (1- (length dirs1)) dirs1)) - (make-pathname :directory new-dirs2 :device :unspecific))) - -;;; COPY-FILE-1 takes pathnames which either both contain a single wildcard -;;; or none. Wildp1 and Wildp2 are either nil or indexes into the -;;; file-namestring of pname1 and pname2, respectively, indicating the position -;;; of the wildcard character. If there is no wildcard, then simply call -;;; COPY-FILE-2; otherwise, resolve the wildcard and copy those matching files. -;;; -(defun copy-file-1 (pname1 wildp1 exists1p pname2 wildp2 update clobber) - (if wildp1 - (copy-wildcard-files pname1 wildp1 pname2 wildp2 update clobber) - (let ((ses-name1 (namestring pname1))) - (unless exists1p (funcall *error-function* - "~S does not exist." ses-name1)) - (copy-file-2 ses-name1 (namestring pname2) update clobber)))) - -(defun copy-wildcard-files (pname1 wildp1 pname2 wildp2 update clobber - &optional directory) - (multiple-value-bind (dst-before dst-after) - (before-wildcard-after (file-namestring pname2) wildp2) - (dolist (match (resolve-wildcard pname1 wildp1 directory)) - (copy-file-2 (wild-match-file match) - (namestring (concatenate 'simple-string - (directory-namestring pname2) - dst-before - (wild-match-substitute match) - dst-after)) - update clobber)))) - -;;; COPY-FILE-2 copies ses-name1 to ses-name2 depending on the values of update -;;; and clobber, with respect to the documentation of COPY-FILE. If ses-name2 -;;; doesn't exist, then just copy it; otherwise, if update, then only copy it -;;; if the destination's write date precedes the source's, and if not clobber -;;; and not update, then ask the user before doing the copy. -;;; -(defun copy-file-2 (ses-name1 ses-name2 update clobber) - (let ((secs1 (get-write-date ses-name1))) - (cond ((not (probe-file ses-name2)) - (do-the-copy ses-name1 ses-name2 secs1)) - (update - (let ((secs2 (get-write-date ses-name2))) - (cond (clobber - (do-the-copy ses-name1 ses-name2 secs1)) - ((and (> secs2 secs1) - (funcall *yesp-function* - "~&~S ==> ~S~% ~ - ** Destination is newer than source. ~ - Overwrite it? " - ses-name1 ses-name2)) - (do-the-copy ses-name1 ses-name2 secs1)) - ((< secs2 secs1) - (do-the-copy ses-name1 ses-name2 secs1))))) - ((not clobber) - (when (funcall *yesp-function* - "~&~S ==> ~S~% ** Destination already exists. ~ - Overwrite it? " - ses-name1 ses-name2) - (do-the-copy ses-name1 ses-name2 secs1))) - (t (do-the-copy ses-name1 ses-name2 secs1))))) - -(defun do-the-copy (ses-name1 ses-name2 secs1) - (let* ((fd (open-file ses-name1))) - (unwind-protect - (multiple-value-bind (data byte-count mode) - (read-file fd ses-name1) - (unwind-protect (write-file ses-name2 data byte-count mode) - (system:deallocate-system-memory data byte-count))) - (close-file fd))) - (set-write-date ses-name2 secs1) - (funcall *report-function* "~&~S ==>~% ~S~%" ses-name1 ses-name2)) - - - -;;;; Rename-File - -(defun rename-file (spec1 spec2 &key (clobber *clobber-default*) - (directory () directoryp)) - "Rename file spec1 to spec2. A single wildcard is acceptable, and spec2 may - be a directory with the result spec being the merging of spec2 with spec1. - If clobber is nil and spec2 exists, then the user will be asked to confirm - the renaming. As with Unix mv, if you are renaming a directory, don't - specify the trailing slash." - (cond - ((not directoryp) - (let* ((ses-name1 (ext:unix-namestring spec1 t)) - (exists1p (unix:unix-file-kind ses-name1)) - (ses-name2 (ext:unix-namestring spec2 nil)) - (pname1 (pathname ses-name1)) - (pname2 (pathname ses-name2)) - (dirp2 (directoryp pname2)) - (wildp1 (wildcardp (file-namestring pname1))) - (wildp2 (wildcardp (file-namestring pname2)))) - (if (and dirp2 wildp2) - (funcall *error-function* - "Cannot have wildcards in directory names -- ~S." pname2)) - (if (and wildp2 (not wildp1)) - (funcall *error-function* - "Cannot handle destination having wildcards without ~ - source having wildcards.")) - (if (and wildp1 (not wildp2) (not dirp2)) - (funcall *error-function* - "Cannot handle source with wildcards and destination ~ - without, unless destination is a directory.")) - (if dirp2 - (rename-file-1 pname1 wildp1 exists1p (merge-pathnames pname2 - pname1) - wildp1 clobber) - (rename-file-1 pname1 wildp1 exists1p pname2 wildp2 clobber)))) - (directory - (when (pathname-directory spec1) - (funcall *error-function* - "Spec1 is just a pattern when supplying directory -- ~S." - spec1)) - - (let* ((pname2 (pathname (ext:unix-namestring spec2 nil))) - (dirp2 (directoryp pname2)) - (wildp1 (wildcardp spec1)) - (wildp2 (wildcardp (file-namestring pname2)))) - (unless wildp1 - (funcall *error-function* - "Pattern, ~S, does not contain a wildcard." - spec1)) - (when (and (not wildp2) (not dirp2)) - (funcall *error-function* - "Cannot handle source with wildcards and destination ~ - without, unless destination is a directory.")) - (rename-wildcard-files spec1 wildp1 - (if dirp2 (merge-pathnames pname2 spec1) pname2) - (if dirp2 wildp1 wildp2) - clobber directory)))) - (values)) - -;;; RENAME-FILE-1 takes pathnames which either both contain a single wildcard -;;; or none. Wildp1 and Wildp2 are either nil or indexes into the -;;; file-namestring of pname1 and pname2, respectively, indicating the position -;;; of the wildcard character. If there is no wildcard, then simply call -;;; RENAME-FILE-2; otherwise, resolve the wildcard and rename those matching files. -;;; -(defun rename-file-1 (pname1 wildp1 exists1p pname2 wildp2 clobber) - (if wildp1 - (rename-wildcard-files pname1 wildp1 pname2 wildp2 clobber) - (let ((ses-name1 (namestring pname1))) - (unless exists1p (funcall *error-function* - "~S does not exist." ses-name1)) - (rename-file-2 ses-name1 (namestring pname2) clobber)))) - -(defun rename-wildcard-files (pname1 wildp1 pname2 wildp2 clobber - &optional directory) - (multiple-value-bind (dst-before dst-after) - (before-wildcard-after (file-namestring pname2) wildp2) - (dolist (match (resolve-wildcard pname1 wildp1 directory)) - (rename-file-2 (wild-match-file match) - (namestring (concatenate 'simple-string - (directory-namestring pname2) - dst-before - (wild-match-substitute match) - dst-after)) - clobber)))) - -(defun rename-file-2 (ses-name1 ses-name2 clobber) - (cond ((and (probe-file ses-name2) (not clobber)) - (when (funcall *yesp-function* - "~&~S ==> ~S~% ** Destination already exists. ~ - Overwrite it? " - ses-name1 ses-name2) - (sub-rename-file ses-name1 ses-name2) - (funcall *report-function* "~&~S ==>~% ~S~%" ses-name1 ses-name2))) - (t (sub-rename-file ses-name1 ses-name2) - (funcall *report-function* "~&~S ==>~% ~S~%" ses-name1 ses-name2)))) - - - - -;;;; Find-File - -(defun find-file (file-name &optional (directory "") - (find-all-p nil find-all-suppliedp)) - "Find the file with file-namestring file recursively looking in directory. - If find-all-p is non-nil, then do not stop searching upon finding the first - occurance of file. File may contain a single wildcard, which causes - find-all-p to default to t instead of nil." - (let* ((file (coerce file-name 'simple-string)) - (wildp (wildcardp file)) - (find-all-p (if find-all-suppliedp find-all-p wildp))) - (declare (simple-string file)) - (catch 'found-file - (if wildp - (multiple-value-bind (before after) - (before-wildcard-after file wildp) - (find-file-aux file directory find-all-p before after)) - (find-file-aux file directory find-all-p)))) - (values)) - -(defun find-file-aux (the-file directory find-all-p &optional before after) - (declare (simple-string the-file)) - (dolist (spec (directory directory)) - (let* ((spec-ses-name (namestring spec)) - (spec-file-name (file-namestring spec-ses-name))) - (declare (simple-string spec-ses-name spec-file-name)) - (if (directoryp spec) - (find-file-aux the-file spec find-all-p before after) - (when (if before - (find-match before after spec-file-name :no-cons) - (string-equal the-file spec-file-name)) - (print spec-ses-name) - (unless find-all-p (throw 'found-file t))))))) - - - - -;;;; Delete-File - -;;; DELETE-FILE -;;; If spec is a directory, but recursive is nil, just pass the directory -;;; down through, letting LISP:DELETE-FILE signal an error if the directory -;;; is not empty. -;;; -(defun delete-file (spec &key (recursive *recursive-default*) - (clobber *clobber-default*)) - "Delete spec asking confirmation on each file if clobber is nil. A single - wildcard is acceptable. If recursive is non-nil, then a directory spec may - be given to recursively delete the entirety of the directory and its - subdirectory structure. An empty directory may be specified without - recursive being non-nil. When specifying a directory, the trailing slash - must be included." - (let* ((ses-name (ext:unix-namestring spec t)) - (pname (pathname ses-name)) - (wildp (wildcardp (file-namestring pname))) - (dirp (directoryp pname))) - (if dirp - (if recursive - (recursive-delete pname ses-name clobber) - (delete-file-2 ses-name clobber)) - (delete-file-1 pname ses-name wildp clobber))) - (values)) - -(defun recursive-delete (directory dir-ses-name clobber) - (dolist (spec (directory (directory-namestring directory))) - (let ((spec-ses-name (namestring spec))) - (if (directoryp spec) - (recursive-delete (pathname spec-ses-name) spec-ses-name clobber) - (delete-file-2 spec-ses-name clobber)))) - (delete-file-2 dir-ses-name clobber)) - -(defun delete-file-1 (pname ses-name wildp clobber) - (if wildp - (dolist (match (resolve-wildcard pname wildp)) - (delete-file-2 (wild-match-file match) clobber)) - (delete-file-2 ses-name clobber))) - -(defun delete-file-2 (ses-name clobber) - (when (or clobber (funcall *yesp-function* "~&Delete ~S? " ses-name)) - (if (directoryp ses-name) - (delete-directory ses-name) - (lisp:delete-file ses-name)) - (funcall *report-function* "~&~A~%" ses-name))) - - - - -;;;; Wildcard resolution - -(defun pathnames-from-pattern (pattern files) - "Return a list of pathnames from files whose file-namestrings match - pattern. Pattern must be a non-empty string and contains only one - asterisk. Files contains no directories." - (declare (simple-string pattern)) - (when (string= pattern "") - (funcall *error-function* "Must be a non-empty pattern.")) - (unless (= (count wildcard-char pattern :test #'char=) 1) - (funcall *error-function* "Pattern must contain one asterisk.")) - (multiple-value-bind (before after) - (before-wildcard-after pattern (wildcardp pattern)) - (let ((result nil)) - (dolist (f files result) - (let* ((ses-namestring (namestring f)) - (f-namestring (file-namestring ses-namestring)) - (match (find-match before after f-namestring))) - (when match (push f result))))))) - - -;;; RESOLVE-WILDCARD takes a pathname with a wildcard and the position of the -;;; wildcard character in the file-namestring and returns a list of wild-match -;;; objects. When directory is supplied, pname is just a pattern, or a -;;; file-namestring. It is an error for directory to be anything other than -;;; absolute pathnames in the same directory. Each wild-match object contains -;;; the Sesame namestring of a file in the same directory as pname, or -;;; directory, and a simple-string representing what the wildcard matched. -;;; -(defun resolve-wildcard (pname wild-pos &optional directory) - (multiple-value-bind (before after) - (before-wildcard-after (if directory - pname - (file-namestring pname)) - wild-pos) - (let (result) - (dolist (f (or directory (directory (directory-namestring pname))) - (nreverse result)) - (unless (directoryp f) - (let* ((ses-namestring (namestring f)) - (f-namestring (file-namestring ses-namestring)) - (match (find-match before after f-namestring))) - (if match - (push (make-wild-match ses-namestring match) result)))))))) - -;;; FIND-MATCH takes a "before wildcard" and "after wildcard" string and a -;;; file-namestring. If before and after match a substring of file-namestring -;;; and are respectively left bound and right bound, then anything left in -;;; between is the match returned. If no match is found, nil is returned. -;;; NOTE: if version numbers ever really exist, then this code will have to be -;;; changed since the file-namestring of a pathname contains the version number. -;;; -(defun find-match (before after file-namestring &optional no-cons) - (declare (simple-string before after file-namestring)) - (let ((before-len (length before)) - (after-len (length after)) - (name-len (length file-namestring))) - (if (>= name-len (+ before-len after-len)) - (let* ((start (if (string= before file-namestring - :end1 before-len :end2 before-len) - before-len)) - (end (- name-len after-len)) - (matchp (and start - (string= after file-namestring :end1 after-len - :start2 end :end2 name-len)))) - (if matchp - (if no-cons - t - (subseq file-namestring start end))))))) - -(defun before-wildcard-after (file-namestring wild-pos) - (declare (simple-string file-namestring)) - (values (subseq file-namestring 0 wild-pos) - (subseq file-namestring (1+ wild-pos) (length file-namestring)))) - - - - -;;;; Miscellaneous Utilities (e.g., MAKEDIR). - -(defun make-directory (name) - "Creates directory name. If name exists, then an error is signaled." - (let ((ses-name (ext:unix-namestring name nil))) - (when (unix:unix-file-kind ses-name) - (funcall *error-function* "Name already exists -- ~S" ses-name)) - (enter-directory ses-name)) - t) - - - - -;;;; Mach Operations - -(defun open-file (ses-name) - (multiple-value-bind (fd err) - (unix:unix-open ses-name unix:o_rdonly 0) - (unless fd - (funcall *error-function* "Opening ~S failed: ~A." ses-name err)) - fd)) - -(defun close-file (fd) - (unix:unix-close fd)) - -(defun read-file (fd ses-name) - (multiple-value-bind (winp dev-or-err ino mode nlink uid gid rdev size) - (unix:unix-fstat fd) - (declare (ignore ino nlink uid gid rdev)) - (unless winp (funcall *error-function* - "Opening ~S failed: ~A." ses-name dev-or-err)) - (let ((storage (system:allocate-system-memory size))) - (multiple-value-bind (read-bytes err) - (unix:unix-read fd storage size) - (when (or (null read-bytes) (not (= size read-bytes))) - (system:deallocate-system-memory storage size) - (funcall *error-function* - "Reading file ~S failed: ~A." ses-name err))) - (values storage size mode)))) - -(defun write-file (ses-name data byte-count mode) - (multiple-value-bind (fd err) (unix:unix-creat ses-name #o644) - (unless fd - (funcall *error-function* "Couldn't create file ~S: ~A" - ses-name (unix:get-unix-error-msg err))) - (multiple-value-bind (winp err) (unix:unix-write fd data 0 byte-count) - (unless winp - (funcall *error-function* "Writing file ~S failed: ~A" - ses-name - (unix:get-unix-error-msg err)))) - (unix:unix-fchmod fd (logand mode #o777)) - (unix:unix-close fd))) - -(defun set-write-date (ses-name secs) - (multiple-value-bind (winp dev-or-err ino mode nlink uid gid rdev size atime) - (unix:unix-stat ses-name) - (declare (ignore ino mode nlink uid gid rdev size)) - (unless winp - (funcall *error-function* "Couldn't stat file ~S failed: ~A." - ses-name dev-or-err)) - (multiple-value-bind (winp err) - (unix:unix-utimes ses-name atime 0 secs 0) - (unless winp - (funcall *error-function* "Couldn't set write date of file ~S: ~A" - ses-name (unix:get-unix-error-msg err)))))) - -(defun get-write-date (ses-name) - (multiple-value-bind (winp dev-or-err ino mode nlink uid gid rdev size - atime mtime) - (unix:unix-stat ses-name) - (declare (ignore ino mode nlink uid gid rdev size atime)) - (unless winp (funcall *error-function* "Couldn't stat file ~S failed: ~A." - ses-name dev-or-err)) - mtime)) - -;;; SUB-RENAME-FILE must exist because we can't use Common Lisp's RENAME-FILE. -;;; This is because it merges the new name with the old name to pick up -;;; defaults, and this conflicts with Unix-oid names. For example, renaming -;;; "foo.bar" to ".baz" causes a result of "foo.baz"! This routine doesn't -;;; have this problem. -;;; -(defun sub-rename-file (ses-name1 ses-name2) - (multiple-value-bind (res err) (unix:unix-rename ses-name1 ses-name2) - (unless res - (funcall *error-function* "Failed to rename ~A to ~A: ~A." - ses-name1 ses-name2 (unix:get-unix-error-msg err))))) - -(defun directory-existsp (ses-name) - (eq (unix:unix-file-kind ses-name) :directory)) - -(defun enter-directory (ses-name) - (declare (simple-string ses-name)) - (let* ((length-1 (1- (length ses-name))) - (name (if (= (position #\/ ses-name :test #'char= :from-end t) - length-1) - (subseq ses-name 0 (1- (length ses-name))) - ses-name))) - (multiple-value-bind (winp err) (unix:unix-mkdir name #o755) - (unless winp - (funcall *error-function* "Couldn't make directory ~S: ~A" - name - (unix:get-unix-error-msg err)))))) - -(defun delete-directory (ses-name) - (declare (simple-string ses-name)) - (multiple-value-bind (winp err) - (unix:unix-rmdir (subseq ses-name 0 - (1- (length ses-name)))) - (unless winp - (funcall *error-function* "Couldn't delete directory ~S: ~A" - ses-name - (unix:get-unix-error-msg err))))) - - - - -;;;; Misc. Utility Utilities - -;;; NSEPARATE-FILES destructively returns a list of file specs from listing. -(defun nseparate-files (listing) - (do (files hold) - ((null listing) files) - (setf hold (cdr listing)) - (unless (directoryp (car listing)) - (setf (cdr listing) files) - (setf files listing)) - (setf listing hold))) - - -(defun directoryp (p) - (not (or (pathname-name p) (pathname-type p)))) Index: anches/ide-1.0/ccl/hemlock/src/diredcoms.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/diredcoms.lisp (revision 6566) +++ (revision ) @@ -1,905 +1,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock -*- -;;; -;;; ********************************************************************** -;;; This code was written as part of the CMU Common Lisp project at -;;; Carnegie Mellon University, and has been placed in the public domain. -;;; -#+CMU (ext:file-comment - "$Header$") -;;; -;;; ********************************************************************** -;;; -;;; Simple directory editing support. -;;; This file contains site dependent calls. -;;; -;;; Written by Blaine Burks and Bill Chiles. -;;; - -(in-package :hemlock) - - -(defmode "Dired" :major-p t - :documentation - "Dired permits convenient directory browsing and file operations including - viewing, deleting, copying, renaming, and wildcard specifications.") - - -(defstruct (dired-information (:print-function print-dired-information) - (:conc-name dired-info-)) - pathname ; Pathname of directory. - pattern ; FILE-NAMESTRING with wildcard possibly. - dot-files-p ; Whether to include UNIX dot files. - write-date ; Write date of directory. - files ; Simple-vector of dired-file structures. - file-list) ; List of pathnames for files, excluding directories. - -(defun print-dired-information (obj str n) - (declare (ignore n)) - (format str "#" (namestring (dired-info-pathname obj)))) - - -(defstruct (dired-file (:print-function print-dired-file) - (:constructor make-dired-file (pathname))) - pathname - (deleted-p nil) - (write-date nil)) - -(defun print-dired-file (obj str n) - (declare (ignore n)) - (format str "#" (namestring (dired-file-pathname obj)))) - - - - -;;;; "Dired" command. - -;;; *pathnames-to-dired-buffers* is an a-list mapping directory namestrings to -;;; buffers that display their contents. -;;; -(defvar *pathnames-to-dired-buffers* ()) - -(make-modeline-field - :name :dired-cmds :width 20 - :function - #'(lambda (buffer window) - (declare (ignore buffer window)) - " Type ? for help. ")) - -(defcommand "Dired" (p &optional directory) - "Prompts for a directory and edits it. If a dired for that directory already - exists, go to that buffer, otherwise create one. With an argument, include - UNIX dot files." - "Prompts for a directory and edits it. If a dired for that directory already - exists, go to that buffer, otherwise create one. With an argument, include - UNIX dot files." - (let ((info (if (hemlock-bound-p 'dired-information) - (value dired-information)))) - (dired-guts nil - ;; Propagate dot-files property to subdirectory edits. - (or (and info (dired-info-dot-files-p info)) - p) - directory))) - -(defcommand "Dired with Pattern" (p) - "Do a dired, prompting for a pattern which may include a single *. With an - argument, include UNIX dit files." - "Do a dired, prompting for a pattern which may include a single *. With an - argument, include UNIX dit files." - (dired-guts t p nil)) - -(defun dired-guts (patternp dot-files-p directory) - (let* ((dpn (value pathname-defaults)) - (directory (dired-directorify - (or directory - (prompt-for-file - :prompt "Edit Directory: " - :help "Pathname to edit." - :default (make-pathname - :device (pathname-device dpn) - :directory (pathname-directory dpn)) - :must-exist nil)))) - (pattern (if patternp - (prompt-for-string - :prompt "Filename pattern: " - :help "Type a filename with a single asterisk." - :trim t))) - (full-name (namestring (if pattern - (merge-pathnames directory pattern) - directory))) - (name (concatenate 'simple-string "Dired " full-name)) - (buffer (cdr (assoc full-name *pathnames-to-dired-buffers* - :test #'string=)))) - (declare (simple-string full-name)) - (setf (value pathname-defaults) (merge-pathnames directory dpn)) - (change-to-buffer - (cond (buffer - (when (and dot-files-p - (not (dired-info-dot-files-p - (variable-value 'dired-information - :buffer buffer)))) - (setf (dired-info-dot-files-p (variable-value 'dired-information - :buffer buffer)) - t) - (update-dired-buffer directory pattern buffer)) - buffer) - (t - (let ((buffer (make-buffer - name :modes '("Dired") - :modeline-fields - (append (value default-modeline-fields) - (list (modeline-field :dired-cmds))) - :delete-hook (list 'dired-buffer-delete-hook)))) - (unless (initialize-dired-buffer directory pattern - dot-files-p buffer) - (delete-buffer-if-possible buffer) - (editor-error "No entries for ~A." full-name)) - (push (cons full-name buffer) *pathnames-to-dired-buffers*) - buffer)))))) - -;;; INITIALIZE-DIRED-BUFFER gets a dired in the buffer and defines some -;;; variables to make it usable as a dired buffer. If there are no file -;;; satisfying directory, then this returns nil, otherwise t. -;;; -(defun initialize-dired-buffer (directory pattern dot-files-p buffer) - (multiple-value-bind (pathnames dired-files) - (dired-in-buffer directory pattern dot-files-p buffer) - (if (zerop (length dired-files)) - nil - (defhvar "Dired Information" - "Contains the information neccessary to manipulate dired buffers." - :buffer buffer - :value (make-dired-information :pathname directory - :pattern pattern - :dot-files-p dot-files-p - :write-date (file-write-date directory) - :files dired-files - :file-list pathnames))))) - -;;; CALL-PRINT-DIRECTORY gives us a nice way to report PRINT-DIRECTORY errors -;;; to the user and to clean up the dired buffer. -;;; -(defun call-print-directory (directory mark dot-files-p) - (handler-case (with-output-to-mark (s mark :full) - (print-directory directory s - :all dot-files-p :verbose t :return-list t)) - (error (condx) - (delete-buffer-if-possible (line-buffer (mark-line mark))) - (editor-error "~A" condx)))) - -;;; DIRED-BUFFER-DELETE-HOOK is called on dired buffers upon deletion. This -;;; removes the buffer from the pathnames mapping, and it deletes and buffer -;;; local variables referring to it. -;;; -(defun dired-buffer-delete-hook (buffer) - (setf *pathnames-to-dired-buffers* - (delete buffer *pathnames-to-dired-buffers* :test #'eq :key #'cdr))) - - - - -;;;; Dired deletion and undeletion. - -(defcommand "Dired Delete File" (p) - "Marks a file for deletion; signals an error if not in a dired buffer. - With an argument, this prompts for a pattern that may contain at most one - wildcard, an asterisk, and all names matching the pattern will be flagged - for deletion." - "Marks a file for deletion; signals an error if not in a dired buffer." - (dired-frob-deletion p t)) - -(defcommand "Dired Undelete File" (p) - "Removes a mark for deletion; signals and error if not in a dired buffer. - With an argument, this prompts for a pattern that may contain at most one - wildcard, an asterisk, and all names matching the pattern will be unflagged - for deletion." - "Removes a mark for deletion; signals and error if not in a dired buffer." - (dired-frob-deletion p nil)) - -(defcommand "Dired Delete File and Down Line" (p) - "Marks file for deletion and moves down a line. - See \"Dired Delete File\"." - "Marks file for deletion and moves down a line. - See \"Dired Delete File\"." - (declare (ignore p)) - (dired-frob-deletion nil t) - (dired-down-line (current-point))) - -(defcommand "Dired Undelete File and Down Line" (p) - "Marks file undeleted and moves down a line. - See \"Dired Delete File\"." - "Marks file undeleted and moves down a line. - See \"Dired Delete File\"." - (declare (ignore p)) - (dired-frob-deletion nil nil) - (dired-down-line (current-point))) - -(defcommand "Dired Delete File with Pattern" (p) - "Prompts for a pattern and marks matching files for deletion. - See \"Dired Delete File\"." - "Prompts for a pattern and marks matching files for deletion. - See \"Dired Delete File\"." - (declare (ignore p)) - (dired-frob-deletion t t) - (dired-down-line (current-point))) - -(defcommand "Dired Undelete File with Pattern" (p) - "Prompts for a pattern and marks matching files undeleted. - See \"Dired Delete File\"." - "Prompts for a pattern and marks matching files undeleted. - See \"Dired Delete File\"." - (declare (ignore p)) - (dired-frob-deletion t nil) - (dired-down-line (current-point))) - -;;; DIRED-FROB-DELETION takes arguments indicating whether to prompt for a -;;; pattern and whether to mark the file deleted or undeleted. This uses -;;; CURRENT-POINT and CURRENT-BUFFER, and if not in a dired buffer, signal -;;; an error. -;;; -(defun dired-frob-deletion (patternp deletep) - (unless (hemlock-bound-p 'dired-information) - (editor-error "Not in Dired buffer.")) - (with-mark ((mark (current-point) :left-inserting)) - (let* ((dir-info (value dired-information)) - (files (dired-info-files dir-info)) - (del-files - (if patternp - (dired:pathnames-from-pattern - (prompt-for-string - :prompt "Filename pattern: " - :help "Type a filename with a single asterisk." - :trim t) - (dired-info-file-list dir-info)) - (list (dired-file-pathname - (array-element-from-mark mark files))))) - (note-char (if deletep #\D #\space))) - (with-writable-buffer ((current-buffer)) - (dolist (f del-files) - (let* ((pos (position f files :test #'equal - :key #'dired-file-pathname)) - (dired-file (svref files pos))) - (buffer-start mark) - (line-offset mark pos 0) - (setf (dired-file-deleted-p dired-file) deletep) - (if deletep - (setf (dired-file-write-date dired-file) - (file-write-date (dired-file-pathname dired-file))) - (setf (dired-file-write-date dired-file) nil)) - (setf (next-character mark) note-char))))))) - -(defun dired-down-line (point) - (line-offset point 1) - (when (blank-line-p (mark-line point)) - (line-offset point -1))) - - - - -;;;; Dired file finding and going to dired buffers. - -(defcommand "Dired Edit File" (p) - "Read in file or recursively \"Dired\" a directory." - "Read in file or recursively \"Dired\" a directory." - (declare (ignore p)) - (let ((point (current-point))) - (when (blank-line-p (mark-line point)) (editor-error "Not on a file line.")) - (let ((pathname (dired-file-pathname - (array-element-from-mark - point (dired-info-files (value dired-information)))))) - (if (directoryp pathname) - (dired-command nil (directory-namestring pathname)) - (change-to-buffer (find-file-buffer pathname)))))) - -(defcommand "Dired View File" (p) - "Read in file as if by \"View File\" or recursively \"Dired\" a directory. - This associates the file's buffer with the dired buffer." - "Read in file as if by \"View File\". - This associates the file's buffer with the dired buffer." - (declare (ignore p)) - (let ((point (current-point))) - (when (blank-line-p (mark-line point)) (editor-error "Not on a file line.")) - (let ((pathname (dired-file-pathname - (array-element-from-mark - point (dired-info-files (value dired-information)))))) - (if (directoryp pathname) - (dired-command nil (directory-namestring pathname)) - (let* ((dired-buf (current-buffer)) - (buffer (view-file-command nil pathname))) - (push #'(lambda (buffer) - (declare (ignore buffer)) - (setf dired-buf nil)) - (buffer-delete-hook dired-buf)) - (setf (variable-value 'view-return-function :buffer buffer) - #'(lambda () - (if dired-buf - (change-to-buffer dired-buf) - (dired-from-buffer-pathname-command nil))))))))) - -(defcommand "Dired from Buffer Pathname" (p) - "Invokes \"Dired\" on the directory part of the current buffer's pathname. - With an argument, also prompt for a file pattern within that directory." - "Invokes \"Dired\" on the directory part of the current buffer's pathname. - With an argument, also prompt for a file pattern within that directory." - (let ((pathname (buffer-pathname (current-buffer)))) - (if pathname - (dired-command p (directory-namestring pathname)) - (editor-error "No pathname associated with buffer.")))) - -(defcommand "Dired Up Directory" (p) - "Invokes \"Dired\" on the directory up one level from the current Dired - buffer." - "Invokes \"Dired\" on the directory up one level from the current Dired - buffer." - (declare (ignore p)) - (unless (hemlock-bound-p 'dired-information) - (editor-error "Not in Dired buffer.")) - (let ((dirs (or (pathname-directory - (dired-info-pathname (value dired-information))) - '(:relative)))) - (dired-command nil - (truename (make-pathname :directory (nconc dirs '(:UP))))))) - - - - -;;;; Dired misc. commands -- update, help, line motion. - -(defcommand "Dired Update Buffer" (p) - "Recompute the contents of a dired buffer. - This maintains delete flags for files that have not been modified." - "Recompute the contents of a dired buffer. - This maintains delete flags for files that have not been modified." - (declare (ignore p)) - (unless (hemlock-bound-p 'dired-information) - (editor-error "Not in Dired buffer.")) - (let ((buffer (current-buffer)) - (dir-info (value dired-information))) - (update-dired-buffer (dired-info-pathname dir-info) - (dired-info-pattern dir-info) - buffer))) - -;;; UPDATE-DIRED-BUFFER updates buffer with a dired of directory, deleting -;;; whatever is in the buffer already. This assumes buffer was previously -;;; used as a dired buffer having necessary variables bound. The new files -;;; are compared to the old ones propagating any deleted flags if the name -;;; and the write date is the same for both specifications. -;;; -(defun update-dired-buffer (directory pattern buffer) - (with-writable-buffer (buffer) - (delete-region (buffer-region buffer)) - (let ((dir-info (variable-value 'dired-information :buffer buffer))) - (multiple-value-bind (pathnames new-dired-files) - (dired-in-buffer directory pattern - (dired-info-dot-files-p dir-info) - buffer) - (let ((point (buffer-point buffer)) - (old-dired-files (dired-info-files dir-info))) - (declare (simple-vector old-dired-files)) - (dotimes (i (length old-dired-files)) - (let ((old-file (svref old-dired-files i))) - (when (dired-file-deleted-p old-file) - (let ((pos (position (dired-file-pathname old-file) - new-dired-files :test #'equal - :key #'dired-file-pathname))) - (when pos - (let* ((new-file (svref new-dired-files pos)) - (write-date (file-write-date - (dired-file-pathname new-file)))) - (when (= (dired-file-write-date old-file) write-date) - (setf (dired-file-deleted-p new-file) t) - (setf (dired-file-write-date new-file) write-date) - (setf (next-character - (line-offset (buffer-start point) pos 0)) - #\D)))))))) - (setf (dired-info-files dir-info) new-dired-files) - (setf (dired-info-file-list dir-info) pathnames) - (setf (dired-info-write-date dir-info) - (file-write-date directory)) - (move-mark point (buffer-start-mark buffer))))))) - -;;; DIRED-IN-BUFFER inserts a dired listing of directory in buffer returning -;;; two values: a list of pathnames of files only, and an array of dired-file -;;; structures. This uses FILTER-REGION to insert a space for the indication -;;; of whether the file is flagged for deletion. Then we clean up extra header -;;; and trailing lines known to be in the output (into every code a little -;;; slime must fall). -;;; -(defun dired-in-buffer (directory pattern dot-files-p buffer) - (let ((point (buffer-point buffer))) - (with-writable-buffer (buffer) - (let* ((pathnames (call-print-directory - (if pattern - (merge-pathnames directory pattern) - directory) - point - dot-files-p)) - (dired-files (make-array (length pathnames)))) - (declare (list pathnames) (simple-vector dired-files)) - (filter-region #'(lambda (str) - (concatenate 'simple-string " " str)) - (buffer-region buffer)) - (delete-characters point -2) - (delete-region (line-to-region (mark-line (buffer-start point)))) - (delete-characters point) - (do ((p pathnames (cdr p)) - (i 0 (1+ i))) - ((null p)) - (setf (svref dired-files i) (make-dired-file (car p)))) - (values (delete-if #'directoryp pathnames) dired-files))))) - - -(defcommand "Dired Help" (p) - "How to use dired." - "How to use dired." - (declare (ignore p)) - (describe-mode-command nil "Dired")) - -(defcommand "Dired Next File" (p) - "Moves to next undeleted file." - "Moves to next undeleted file." - (unless (dired-line-offset (current-point) (or p 1)) - (editor-error "Not enough lines."))) - -(defcommand "Dired Previous File" (p) - "Moves to previous undeleted file." - "Moves to next undeleted file." - (unless (dired-line-offset (current-point) (or p -1)) - (editor-error "Not enough lines."))) - -;;; DIRED-LINE-OFFSET moves mark n undeleted file lines, returning mark. If -;;; there are not enough lines, mark remains unmoved, this returns nil. -;;; -(defun dired-line-offset (mark n) - (with-mark ((m mark)) - (let ((step (if (plusp n) 1 -1))) - (dotimes (i (abs n) (move-mark mark m)) - (loop - (unless (line-offset m step 0) - (return-from dired-line-offset nil)) - (when (blank-line-p (mark-line m)) - (return-from dired-line-offset nil)) - (when (char= (next-character m) #\space) - (return))))))) - - - - -;;;; Dired user interaction functions. - -(defun dired-error-function (string &rest args) - (apply #'editor-error string args)) - -(defun dired-report-function (string &rest args) - (clear-echo-area) - (apply #'message string args)) - -(defun dired-yesp-function (string &rest args) - (prompt-for-y-or-n :prompt (cons string args) :default t)) - - - - -;;;; Dired expunging and quitting. - -(defcommand "Dired Expunge Files" (p) - "Expunges files marked for deletion. - Query the user if value of \"Dired File Expunge Confirm\" is non-nil. Do - the same with directories and the value of \"Dired Directory Expunge - Confirm\"." - "Expunges files marked for deletion. - Query the user if value of \"Dired File Expunge Confirm\" is non-nil. Do - the same with directories and the value of \"Dired Directory Expunge - Confirm\"." - (declare (ignore p)) - (when (expunge-dired-files) - (dired-update-buffer-command nil)) - (maintain-dired-consistency)) - -(defcommand "Dired Quit" (p) - "Expunges the files in a dired buffer and then exits." - "Expunges the files in a dired buffer and then exits." - (declare (ignore p)) - (expunge-dired-files) - (delete-buffer-if-possible (current-buffer))) - -(defhvar "Dired File Expunge Confirm" - "When set (the default), \"Dired Expunge Files\" and \"Dired Quit\" will ask - for confirmation before deleting the marked files." - :value t) - -(defhvar "Dired Directory Expunge Confirm" - "When set (the default), \"Dired Expunge Files\" and \"Dired Quit\" will ask - for confirmation before deleting each marked directory." - :value t) - -(defun expunge-dired-files () - (multiple-value-bind (marked-files marked-dirs) (get-marked-dired-files) - (let ((dired:*error-function* #'dired-error-function) - (dired:*report-function* #'dired-report-function) - (dired:*yesp-function* #'dired-yesp-function) - (we-did-something nil)) - (when (and marked-files - (or (not (value dired-file-expunge-confirm)) - (prompt-for-y-or-n :prompt "Really delete files? " - :default t - :must-exist t - :default-string "Y"))) - (setf we-did-something t) - (dolist (file-info marked-files) - (let ((pathname (car file-info)) - (write-date (cdr file-info))) - (if (= write-date (file-write-date pathname)) - (dired:delete-file (namestring pathname) :clobber t - :recursive nil) - (message "~A has been modified, it remains unchanged." - (namestring pathname)))))) - (when marked-dirs - (dolist (dir-info marked-dirs) - (let ((dir (car dir-info)) - (write-date (cdr dir-info))) - (if (= write-date (file-write-date dir)) - (when (or (not (value dired-directory-expunge-confirm)) - (prompt-for-y-or-n - :prompt (list "~a is a directory. Delete it? " - (directory-namestring dir)) - :default t - :must-exist t - :default-string "Y")) - (dired:delete-file (directory-namestring dir) :clobber t - :recursive t) - (setf we-did-something t)) - (message "~A has been modified, it remains unchanged."))))) - we-did-something))) - - - - -;;;; Dired copying and renaming. - -(defhvar "Dired Copy File Confirm" - "Can be either t, nil, or :update. T means always query before clobbering an - existing file, nil means don't query before clobbering an existing file, and - :update means only ask if the existing file is newer than the source." - :value T) - -(defhvar "Dired Rename File Confirm" - "When non-nil, dired will query before clobbering an existing file." - :value T) - -(defcommand "Dired Copy File" (p) - "Copy the file under the point" - "Copy the file under the point" - (declare (ignore p)) - (let* ((point (current-point)) - (confirm (value dired-copy-file-confirm)) - (source (dired-file-pathname - (array-element-from-mark - point (dired-info-files (value dired-information))))) - (dest (prompt-for-file - :prompt (if (directoryp source) - "Destination Directory Name: " - "Destination Filename: ") - :help "Name of new file." - :default source - :must-exist nil)) - (dired:*error-function* #'dired-error-function) - (dired:*report-function* #'dired-report-function) - (dired:*yesp-function* #'dired-yesp-function)) - (dired:copy-file source dest :update (if (eq confirm :update) t nil) - :clobber (not confirm))) - (maintain-dired-consistency)) - -(defcommand "Dired Rename File" (p) - "Rename the file or directory under the point" - "Rename the file or directory under the point" - (declare (ignore p)) - (let* ((point (current-point)) - (source (dired-namify (dired-file-pathname - (array-element-from-mark - point - (dired-info-files (value dired-information)))))) - (dest (prompt-for-file - :prompt "New Filename: " - :help "The new name for this file." - :default source - :must-exist nil)) - (dired:*error-function* #'dired-error-function) - (dired:*report-function* #'dired-report-function) - (dired:*yesp-function* #'dired-yesp-function)) - ;; ARRAY-ELEMENT-FROM-MARK moves mark to line start. - (dired:rename-file source dest :clobber (value dired-rename-file-confirm))) - (maintain-dired-consistency)) - -(defcommand "Dired Copy with Wildcard" (p) - "Copy files that match a pattern containing ONE wildcard." - "Copy files that match a pattern containing ONE wildcard." - (declare (ignore p)) - (let* ((dir-info (value dired-information)) - (confirm (value dired-copy-file-confirm)) - (pattern (prompt-for-string - :prompt "Filename pattern: " - :help "Type a filename with a single asterisk." - :trim t)) - (destination (namestring - (prompt-for-file - :prompt "Destination Spec: " - :help "Destination spec. May contain ONE asterisk." - :default (dired-info-pathname dir-info) - :must-exist nil))) - (dired:*error-function* #'dired-error-function) - (dired:*yesp-function* #'dired-yesp-function) - (dired:*report-function* #'dired-report-function)) - (dired:copy-file pattern destination :update (if (eq confirm :update) t nil) - :clobber (not confirm) - :directory (dired-info-file-list dir-info))) - (maintain-dired-consistency)) - -(defcommand "Dired Rename with Wildcard" (p) - "Rename files that match a pattern containing ONE wildcard." - "Rename files that match a pattern containing ONE wildcard." - (declare (ignore p)) - (let* ((dir-info (value dired-information)) - (pattern (prompt-for-string - :prompt "Filename pattern: " - :help "Type a filename with a single asterisk." - :trim t)) - (destination (namestring - (prompt-for-file - :prompt "Destination Spec: " - :help "Destination spec. May contain ONE asterisk." - :default (dired-info-pathname dir-info) - :must-exist nil))) - (dired:*error-function* #'dired-error-function) - (dired:*yesp-function* #'dired-yesp-function) - (dired:*report-function* #'dired-report-function)) - (dired:rename-file pattern destination - :clobber (not (value dired-rename-file-confirm)) - :directory (dired-info-file-list dir-info))) - (maintain-dired-consistency)) - -(defcommand "Delete File" (p) - "Delete a file. Specify directories with a trailing slash." - "Delete a file. Specify directories with a trailing slash." - (declare (ignore p)) - (let* ((spec (namestring - (prompt-for-file - :prompt "Delete File: " - :help '("Name of File or Directory to delete. ~ - One wildcard is permitted.") - :must-exist nil))) - (directoryp (directoryp spec)) - (dired:*error-function* #'dired-error-function) - (dired:*report-function* #'dired-report-function) - (dired:*yesp-function* #'dired-yesp-function)) - (when (or (not directoryp) - (not (value dired-directory-expunge-confirm)) - (prompt-for-y-or-n - :prompt (list "~A is a directory. Delete it? " - (directory-namestring spec)) - :default t :must-exist t :default-string "Y"))) - (dired:delete-file spec :recursive t - :clobber (or directoryp - (value dired-file-expunge-confirm)))) - (maintain-dired-consistency)) - -(defcommand "Copy File" (p) - "Copy a file, allowing ONE wildcard." - "Copy a file, allowing ONE wildcard." - (declare (ignore p)) - (let* ((confirm (value dired-copy-file-confirm)) - (source (namestring - (prompt-for-file - :prompt "Source Filename: " - :help "Name of File to copy. One wildcard is permitted." - :must-exist nil))) - (dest (namestring - (prompt-for-file - :prompt (if (directoryp source) - "Destination Directory Name: " - "Destination Filename: ") - :help "Name of new file." - :default source - :must-exist nil))) - (dired:*error-function* #'dired-error-function) - (dired:*report-function* #'dired-report-function) - (dired:*yesp-function* #'dired-yesp-function)) - (dired:copy-file source dest :update (if (eq confirm :update) t nil) - :clobber (not confirm))) - (maintain-dired-consistency)) - -(defcommand "Rename File" (p) - "Rename a file, allowing ONE wildcard." - "Rename a file, allowing ONE wildcard." - (declare (ignore p)) - (let* ((source (namestring - (prompt-for-file - :prompt "Source Filename: " - :help "Name of file to rename. One wildcard is permitted." - :must-exist nil))) - (dest (namestring - (prompt-for-file - :prompt (if (directoryp source) - "Destination Directory Name: " - "Destination Filename: ") - :help "Name of new file." - :default source - :must-exist nil))) - (dired:*error-function* #'dired-error-function) - (dired:*report-function* #'dired-report-function) - (dired:*yesp-function* #'dired-yesp-function)) - (dired:rename-file source dest - :clobber (not (value dired-rename-file-confirm)))) - (maintain-dired-consistency)) - -(defun maintain-dired-consistency () - (dolist (info *pathnames-to-dired-buffers*) - (let* ((directory (directory-namestring (car info))) - (buffer (cdr info)) - (dir-info (variable-value 'dired-information :buffer buffer)) - (write-date (file-write-date directory))) - (unless (= (dired-info-write-date dir-info) write-date) - (update-dired-buffer directory (dired-info-pattern dir-info) buffer))))) - - - - -;;;; Dired utilities. - -;;; GET-MARKED-DIRED-FILES returns as multiple values a list of file specs -;;; and a list of directory specs that have been marked for deletion. This -;;; assumes the current buffer is a "Dired" buffer. -;;; -(defun get-marked-dired-files () - (let* ((files (dired-info-files (value dired-information))) - (length (length files)) - (marked-files ()) - (marked-dirs ())) - (unless files (editor-error "Not in Dired buffer.")) - (do ((i 0 (1+ i))) - ((= i length) (values (nreverse marked-files) (nreverse marked-dirs))) - (let* ((thing (svref files i)) - (pathname (dired-file-pathname thing))) - (when (and (dired-file-deleted-p thing) ; file marked for delete - (probe-file pathname)) ; file still exists - (if (directoryp pathname) - (push (cons pathname (file-write-date pathname)) marked-dirs) - (push (cons pathname (file-write-date pathname)) - marked-files))))))) - -;;; ARRAY-ELEMENT-FROM-MARK -- Internal Interface. -;;; -;;; This counts the lines between it and the beginning of the buffer. The -;;; number is used to index vector as if each line mapped to an element -;;; starting with the zero'th element (lines are numbered starting at 1). -;;; This must use AREF since some modes use this with extendable vectors. -;;; -(defun array-element-from-mark (mark vector - &optional (error-msg "Invalid line.")) - (when (blank-line-p (mark-line mark)) (editor-error error-msg)) - (aref vector - (1- (count-lines (region - (buffer-start-mark (line-buffer (mark-line mark))) - mark))))) - -;;; DIRED-NAMIFY and DIRED-DIRECTORIFY are implementation dependent slime. -;;; -(defun dired-namify (pathname) - (let* ((string (namestring pathname)) - (last (1- (length string)))) - (if (char= (schar string last) #\/) - (subseq string 0 last) - string))) -;;; -;;; This is necessary to derive a canonical representation for directory -;;; names, so "Dired" can map various strings naming one directory to that -;;; one directory. -;;; -(defun dired-directorify (pathname) - (let ((directory (ext:unix-namestring pathname))) - (if (directoryp directory) - directory - (pathname (concatenate 'simple-string (namestring directory) "/"))))) - - - - -;;;; View Mode. - -(defmode "View" :major-p nil - :setup-function 'setup-view-mode - :cleanup-function 'cleanup-view-mode - :precedence 5.0 - :documentation - "View mode scrolls forwards and backwards in a file with the buffer read-only. - Scrolling off the end optionally deletes the buffer.") - -(defun setup-view-mode (buffer) - (defhvar "View Return Function" - "Function that gets called when quitting or returning from view mode." - :value nil - :buffer buffer) - (setf (buffer-writable buffer) nil)) -;;; -(defun cleanup-view-mode (buffer) - (delete-variable 'view-return-function :buffer buffer) - (setf (buffer-writable buffer) t)) - -(defcommand "View File" (p &optional pathname) - "Reads a file in as if by \"Find File\", but read-only. Commands exist - for scrolling convenience." - "Reads a file in as if by \"Find File\", but read-only. Commands exist - for scrolling convenience." - (declare (ignore p)) - (let* ((pn (or pathname - (prompt-for-file - :prompt "View File: " :must-exist t - :help "Name of existing file to read into its own buffer." - :default (buffer-default-pathname (current-buffer))))) - (buffer (make-buffer (format nil "View File ~A" (gensym))))) - (visit-file-command nil pn buffer) - (setf (buffer-minor-mode buffer "View") t) - (change-to-buffer buffer) - buffer)) - -(defcommand "View Return" (p) - "Return to a parent buffer, if it exists." - "Return to a parent buffer, if it exists." - (declare (ignore p)) - (unless (call-view-return-fun) - (editor-error "No View return method for this buffer."))) - -(defcommand "View Quit" (p) - "Delete a buffer in view mode." - "Delete a buffer in view mode, invoking VIEW-RETURN-FUNCTION if it exists for - this buffer." - (declare (ignore p)) - (let* ((buf (current-buffer)) - (funp (call-view-return-fun))) - (delete-buffer-if-possible buf) - (unless funp (editor-error "No View return method for this buffer.")))) - -;;; CALL-VIEW-RETURN-FUN returns nil if there is no current -;;; view-return-function. If there is one, it calls it and returns t. -;;; -(defun call-view-return-fun () - (if (hemlock-bound-p 'view-return-function) - (let ((fun (value view-return-function))) - (cond (fun - (funcall fun) - t))))) - - -(defhvar "View Scroll Deleting Buffer" - "When this is set, \"View Scroll Down\" deletes the buffer when the end - of the file is visible." - :value t) - -(defcommand "View Scroll Down" (p) - "Scroll the current window down through its buffer. - If the end of the file is visible, then delete the buffer if \"View Scroll - Deleting Buffer\" is set. If the buffer is associated with a dired buffer, - this returns there instead of to the previous buffer." - "Scroll the current window down through its buffer. - If the end of the file is visible, then delete the buffer if \"View Scroll - Deleting Buffer\" is set. If the buffer is associated with a dired buffer, - this returns there instead of to the previous buffer." - (if (and (not p) - (displayed-p (buffer-end-mark (current-buffer)) - (current-window)) - (value view-scroll-deleting-buffer)) - (view-quit-command nil) - (scroll-window-down-command p))) - -(defcommand "View Edit File" (p) - "Turn off \"View\" mode in this buffer." - "Turn off \"View\" mode in this buffer." - (declare (ignore p)) - (let ((buf (current-buffer))) - (setf (buffer-minor-mode buf "View") nil) - (warn-about-visit-file-buffers buf))) - -(defcommand "View Help" (p) - "Shows \"View\" mode help message." - "Shows \"View\" mode help message." - (declare (ignore p)) - (describe-mode-command nil "View")) Index: anches/ide-1.0/ccl/hemlock/src/display.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/display.lisp (revision 6566) +++ (revision ) @@ -1,310 +1,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- -;;; -;;; ********************************************************************** -;;; This code was written as part of the CMU Common Lisp project at -;;; Carnegie Mellon University, and has been placed in the public domain. -;;; -#+CMU (ext:file-comment - "$Header$") -;;; -;;; ********************************************************************** -;;; -;;; Written by Bill Chiles. -;;; -;;; This is the device independent redisplay entry points for Hemlock. -;;; - -(in-package :hemlock-internals) - - - -;;;; Main redisplay entry points. - -(defvar *things-to-do-once* () - "This is a list of lists of functions and args to be applied to. The - functions are called with args supplied at the top of the command loop.") - -(defvar *screen-image-trashed* () - "This variable is set to true if the screen has been trashed by some screen - manager operation, and thus should be totally refreshed. This is currently - only used by tty redisplay.") - -;;; True if we are in redisplay, and thus don't want to enter it recursively. -;;; -(defvar *in-redisplay* nil) - -(declaim (special *window-list*)) - -(eval-when (:compile-toplevel :execute) - -;;; REDISPLAY-LOOP -- Internal. -;;; -;;; This executes internal redisplay routines on all windows interleaved with -;;; checking for input, and if any input shows up we punt returning -;;; :editor-input. Special-fun is for windows that the redisplay interface -;;; wants to recenter to keep the window's buffer's point visible. General-fun -;;; is for other windows. -;;; -;;; Whenever we invoke one of the internal routines, we keep track of the -;;; non-nil return values, so we can return t when we are done. Returning t -;;; means redisplay should run again to make sure it converged. To err on the -;;; safe side, if any window had any changed lines, then let's go through -;;; redisplay again; that is, return t. -;;; -;;; After checking each window, we put the cursor in the appropriate place and -;;; force output. When we try to position the cursor, it may no longer lie -;;; within the window due to buffer modifications during redisplay. If it is -;;; out of the window, return t to indicate we need to finish redisplaying. -;;; -;;; Then we check for the after-redisplay method. Routines such as REDISPLAY -;;; and REDISPLAY-ALL want to invoke the after method to make sure we handle -;;; any events generated from redisplaying. There wouldn't be a problem with -;;; handling these events if we were going in and out of Hemlock's event -;;; handling, but some user may loop over one of these interface functions for -;;; a long time without going through Hemlock's input loop; when that happens, -;;; each call to redisplay may not result in a complete redisplay of the -;;; device. Routines such as INTERNAL-REDISPLAY don't want to worry about this -;;; since Hemlock calls them while going in and out of the input/event-handling -;;; loop. -;;; -;;; Around all of this, we establish the 'redisplay-catcher tag. Some device -;;; redisplay methods throw to this to abort redisplay in addition to this -;;; code. -;;; -(defmacro redisplay-loop (general-fun special-fun &optional (afterp t)) - (let* ((device (gensym)) (point (gensym)) (hunk (gensym)) (n-res (gensym)) - (win-var (gensym)) - (general-form (if (symbolp general-fun) - `(,general-fun ,win-var) - `(funcall ,general-fun ,win-var))) - (special-form (if (symbolp special-fun) - `(,special-fun ,win-var) - `(funcall ,special-fun ,win-var)))) - `(let ((,n-res nil) - (*in-redisplay* t)) - (catch 'redisplay-catcher - (when (listen-editor-input *real-editor-input*) - (throw 'redisplay-catcher :editor-input)) - (let ((,win-var *current-window*)) - (when ,special-form (setf ,n-res t))) - (dolist (,win-var *window-list*) - (unless (eq ,win-var *current-window*) - (when (listen-editor-input *real-editor-input*) - (throw 'redisplay-catcher :editor-input)) - (when (if (window-display-recentering ,win-var) - ,special-form - ,general-form) - (setf ,n-res t)))) - (let* ((,hunk (window-hunk *current-window*)) - (,device (device-hunk-device ,hunk)) - (,point (window-point *current-window*))) - (move-mark ,point (buffer-point (window-buffer *current-window*))) - (multiple-value-bind (x y) - (mark-to-cursorpos ,point *current-window*) - (if x - (funcall (device-put-cursor ,device) ,hunk x y) - (setf ,n-res t))) - (when (device-force-output ,device) - (funcall (device-force-output ,device))) - ,@(if afterp - `((when (device-after-redisplay ,device) - (funcall (device-after-redisplay ,device) ,device) - ;; The after method may have queued input that the input - ;; loop won't see until the next input arrives, so check - ;; here to return the correct value as per the redisplay - ;; contract. - (when (listen-editor-input *real-editor-input*) - (setf ,n-res :editor-input))))) - ,n-res))))) - -) ;eval-when - - -;;; REDISPLAY -- Public. -;;; -;;; This function updates the display of all windows which need it. It assumes -;;; it's internal representation of the screen is accurate and attempts to do -;;; the minimal amount of output to bring the screen into correspondence. -;;; *screen-image-trashed* is only used by terminal redisplay. -;;; -(defun redisplay () - "The main entry into redisplay; updates any windows that seem to need it." - (when *things-to-do-once* - (dolist (thing *things-to-do-once*) (apply (car thing) (cdr thing))) - (setf *things-to-do-once* nil)) - (cond (*in-redisplay* t) - (*screen-image-trashed* - (when (eq (redisplay-all) t) - (setf *screen-image-trashed* nil) - t)) - (t - (redisplay-loop redisplay-window redisplay-window-recentering)))) - - -;;; REDISPLAY-ALL -- Public. -;;; -;;; Update the screen making no assumptions about its correctness. This is -;;; useful if the screen gets trashed, or redisplay gets lost. Since windows -;;; may be on different devices, we have to go through the list clearing all -;;; possible devices. Always returns T or :EDITOR-INPUT, never NIL. -;;; -(defun redisplay-all () - "An entry into redisplay; causes all windows to be fully refreshed." - (let ((cleared-devices nil)) - (dolist (w *window-list*) - (let* ((hunk (window-hunk w)) - (device (device-hunk-device hunk))) - (unless (member device cleared-devices :test #'eq) - (when (device-clear device) - (funcall (device-clear device) device)) - ;; - ;; It's cleared whether we did clear it or there was no method. - (push device cleared-devices))))) - (redisplay-loop - redisplay-window-all - #'(lambda (window) - (setf (window-tick window) (tick)) - (update-window-image window) - (maybe-recenter-window window) - (funcall (device-dumb-redisplay - (device-hunk-device (window-hunk window))) - window) - t))) - - - - -;;;; Internal redisplay entry points. - -(defun internal-redisplay () - "The main internal entry into redisplay. This is just like REDISPLAY, but it - doesn't call the device's after-redisplay method." - (when *things-to-do-once* - (dolist (thing *things-to-do-once*) (apply (car thing) (cdr thing))) - (setf *things-to-do-once* nil)) - (cond (*in-redisplay* t) - (*screen-image-trashed* - (when (eq (redisplay-all) t) - (setf *screen-image-trashed* nil) - t)) - (t - (redisplay-loop redisplay-window redisplay-window-recentering)))) - -;;; REDISPLAY-WINDOWS-FROM-MARK -- Internal Interface. -;;; -;;; hemlock-output-stream methods call this to update the screen. It only -;;; redisplays windows which are displaying the buffer concerned and doesn't -;;; deal with making the cursor track the point. *screen-image-trashed* is -;;; only used by terminal redisplay. This must call the device after-redisplay -;;; method since stream output may occur without ever returning to the -;;; Hemlock input/event-handling loop. -;;; -(defun redisplay-windows-from-mark (mark) - (when *things-to-do-once* - (dolist (thing *things-to-do-once*) (apply (car thing) (cdr thing))) - (setf *things-to-do-once* nil)) - (cond ((or *in-redisplay* (not *in-the-editor*)) t) - ((listen-editor-input *real-editor-input*) :editor-input) - (*screen-image-trashed* - (when (eq (redisplay-all) t) - (setf *screen-image-trashed* nil) - t)) - (t - (catch 'redisplay-catcher - (let ((buffer (line-buffer (mark-line mark)))) - (when buffer - (flet ((frob (win) - (let* ((device (device-hunk-device (window-hunk win))) - (force (device-force-output device)) - (after (device-after-redisplay device))) - (when force (funcall force)) - (when after (funcall after device))))) - (let ((windows (buffer-windows buffer))) - (when (member *current-window* windows :test #'eq) - (redisplay-window-recentering *current-window*) - (frob *current-window*)) - (dolist (window windows) - (unless (eq window *current-window*) - (redisplay-window window) - (frob window))))))))))) - -;;; REDISPLAY-WINDOW -- Internal. -;;; -;;; Return t if there are any changed lines, nil otherwise. -;;; -(defun redisplay-window (window) - "Maybe updates the window's image and calls the device's smart redisplay - method. NOTE: the smart redisplay method may throw to - 'hi::redisplay-catcher to abort redisplay." - (maybe-update-window-image window) - (prog1 - (not (eq (window-first-changed window) *the-sentinel*)) - (funcall (device-smart-redisplay (device-hunk-device (window-hunk window))) - window))) - -(defun redisplay-window-all (window) - "Updates the window's image and calls the device's dumb redisplay method." - (setf (window-tick window) (tick)) - (update-window-image window) - (funcall (device-dumb-redisplay (device-hunk-device (window-hunk window))) - window) - t) - -(defun random-typeout-redisplay (window) - (catch 'redisplay-catcher - (maybe-update-window-image window) - (let* ((device (device-hunk-device (window-hunk window))) - (force (device-force-output device))) - (funcall (device-smart-redisplay device) window) - (when force (funcall force))))) - - - -;;;; Support for redisplay entry points. - -;;; REDISPLAY-WINDOW-RECENTERING -- Internal. -;;; -;;; This tries to be clever about updating the window image unnecessarily, -;;; recenters the window if the window's buffer's point moved off the window, -;;; and does a smart redisplay. We call the redisplay method even if we didn't -;;; update the image or recenter because someone else may have modified the -;;; window's image and already have updated it; if nothing happened, then the -;;; smart method shouldn't do anything anyway. NOTE: the smart redisplay -;;; method may throw to 'hi::redisplay-catcher to abort redisplay. -;;; -;;; This return t if there are any changed lines, nil otherwise. -;;; -(defun redisplay-window-recentering (window) - (setup-for-recentering-redisplay window) - (invoke-hook hemlock::redisplay-hook window) - (setup-for-recentering-redisplay window) - (prog1 - (not (eq (window-first-changed window) *the-sentinel*)) - (funcall (device-smart-redisplay (device-hunk-device (window-hunk window))) - window))) - -(defun setup-for-recentering-redisplay (window) - (let* ((display-start (window-display-start window)) - (old-start (window-old-start window))) - ;; - ;; If the start is in the middle of a line and it wasn't before, - ;; then move the start there. - (when (and (same-line-p display-start old-start) - (not (start-line-p display-start)) - (start-line-p old-start)) - (line-start display-start)) - (maybe-update-window-image window) - (maybe-recenter-window window))) - - -;;; MAYBE-UPDATE-WINDOW-IMAGE only updates if the text has changed or the -;;; display start. -;;; -(defun maybe-update-window-image (window) - (when (or (> (buffer-modified-tick (window-buffer window)) - (window-tick window)) - (mark/= (window-display-start window) - (window-old-start window))) - (setf (window-tick window) (tick)) - (update-window-image window) - t)) Index: anches/ide-1.0/ccl/hemlock/src/dylan.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/dylan.lisp (revision 6566) +++ (revision ) @@ -1,66 +1,0 @@ -;;; -*- Package: hemlock -*- -;;; -;;; ********************************************************************** -;;; This code was written as part of the CMU Common Lisp project at -;;; Carnegie Mellon University, and has been placed in the public domain. -;;; -#+CMU (ext:file-comment - "$Header$") -;;; -;;; ********************************************************************** -;;; -;;; This file contains a minimal dylan mode. -;;; -(in-package :hemlock) - -;;; hack .. - -(setf (getstring "dylan" *mode-names*) nil) - - -(defmode "Dylan" :major-p t) -(defcommand "Dylan Mode" (p) - "Put the current buffer into \"Dylan\" mode." - "Put the current buffer into \"Dylan\" mode." - (declare (ignore p)) - (setf (buffer-major-mode (current-buffer)) "Dylan")) - -(define-file-type-hook ("dylan") (buffer type) - (declare (ignore type)) - (setf (buffer-major-mode buffer) "Dylan")) - -(defhvar "Indent Function" - "Indentation function which is invoked by \"Indent\" command. - It must take one argument that is the prefix argument." - :value #'generic-indent - :mode "Dylan") - -(defhvar "Auto Fill Space Indent" - "When non-nil, uses \"Indent New Comment Line\" to break lines instead of - \"New Line\"." - :mode "Dylan" :value t) - -(defhvar "Comment Start" - "String that indicates the start of a comment." - :mode "Dylan" :value "//") - -(defhvar "Comment End" - "String that ends comments. Nil indicates #\newline termination." - :mode "Dylan" :value nil) - -(defhvar "Comment Begin" - "String that is inserted to begin a comment." - :mode "Dylan" :value "// ") - -(bind-key "Delete Previous Character Expanding Tabs" #k"backspace" - :mode "Dylan") -(bind-key "Delete Previous Character Expanding Tabs" #k"delete" :mode "Dylan") - -;;; hacks... - -(shadow-attribute :scribe-syntax #\< nil "Dylan") -(shadow-attribute :scribe-syntax #\> nil "Dylan") -(bind-key "Self Insert" #k"\>" :mode "Dylan") -(bind-key "Scribe Insert Bracket" #k")" :mode "Dylan") -(bind-key "Scribe Insert Bracket" #k"]" :mode "Dylan") -(bind-key "Scribe Insert Bracket" #k"}" :mode "Dylan") Index: anches/ide-1.0/ccl/hemlock/src/eval-server.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/eval-server.lisp (revision 6566) +++ (revision ) @@ -1,1097 +1,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock -*- -;;; -;;; ********************************************************************** -;;; This code was written as part of the CMU Common Lisp project at -;;; Carnegie Mellon University, and has been placed in the public domain. -;;; -(hemlock-ext:file-comment - "$Header$") -;;; -;;; ********************************************************************** -;;; -;;; This file contains code for connecting to eval servers and some command -;;; level stuff too. -;;; -;;; Written by William Lott. -;;; - -(in-package :hemlock) - - - - -;;;; Structures. - -(defstruct (server-info (:print-function print-server-info)) - name ; String name of this server. - wire ; Wire connected to this server. - notes ; List of note objects for operations - ; which have not yet completed. - slave-info ; Ts-Info used in "Slave Lisp" buffer - ; (formerly the "Lisp Listener" buffer). - slave-buffer ; "Slave Lisp" buffer for slave's *terminal-io*. - background-info ; Ts-Info structure of typescript we use in - ; "background" buffer. - background-buffer ; Buffer "background" typescript is in. - (errors ; Array of errors while compiling - (make-array 16 :adjustable t :fill-pointer 0)) - error-index) ; Index of current error. -;;; -(defun print-server-info (obj stream n) - (declare (ignore n)) - (format stream "#" (server-info-name obj))) - - -(defstruct (error-info (:print-function print-error-info)) - buffer ; Buffer this error is for. - message ; Error Message - line ; Pointer to message in log buffer. - region) ; Region of faulty text -;;; -(defun print-error-info (obj stream n) - (declare (ignore n)) - (format stream "#" (error-info-message obj))) - - -(defvar *server-names* (make-string-table) - "A string-table of the name of all Eval servers and their corresponding - server-info structures.") - -(defvar *abort-operations* nil - "T iff we should ignore any operations sent to us.") - -(defvar *inside-operation* nil - "T iff we are currenly working on an operation. A catcher for the tag - abort-operation will be established whenever this is T.") - -(defconstant *slave-connect-wait* 300) - -;;; Used internally for communications. -;;; -(defvar *newly-created-slave* nil) -(defvar *compiler-wire* nil) -(defvar *compiler-error-stream* nil) -(defvar *compiler-note* nil) - - - - -;;;; Hemlock Variables - -(defhvar "Current Compile Server" - "The Server-Info object for the server currently used for compilation - requests." - :value nil) - -(defhvar "Current Package" - "This variable holds the name of the package currently used for Lisp - evaluation and compilation. If it is Nil, the value of *Package* is used - instead." - :value nil) - -(defhvar "Slave Utility" - "This is the pathname of the utility to fire up slave Lisps. It defaults - to \"cmucl\"." - :value "cmucl") - -(defhvar "Slave Utility Switches" - "These are additional switches to pass to the Slave Utility. - For example, (list \"-core\" ). The -slave - switch and the editor name are always supplied, and they should - not be present in this variable." - :value nil) - -(defhvar "Ask About Old Servers" - "When set (the default), Hemlock will prompt for an existing server's name - in preference to prompting for a new slave's name and creating it." - :value t) - -(defhvar "Confirm Slave Creation" - "When set (the default), Hemlock always confirms a slave's creation for - whatever reason." - :value t) - - -(defhvar "Slave GC Alarm" - "Determines that is done when the slave notifies that it is GCing. - :MESSAGE prints a message in the echo area, :LOUD-MESSAGE beeps as well. - NIL does nothing." - :value :message) - - - -;;;; Slave destruction. - -;;; WIRE-DIED -- Internal. -;;; -;;; The routine is called whenever a wire dies. We roll through all the -;;; servers looking for any that use this wire and nuke them with server-died. -;;; -(defun wire-died (wire) - (let ((servers nil)) - (do-strings (name info *server-names*) - (declare (ignore name)) - (when (eq wire (server-info-wire info)) - (push info servers))) - (dolist (server servers) - (server-died server)))) - -;;; SERVER-DIED -- Internal. -;;; -;;; Clean up the server. Remove any references to it from variables, etc. -;;; -(defun server-died (server) - (declare (special *breakpoints*)) - (let ((name (server-info-name server))) - (delete-string name *server-names*) - (message "Server ~A just died." name)) - (when (server-info-wire server) - #+NILGB - (let ((fd (hemlock.wire:wire-fd (server-info-wire server)))) - (system:invalidate-descriptor fd) - (unix:unix-close fd)) - (setf (server-info-wire server) nil)) - (when (server-info-slave-info server) - (ts-buffer-wire-died (server-info-slave-info server)) - (setf (server-info-slave-info server) nil)) - (when (server-info-background-info server) - (ts-buffer-wire-died (server-info-background-info server)) - (setf (server-info-background-info server) nil)) - (clear-server-errors server) - (when (eq server (variable-value 'current-eval-server :global)) - (setf (variable-value 'current-eval-server :global) nil)) - (when (eq server (variable-value 'current-compile-server :global)) - (setf (variable-value 'current-compile-server :global) nil)) - (dolist (buffer *buffer-list*) - (dolist (var '(current-eval-server current-compile-server server-info)) - (when (and (hemlock-bound-p var :buffer buffer) - (eq (variable-value var :buffer buffer) server)) - (delete-variable var :buffer buffer)))) - (setf *breakpoints* (delete-if #'(lambda (b) - (eq (breakpoint-info-slave b) server)) - *breakpoints*))) - -;;; SERVER-CLEANUP -- Internal. -;;; -;;; This routine is called as a buffer delete hook. It takes care of any -;;; per-buffer cleanup that is necessary. It clears out all references to the -;;; buffer from server-info structures and that any errors that refer to this -;;; buffer are finalized. -;;; -(defun server-cleanup (buffer) - (let ((info (if (hemlock-bound-p 'server-info :buffer buffer) - (variable-value 'server-info :buffer buffer)))) - (when info - (when (eq buffer (server-info-slave-buffer info)) - (setf (server-info-slave-buffer info) nil) - (setf (server-info-slave-info info) nil)) - (when (eq buffer (server-info-background-buffer info)) - (setf (server-info-background-buffer info) nil) - (setf (server-info-background-info info) nil)))) - (do-strings (string server *server-names*) - (declare (ignore string)) - (clear-server-errors server - #'(lambda (error) - (eq (error-info-buffer error) buffer))))) -;;; -(add-hook delete-buffer-hook 'server-cleanup) - -;;; CLEAR-SERVER-ERRORS -- Public. -;;; -;;; Clears all known errors for the given server and resets it so more can -;;; accumulate. -;;; -(defun clear-server-errors (server &optional test-fn) - "This clears compiler errors for server cleaning up any pointers for GC - purposes and allowing more errors to register." - (let ((array (server-info-errors server)) - (current nil)) - (dotimes (i (fill-pointer array)) - (let ((error (aref array i))) - (when (or (null test-fn) - (funcall test-fn error)) - (let ((region (error-info-region error))) - (when (regionp region) - (delete-mark (region-start region)) - (delete-mark (region-end region)))) - (setf (aref array i) nil)))) - (let ((index (server-info-error-index server))) - (when index - (setf current - (or (aref array index) - (find-if-not #'null array - :from-end t - :end current))))) - (delete nil array) - (setf (server-info-error-index server) - (position current array)))) - - - - -;;;; Slave creation. - -;;; INITIALIZE-SERVER-STUFF -- Internal. -;;; -;;; Reinitialize stuff when a core file is saved. -;;; -(defun initialize-server-stuff () - (clrstring *server-names*)) - - -(defvar *editor-name* nil "Name of this editor.") -(defvar *accept-connections* nil - "When set, allow slaves to connect to the editor.") - -;;; GET-EDITOR-NAME -- Internal. -;;; -;;; Pick a name for the editor. Names consist of machine-name:port-number. If -;;; in ten tries we can't get an unused port, choak. We don't save the result -;;; of HEMLOCK.WIRE:CREATE-REQUEST-SERVER because we don't think the editor needs to -;;; ever kill the request server, and we can always inhibit connection with -;;; "Accept Connections". -;;; -(defun get-editor-name () - (if *editor-name* - *editor-name* - (let ((random-state (make-random-state t))) - (dotimes (tries 10 (error "Could not create an internet listener.")) - (let ((port (+ 2000 (random 10000 random-state)))) - (setf port 4711) ;### - (when (handler-case (hemlock.wire:create-request-server - port - #'(lambda (wire addr) - (declare (ignore addr)) - (values *accept-connections* - #'(lambda () (wire-died wire))))) - (error () nil)) - (return (setf *editor-name* - (format nil "~A:~D" (machine-instance) port))))))))) - - -;;; MAKE-BUFFERS-FOR-TYPESCRIPT -- Internal. -;;; -;;; This function returns no values because it is called remotely for value by -;;; connecting slaves. Though we know the system will propagate nil back to -;;; the slave, we indicate here that nil is meaningless. -;;; -(defun make-buffers-for-typescript (slave-name background-name) - "Make the interactive and background buffers slave-name and background-name. - If either is nil, then prompt the user." - (multiple-value-bind (slave-name background-name) - (cond ((not (and slave-name background-name)) - (pick-slave-buffer-names)) - ((getstring slave-name *server-names*) - (multiple-value-bind - (new-sn new-bn) - (pick-slave-buffer-names) - (message "~S is already an eval server; ~ - using ~S instead." - slave-name new-sn) - (values new-sn new-bn))) - (t (values slave-name background-name))) - (let* ((slave-buffer (or (getstring slave-name *buffer-names*) - (make-buffer slave-name :modes '("Lisp")))) - (background-buffer (or (getstring background-name *buffer-names*) - (make-buffer background-name - :modes '("Lisp")))) - (server-info (make-server-info :name slave-name - :wire hemlock.wire:*current-wire* - :slave-buffer slave-buffer - :background-buffer background-buffer)) - (slave-info (typescriptify-buffer slave-buffer server-info - hemlock.wire:*current-wire*)) - (background-info (typescriptify-buffer background-buffer server-info - hemlock.wire:*current-wire*))) - (setf (server-info-slave-info server-info) slave-info) - (setf (server-info-background-info server-info) background-info) - (setf (getstring slave-name *server-names*) server-info) - (unless (variable-value 'current-eval-server :global) - (setf (variable-value 'current-eval-server :global) server-info)) - (hemlock.wire:remote-value - hemlock.wire:*current-wire* - (made-buffers-for-typescript (hemlock.wire:make-remote-object slave-info) - (hemlock.wire:make-remote-object background-info))) - (setf *newly-created-slave* server-info) - (values)))) - - -;;; CREATE-SLAVE -- Public. -;;; -#+NILGB -(defun create-slave (&optional name) - "This creates a slave that tries to connect to the editor. When the slave - connects to the editor, this returns a slave-information structure. Name is - the name of the interactive buffer. If name is nil, this generates a name. - If name is supplied, and a buffer with that name already exists, this - signals an error. In case the slave never connects, this will eventually - timeout and signal an editor-error." - (when (and name (getstring name *buffer-names*)) - (editor-error "Buffer ~A is already in use." name)) - (let ((lisp (unix-namestring (merge-pathnames (value slave-utility) "path:") - t t))) - (unless lisp - (editor-error "Can't find ``~S'' in your path to run." - (value slave-utility))) - (multiple-value-bind (slave background) - (if name - (values name (format nil "Background ~A" name)) - (pick-slave-buffer-names)) - (when (value confirm-slave-creation) - (setf slave (prompt-for-string - :prompt "New slave name? " - :help "Enter the name to use for the newly created slave." - :default slave - :default-string slave)) - (setf background (format nil "Background ~A" slave)) - (when (getstring slave *buffer-names*) - (editor-error "Buffer ~A is already in use." slave)) - (when (getstring background *buffer-names*) - (editor-error "Buffer ~A is already in use." background))) - (message "Spawning slave ... ") - (let ((proc - (ext:run-program lisp - `("-slave" ,(get-editor-name) - ,@(if slave (list "-slave-buffer" slave)) - ,@(if background - (list "-background-buffer" background)) - ,@(value slave-utility-switches)) - :wait nil - :output "/dev/null" - :if-output-exists :append)) - (*accept-connections* t) - (*newly-created-slave* nil)) - (unless proc - (editor-error "Could not start slave.")) - (dotimes (i *slave-connect-wait* - (editor-error - "Client Lisp is still unconnected. ~ - You must use \"Accept Slave Connections\" to ~ - allow the slave to connect at this point.")) - (system:serve-event 1) - (case (ext:process-status proc) - (:exited - (editor-error "The slave lisp exited before connecting.")) - (:signaled - (editor-error "The slave lisp was kill before connecting."))) - (when *newly-created-slave* - (message "DONE") - (return *newly-created-slave*))))))) - -;;; MAYBE-CREATE-SERVER -- Internal interface. -;;; -(defun maybe-create-server () - "If there is an existing server and \"Ask about Old Servers\" is set, then - prompt for a server's name and return that server's info. Otherwise, - create a new server." - (if (value ask-about-old-servers) - (multiple-value-bind (first-server-name first-server-info) - (do-strings (name info *server-names*) - (return (values name info))) - (if first-server-info - (multiple-value-bind - (name info) - (prompt-for-keyword (list *server-names*) - :prompt "Existing server name: " - :default first-server-name - :default-string first-server-name - :help - "Enter the name of an existing eval server." - :must-exist t) - (declare (ignore name)) - (or info (create-slave))) - (create-slave))) - (create-slave))) - - -(defvar *next-slave-index* 0 - "Number to use when creating the next slave.") - -;;; PICK-SLAVE-BUFFER-NAMES -- Internal. -;;; -;;; Return two unused names to use for the slave and background buffers. -;;; -(defun pick-slave-buffer-names () - (loop - (let ((slave (format nil "Slave ~D" (incf *next-slave-index*))) - (background (format nil "Background Slave ~D" *next-slave-index*))) - (unless (or (getstring slave *buffer-names*) - (getstring background *buffer-names*)) - (return (values slave background)))))) - - - - -;;;; Slave selection. - -;;; GET-CURRENT-EVAL-SERVER -- Public. -;;; -(defun get-current-eval-server (&optional errorp) - "Returns the server-info struct for the current eval server. If there is - none, and errorp is non-nil, then signal an editor error. If there is no - current server, and errorp is nil, then create one, prompting the user for - confirmation. Also, set the current server to be the newly created one." - (let ((info (value current-eval-server))) - (cond (info) - (errorp - (editor-error "No current eval server.")) - (t - (setf (value current-eval-server) (maybe-create-server)))))) - -;;; GET-CURRENT-COMPILE-SERVER -- Public. -;;; -;;; If a current compile server is defined, return it, otherwise return the -;;; current eval server using get-current-eval-server. -;;; -(defun get-current-compile-server (&optional errorp) - "Returns the server-info struct for the current compile server. If there is - no current compile server, return the current eval server." - (or (value current-compile-server) - (get-current-eval-server errorp))) - - - - -;;;; Server Manipulation commands. - -(defcommand "Select Slave" (p) - "Switch to the current slave's buffer. When given an argument, create a new - slave." - "Switch to the current slave's buffer. When given an argument, create a new - slave." - (let* ((info (if p (create-slave) (get-current-eval-server))) - (slave (server-info-slave-buffer info))) - (unless slave - (editor-error "The current eval server doesn't have a slave buffer!")) - (change-to-buffer slave))) - -(defcommand "Select Background" (p) - "Switch to the current slave's background buffer. When given an argument, use - the current compile server instead of the current eval server." - "Switch to the current slave's background buffer. When given an argument, use - the current compile server instead of the current eval server." - (let* ((info (if p - (get-current-compile-server t) - (get-current-eval-server t))) - (background (server-info-background-buffer info))) - (unless background - (editor-error "The current ~A server doesn't have a background buffer!" - (if p "compile" "eval"))) - (change-to-buffer background))) - -#+NILGB -(defcommand "Kill Slave" (p) - "This aborts any operations in the slave, tells the slave to QUIT, and shuts - down the connection to the specified eval server. This makes no attempt to - assure the eval server actually dies." - "This aborts any operations in the slave, tells the slave to QUIT, and shuts - down the connection to the specified eval server. This makes no attempt to - assure the eval server actually dies." - (declare (ignore p)) - (let ((default (and (value current-eval-server) - (server-info-name (value current-eval-server))))) - (multiple-value-bind - (name info) - (prompt-for-keyword - (list *server-names*) - :prompt "Kill Slave: " - :help "Enter the name of the eval server you wish to destroy." - :must-exist t - :default default - :default-string default) - (declare (ignore name)) - (let ((wire (server-info-wire info))) - (when wire - (ext:send-character-out-of-band (hemlock.wire:wire-fd wire) #\N) - (hemlock.wire:remote wire (ext:quit)) - (hemlock.wire:wire-force-output wire))) - (server-died info)))) - -#+NILGB -(defcommand "Kill Slave and Buffers" (p) - "This is the same as \"Kill Slave\", but it also deletes the slaves - interaction and background buffers." - "This is the same as \"Kill Slave\", but it also deletes the slaves - interaction and background buffers." - (declare (ignore p)) - (let ((default (and (value current-eval-server) - (server-info-name (value current-eval-server))))) - (multiple-value-bind - (name info) - (prompt-for-keyword - (list *server-names*) - :prompt "Kill Slave: " - :help "Enter the name of the eval server you wish to destroy." - :must-exist t - :default default - :default-string default) - (declare (ignore name)) - (let ((wire (server-info-wire info))) - (when wire - (ext:send-character-out-of-band (hemlock.wire:wire-fd wire) #\N) - (hemlock.wire:remote wire (ext:quit)) - (hemlock.wire:wire-force-output wire))) - (let ((buffer (server-info-slave-buffer info))) - (when buffer (delete-buffer-if-possible buffer))) - (let ((buffer (server-info-background-buffer info))) - (when buffer (delete-buffer-if-possible buffer))) - (server-died info)))) - -(defcommand "Accept Slave Connections" (p) - "This causes Hemlock to accept slave connections and displays the port of - the editor's connections request server. This is suitable for use with the - Lisp's -slave switch. Given an argument, this inhibits slave connections." - "This causes Hemlock to accept slave connections and displays the port of - the editor's connections request server. This is suitable for use with the - Lisp's -slave switch. Given an argument, this inhibits slave connections." - (let ((accept (not p))) - (setf *accept-connections* accept) - (message "~:[Inhibiting~;Accepting~] connections to ~S" - accept (get-editor-name)))) - - - - -;;;; Slave initialization junk. - -(defvar *original-beep-function* nil - "Handle on original beep function.") - -(defvar *original-gc-notify-before* nil - "Handle on original before-GC notification function.") - -(defvar *original-gc-notify-after* nil - "Handle on original after-GC notification function.") - -(defvar *original-terminal-io* nil - "Handle on original *terminal-io* so we can restore it.") - -(defvar *original-standard-input* nil - "Handle on original *standard-input* so we can restore it.") - -(defvar *original-standard-output* nil - "Handle on original *standard-output* so we can restore it.") - -(defvar *original-error-output* nil - "Handle on original *error-output* so we can restore it.") - -(defvar *original-debug-io* nil - "Handle on original *debug-io* so we can restore it.") - -(defvar *original-query-io* nil - "Handle on original *query-io* so we can restore it.") - -(defvar *original-trace-output* nil - "Handle on original *trace-output* so we can restore it.") - -(defvar *background-io* nil - "Stream connected to the editor's background buffer in case we want to use it - in the future.") - -;;; CONNECT-STREAM -- internal -;;; -;;; Run in the slave to create a new stream and connect it to the supplied -;;; buffer. Returns the stream. -;;; -(defun connect-stream (remote-buffer) - (let ((stream (make-ts-stream hemlock.wire:*current-wire* remote-buffer))) - (hemlock.wire:remote hemlock.wire:*current-wire* - (ts-buffer-set-stream remote-buffer - (hemlock.wire:make-remote-object stream))) - stream)) - -;;; MADE-BUFFERS-FOR-TYPESCRIPT -- Internal Interface. -;;; -;;; Run in the slave by the editor with the two buffers' info structures, -;;; actually remote-objects in the slave. Does any necessary stream hacking. -;;; Return nil to make sure no weird objects try to go back over the wire -;;; since the editor calls this in the slave for value. The editor does this -;;; for synch'ing, not for values. -;;; -(defun made-buffers-for-typescript (slave-info background-info) - (setf *original-terminal-io* *terminal-io*) - (warn "made-buffers-for-typescript ~S ~S ~S." - (connect-stream slave-info) - *terminal-io* - (connect-stream background-info)) - (sleep 3) - (macrolet ((frob (symbol new-value) - `(setf ,(intern (concatenate 'simple-string - "*ORIGINAL-" - (subseq (string symbol) 1))) - ,symbol - ,symbol ,new-value))) - #+NILGB - (let ((wire hemlock.wire:*current-wire*)) - (frob system:*beep-function* - #'(lambda (&optional stream) - (declare (ignore stream)) - (hemlock.wire:remote-value wire (beep)))) - (frob ext:*gc-notify-before* - #'(lambda (bytes-in-use) - (hemlock.wire:remote wire - (slave-gc-notify-before - slave-info - (format nil - "~%[GC threshold exceeded with ~:D bytes in use. ~ - Commencing GC.]~%" - bytes-in-use))) - (hemlock.wire:wire-force-output wire))) - (frob ext:*gc-notify-after* - #'(lambda (bytes-retained bytes-freed new-trigger) - (hemlock.wire:remote wire - (slave-gc-notify-after - slave-info - (format nil - "[GC completed with ~:D bytes retained and ~:D ~ - bytes freed.]~%[GC will next occur when at least ~ - ~:D bytes are in use.]~%" - bytes-retained bytes-freed new-trigger))) - (hemlock.wire:wire-force-output wire)))) - (warn "#7")(sleep 1) - (frob *terminal-io* (connect-stream slave-info)) - #+NIL - (progn - (setf cl-user::*io* (connect-stream slave-info)) - (let ((*terminal-io* *original-terminal-io*)) - (warn "#8")(sleep 1)) - (frob *standard-input* (make-synonym-stream '*terminal-io*)) - (let ((*terminal-io* *original-terminal-io*)) - (warn "#9")(sleep 1)) - (frob *standard-output* *standard-input*) - (let ((*terminal-io* *original-terminal-io*)) - (warn "#10")(sleep 1)) - ;;### - ;;(frob *error-output* *standard-input*) - ;;(frob *debug-io* *standard-input*) - (let ((*terminal-io* *original-terminal-io*)) - (warn "#11")(sleep 1)) - (frob *query-io* *standard-input*) - (let ((*terminal-io* *original-terminal-io*)) - (warn "#12")(sleep 1))) - (frob *trace-output* *original-terminal-io*) - ) - #+NILGB (setf *background-io* (connect-stream background-info)) - nil) - -;;; SLAVE-GC-NOTIFY-BEFORE and SLAVE-GC-NOTIFY-AFTER -- internal -;;; -;;; These two routines are run in the editor by the slave's gc notify routines. -;;; -(defun slave-gc-notify-before (remote-ts message) - (let ((ts (hemlock.wire:remote-object-value remote-ts))) - (ts-buffer-output-string ts message t) - (when (value slave-gc-alarm) - (message "~A is GC'ing." (buffer-name (ts-data-buffer ts))) - (when (eq (value slave-gc-alarm) :loud-message) - (beep))))) - -(defun slave-gc-notify-after (remote-ts message) - (let ((ts (hemlock.wire:remote-object-value remote-ts))) - (ts-buffer-output-string ts message t) - (when (value slave-gc-alarm) - (message "~A is done GC'ing." (buffer-name (ts-data-buffer ts))) - (when (eq (value slave-gc-alarm) :loud-message) - (beep))))) - -;;; EDITOR-DIED -- internal -;;; -;;; Run in the slave when the editor goes belly up. -;;; -(defun editor-died () - (macrolet ((frob (symbol) - (let ((orig (intern (concatenate 'simple-string - "*ORIGINAL-" - (subseq (string symbol) 1))))) - `(when ,orig - (setf ,symbol ,orig))))) - #+NILGB - (progn - (frob system:*beep-function*) - (frob ext:*gc-notify-before*) - (frob ext:*gc-notify-after*)) - (frob *terminal-io*) - (frob *standard-input*) - (frob *standard-output*) - (frob *error-output*) - (frob *debug-io*) - (frob *query-io*) - (frob *trace-output*)) - (setf *background-io* nil) - (format t "~2&Connection to editor died.~%") - #+NILGB - (ext:quit)) - -;;; START-SLAVE -- internal -;;; -;;; Initiate the process by which a lisp becomes a slave. -;;; -(defun start-slave (editor) - (declare (simple-string editor)) - (let ((seperator (position #\: editor :test #'char=))) - (unless seperator - (error "Editor name ~S invalid. ~ - Must be of the form \"MachineName:PortNumber\"." - editor)) - (let ((machine (subseq editor 0 seperator)) - (port (parse-integer editor :start (1+ seperator)))) - (format t "Connecting to ~A:~D~%" machine port) - (connect-to-editor machine port)))) - - -;;; PRINT-SLAVE-STATUS -- Internal -;;; -;;; Print out some useful information about what the slave is up to. -;;; -#+NILGB -(defun print-slave-status () - (ignore-errors - (multiple-value-bind (sys user faults) - (system:get-system-info) - (let* ((seconds (truncate (+ sys user) 1000000)) - (minutes (truncate seconds 60)) - (hours (truncate minutes 60)) - (days (truncate hours 24))) - (format *error-output* "~&; Used ~D:~2,'0D:~2,'0D~V@{!~}, " - hours (rem minutes 60) (rem seconds 60) days)) - (format *error-output* "~D fault~:P. In: " faults) - - (do ((i 0 (1+ i)) - (frame (di:top-frame) (di:frame-down frame))) - (#-x86(= i 3) - #+x86 - (and (> i 6) ; get past extra cruft - (let ((name (di:debug-function-name - (di:frame-debug-function frame)))) - (and (not (string= name "Bogus stack frame")) - (not (string= name "Foreign function call land"))))) - (prin1 (di:debug-function-name (di:frame-debug-function frame)) - *error-output*)) - (unless frame (return))) - (terpri *error-output*) - (force-output *error-output*))) - (values)) - - -;;; CONNECT-TO-EDITOR -- internal -;;; -;;; Do the actual connect to the editor. -;;; -(defun connect-to-editor (machine port - &optional - (slave (find-eval-server-switch "slave-buffer")) - (background (find-eval-server-switch - "background-buffer"))) - (let ((wire (hemlock.wire:connect-to-remote-server machine port 'editor-died))) - #+NILGB - (progn - (ext:add-oob-handler (hemlock.wire:wire-fd wire) - #\B - #'(lambda () - (system:without-hemlock - (system:with-interrupts - (break "Software Interrupt"))))) - (ext:add-oob-handler (hemlock.wire:wire-fd wire) - #\T - #'(lambda () - (when lisp::*in-top-level-catcher* - (throw 'lisp::top-level-catcher nil)))) - (ext:add-oob-handler (hemlock.wire:wire-fd wire) - #\A - #'abort) - (ext:add-oob-handler (hemlock.wire:wire-fd wire) - #\N - #'(lambda () - (setf *abort-operations* t) - (when *inside-operation* - (throw 'abort-operation - (if debug::*in-the-debugger* - :was-in-debugger))))) - (ext:add-oob-handler (hemlock.wire:wire-fd wire) #\S #'print-slave-status)) - - (hemlock.wire:remote-value wire - (make-buffers-for-typescript slave background)))) - - - -;;;; Eval server evaluation functions. - -(defvar *eval-form-stream* - (make-two-way-stream - #+NILGB - (lisp::make-lisp-stream - :in #'(lambda (&rest junk) - (declare (ignore junk)) - (error "You cannot read when handling an eval_form request."))) - #-NILGB - (make-concatenated-stream) - (make-broadcast-stream))) - -;;; SERVER-EVAL-FORM -- Public. -;;; Evaluates the given form (which is a string to be read from in the given -;;; package) and returns the results as a list. -;;; -(defun server-eval-form (package form) - (declare (type (or string null) package) (simple-string form)) - (handler-bind - ((error #'(lambda (condition) - (hemlock.wire:remote hemlock.wire:*current-wire* - (eval-form-error (format nil "~A~&" condition))) - (return-from server-eval-form nil)))) - (let ((*package* (if package - (lisp::package-or-lose package) - *package*)) - (*terminal-io* *eval-form-stream*)) - (stringify-list (multiple-value-list (eval (read-from-string form))))))) - - -;;; DO-OPERATION -- Internal. -;;; Checks to see if we are aborting operations. If not, do the operation -;;; wrapping it with operation-started and operation-completed calls. Also -;;; deals with setting up *terminal-io* and *package*. -;;; -(defmacro do-operation ((note package terminal-io) &body body) - `(let ((aborted t) - (*terminal-io* (if ,terminal-io - (hemlock.wire:remote-object-value ,terminal-io) - *terminal-io*)) - (*package* (maybe-make-package ,package))) - (unwind-protect - (unless *abort-operations* - (when (eq :was-in-debugger - (catch 'abort-operation - (let ((*inside-operation* t)) - (hemlock.wire:remote hemlock.wire:*current-wire* - (operation-started ,note)) - (hemlock.wire:wire-force-output hemlock.wire:*current-wire*) - ,@body - (setf aborted nil)))) - (format t - "~&[Operation aborted. ~ - You are no longer in this instance of the debugger.]~%"))) - (hemlock.wire:remote hemlock.wire:*current-wire* - (operation-completed ,note aborted)) - (hemlock.wire:wire-force-output hemlock.wire:*current-wire*)))) - - -;;; unique-thingie is a unique eof-value for READ'ing. Its a parameter, so -;;; we can reload the file. -;;; -(defparameter unique-thingie (gensym) - "Used as eof-value in reads to check for the end of a file.") - -;;; SERVER-EVAL-TEXT -- Public. -;;; -;;; Evaluate all the forms read from text in the given package, and send the -;;; results back. The error handler bound does not handle any errors. It -;;; simply notifies the client that an error occurred and then returns. -;;; -(defun server-eval-text (note package text terminal-io) - (do-operation (note package terminal-io) - (with-input-from-string (stream text) - (let ((last-pos 0)) - (handler-bind - ((error - #'(lambda (condition) - (hemlock.wire:remote hemlock.wire:*current-wire* - (lisp-error note last-pos - (file-position stream) - (format nil "~A~&" condition)))))) - (loop - (let ((form (read stream nil unique-thingie))) - (when (eq form unique-thingie) - (return nil)) - (let* ((values (stringify-list (multiple-value-list (eval form)))) - (pos (file-position stream))) - (hemlock.wire:remote hemlock.wire:*current-wire* - (eval-text-result note last-pos pos values)) - (setf last-pos pos))))))))) - -(defun stringify-list (list) - (mapcar #'prin1-to-string list)) -#| -(defun stringify-list (list) - (mapcar #'(lambda (thing) - (with-output-to-string (stream) - (write thing - :stream stream :radix nil :base 10 :circle t - :pretty nil :level nil :length nil :case :upcase - :array t :gensym t))) - list)) -|# - - - -;;;; Eval server compilation stuff. - -;;; DO-COMPILER-OPERATION -- Internal. -;;; -;;; Useful macro that does the operation with *compiler-note* and -;;; *compiler-wire* bound. -;;; -(defmacro do-compiler-operation ((note package terminal-io error) &body body) - #+NILGB - `(let ((*compiler-note* ,note) - (*compiler-error-stream* ,error) - (*compiler-wire* hemlock.wire:*current-wire*) - (c:*compiler-notification-function* #'compiler-note-in-editor)) - (do-operation (*compiler-note* ,package ,terminal-io) - (unwind-protect - (handler-bind ((error #'compiler-error-handler)) - ,@body) - (when *compiler-error-stream* - (force-output *compiler-error-stream*)))))) - -;;; COMPILER-NOTE-IN-EDITOR -- Internal. -;;; -;;; DO-COMPILER-OPERATION binds c:*compiler-notification-function* to this, so -;;; interesting observations in the compilation can be propagated back to the -;;; editor. If there is a notification point defined, we send information -;;; about the position and kind of error. The actual error text is written out -;;; using typescript operations. -;;; -;;; Start and End are the compiler's best guess at the file position where the -;;; error occurred. Function is some string describing where the error was. -;;; -(defun compiler-note-in-editor (severity function name pos) - (declare (ignore name)) - (when *compiler-wire* - (force-output *compiler-error-stream*) - (hemlock.wire:remote *compiler-wire* - (compiler-error *compiler-note* pos pos function severity))) - (hemlock.wire:wire-force-output *compiler-wire*)) - - -;;; COMPILER-ERROR-HANDLER -- Internal. -;;; -;;; The error handler function for the compiler interfaces. -;;; DO-COMPILER-OPERATION binds this as an error handler while evaluating the -;;; compilation form. -;;; -(defun compiler-error-handler (condition) - (when *compiler-wire* - (hemlock.wire:remote *compiler-wire* - (lisp-error *compiler-note* nil nil - (format nil "~A~&" condition))))) - - -;;; SERVER-COMPILE-TEXT -- Public. -;;; -;;; Similar to server-eval-text, except that the stuff is compiled. -;;; -#+NILGB -(defun server-compile-text (note package text defined-from - terminal-io error-output) - (let ((error-output (if error-output - (hemlock.wire:remote-object-value error-output)))) - (do-compiler-operation (note package terminal-io error-output) - (with-input-from-string (input-stream text) - (terpri error-output) - (c::compile-from-stream input-stream - :error-stream error-output - :source-info defined-from))))) - -;;; SERVER-COMPILE-FILE -- Public. -;;; -;;; Compiles the file sending error info back to the editor. -;;; -(defun server-compile-file (note package input output error trace - load terminal background) - (macrolet ((frob (x) - `(if (hemlock.wire:remote-object-p ,x) - (hemlock.wire:remote-object-value ,x) - ,x))) - (let ((error-stream (frob background))) - (do-compiler-operation (note package terminal error-stream) - (compile-file (frob input) - :output-file (frob output) - :error-file (frob error) - :trace-file (frob trace) - :load load - :error-output error-stream))))) - - - -;;;; Other random eval server stuff. - -;;; MAYBE-MAKE-PACKAGE -- Internal. -;;; -;;; Returns a package for a name. Creates it if it doesn't already exist. -;;; -(defun maybe-make-package (name) - (cond ((null name) *package*) - ((find-package name)) - (t - (hemlock.wire:remote-value (ts-stream-wire *terminal-io*) - (ts-buffer-output-string - (ts-stream-typescript *terminal-io*) - (format nil "~&Creating package ~A.~%" name) - t)) - (make-package name)))) - -;;; SERVER-SET-PACKAGE -- Public. -;;; -;;; Serves package setting requests. It simply sets -;;; *package* to an already existing package or newly created one. -;;; -(defun server-set-package (package) - (setf *package* (maybe-make-package package))) - -;;; SERVER-ACCEPT-OPERATIONS -- Public. -;;; -;;; Start accepting operations again. -;;; -(defun server-accept-operations () - (setf *abort-operations* nil)) - - - - -;;;; Command line switches. - -#+NILGB -(progn - -;;; FIND-EVAL-SERVER-SWITCH -- Internal. -;;; -;;; This is special to the switches supplied by CREATE-SLAVE and fetched by -;;; CONNECT-EDITOR-SERVER, so we can use STRING=. -;;; -(defun find-eval-server-switch (string) - #+NILGB - (let ((switch (find string ext:*command-line-switches* - :test #'string= - :key #'ext:cmd-switch-name))) - (if switch - (or (ext:cmd-switch-value switch) - (car (ext:cmd-switch-words switch)))))) - - -(defun slave-switch-demon (switch) - (let ((editor (ext:cmd-switch-arg switch))) - (unless editor - (error "Editor to connect to unspecified.")) - (start-slave editor) - (setf debug:*help-line-scroll-count* most-positive-fixnum))) -;;; -(defswitch "slave" 'slave-switch-demon) -(defswitch "slave-buffer") -(defswitch "background-buffer") - - -(defun edit-switch-demon (switch) - (declare (ignore switch)) -#| (let ((arg (or (ext:cmd-switch-value switch) - (car (ext:cmd-switch-words switch))))) - (when (stringp arg) (setq *editor-name* arg)))|# - (let ((initp (not (ext:get-command-line-switch "noinit")))) - (if (stringp (car ext:*command-line-words*)) - (ed (car ext:*command-line-words*) :init initp) - (ed nil :init initp)))) -;;; -(defswitch "edit" 'edit-switch-demon) -) - -#+SBCL -(defun hemlock.wire::serve-all-events () - (sleep .1)) Index: anches/ide-1.0/ccl/hemlock/src/hunk-draw.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/hunk-draw.lisp (revision 6566) +++ (revision ) @@ -1,504 +1,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- -;;; -;;; ********************************************************************** -;;; This code was written as part of the CMU Common Lisp project at -;;; Carnegie Mellon University, and has been placed in the public domain. -;;; -#+CMU (ext:file-comment - "$Header$") -;;; -;;; ********************************************************************** -;;; -;;; Written by Bill Chiles and Rob MacLachlan. -;;; -;;; Hemlock screen painting routines for the IBM RT running X. -;;; -(in-package :hemlock-internals) - - -;;;; TODO - -;; . do away with these bogus macros HUNK-PUT-STRING and HUNK-REPLACE-LINE-STRING. - -;; . concentrate these in a single point where we draw a string, so that we -;; can easily introduce foreground and background colors for syntax -;; highlighting and neater region highlighting. - -;; --GB 2003-05-22 - -(defparameter hunk-height-limit 80 "Maximum possible height for any hunk.") -(defparameter hunk-width-limit 200 "Maximum possible width for any hunk.") -(defparameter hunk-top-border 2 "Clear area at beginning.") -(defparameter hunk-left-border 10 "Clear area before first character.") -(defparameter hunk-bottom-border 3 "Minimum Clear area at end.") -(defparameter hunk-thumb-bar-bottom-border 10 - "Minimum Clear area at end including room for thumb bar." ) -(defparameter hunk-modeline-top 2 "Extra black pixels above modeline chars.") -(defparameter hunk-modeline-bottom 2 "Extra black pixels below modeline chars.") - - - - -;;;; Character translations for CLX - -;;; HEMLOCK-TRANSLATE-DEFAULT. -;;; -;;; CLX glyph drawing routines allow for a character translation function. The -;;; default one takes a string (any kind) or a vector of numbers and slams them -;;; into the outgoing request buffer. When the argument is a string, it stops -;;; processing if it sees a character that is not GRAPHIC-CHAR-P. For each -;;; graphical character, the function ultimately calls CHAR-CODE. -;;; -;;; Hemlock only passes simple-strings in, and these can only contain graphical -;;; characters because of the line image builder, except for one case -- -;;; *line-wrap-char* which anyone can set. Those who want to do evil things -;;; with this should know what they are doing: if they want a funny glyph as -;;; a line wrap char, then they should use CODE-CHAR on the font index. This -;;; allows the following function to translate everything with CHAR-CODE, and -;;; everybody's happy. -;;; -;;; Actually, Hemlock can passes the line string when doing random-typeout which -;;; does contain ^L's, tabs, etc. Under X10 these came out as funny glyphs, -;;; and under X11 the output is aborted without this function. -;;; -(defun hemlock-translate-default (src src-start src-end font dst dst-start) - (declare (simple-string src) - (fixnum src-start src-end dst-start) - (vector dst) - (ignore font)) - (do ((i src-start (1+ i)) - (j dst-start (1+ j))) - ((>= i src-end) i) - (declare (fixnum i j)) - (setf (aref dst j) (char-code (schar src i))))) - -#+clx -(defvar *glyph-translate-function* #'xlib:translate-default) - - - - -;;;; Drawing a line. - -;;;; We hack along --GB -#+clx -(defun find-color (window color) - (let ((ht (or (getf (xlib:window-plist window) :color-hash) - (setf (getf (xlib:window-plist window) :color-hash) - (make-hash-table :test #'equalp))))) - (or (gethash color ht) - (setf (gethash color ht) (xlib:alloc-color (xlib:window-colormap window) color))))) - -(defparameter *color-map* - #("black" "white" - "black" "white" - "black" "white" - "black" "cornflower blue" - - "black" "white" - "black" "white" - "black" "white" - "black" "white" - - "blue4" "white" ;8 = comments - "green4" "white" ;9 = strings - "red" "white" ;10 = quote - "black" "white" - - "black" "white" - "black" "white" - "black" "white" - "black" "white")) - -;;; HUNK-PUT-STRING takes a character (x,y) pair and computes at which pixel -;;; coordinate to draw string with font from start to end. -;;; -(defmacro hunk-put-string (x y font string start end) - (let ((gcontext (gensym))) - `(let ((,gcontext (bitmap-hunk-gcontext hunk))) - (xlib:with-gcontext (,gcontext :font ,font) - (xlib:draw-image-glyphs - (bitmap-hunk-xwindow hunk) ,gcontext - (+ hunk-left-border (* ,x (font-family-width font-family))) - (+ hunk-top-border (* ,y (font-family-height font-family)) - (font-family-baseline font-family)) - ,string :start ,start :end ,end - :translate *glyph-translate-function*))))) - -(defun hunk-put-string* (hunk x y font-family font string start end) - (let ((gcontext (bitmap-hunk-gcontext hunk)) - (font (svref (font-family-map font-family) font)) - (fg (find-color (bitmap-hunk-xwindow hunk) (svref *color-map* (* font 2)))) - (bg (find-color (bitmap-hunk-xwindow hunk) (svref *color-map* (1+ (* font 2)))))) - (xlib:with-gcontext (gcontext :font font - :foreground fg - :background bg) - (xlib:draw-image-glyphs - (bitmap-hunk-xwindow hunk) gcontext - (+ hunk-left-border (* x (font-family-width font-family))) - (+ hunk-top-border (* y (font-family-height font-family)) - (font-family-baseline font-family)) - string :start start :end end - :translate *glyph-translate-function*)))) - -;;; HUNK-REPLACE-LINE-STRING takes a character (x,y) pair and computes at -;;; which pixel coordinate to draw string with font from start to end. We draw -;;; the text on a pixmap and later blast it out to avoid line flicker since -;;; server on the RT is not very clever; it clears the entire line before -;;; drawing text. - -(defun hunk-replace-line-string* (hunk gcontext x y font-family font string start end) - (declare (ignore y)) - (let ((font (svref (font-family-map font-family) font)) - (fg (find-color (bitmap-hunk-xwindow hunk) (svref *color-map* (* font 2)))) - (bg (find-color (bitmap-hunk-xwindow hunk) (svref *color-map* (1+ (* font 2)))))) - (xlib:with-gcontext (gcontext :font font - :foreground fg - :background bg) - (xlib:draw-image-glyphs - (hunk-replace-line-pixmap) gcontext - (+ hunk-left-border (* x (font-family-width font-family))) - (font-family-baseline font-family) - string :start start :end end - :translate *glyph-translate-function*)))) - -;;; Hunk-Write-Line -- Internal -;;; -;;; Paint a dis-line on a hunk, taking font-changes into consideration. -;;; The area of the hunk drawn on is assumed to be cleared. If supplied, -;;; the line is written at Position, and the position in the dis-line -;;; is ignored. -;;; -(defun hunk-write-line (hunk dl &optional (position (dis-line-position dl))) - (let* ((font-family (bitmap-hunk-font-family hunk)) - (chars (dis-line-chars dl)) - (length (dis-line-length dl))) - (let ((last 0) - (last-font 0)) - (do ((change (dis-line-font-changes dl) (font-change-next change))) - ((null change) - (hunk-put-string* hunk last position font-family last-font chars last length)) - (let ((x (font-change-x change))) - (hunk-put-string* hunk last position font-family last-font chars last x) - (setq last x - last-font (font-change-font change)) ))))) - - -;;; We hack this since the X11 server's aren't clever about DRAW-IMAGE-GLYPHS; -;;; that is, they literally clear the line, and then blast the new glyphs. -;;; We don't hack replacing the line when reverse video is turned on because -;;; this doesn't seem to work too well. Also, hacking replace line on the -;;; color Megapel display is SLOW! -;;; -(defvar *hack-hunk-replace-line* t) - -;;; Hunk-Replace-Line -- Internal -;;; -;;; Similar to Hunk-Write-Line, but the line need not be clear. -;;; -(defun hunk-replace-line (hunk dl &optional - (position (dis-line-position dl))) - (if *hack-hunk-replace-line* - (hunk-replace-line-on-a-pixmap hunk dl position) - (old-hunk-replace-line hunk dl position))) - -(defun old-hunk-replace-line (hunk dl &optional (position (dis-line-position dl))) - (let* ((font-family (bitmap-hunk-font-family hunk)) - (chars (dis-line-chars dl)) - (length (dis-line-length dl)) - (height (font-family-height font-family)) ) - (let ((last 0) - (last-font 0)) - (do ((change (dis-line-font-changes dl) (font-change-next change))) - ((null change) - (hunk-put-string* hunk last position font-family last-font chars last length) - (let ((dx (+ hunk-left-border - (* (font-family-width font-family) length)))) - (xlib:clear-area (bitmap-hunk-xwindow hunk) - :x dx - :y (+ hunk-top-border (* position height)) - :width (- (bitmap-hunk-width hunk) dx) - :height height))) - (let ((x (font-change-x change))) - (hunk-put-string* hunk last position font-family last-font chars last x) - (setq last x last-font (font-change-font change)) ))))) - -(defvar *hunk-replace-line-pixmap* nil) - -(defun hunk-replace-line-pixmap () - (if *hunk-replace-line-pixmap* - *hunk-replace-line-pixmap* - (let* ((hunk (window-hunk *current-window*)) - (gcontext (bitmap-hunk-gcontext hunk)) - (screen (xlib:display-default-screen - (bitmap-device-display (device-hunk-device hunk)))) - (height (font-family-height *default-font-family*)) - (pixmap (xlib:create-pixmap - :width (* hunk-width-limit - (font-family-width *default-font-family*)) - :height height :depth (xlib:screen-root-depth screen) - :drawable (xlib:screen-root screen)))) - (xlib:with-gcontext (gcontext :function boole-1 - :foreground *default-background-pixel*) - (xlib:draw-rectangle pixmap gcontext 0 0 hunk-left-border height t)) - (setf *hunk-replace-line-pixmap* pixmap)))) - -(defun hunk-replace-line-on-a-pixmap (hunk dl position) - (let* ((font-family (bitmap-hunk-font-family hunk)) - (chars (dis-line-chars dl)) - (length (dis-line-length dl)) - (height (font-family-height font-family)) - (last 0) - (last-font 0) - (gcontext (bitmap-hunk-gcontext hunk))) - (do ((change (dis-line-font-changes dl) (font-change-next change))) - ((null change) - (hunk-replace-line-string* hunk gcontext last position font-family last-font chars last length) - (let* ((dx (+ hunk-left-border - (* (font-family-width font-family) length))) - (dy (+ hunk-top-border (* position height))) - (xwin (bitmap-hunk-xwindow hunk))) - (xlib:with-gcontext (gcontext :exposures nil) - (xlib:copy-area (hunk-replace-line-pixmap) gcontext - 0 0 dx height xwin 0 dy)) - (xlib:clear-area xwin :x dx :y dy - :width (- (bitmap-hunk-width hunk) dx) - :height height))) - (let ((x (font-change-x change))) - (hunk-replace-line-string* hunk gcontext last position font-family last-font chars last x) - (setq last x last-font (font-change-font change)))))) - - -;;; HUNK-REPLACE-MODELINE sets the entire mode line to the the foreground -;;; color, so the initial bits where no characters go also is highlighted. -;;; Then the text is drawn background on foreground (hightlighted). This -;;; function assumes that BITMAP-HUNK-MODELINE-POS will not return nil; -;;; that is, there is a modeline. This function should assume the gcontext's -;;; font is the default font of the hunk. We must LET bind the foreground and -;;; background values before entering XLIB:WITH-GCONTEXT due to a non-obvious -;;; or incorrect implementation. -;;; -(defun hunk-replace-modeline (hunk) - (let* ((dl (bitmap-hunk-modeline-dis-line hunk)) - (font-family (bitmap-hunk-font-family hunk)) - (default-font (svref (font-family-map font-family) 0)) - (modeline-pos (bitmap-hunk-modeline-pos hunk)) - (xwindow (bitmap-hunk-xwindow hunk)) - (gcontext (bitmap-hunk-gcontext hunk))) - (xlib:draw-rectangle xwindow gcontext 0 modeline-pos - (bitmap-hunk-width hunk) - (+ hunk-modeline-top hunk-modeline-bottom - (font-family-height font-family)) - t) - (xlib:with-gcontext (gcontext :foreground - (xlib:gcontext-background gcontext) - :background - (xlib:gcontext-foreground gcontext) - :font default-font) - (xlib:draw-image-glyphs xwindow gcontext hunk-left-border - (+ modeline-pos hunk-modeline-top - (font-family-baseline font-family)) - (dis-line-chars dl) - :end (dis-line-length dl) - :translate *glyph-translate-function*)))) - - - -;;;; Cursor/Border color manipulation. - -;;; *hemlock-listener* is set to t by default because we can't know from X -;;; whether we come up with the pointer in our window. There is no initial -;;; :enter-window event. Defaulting this to nil causes the cursor to be hollow -;;; when the window comes up under the mouse, and you have to know how to fix -;;; it. Defaulting it to t causes the cursor to always come up full, as if -;;; Hemlock is the X listener, but this recovers naturally as you move into the -;;; window. This also coincides with Hemlock's border coming up highlighted, -;;; even when Hemlock is not the listener. -;;; -(defvar *hemlock-listener* t - "Highlight border when the cursor is dropped and Hemlock can receive input.") -(defvar *current-highlighted-border* nil - "When non-nil, the bitmap-hunk with the highlighted border.") - -(defvar *hunk-cursor-x* 0 "The current cursor X position in pixels.") -(defvar *hunk-cursor-y* 0 "The current cursor Y position in pixels.") -(defvar *cursor-hunk* nil "Hunk the cursor is displayed on.") -(defvar *cursor-dropped* nil) ; True if the cursor is currently displayed. - -;;; HUNK-SHOW-CURSOR locates the cursor at character position (x,y) in hunk. -;;; If the cursor is currently displayed somewhere, then lift it, and display -;;; it at its new location. -;;; -(defun hunk-show-cursor (hunk x y) - (unless (and (= x *hunk-cursor-x*) - (= y *hunk-cursor-y*) - (eq hunk *cursor-hunk*)) - (let ((cursor-down *cursor-dropped*)) - (when cursor-down (lift-cursor)) - (setf *hunk-cursor-x* x) - (setf *hunk-cursor-y* y) - (setf *cursor-hunk* hunk) - (when cursor-down (drop-cursor))))) - -;;; FROB-CURSOR is the note-read-wait method for bitmap redisplay. We -;;; show a cursor and highlight the listening window's border when waiting -;;; for input. -;;; -(defun frob-cursor (on) - (if on (drop-cursor) (lift-cursor))) - -(declaim (special *default-border-pixmap* *highlight-border-pixmap*)) - -;;; DROP-CURSOR and LIFT-CURSOR are separate functions from FROB-CURSOR -;;; because they are called a couple places (e.g., HUNK-EXPOSED-REGION -;;; and SMART-WINDOW-REDISPLAY). When the cursor is being dropped, since -;;; this means Hemlock is listening in the *cursor-hunk*, make sure the -;;; border of the window is highlighted as well. -;;; -(defun drop-cursor () - (unless *cursor-dropped* - (unless *hemlock-listener* (cursor-invert-center)) - (cursor-invert) - (when *hemlock-listener* - (cond (*current-highlighted-border* - (unless (eq *current-highlighted-border* *cursor-hunk*) - (setf (xlib:window-border - (window-group-xparent - (bitmap-hunk-window-group *current-highlighted-border*))) - *default-border-pixmap*) - (setf (xlib:window-border - (window-group-xparent - (bitmap-hunk-window-group *cursor-hunk*))) - *highlight-border-pixmap*) - ;; For complete gratuitous pseudo-generality, should force - ;; output on *current-highlighted-border* device too. - (xlib:display-force-output - (bitmap-device-display (device-hunk-device *cursor-hunk*))))) - (t (setf (xlib:window-border - (window-group-xparent - (bitmap-hunk-window-group *cursor-hunk*))) - *highlight-border-pixmap*) - (xlib:display-force-output - (bitmap-device-display (device-hunk-device *cursor-hunk*))))) - (setf *current-highlighted-border* *cursor-hunk*)) - (setq *cursor-dropped* t))) - -;;; -(defun lift-cursor () - (when *cursor-dropped* - (unless *hemlock-listener* (cursor-invert-center)) - (cursor-invert) - (setq *cursor-dropped* nil))) - - -(defun cursor-invert-center () - (let ((family (bitmap-hunk-font-family *cursor-hunk*)) - (gcontext (bitmap-hunk-gcontext *cursor-hunk*))) - (xlib:with-gcontext (gcontext :function boole-xor - :foreground *foreground-background-xor*) - (xlib:draw-rectangle (bitmap-hunk-xwindow *cursor-hunk*) - gcontext - (+ hunk-left-border - (* *hunk-cursor-x* (font-family-width family)) - (font-family-cursor-x-offset family) - 1) - (+ hunk-top-border - (* *hunk-cursor-y* (font-family-height family)) - (font-family-cursor-y-offset family) - 1) - (- (font-family-cursor-width family) 2) - (- (font-family-cursor-height family) 2) - t))) - (xlib:display-force-output - (bitmap-device-display (device-hunk-device *cursor-hunk*)))) - -(defun cursor-invert () - (let ((family (bitmap-hunk-font-family *cursor-hunk*)) - (gcontext (bitmap-hunk-gcontext *cursor-hunk*))) - (xlib:with-gcontext (gcontext :function boole-xor - :foreground *foreground-background-xor*) - (xlib:draw-rectangle (bitmap-hunk-xwindow *cursor-hunk*) - gcontext - (+ hunk-left-border - (* *hunk-cursor-x* (font-family-width family)) - (font-family-cursor-x-offset family)) - (+ hunk-top-border - (* *hunk-cursor-y* (font-family-height family)) - (font-family-cursor-y-offset family)) - (font-family-cursor-width family) - (font-family-cursor-height family) - t))) - (xlib:display-force-output - (bitmap-device-display (device-hunk-device *cursor-hunk*)))) - - - - -;;;; Clearing and Copying Lines. - -(defun hunk-clear-lines (hunk start count) - (let ((height (font-family-height (bitmap-hunk-font-family hunk)))) - (xlib:clear-area (bitmap-hunk-xwindow hunk) - :x 0 :y (+ hunk-top-border (* start height)) - :width (bitmap-hunk-width hunk) - :height (* count height)))) - -(defun hunk-copy-lines (hunk src dst count) - (let ((height (font-family-height (bitmap-hunk-font-family hunk))) - (xwindow (bitmap-hunk-xwindow hunk))) - (xlib:copy-area xwindow (bitmap-hunk-gcontext hunk) - 0 (+ hunk-top-border (* src height)) - (bitmap-hunk-width hunk) (* height count) - xwindow 0 (+ hunk-top-border (* dst height))))) - - - - -;;;; Drawing bottom border meter. - -;;; HUNK-DRAW-BOTTOM-BORDER assumes eight-character-space tabs. The LOGAND -;;; calls in the loop are testing for no remainder when dividing by 8, 4, -;;; and other. This lets us quickly draw longer notches at tab stops and -;;; half way in between. This function assumes that -;;; BITMAP-HUNK-MODELINE-POS will not return nil; that is, that there is a -;;; modeline. -;;; -(defun hunk-draw-bottom-border (hunk) - (when (bitmap-hunk-thumb-bar-p hunk) - (let* ((xwindow (bitmap-hunk-xwindow hunk)) - (gcontext (bitmap-hunk-gcontext hunk)) - (modeline-pos (bitmap-hunk-modeline-pos hunk)) - (font-family (bitmap-hunk-font-family hunk)) - (font-width (font-family-width font-family))) - (xlib:clear-area xwindow :x 0 :y (- modeline-pos - hunk-thumb-bar-bottom-border) - :width (bitmap-hunk-width hunk) - :height hunk-bottom-border) - (let ((x (+ hunk-left-border (ash font-width -1))) - (y7 (- modeline-pos 7)) - (y5 (- modeline-pos 5)) - (y3 (- modeline-pos 3))) - (dotimes (i (bitmap-hunk-char-width hunk)) - (cond ((zerop (logand i 7)) - (xlib:draw-rectangle xwindow gcontext - x y7 (if (= i 80) 2 1) 7 t)) - ((zerop (logand i 3)) - (xlib:draw-rectangle xwindow gcontext x y5 1 5 t)) - (t - (xlib:draw-rectangle xwindow gcontext x y3 1 3 t))) - (incf x font-width)))))) - -;; $Log$ -;; Revision 1.1 2003/10/19 08:57:15 gb -;; Initial revision -;; -;; Revision 1.1.2.2 2003/09/18 13:40:16 gb -;; Conditionalize for #-CLX, a little more. -;; -;; Revision 1.1.2.1 2003/08/10 19:11:27 gb -;; New files, imported from upstream CVS as of 03/08/09. -;; -;; Revision 1.4 2003/08/05 19:54:17 gilbert -;; - did away with some macros -;; - invested in a left margin for added readability of hemlock frames. -;; Index: anches/ide-1.0/ccl/hemlock/src/input.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/input.lisp (revision 6566) +++ (revision ) @@ -1,501 +1,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- -;;; -;;; ********************************************************************** -;;; This code was written as part of the CMU Common Lisp project at -;;; Carnegie Mellon University, and has been placed in the public domain. -;;; -#+CMU (ext:file-comment - "$Header$") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the code that handles input to Hemlock. -;;; -(in-package :hemlock-internals) - -;;; -;;; INPUT-WAITING is exported solely as a hack for the kbdmac definition -;;; mechanism. -;;; - - -;;; These are public variables users hand to the four basic editor input -;;; routines for method dispatching: -;;; GET-KEY-EVENT -;;; UNGET-KEY-EVENT -;;; LISTEN-EDITOR-INPUT -;;; CLEAR-EDITOR-INPUT -;;; -(defvar *editor-input* nil - "A structure used to do various operations on terminal input.") - -(defvar *real-editor-input* () - "Useful when we want to read from the terminal when *editor-input* is - rebound.") - - - - -;;;; editor-input structure. - -(defstruct (editor-input (:print-function - (lambda (s stream d) - (declare (ignore s d)) - (write-string "#" stream)))) - get ; A function that returns the next key-event in the queue. - unget ; A function that puts a key-event at the front of the queue. - listen ; A function that tells whether the queue is empty. - clear ; A function that empties the queue. - ;; - ;; Queue of events on this stream. The queue always contains at least one - ;; one element, which is the key-event most recently read. If no event has - ;; been read, the event is a dummy with a nil key-event. - head - tail) - - -;;; These are the elements of the editor-input event queue. -;;; -(defstruct (input-event (:constructor make-input-event ())) - next ; Next queued event, or NIL if none. - hunk ; Screen hunk event was read from. - key-event ; Key-event read. - x ; X and Y character position of mouse cursor. - y - unread-p) - -(defvar *free-input-events* ()) - -(defun new-event (key-event x y hunk next &optional unread-p) - (let ((res (if *free-input-events* - (shiftf *free-input-events* - (input-event-next *free-input-events*)) - (make-input-event)))) - (setf (input-event-key-event res) key-event) - (setf (input-event-x res) x) - (setf (input-event-y res) y) - (setf (input-event-hunk res) hunk) - (setf (input-event-next res) next) - (setf (input-event-unread-p res) unread-p) - res)) - -;;; This is a public variable. -;;; -(defvar *last-key-event-typed* () - "This variable contains the last key-event typed by the user and read as - input.") - -;;; This is a public variable. SITE-INIT initializes this. -;;; -(defvar *key-event-history* nil - "This ring holds the last 60 key-events read by the command interpreter.") - -(declaim (special *input-transcript*)) - -;;; DQ-EVENT is used in editor stream methods for popping off input. -;;; If there is an event not yet read in Stream, then pop the queue -;;; and return the character. If there is none, return NIL. -;;; -(defun dq-event (stream) - (hemlock-ext:without-interrupts - (let* ((head (editor-input-head stream)) - (next (input-event-next head))) - (if next - (let ((key-event (input-event-key-event next))) - (setf (editor-input-head stream) next) - (shiftf (input-event-next head) *free-input-events* head) - (ring-push key-event *key-event-history*) - (setf *last-key-event-typed* key-event) - (when *input-transcript* - (vector-push-extend key-event *input-transcript*)) - key-event))))) - -;;; Q-EVENT is used in low level input fetching routines to add input to the -;;; editor stream. -;;; -(defun q-event (stream key-event &optional x y hunk) - (hemlock-ext:without-interrupts - (let ((new (new-event key-event x y hunk nil)) - (tail (editor-input-tail stream))) - (setf (input-event-next tail) new) - (setf (editor-input-tail stream) new)))) - -(defun un-event (key-event stream) - (hemlock-ext:without-interrupts - (let* ((head (editor-input-head stream)) - (next (input-event-next head)) - (new (new-event key-event (input-event-x head) (input-event-y head) - (input-event-hunk head) next t))) - (setf (input-event-next head) new) - (unless next (setf (editor-input-tail stream) new))))) - - - - -;;;; Keyboard macro hacks. - -(defvar *input-transcript* () - "If this variable is non-null then it should contain an adjustable vector - with a fill pointer into which all keyboard input will be pushed.") - -;;; INPUT-WAITING -- Internal -;;; -;;; An Evil hack that tells us whether there is an unread key-event on -;;; *editor-input*. Note that this is applied to the real *editor-input* -;;; rather than to a kbdmac stream. -;;; -(defun input-waiting () - "Returns true if there is a key-event which has been unread-key-event'ed - on *editor-input*. Used by the keyboard macro stuff." - (let ((next (input-event-next - (editor-input-head *real-editor-input*)))) - (and next (input-event-unread-p next)))) - - - - -;;;; Input method macro. - -(defvar *in-hemlock-stream-input-method* nil - "This keeps us from undefined nasties like re-entering Hemlock stream - input methods from input hooks and scheduled events.") - -(declaim (special *screen-image-trashed*)) - -;;; These are the characters GET-KEY-EVENT notices when it pays attention -;;; to aborting input. This happens via EDITOR-INPUT-METHOD-MACRO. -;;; -(defparameter editor-abort-key-events (list #k"Control-g" #k"Control-G")) - -#+clx -(defun cleanup-for-wm-closed-display(closed-display) - ;; Remove fd-handlers - (hemlock-ext:disable-clx-event-handling closed-display) - ;; Close file descriptor and note DEAD. - (xlib:close-display closed-display) - ;; - ;; At this point there is not much sense to returning to Lisp - ;; as the editor cannot be re-entered (there are lots of pointers - ;; to the dead display around that will cause subsequent failures). - ;; Maybe could switch to tty mode then (save-all-files-and-exit)? - ;; For now, just assume user wanted an easy way to kill the session. - (hemlock-ext:quit)) - -(defmacro abort-key-event-p (key-event) - `(member ,key-event editor-abort-key-events)) - -;;; EDITOR-INPUT-METHOD-MACRO -- Internal. -;;; -;;; WINDOWED-GET-KEY-EVENT and TTY-GET-KEY-EVENT use this. Somewhat odd stuff -;;; goes on here because this is the place where Hemlock waits, so this is -;;; where we redisplay, check the time for scheduled events, etc. In the loop, -;;; we call the input hook when we get a character and leave the loop. If -;;; there isn't any input, invoke any scheduled events whose time is up. -;;; Unless SERVE-EVENT returns immediately and did something, (serve-event 0), -;;; call redisplay, note that we are going into a read wait, and call -;;; SERVE-EVENT with a wait or infinite timeout. Upon exiting the loop, turn -;;; off the read wait note and check for the abort character. Return the -;;; key-event we got. We bind an error condition handler here because the -;;; default Hemlock error handler goes into a little debugging prompt loop, but -;;; if we got an error in getting input, we should prompt the user using the -;;; input method (recursively even). -;;; -(eval-when (:compile-toplevel :execute) - -(defmacro editor-input-method-macro () - `(handler-bind - ((error - (lambda (condition) - (when (typep condition 'stream-error) - (let* ((stream (stream-error-stream condition)) - (display *editor-windowed-input*) - (display-stream - #+CLX - (and display (xlib::display-input-stream display)))) - (when (eq stream display-stream) - ;;(format *error-output* "~%Hemlock: Display died!~%~%") - (cleanup-for-wm-closed-display display) - (exit-hemlock nil)) - (let ((device - (device-hunk-device (window-hunk (current-window))))) - (funcall (device-exit device) device)) - (invoke-debugger condition))))) - #+(and CLX ) - (xlib:closed-display - (lambda(condition) - (let ((display (xlib::closed-display-display condition))) - (format *error-output* - "Closed display on stream ~a~%" - (xlib::display-input-stream display))) - (exit-hemlock nil))) - ) -; (when *in-hemlock-stream-input-method* -; (error "Entering Hemlock stream input method recursively!")) - (let ((*in-hemlock-stream-input-method* t) - (nrw-fun (device-note-read-wait - (device-hunk-device (window-hunk (current-window))))) - key-event) - (loop - (when (setf key-event (dq-event stream)) - (dolist (f (variable-value 'hemlock::input-hook)) (funcall f)) - (return)) - (invoke-scheduled-events) - (unless (or (hemlock-ext:serve-event 0) - (internal-redisplay)) - (internal-redisplay) - (when nrw-fun (funcall nrw-fun t)) - (let ((wait (next-scheduled-event-wait))) - (if wait (hemlock-ext:serve-event wait) (hemlock-ext:serve-event))))) - (when nrw-fun (funcall nrw-fun nil)) - (when (and (abort-key-event-p key-event) - ;; ignore-abort-attempts-p must exist outside the macro. - ;; in this case it is bound in GET-KEY-EVENT. - (not ignore-abort-attempts-p)) - (beep) - (throw 'editor-top-level-catcher nil)) - key-event))) -) ;eval-when - - - - -;;;; Editor input from windowing system. -#+clx -(defstruct (windowed-editor-input - (:include editor-input - (get #'windowed-get-key-event) - (unget #'windowed-unget-key-event) - (listen #'windowed-listen) - (clear #'windowed-clear-input)) - (:print-function - (lambda (s stream d) - (declare (ignore s d)) - (write-string "#" stream))) - (:constructor make-windowed-editor-input - (&optional (head (make-input-event)) (tail head)))) - hunks) ; List of bitmap-hunks which input to this stream. - -#+clx -;;; There's actually no difference from the TTY case... -(defun windowed-get-key-event (stream ignore-abort-attempts-p) - (tty-get-key-event stream ignore-abort-attempts-p)) - -#+clx -(defun windowed-unget-key-event (key-event stream) - (un-event key-event stream)) - -#+clx -(defun windowed-clear-input (stream) - (loop (unless (hemlock-ext:serve-event 0) (return))) - (hemlock-ext:without-interrupts - (let* ((head (editor-input-head stream)) - (next (input-event-next head))) - (when next - (setf (input-event-next head) nil) - (shiftf (input-event-next (editor-input-tail stream)) - *free-input-events* next) - (setf (editor-input-tail stream) head))))) - -#+clx -(defun windowed-listen (stream) - (loop - ;; Don't service anymore events if we just got some input. - (when (input-event-next (editor-input-head stream)) - (return t)) - ;; - ;; If nothing is pending, check the queued input. - (unless (hemlock-ext:serve-event 0) - (return (not (null (input-event-next (editor-input-head stream)))))))) - - - -;;;; Editor input from a tty. - -(defstruct (tty-editor-input - (:include editor-input - (get #'tty-get-key-event) - (unget #'tty-unget-key-event) - (listen #'tty-listen) - (clear #'tty-clear-input)) - (:print-function - (lambda (obj stream n) - (declare (ignore obj n)) - (write-string "#" stream))) - (:constructor make-tty-editor-input - (fd &optional (head (make-input-event)) (tail head)))) - fd) - -(defun tty-get-key-event (stream ignore-abort-attempts-p) - (editor-input-method-macro)) - -(defun tty-unget-key-event (key-event stream) - (un-event key-event stream)) - -(defun tty-clear-input (stream) - (hemlock-ext:without-interrupts - (let* ((head (editor-input-head stream)) - (next (input-event-next head))) - (when next - (setf (input-event-next head) nil) - (shiftf (input-event-next (editor-input-tail stream)) - *free-input-events* next) - (setf (editor-input-tail stream) head))))) - -;;; Note that we never return NIL as long as there are events to be served with -;;; SERVE-EVENT. Thus non-keyboard input (i.e. process output) -;;; effectively causes LISTEN to block until either all the non-keyboard input -;;; has happened, or there is some real keyboard input. -;;; -(defun tty-listen (stream) - (loop - ;; Don't service anymore events if we just got some input. - (when (or (input-event-next (editor-input-head stream)) - (editor-tty-listen stream)) - (return t)) - ;; If nothing is pending, check the queued input. - (unless (hemlock-ext:serve-event 0) - (return (not (null (input-event-next (editor-input-head stream)))))))) - - - -;;;; GET-KEY-EVENT, UNGET-KEY-EVENT, LISTEN-EDITOR-INPUT, CLEAR-EDITOR-INPUT. - -;;; GET-KEY-EVENT -- Public. -;;; -(defun get-key-event (editor-input &optional ignore-abort-attempts-p) - "This function returns a key-event as soon as it is available on - editor-input. Editor-input is either *editor-input* or *real-editor-input*. - Ignore-abort-attempts-p indicates whether #k\"C-g\" and #k\"C-G\" throw to - the editor's top-level command loop; when this is non-nil, this function - returns those key-events when the user types them. Otherwise, it aborts the - editor's current state, returning to the command loop." - (funcall (editor-input-get editor-input) editor-input ignore-abort-attempts-p)) - -;;; UNGET-KEY-EVENT -- Public. -;;; -(defun unget-key-event (key-event editor-input) - "This function returns the key-event to editor-input, so the next invocation - of GET-KEY-EVENT will return the key-event. If the key-event is #k\"C-g\" - or #k\"C-G\", then whether GET-KEY-EVENT returns it depends on its second - argument. Editor-input is either *editor-input* or *real-editor-input*." - (funcall (editor-input-unget editor-input) key-event editor-input)) - -;;; CLEAR-EDITOR-INPUT -- Public. -;;; -(defun clear-editor-input (editor-input) - "This function flushes any pending input on editor-input. Editor-input - is either *editor-input* or *real-editor-input*." - (funcall (editor-input-clear editor-input) editor-input)) - -;;; LISTEN-EDITOR-INPUT -- Public. -;;; -(defun listen-editor-input (editor-input) - "This function returns whether there is any input available on editor-input. - Editor-input is either *editor-input* or *real-editor-input*." - (funcall (editor-input-listen editor-input) editor-input)) - - - - -;;;; LAST-KEY-EVENT-CURSORPOS and WINDOW-INPUT-HANDLER. - -;;; LAST-KEY-EVENT-CURSORPOS -- Public -;;; -;;; Just look up the saved info in the last read key event. -;;; -(defun last-key-event-cursorpos () - "Return as values, the (X, Y) character position and window where the - last key event happened. If this cannot be determined, Nil is returned. - If in the modeline, return a Y position of NIL and the correct X and window. - Returns nil for terminal input." - (let* ((ev (editor-input-head *real-editor-input*)) - (hunk (input-event-hunk ev)) - (window (and hunk (device-hunk-window hunk)))) - (when window - (values (input-event-x ev) (input-event-y ev) window)))) - -;;; WINDOW-INPUT-HANDLER -- Internal -;;; -;;; This is the input-handler function for hunks that implement windows. It -;;; just queues the events on *real-editor-input*. -;;; -(defun window-input-handler (hunk char x y) - (q-event *real-editor-input* char x y hunk)) - - - - -;;;; Random typeout input routines. - -(defun wait-for-more (stream) - (let ((key-event (more-read-key-event))) - (cond ((logical-key-event-p key-event :yes)) - ((or (logical-key-event-p key-event :do-all) - (logical-key-event-p key-event :exit)) - (setf (random-typeout-stream-no-prompt stream) t) - (random-typeout-cleanup stream)) - ((logical-key-event-p key-event :keep) - (setf (random-typeout-stream-no-prompt stream) t) - (maybe-keep-random-typeout-window stream) - (random-typeout-cleanup stream)) - ((logical-key-event-p key-event :no) - (random-typeout-cleanup stream) - (throw 'more-punt nil)) - (t - (unget-key-event key-event *editor-input*) - (random-typeout-cleanup stream) - (throw 'more-punt nil))))) - -(declaim (special *more-prompt-action*)) - -(defun maybe-keep-random-typeout-window (stream) - (let* ((window (random-typeout-stream-window stream)) - (buffer (window-buffer window)) - (start (buffer-start-mark buffer))) - (when (typep (hi::device-hunk-device (hi::window-hunk window)) - 'hi::bitmap-device) - (let ((*more-prompt-action* :normal)) - (update-modeline-field buffer window :more-prompt) - (random-typeout-redisplay window)) - (buffer-start (buffer-point buffer)) - (let* ((xwindow (make-xwindow-like-hwindow window)) - (window (make-window start :window xwindow))) - (unless window - #+clx(xlib:destroy-window xwindow) - (editor-error "Could not create random typeout window.")))))) - -(defun end-random-typeout (stream) - (let ((*more-prompt-action* :flush) - (window (random-typeout-stream-window stream))) - (update-modeline-field (window-buffer window) window :more-prompt) - (random-typeout-redisplay window)) - (unless (random-typeout-stream-no-prompt stream) - (let* ((key-event (more-read-key-event)) - (keep-p (logical-key-event-p key-event :keep))) - (when keep-p (maybe-keep-random-typeout-window stream)) - (random-typeout-cleanup stream) - (unless (or (logical-key-event-p key-event :do-all) - (logical-key-event-p key-event :exit) - (logical-key-event-p key-event :no) - (logical-key-event-p key-event :yes) - keep-p) - (unget-key-event key-event *editor-input*))))) - -;;; MORE-READ-KEY-EVENT -- Internal. -;;; -;;; This gets some input from the type of stream bound to *editor-input*. Need -;;; to loop over SERVE-EVENT since it returns on any kind of event (not -;;; necessarily a key or button event). -;;; -;;; Currently this does not work for keyboard macro streams! -;;; -(defun more-read-key-event () - (clear-editor-input *editor-input*) - (let ((key-event (loop - (let ((key-event (dq-event *editor-input*))) - (when key-event (return key-event)) - (hemlock-ext:serve-event))))) - (when (abort-key-event-p key-event) - (beep) - (throw 'editor-top-level-catcher nil)) - key-event)) Index: anches/ide-1.0/ccl/hemlock/src/lispbuf.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/lispbuf.lisp (revision 6566) +++ (revision ) @@ -1,794 +1,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock -*- -;;; -;;; ********************************************************************** -;;; This code was written as part of the CMU Common Lisp project at -;;; Carnegie Mellon University, and has been placed in the public domain. -;;; -#+CMU (ext:file-comment - "$Header$") -;;; -;;; ********************************************************************** -;;; -;;; Stuff to do a little lisp hacking in the editor's Lisp environment. -;;; - -(in-package :hemlock) - - -(defmacro in-lisp (&body body) - "Evaluates body inside HANDLE-LISP-ERRORS. *package* is bound to the package - named by \"Current Package\" if it is non-nil." - (let ((name (gensym)) (package (gensym))) - `(handle-lisp-errors - (let* ((,name (value current-package)) - (,package (and ,name (find-package ,name)))) - (progv (if ,package '(*package*)) (if ,package (list ,package)) - ,@body))))) - - -(define-file-option "Package" (buffer value) - (defhvar "Current Package" - "The package used for evaluation of Lisp in this buffer." - :buffer buffer - :value - (let* ((eof (list nil)) - (thing (read-from-string value nil eof))) - (when (eq thing eof) (error "Bad package file option value.")) - (cond - ((stringp thing) - thing) - ((symbolp thing) - (symbol-name thing)) - ((characterp thing) - (string thing)) - (t - (message - "Ignoring \"package\" file option -- cannot convert to a string.")))) - :hooks (list 'package-name-change-hook))) - - - -;;;; Eval Mode Interaction. - -(declaim (special * ** *** - + ++ +++ / // ///)) - - -(defun get-prompt () - #+cmu (locally (declare (special ext:*prompt*)) - (if (functionp ext:*prompt*) - (funcall ext:*prompt*) - ext:*prompt*)) - #+sbcl (with-output-to-string (out) - (funcall sb-int:*repl-prompt-fun* out)) - #-(or cmu sbcl) "* ") - - -(defun show-prompt (&optional (stream *standard-output*)) - #-sbcl (princ (get-prompt) stream) - #+sbcl (funcall sb-int:*repl-prompt-fun* stream)) - - -(defun setup-eval-mode (buffer) - (let ((point (buffer-point buffer))) - (setf (buffer-minor-mode buffer "Eval") t) - (setf (buffer-minor-mode buffer "Editor") t) - (setf (buffer-major-mode buffer) "Lisp") - (buffer-end point) - (defhvar "Current Package" - "This variable holds the name of the package currently used for Lisp - evaluation and compilation. If it is Nil, the value of *Package* is used - instead." - :value nil - :buffer buffer) - (unless (hemlock-bound-p 'buffer-input-mark :buffer buffer) - (defhvar "Buffer Input Mark" - "Mark used for Eval Mode input." - :buffer buffer - :value (copy-mark point :right-inserting)) - (defhvar "Eval Output Stream" - "Output stream used for Eval Mode output in this buffer." - :buffer buffer - :value (make-hemlock-output-stream point)) - (defhvar "Interactive History" - "A ring of the regions input to an interactive mode (Eval or Typescript)." - :buffer buffer - :value (make-ring (value interactive-history-length))) - (defhvar "Interactive Pointer" - "Pointer into \"Interactive History\"." - :buffer buffer - :value 0) - (defhvar "Searching Interactive Pointer" - "Pointer into \"Interactive History\"." - :buffer buffer - :value 0)) - (let ((*standard-output* - (variable-value 'eval-output-stream :buffer buffer))) - (fresh-line) - (show-prompt)) - (move-mark (variable-value 'buffer-input-mark :buffer buffer) point))) - -(defmode "Eval" :major-p nil :setup-function #'setup-eval-mode) - -(defun eval-mode-lisp-mode-hook (buffer on) - "Turn on Lisp mode when we go into Eval Mode." - (when on - (setf (buffer-major-mode buffer) "Lisp"))) -;;; -(add-hook eval-mode-hook 'eval-mode-lisp-mode-hook) - -(defhvar "Editor Definition Info" - "When this is non-nil, the editor Lisp is used to determine definition - editing information; otherwise, the slave Lisp is used." - :value t - :mode "Eval") - - -(defvar *selected-eval-buffer* nil) - -(defcommand "Select Eval Buffer" (p) - "Goto buffer in \"Eval\" mode, creating one if necessary." - "Goto buffer in \"Eval\" mode, creating one if necessary." - (declare (ignore p)) - (unless *selected-eval-buffer* - (when (getstring "Eval" *buffer-names*) - (editor-error "There is already a buffer named \"Eval\"!")) - (setf *selected-eval-buffer* - (make-buffer "Eval" - :delete-hook - (list #'(lambda (buf) - (declare (ignore buf)) - (setf *selected-eval-buffer* nil))))) - (setf (buffer-minor-mode *selected-eval-buffer* "Eval") t)) - (change-to-buffer *selected-eval-buffer*)) - - -(defvar lispbuf-eof '(nil)) - -(defhvar "Unwedge Interactive Input Confirm" - "When set (the default), trying to confirm interactive input when the - point is not after the input mark causes Hemlock to ask the user if he - needs to be unwedged. When not set, an editor error is signaled - informing the user that the point is before the input mark." - :value t) - -(defun unwedge-eval-buffer () - (abort-eval-input-command nil)) - -(defhvar "Unwedge Interactive Input Fun" - "Function to call when input is confirmed, but the point is not past the - input mark." - :value #'unwedge-eval-buffer - :mode "Eval") - -(defhvar "Unwedge Interactive Input String" - "String to add to \"Point not past input mark. \" explaining what will - happen if the the user chooses to be unwedged." - :value "Prompt again at the end of the buffer? " - :mode "Eval") - -(defcommand "Confirm Eval Input" (p) - "Evaluate Eval Mode input between point and last prompt." - "Evaluate Eval Mode input between point and last prompt." - (declare (ignore p)) - (let ((input-region (get-interactive-input))) - (when input-region - (let* ((output (value eval-output-stream)) - (*standard-output* output) - (*error-output* output) - (*trace-output* output)) - (fresh-line) - (in-lisp - ;; Copy the region to keep the output and input streams from interacting - ;; since input-region is made of permanent marks into the buffer. - (with-input-from-region (stream (copy-region input-region)) - (loop - (let ((form (read stream nil lispbuf-eof))) - (when (eq form lispbuf-eof) - ;; Move the buffer's input mark to the end of the buffer. - (move-mark (region-start input-region) - (region-end input-region)) - (return)) - (setq +++ ++ ++ + + - - form) - (let ((this-eval (multiple-value-list (eval form)))) - (fresh-line) - (dolist (x this-eval) (prin1 x) (terpri)) - (show-prompt) - (setq /// // // / / this-eval) - (setq *** ** ** * * (car this-eval))))))))))) - -(defcommand "Abort Eval Input" (p) - "Move to the end of the buffer and prompt." - "Move to the end of the buffer and prompt." - (declare (ignore p)) - (let ((point (current-point))) - (buffer-end point) - (insert-character point #\newline) - (insert-string point "Aborted.") - (insert-character point #\newline) - (insert-string point (get-prompt)) - (move-mark (value buffer-input-mark) point))) - - - - -;;;; General interactive commands used in eval and typescript buffers. - -(defun get-interactive-input () - "Tries to return a region. When the point is not past the input mark, and - the user has \"Unwedge Interactive Input Confirm\" set, the buffer is - optionally fixed up, and nil is returned. Otherwise, an editor error is - signalled. When a region is returned, the start is the current buffer's - input mark, and the end is the current point moved to the end of the buffer." - (let ((point (current-point)) - (mark (value buffer-input-mark))) - (cond - ((mark>= point mark) - (buffer-end point) - (let* ((input-region (region mark point)) - (string (region-to-string input-region)) - (ring (value interactive-history))) - (when (and (or (zerop (ring-length ring)) - (string/= string (region-to-string (ring-ref ring 0)))) - (> (length string) (value minimum-interactive-input-length))) - (ring-push (copy-region input-region) ring)) - input-region)) - ((value unwedge-interactive-input-confirm) - (beep) - (when (prompt-for-y-or-n - :prompt (concatenate 'simple-string - "Point not past input mark. " - (value unwedge-interactive-input-string)) - :must-exist t :default t :default-string "yes") - (funcall (value unwedge-interactive-input-fun)) - (message "Unwedged.")) - nil) - (t - (editor-error "Point not past input mark."))))) - -(defhvar "Interactive History Length" - "This is the length used for the history ring in interactive buffers. - It must be set before turning on the mode." - :value 10) - -(defhvar "Minimum Interactive Input Length" - "When the number of characters in an interactive buffer exceeds this value, - it is pushed onto the interactive history, otherwise it is lost forever." - :value 2) - - -(defvar *previous-input-search-string* "ignore") - -(defvar *previous-input-search-pattern* - ;; Give it a bogus string since you can't give it the empty string. - (new-search-pattern :string-insensitive :forward "ignore")) - -(defun get-previous-input-search-pattern (string) - (if (string= *previous-input-search-string* string) - *previous-input-search-pattern* - (new-search-pattern :string-insensitive :forward - (setf *previous-input-search-string* string) - *previous-input-search-pattern*))) - -(defcommand "Search Previous Interactive Input" (p) - "Search backward through the interactive history using the current input as - a search string. Consecutive invocations repeat the previous search." - "Search backward through the interactive history using the current input as - a search string. Consecutive invocations repeat the previous search." - (declare (ignore p)) - (let* ((mark (value buffer-input-mark)) - (ring (value interactive-history)) - (point (current-point)) - (just-invoked (eq (last-command-type) :searching-interactive-input))) - (when (mark<= point mark) - (editor-error "Point not past input mark.")) - (when (zerop (ring-length ring)) - (editor-error "No previous input in this buffer.")) - (unless just-invoked - (get-previous-input-search-pattern (region-to-string (region mark point)))) - (let ((found-it (find-previous-input ring just-invoked))) - (unless found-it - (editor-error "Couldn't find ~a." *previous-input-search-string*)) - (delete-region (region mark point)) - (insert-region point (ring-ref ring found-it)) - (setf (value searching-interactive-pointer) found-it)) - (setf (last-command-type) :searching-interactive-input))) - -(defun find-previous-input (ring againp) - (let ((ring-length (ring-length ring)) - (base (if againp - (+ (value searching-interactive-pointer) 1) - 0))) - (loop - (when (= base ring-length) - (if againp - (setf base 0) - (return nil))) - (with-mark ((m (region-start (ring-ref ring base)))) - (when (find-pattern m *previous-input-search-pattern*) - (return base))) - (incf base)))) - -(defcommand "Previous Interactive Input" (p) - "Insert the previous input in an interactive mode (Eval or Typescript). - If repeated, keep rotating the history. With prefix argument, rotate - that many times." - "Pop the *interactive-history* at the point." - (let* ((point (current-point)) - (mark (value buffer-input-mark)) - (ring (value interactive-history)) - (length (ring-length ring)) - (p (or p 1))) - (when (or (mark< point mark) (zerop length)) (editor-error)) - (cond - ((eq (last-command-type) :interactive-history) - (let ((base (mod (+ (value interactive-pointer) p) length))) - (delete-region (region mark point)) - (insert-region point (ring-ref ring base)) - (setf (value interactive-pointer) base))) - (t - (let ((base (mod (if (minusp p) p (1- p)) length)) - (region (delete-and-save-region (region mark point)))) - (insert-region point (ring-ref ring base)) - (when (mark/= (region-start region) (region-end region)) - (ring-push region ring) - (incf base)) - (setf (value interactive-pointer) base))))) - (setf (last-command-type) :interactive-history)) - -(defcommand "Next Interactive Input" (p) - "Rotate the interactive history backwards. The region is left around the - inserted text. With prefix argument, rotate that many times." - "Call previous-interactive-input-command with negated arg." - (previous-interactive-input-command (- (or p 1)))) - -(defcommand "Kill Interactive Input" (p) - "Kill any input to an interactive mode (Eval or Typescript)." - "Kill any input to an interactive mode (Eval or Typescript)." - (declare (ignore p)) - (let ((point (buffer-point (current-buffer))) - (mark (value buffer-input-mark))) - (when (mark< point mark) (editor-error)) - (kill-region (region mark point) :kill-backward))) - -(defcommand "Interactive Beginning of Line" (p) - "If on line with current prompt, go to after it, otherwise do what - \"Beginning of Line\" always does." - "Go to after prompt when on prompt line." - (let ((mark (value buffer-input-mark)) - (point (current-point))) - (if (and (same-line-p point mark) (or (not p) (= p 1))) - (move-mark point mark) - (beginning-of-line-command p)))) - -(defcommand "Reenter Interactive Input" (p) - "Copies the form to the left of point to be after the interactive buffer's - input mark. When the current region is active, it is copied instead." - "Copies the form to the left of point to be after the interactive buffer's - input mark. When the current region is active, it is copied instead." - (declare (ignore p)) - (unless (hemlock-bound-p 'buffer-input-mark) - (editor-error "Not in an interactive buffer.")) - (let ((point (current-point))) - (let ((region (if (region-active-p) - ;; Copy this, so moving point doesn't affect the region. - (copy-region (current-region)) - (with-mark ((start point) - (end point)) - (pre-command-parse-check start) - (unless (form-offset start -1) - (editor-error "Not after complete form.")) - (region (copy-mark start) (copy-mark end)))))) - (buffer-end point) - (push-buffer-mark (copy-mark point)) - (insert-region point region) - (setf (last-command-type) :ephemerally-active)))) - - - - -;;; Other stuff. - -(defmode "Editor") - -(defcommand "Editor Mode" (p) - "Turn on \"Editor\" mode in the current buffer. If it is already on, turn it - off. When in editor mode, most lisp compilation and evaluation commands - manipulate the editor process instead of the current eval server." - "Toggle \"Editor\" mode in the current buffer." - (declare (ignore p)) - (setf (buffer-minor-mode (current-buffer) "Editor") - (not (buffer-minor-mode (current-buffer) "Editor")))) - -(define-file-option "Editor" (buffer value) - (declare (ignore value)) - (setf (buffer-minor-mode buffer "Editor") t)) - -(defhvar "Editor Definition Info" - "When this is non-nil, the editor Lisp is used to determine definition - editing information; otherwise, the slave Lisp is used." - :value t - :mode "Editor") - -(defcommand "Editor Compile Defun" (p) - "Compiles the current or next top-level form in the editor Lisp. - First the form is evaluated, then the result of this evaluation - is passed to compile. If the current region is active, this - compiles the region." - "Evaluates the current or next top-level form in the editor Lisp." - (declare (ignore p)) - (if (region-active-p) - (editor-compile-region (current-region)) - (editor-compile-region (defun-region (current-point)) t))) - -(defcommand "Editor Compile Region" (p) - "Compiles lisp forms between the point and the mark in the editor Lisp." - "Compiles lisp forms between the point and the mark in the editor Lisp." - (declare (ignore p)) - (editor-compile-region (current-region))) - -(defun defun-region (mark) - "This returns a region around the current or next defun with respect to mark. - Mark is not used to form the region. If there is no appropriate top level - form, this signals an editor-error. This calls PRE-COMMAND-PARSE-CHECK." - (with-mark ((start mark) - (end mark)) - (pre-command-parse-check start) - (cond ((not (mark-top-level-form start end)) - (editor-error "No current or next top level form.")) - (t (region start end))))) - -(defun editor-compile-region (region &optional quiet) - (unless quiet (message "Compiling region ...")) - (in-lisp - (with-input-from-region (stream region) - (with-pop-up-display (*error-output* :height 19) - ;; JDz: We don't record source locations and what not, but this - ;; is portable. CMUCL specific implementation removed because - ;; it does not work on HEMLOCK-REGION-STREAM (but it can be - ;; added back later if CMUCL starts using user-extensible - ;; streams internally.) - (funcall (compile nil `(lambda () - ,@(loop for form = (read stream nil stream) - until (eq form stream) - collect form)))))))) - - -(defcommand "Editor Evaluate Defun" (p) - "Evaluates the current or next top-level form in the editor Lisp. - If the current region is active, this evaluates the region." - "Evaluates the current or next top-level form in the editor Lisp." - (declare (ignore p)) - (if (region-active-p) - (editor-evaluate-region-command nil) - (with-input-from-region (stream (defun-region (current-point))) - (clear-echo-area) - (in-lisp - (message "Editor Evaluation returned ~S" - (eval (read stream))))))) - -(defcommand "Editor Evaluate Region" (p) - "Evaluates lisp forms between the point and the mark in the editor Lisp." - "Evaluates lisp forms between the point and the mark in the editor Lisp." - (declare (ignore p)) - (with-input-from-region (stream (current-region)) - (clear-echo-area) - (write-string "Evaluating region in the editor ..." *echo-area-stream*) - (finish-output *echo-area-stream*) - (in-lisp - (do ((object (read stream nil lispbuf-eof) - (read stream nil lispbuf-eof))) - ((eq object lispbuf-eof)) - (eval object))) - (message "Evaluation complete."))) - -(defcommand "Editor Re-evaluate Defvar" (p) - "Evaluate the current or next top-level form if it is a DEFVAR. Treat the - form as if the variable is not bound. This occurs in the editor Lisp." - "Evaluate the current or next top-level form if it is a DEFVAR. Treat the - form as if the variable is not bound. This occurs in the editor Lisp." - (declare (ignore p)) - (with-input-from-region (stream (defun-region (current-point))) - (clear-echo-area) - (in-lisp - (let ((form (read stream))) - (unless (eq (car form) 'defvar) (editor-error "Not a DEFVAR.")) - (makunbound (cadr form)) - (message "Evaluation returned ~S" (eval form)))))) - -(defcommand "Editor Macroexpand Expression" (p) - "Show the macroexpansion of the current expression in the null environment. - With an argument, use MACROEXPAND instead of MACROEXPAND-1." - "Show the macroexpansion of the current expression in the null environment. - With an argument, use MACROEXPAND instead of MACROEXPAND-1." - (let ((point (buffer-point (current-buffer)))) - (with-mark ((start point)) - (pre-command-parse-check start) - (with-mark ((end start)) - (unless (form-offset end 1) (editor-error)) - (in-lisp - (with-pop-up-display (rts) - (write-string (with-input-from-region (s (region start end)) - (prin1-to-string (funcall (if p - 'macroexpand - 'macroexpand-1) - (read s)))) - rts))))))) - -(defcommand "Editor Evaluate Expression" (p) - "Prompt for an expression to evaluate in the editor Lisp." - "Prompt for an expression to evaluate in the editor Lisp." - (declare (ignore p)) - (in-lisp - (multiple-value-call #'message "=> ~@{~#[~;~S~:;~S, ~]~}" - (eval (prompt-for-expression - :prompt "Editor Eval: " - :help "Expression to evaluate"))))) - -(defcommand "Editor Evaluate Buffer" (p) - "Evaluates the text in the current buffer in the editor Lisp." - "Evaluates the text in the current buffer redirecting *Standard-Output* to - the echo area. This occurs in the editor Lisp. The prefix argument is - ignored." - (declare (ignore p)) - (clear-echo-area) - (write-string "Evaluating buffer in the editor ..." *echo-area-stream*) - (finish-output *echo-area-stream*) - (with-input-from-region (stream (buffer-region (current-buffer))) - (let ((*standard-output* *echo-area-stream*)) - (in-lisp - (do ((object (read stream nil lispbuf-eof) - (read stream nil lispbuf-eof))) - ((eq object lispbuf-eof)) - (eval object)))) - (message "Evaluation complete."))) - - - -;;; With-Output-To-Window -- Internal -;;; -;;; -(defmacro with-output-to-window ((stream name) &body forms) - "With-Output-To-Window (Stream Name) {Form}* - Bind Stream to a stream that writes into the buffer named Name a la - With-Output-To-Mark. The buffer is created if it does not exist already - and a window is created to display the buffer if it is not displayed. - For the duration of the evaluation this window is made the current window." - (let ((nam (gensym)) (buffer (gensym)) (point (gensym)) - (window (gensym)) (old-window (gensym))) - `(let* ((,nam ,name) - (,buffer (or (getstring ,nam *buffer-names*) (make-buffer ,nam))) - (,point (buffer-end (buffer-point ,buffer))) - (,window (or (car (buffer-windows ,buffer)) (make-window ,point))) - (,old-window (current-window))) - (unwind-protect - (progn (setf (current-window) ,window) - (buffer-end ,point) - (with-output-to-mark (,stream ,point) ,@forms)) - (setf (current-window) ,old-window))))) - -(defcommand "Editor Compile File" (p) - "Prompts for file to compile in the editor Lisp. Does not compare source - and binary write dates. Does not check any buffer for that file for - whether the buffer needs to be saved." - "Prompts for file to compile." - (declare (ignore p)) - (let ((pn (prompt-for-file :default - (buffer-default-pathname (current-buffer)) - :prompt "File to compile: "))) - (with-output-to-window (*error-output* "Compiler Warnings") - (in-lisp (compile-file (namestring pn) #+cmu :error-file #+cmu nil))))) - - -(defun older-or-non-existent-fasl-p (pathname &optional definitely) - (let ((obj-pn (probe-file (compile-file-pathname pathname)))) - (or definitely - (not obj-pn) - (< (file-write-date obj-pn) (file-write-date pathname))))) - - -(defcommand "Editor Compile Buffer File" (p) - "Compile the file in the current buffer in the editor Lisp if its associated - binary file (of type .fasl) is older than the source or doesn't exist. When - the binary file is up to date, the user is asked if the source should be - compiled anyway. When the prefix argument is supplied, compile the file - without checking the binary file. When \"Compile Buffer File Confirm\" is - set, this command will ask for confirmation when it otherwise would not." - "Compile the file in the current buffer in the editor Lisp if the fasl file - isn't up to date. When p, always do it." - (let* ((buf (current-buffer)) - (pn (buffer-pathname buf))) - (unless pn (editor-error "Buffer has no associated pathname.")) - (cond ((buffer-modified buf) - (when (or (not (value compile-buffer-file-confirm)) - (prompt-for-y-or-n - :default t :default-string "Y" - :prompt (list "Save and compile file ~A? " - (namestring pn)))) - (write-buffer-file buf pn) - (with-output-to-window (*error-output* "Compiler Warnings") - (in-lisp (compile-file (namestring pn) #+cmu :error-file #+cmu nil))))) - ((older-or-non-existent-fasl-p pn p) - (when (or (not (value compile-buffer-file-confirm)) - (prompt-for-y-or-n - :default t :default-string "Y" - :prompt (list "Compile file ~A? " (namestring pn)))) - (with-output-to-window (*error-output* "Compiler Warnings") - (in-lisp (compile-file (namestring pn) #+cmu :error-file #+cmu nil))))) - (t (when (or p - (prompt-for-y-or-n - :default t :default-string "Y" - :prompt - "Fasl file up to date, compile source anyway? ")) - (with-output-to-window (*error-output* "Compiler Warnings") - (in-lisp (compile-file (namestring pn) #+cmu :error-file #+cmu nil)))))))) - -(defcommand "Editor Compile Group" (p) - "Compile each file in the current group which needs it in the editor Lisp. - If a file has type LISP and there is a curresponding file with type - FASL which has been written less recently (or it doesn't exit), then - the file is compiled, with error output directed to the \"Compiler Warnings\" - buffer. If a prefix argument is provided, then all the files are compiled. - All modified files are saved beforehand." - "Do a Compile-File in each file in the current group that seems to need it - in the editor Lisp." - (save-all-files-command ()) - (unless *active-file-group* (editor-error "No active file group.")) - (dolist (file *active-file-group*) - (when (string-equal (pathname-type file) "lisp") - (let ((tn (probe-file file))) - (cond ((not tn) - (message "File ~A not found." (namestring file))) - ((older-or-non-existent-fasl-p tn p) - (with-output-to-window (*error-output* "Compiler Warnings") - (in-lisp (compile-file (namestring tn) #+cmu :error-file #+cmu nil))))))))) - -(defcommand "List Compile Group" (p) - "List any files that would be compiled by \"Compile Group\". All Modified - files are saved before checking to generate a consistent list." - "Do a Compile-File in each file in the current group that seems to need it." - (declare (ignore p)) - (save-all-files-command ()) - (unless *active-file-group* (editor-error "No active file group.")) - (with-pop-up-display (s) - (write-line "\"Compile Group\" would compile the following files:" s) - (force-output s) - (dolist (file *active-file-group*) - (when (string-equal (pathname-type file) "lisp") - (let ((tn (probe-file file))) - (cond ((not tn) - (format s "File ~A not found.~%" (namestring file))) - ((older-or-non-existent-fasl-p tn) - (write-line (namestring tn) s))) - (force-output s)))))) - -(defhvar "Load Pathname Defaults" - "The default pathname used by the load command.") - -(defcommand "Editor Load File" (p) - "Prompt for a file to load into Editor Lisp." - "Prompt for a file to load into the Editor Lisp." - (declare (ignore p)) - (let ((name (truename (prompt-for-file - :default - (or (value load-pathname-defaults) - (buffer-default-pathname (current-buffer))) - :prompt "Editor file to load: " - :help "The name of the file to load")))) - (setv load-pathname-defaults name) - (in-lisp (load name)))) - - - - -;;;; Lisp documentation stuff. - -;;; FUNCTION-TO-DESCRIBE is used in "Editor Describe Function Call" and -;;; "Describe Function Call". -;;; -(defmacro function-to-describe (var error-name) - `(cond ((not (symbolp ,var)) - (,error-name "~S is not a symbol." ,var)) - ((macro-function ,var)) - ((fboundp ,var) - (if (listp (symbol-function ,var)) - ,var - (symbol-function ,var))) - (t - (,error-name "~S is not a function." ,var)))) - -(defcommand "Editor Describe Function Call" (p) - "Describe the most recently typed function name in the editor Lisp." - "Describe the most recently typed function name in the editor Lisp." - (declare (ignore p)) - (with-mark ((mark1 (current-point)) - (mark2 (current-point))) - (pre-command-parse-check mark1) - (unless (backward-up-list mark1) (editor-error)) - (form-offset (move-mark mark2 (mark-after mark1)) 1) - (with-input-from-region (s (region mark1 mark2)) - (in-lisp - (let* ((sym (read s)) - (fun (function-to-describe sym editor-error))) - (with-pop-up-display (*standard-output*) - (editor-describe-function fun sym))))))) - - -(defcommand "Editor Describe Symbol" (p) - "Describe the previous s-expression if it is a symbol in the editor Lisp." - "Describe the previous s-expression if it is a symbol in the editor Lisp." - (declare (ignore p)) - (with-mark ((mark1 (current-point)) - (mark2 (current-point))) - (mark-symbol mark1 mark2) - (with-input-from-region (s (region mark1 mark2)) - (in-lisp - (let ((thing (read s))) - (if (symbolp thing) - (with-pop-up-display (*standard-output*) - (describe thing)) - (if (and (consp thing) - (or (eq (car thing) 'quote) - (eq (car thing) 'function)) - (symbolp (cadr thing))) - (with-pop-up-display (*standard-output*) - (describe (cadr thing))) - (editor-error "~S is not a symbol, or 'symbol, or #'symbol." - thing)))))))) - -;;; MARK-SYMBOL moves mark1 and mark2 around the previous or current symbol. -;;; However, if the marks are immediately before the first constituent char -;;; of the symbol name, we use the next symbol since the marks probably -;;; correspond to the point, and Hemlock's cursor display makes it look like -;;; the point is within the symbol name. This also tries to ignore :prefix -;;; characters such as quotes, commas, etc. -;;; -(defun mark-symbol (mark1 mark2) - (pre-command-parse-check mark1) - (with-mark ((tmark1 mark1) - (tmark2 mark1)) - (cond ((and (form-offset tmark1 1) - (form-offset (move-mark tmark2 tmark1) -1) - (or (mark= mark1 tmark2) - (and (find-attribute tmark2 :lisp-syntax - #'(lambda (x) (not (eq x :prefix)))) - (mark= mark1 tmark2)))) - (form-offset mark2 1)) - (t - (form-offset mark1 -1) - (find-attribute mark1 :lisp-syntax - #'(lambda (x) (not (eq x :prefix)))) - (form-offset (move-mark mark2 mark1) 1))))) - - -(defcommand "Editor Describe" (p) - "Call Describe on a Lisp object. - Prompt for an expression which is evaluated to yield the object." - "Prompt for an object to describe." - (declare (ignore p)) - (in-lisp - (let* ((exp (prompt-for-expression - :prompt "Object: " - :help "Expression to evaluate to get object to describe.")) - (obj (eval exp))) - (with-pop-up-display (*standard-output*) - (describe obj))))) - - -(defcommand "Filter Region" (p) - "Apply a Lisp function to each line of the region. - An expression is prompted for which should evaluate to a Lisp function - from a string to a string. The function must neither modify its argument - nor modify the return value after it is returned." - "Call prompt for a function, then call Filter-Region with it and the region." - (declare (ignore p)) - (let* ((exp (prompt-for-expression - :prompt "Function: " - :help "Expression to evaluate to get function to use as filter.")) - (fun (in-lisp (eval exp))) - (region (current-region))) - (let* ((start (copy-mark (region-start region) :left-inserting)) - (end (copy-mark (region-end region) :left-inserting)) - (region (region start end)) - (undo-region (copy-region region))) - (filter-region fun region) - (make-region-undo :twiddle "Filter Region" region undo-region)))) Index: anches/ide-1.0/ccl/hemlock/src/lispeval.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/lispeval.lisp (revision 6566) +++ (revision ) @@ -1,978 +1,0 @@ -;;; -*- Package: Hemlock; Log: hemlock.log -*- -;;; -;;; ********************************************************************** -;;; This code was written as part of the CMU Common Lisp project at -;;; Carnegie Mellon University, and has been placed in the public domain. -;;; -#+CMU (ext:file-comment - "$Header$") -;;; -;;; ********************************************************************** -;;; -;;; This file contains code for sending requests to eval servers and the -;;; commands based on that code. -;;; -;;; Written by William Lott and Rob MacLachlan. -;;; - -(in-package :hemlock) - - -;;; The note structure holds everything we need to know about an -;;; operation. Not all operations use all the available fields. -;;; -(defstruct (note (:print-function %print-note)) - (state :unsent) ; :unsent, :pending, :running, :aborted or :dead. - server ; Server-Info for the server this op is on. - context ; Short string describing what this op is doing. - kind ; Either :eval, :compile, or :compile-file - buffer ; Buffer source came from. - region ; Region of request - package ; Package or NIL if none - text ; string containing request - input-file ; File to compile or where stuff was found - net-input-file ; Net version of above. - output-file ; Temporary output file for compiler fasl code. - net-output-file ; Net version of above - output-date ; Temp-file is created before calling compiler, - ; and this is its write date. - lap-file ; The lap file for compiles - error-file ; The file to dump errors into - load ; Load compiled file or not? - (errors 0) ; Count of compiler errors. - (warnings 0) ; Count of compiler warnings. - (notes 0)) ; Count of compiler notes. -;;; -(defun %print-note (note stream d) - (declare (ignore d)) - (format stream "#" - (note-context note) - (note-state note))) - - - - -;;;; Note support routines. - -;;; QUEUE-NOTE -- Internal. -;;; -;;; This queues note for server. SERVER-INFO-NOTES keeps notes in stack order, -;;; not queue order. We also link the note to the server and try to send it -;;; to the server. If we didn't send this note, we tell the user the server -;;; is busy and that we're queuing his note to be sent later. -;;; -(defun queue-note (note server) - (push note (server-info-notes server)) - (setf (note-server note) server) - (maybe-send-next-note server) - (when (eq (note-state note) :unsent) - (message "Server ~A busy, ~A queued." - (server-info-name server) - (note-context note)))) - -;;; MAYBE-SEND-NEXT-NOTE -- Internal. -;;; -;;; Loop over all notes in server. If we see any :pending or :running, then -;;; punt since we can't send one. Otherwise, by the end of the list, we may -;;; have found an :unsent one, and if we did, next will be the last :unsent -;;; note. Remember, SERVER-INFO-NOTES is kept in stack order not queue order. -;;; -(defun maybe-send-next-note (server) - (let ((busy nil) - (next nil)) - (dolist (note (server-info-notes server)) - (ecase (note-state note) - ((:pending :running) - (setf busy t) - (return)) - (:unsent - (setf next note)) - (:aborted :dead))) - (when (and (not busy) next) - (send-note next)))) - -(defun send-note (note) - (let* ((remote (hemlock.wire:make-remote-object note)) - (server (note-server note)) - (ts (server-info-slave-info server)) - (bg (server-info-background-info server)) - (wire (server-info-wire server))) - (setf (note-state note) :pending) - (message "Sending ~A." (note-context note)) - (case (note-kind note) - (:eval - (hemlock.wire:remote wire - (server-eval-text remote - (note-package note) - (note-text note) - (and ts (ts-data-stream ts))))) - (:compile - (hemlock.wire:remote wire - (server-compile-text remote - (note-package note) - (note-text note) - (note-input-file note) - (and ts (ts-data-stream ts)) - (and bg (ts-data-stream bg))))) - (:compile-file - (macrolet ((frob (x) - `(if (pathnamep ,x) - (namestring ,x) - ,x))) - (hemlock.wire:remote wire - (server-compile-file remote - (note-package note) - (frob (or (note-net-input-file note) - (note-input-file note))) - (frob (or (note-net-output-file note) - (note-output-file note))) - (frob (note-error-file note)) - (frob (note-lap-file note)) - (note-load note) - (and ts (ts-data-stream ts)) - (and bg (ts-data-stream bg)))))) - (t - (error "Unknown note kind ~S" (note-kind note)))) - (hemlock.wire:wire-force-output wire))) - - - -;;;; Server Callbacks. - -(defun operation-started (note) - (let ((note (hemlock.wire:remote-object-value note))) - (setf (note-state note) :running) - (message "The ~A started." (note-context note))) - (values)) - -(defun eval-form-error (message) - (editor-error message)) - -(defun lisp-error (note start end msg) - (declare (ignore start end)) - (let ((note (hemlock.wire:remote-object-value note))) - (loud-message "During ~A: ~A" - (note-context note) - msg)) - (values)) - -(defun compiler-error (note start end function severity) - (let* ((note (hemlock.wire:remote-object-value note)) - (server (note-server note)) - (line (mark-line - (buffer-end-mark - (server-info-background-buffer server)))) - (message (format nil "~:(~A~) ~@[in ~A ~]during ~A." - severity - function - (note-context note))) - (error (make-error-info :buffer (note-buffer note) - :message message - :line line))) - (message "~A" message) - (case severity - (:error (incf (note-errors note))) - (:warning (incf (note-warnings note))) - (:note (incf (note-notes note)))) - (let ((region (case (note-kind note) - (:compile - (note-region note)) - (:compile-file - (let ((buff (note-buffer note))) - (and buff (buffer-region buff)))) - (t - (error "Compiler error in ~S?" note))))) - (when region - (let* ((region-end (region-end region)) - (m1 (copy-mark (region-start region) :left-inserting)) - (m2 (copy-mark m1 :left-inserting))) - (when start - (character-offset m1 start) - (when (mark> m1 region-end) - (move-mark m1 region-end))) - (unless (and end (character-offset m2 end)) - (move-mark m2 region-end)) - - (setf (error-info-region error) - (region m1 m2))))) - - (vector-push-extend error (server-info-errors server))) - - (values)) - -(defun eval-text-result (note start end values) - (declare (ignore note start end)) - (message "=> ~{~#[~;~A~:;~A, ~]~}" values) - (values)) - -(defun operation-completed (note abortp) - (let* ((note (hemlock.wire:remote-object-value note)) - (server (note-server note)) - (file (note-output-file note))) - (hemlock.wire:forget-remote-translation note) - (setf (note-state note) :dead) - (setf (server-info-notes server) - (delete note (server-info-notes server) - :test #'eq)) - (setf (note-server note) nil) - - (if abortp - (loud-message "The ~A aborted." (note-context note)) - (let ((errors (note-errors note)) - (warnings (note-warnings note)) - (notes (note-notes note))) - (message "The ~A complete.~ - ~@[ ~D error~:P~]~@[ ~D warning~:P~]~@[ ~D note~:P~]" - (note-context note) - (and (plusp errors) errors) - (and (plusp warnings) warnings) - (and (plusp notes) notes)))) - - (let ((region (note-region note))) - (when (regionp region) - (delete-mark (region-start region)) - (delete-mark (region-end region)) - (setf (note-region note) nil))) - - (when (and (eq (note-kind note) - :compile-file) - (not (eq file t)) - file) - (if (> (file-write-date file) - (note-output-date note)) - (let ((new-name (make-pathname :type "fasl" - :defaults (note-input-file note)))) - (rename-file file new-name) - #+NILGB - (unix:unix-chmod (namestring new-name) #o644)) - (delete-file file))) - (maybe-send-next-note server)) - (values)) - - - -;;;; Stuff to send noise to the server. - -;;; EVAL-FORM-IN-SERVER -- Public. -;;; -(defun eval-form-in-server (server-info form - &optional (package (value current-package))) - "This evals form, a simple-string, in the server for server-info. Package - is the name of the package in which the server reads form, and it defaults - to the value of \"Current Package\". If package is nil, then the slave uses - the value of *package*. If server is busy with other requests, this signals - an editor-error to prevent commands using this from hanging. If the server - dies while evaluating form, then this signals an editor-error. This returns - a list of strings which are the printed representation of all the values - returned by form in the server." - (declare (simple-string form)) - (when (server-info-notes server-info) - (editor-error "Server ~S is currently busy. See \"List Operations\"." - (server-info-name server-info))) - (multiple-value-bind (values error) - (hemlock.wire:remote-value (server-info-wire server-info) - (server-eval-form package form)) - (when error - (editor-error "The server died before finishing")) - values)) - -;;; EVAL-FORM-IN-SERVER-1 -- Public. -;;; -;;; We use VALUES to squelch the second value of READ-FROM-STRING. -;;; -(defun eval-form-in-server-1 (server-info form - &optional (package (value current-package))) - "This calls EVAL-FORM-IN-SERVER and returns the result of READ'ing from - the first string EVAL-FORM-IN-SERVER returns." - (values (read-from-string - (car (eval-form-in-server server-info form package))))) - -(defun string-eval (string - &key - (server (get-current-eval-server)) - (package (value current-package)) - (context (format nil - "evaluation of ~S" - string))) - "Queues the evaluation of string on an eval server. String is a simple - string. If package is not supplied, the string is eval'ed in the slave's - current package." - (declare (simple-string string)) - (queue-note (make-note :kind :eval - :context context - :package package - :text string) - server) - (values)) - -(defun region-eval (region - &key - (server (get-current-eval-server)) - (package (value current-package)) - (context (region-context region "evaluation"))) - "Queues the evaluation of a region of text on an eval server. If package - is not supplied, the string is eval'ed in the slave's current package." - (let ((region (region (copy-mark (region-start region) :left-inserting) - (copy-mark (region-end region) :left-inserting)))) - (queue-note (make-note :kind :eval - :context context - :region region - :package package - :text (region-to-string region)) - server)) - (values)) - -(defun region-compile (region - &key - (server (get-current-eval-server)) - (package (value current-package))) - "Queues a compilation on an eval server. If package is not supplied, the - string is eval'ed in the slave's current package." - (let* ((region (region (copy-mark (region-start region) :left-inserting) - (copy-mark (region-end region) :left-inserting))) - (buf (line-buffer (mark-line (region-start region)))) - (pn (and buf (buffer-pathname buf))) - (defined-from (if pn (namestring pn) "unknown"))) - (queue-note (make-note :kind :compile - :context (region-context region "compilation") - :buffer (and region - (region-start region) - (mark-line (region-start region)) - (line-buffer (mark-line - (region-start region)))) - :region region - :package package - :text (region-to-string region) - :input-file defined-from) - server)) - (values)) - - - - -;;;; File compiling noise. - -(defhvar "Remote Compile File" - "When set (the default), this causes slave file compilations to assume the - compilation is occurring on a remote machine. This means the source file - must be world readable. Unsetting this, causes no file accesses to go - through the super root." - :value nil) - -;;; FILE-COMPILE compiles files in a client Lisp. Because of Unix file -;;; protection, one cannot write files over the net unless they are publicly -;;; writeable. To get around this, we create a temporary file that is -;;; publicly writeable for compiler output. This file is renamed to an -;;; ordinary output name if the compiler wrote anything to it, or deleted -;;; otherwise. No temporary file is created when output-file is not t. -;;; - -(defun file-compile (file - &key - buffer - (output-file t) - error-file - lap-file - load - (server (get-current-compile-server)) - (package (value current-package))) - "Compiles file in a client Lisp. When output-file is t, a temporary - output file is used that is publicly writeable in case the client is on - another machine. This file is renamed or deleted after compilation. - Setting \"Remote Compile File\" to nil, inhibits this. If package is not - supplied, the string is eval'ed in the slave's current package." - - (let* ((file (truename file)) ; in case of search-list in pathname. - (namestring (namestring file)) - (note (make-note - :kind :compile-file - :context (format nil "compilation of ~A" namestring) - :buffer buffer - :region nil - :package package - :input-file file - :output-file output-file - :error-file error-file - :lap-file lap-file - :load load))) - - (when (and (value remote-compile-file) - (eq output-file t)) - (multiple-value-bind (net-infile ofile net-ofile date) - (file-compile-temp-file file) - (setf (note-net-input-file note) net-infile) - (setf (note-output-file note) ofile) - (setf (note-net-output-file note) net-ofile) - (setf (note-output-date note) date))) - - (clear-server-errors server - #'(lambda (error) - (eq (error-info-buffer error) - buffer))) - (queue-note note server))) - -;;; FILE-COMPILE-TEMP-FILE creates a a temporary file that is publicly -;;; writable in the directory file is in and with a .fasl type. Four values -;;; are returned -- a pathname suitable for referencing file remotely, the -;;; pathname of the temporary file created, a pathname suitable for referencing -;;; the temporary file remotely, and the write date of the temporary file. -;;; - -#+NILGB -(defun file-compile-temp-file (file) - (let ((ofile (loop (let* ((sym (gensym)) - (f (merge-pathnames - (format nil "compile-file-~A.fasl" sym) - file))) - (unless (probe-file f) (return f)))))) - (multiple-value-bind (fd err) - (unix:unix-open (namestring ofile) - unix:o_creat #o666) - (unless fd - (editor-error "Couldn't create compiler temporary output file:~%~ - ~A" (unix:get-unix-error-msg err))) - (unix:unix-fchmod fd #o666) - (unix:unix-close fd)) - (let ((net-ofile (pathname-for-remote-access ofile))) - (values (make-pathname :directory (pathname-directory net-ofile) - :defaults file) - ofile - net-ofile - (file-write-date ofile))))) - -(defun pathname-for-remote-access (file) - (let* ((machine (machine-instance)) - (usable-name (nstring-downcase - (the simple-string - (subseq machine 0 (position #\. machine)))))) - (declare (simple-string machine usable-name)) - (make-pathname :directory (concatenate 'simple-string - "/../" - usable-name - (directory-namestring file)) - :defaults file))) - -;;; REGION-CONTEXT -- internal -;;; -;;; Return a string which describes the code in a region. Thing is the -;;; thing being done to the region. "compilation" or "evaluation"... - -(defun region-context (region thing) - (declare (simple-string thing)) - (pre-command-parse-check (region-start region)) - (let ((start (region-start region))) - (with-mark ((m1 start)) - (unless (start-defun-p m1) - (top-level-offset m1 1)) - (with-mark ((m2 m1)) - (mark-after m2) - (form-offset m2 2) - (format nil - "~A of ~S" - thing - (if (eq (mark-line m1) (mark-line m2)) - (region-to-string (region m1 m2)) - (concatenate 'simple-string - (line-string (mark-line m1)) - "..."))))))) - - - -;;;; Commands (Gosh, wow gee!) - -(defcommand "Editor Server Name" (p) - "Echos the editor server's name which can be supplied with the -slave switch - to connect to a designated editor." - "Echos the editor server's name which can be supplied with the -slave switch - to connect to a designated editor." - (declare (ignore p)) - (if *editor-name* - (message "This editor is named ~S." *editor-name*) - (message "This editor is not currently named."))) - -(defcommand "Set Buffer Package" (p) - "Set the package to be used by Lisp evaluation and compilation commands - while in this buffer. When in a slave's interactive buffers, do NOT - set the editor's package variable, but changed the slave's *package*." - "Prompt for a package to make into a buffer-local variable current-package." - (declare (ignore p)) - (let* ((name (string (prompt-for-expression - :prompt "Package name: " - :help "Name of package to associate with this buffer."))) - (buffer (current-buffer)) - (info (value current-eval-server))) - (cond ((and info - (or (eq (server-info-slave-buffer info) buffer) - (eq (server-info-background-buffer info) buffer))) - (hemlock.wire:remote (server-info-wire info) - (server-set-package name)) - (hemlock.wire:wire-force-output (server-info-wire info))) - ((eq buffer *selected-eval-buffer*) - (setf *package* (maybe-make-package name))) - (t - (defhvar "Current Package" - "The package used for evaluation of Lisp in this buffer." - :buffer buffer :value name))) - (when (buffer-modeline-field-p buffer :package) - (dolist (w (buffer-windows buffer)) - (update-modeline-field buffer w :package))))) - -(defcommand "Current Compile Server" (p) - "Echos the current compile server's name. With prefix argument, - shows global one. Does not signal an error or ask about creating a slave." - "Echos the current compile server's name. With prefix argument, - shows global one." - (let ((info (if p - (variable-value 'current-compile-server :global) - (value current-compile-server)))) - (if info - (message "~A" (server-info-name info)) - (message "No ~:[current~;global~] compile server." p)))) - -(defcommand "Set Compile Server" (p) - "Specifies the name of the server used globally for file compilation requests." - "Call select-current-compile-server." - (declare (ignore p)) - (hlet ((ask-about-old-servers t)) - (setf (variable-value 'current-compile-server :global) - (maybe-create-server)))) - -(defcommand "Set Buffer Compile Server" (p) - "Specifies the name of the server used for file compilation requests in - the current buffer." - "Call select-current-compile-server after making a buffer local variable." - (declare (ignore p)) - (hlet ((ask-about-old-servers t)) - (defhvar "Current Compile Server" - "The Server-Info object for the server currently used for compilation requests." - :buffer (current-buffer) - :value (maybe-create-server)))) - -(defcommand "Current Eval Server" (p) - "Echos the current eval server's name. With prefix argument, shows - global one. Does not signal an error or ask about creating a slave." - "Echos the current eval server's name. With prefix argument, shows - global one. Does not signal an error or ask about creating a slave." - (let ((info (if p - (variable-value 'current-eval-server :global) - (value current-eval-server)))) - (if info - (message "~A" (server-info-name info)) - (message "No ~:[current~;global~] eval server." p)))) - -(defcommand "Set Eval Server" (p) - "Specifies the name of the server used globally for evaluation and - compilation requests." - "Call select-current-server." - (declare (ignore p)) - (hlet ((ask-about-old-servers t)) - (setf (variable-value 'current-eval-server :global) - (maybe-create-server)))) - -(defcommand "Set Buffer Eval Server" (p) - "Specifies the name of the server used for evaluation and compilation - requests in the current buffer." - "Call select-current-server after making a buffer local variable." - (declare (ignore p)) - (hlet ((ask-about-old-servers t)) - (defhvar "Current Eval Server" - "The Server-Info for the eval server used in this buffer." - :buffer (current-buffer) - :value (maybe-create-server)))) - -(defcommand "Evaluate Defun" (p) - "Evaluates the current or next top-level form. - If the current region is active, then evaluate it." - "Evaluates the current or next top-level form." - (declare (ignore p)) - (if (region-active-p) - (evaluate-region-command nil) - (region-eval (defun-region (current-point))))) - -(defcommand "Re-evaluate Defvar" (p) - "Evaluate the current or next top-level form if it is a DEFVAR. Treat the - form as if the variable is not bound." - "Evaluate the current or next top-level form if it is a DEFVAR. Treat the - form as if the variable is not bound." - (declare (ignore p)) - (let* ((form (defun-region (current-point))) - (start (region-start form))) - (with-mark ((var-start start) - (var-end start)) - (mark-after var-start) - (form-offset var-start 1) - (form-offset (move-mark var-end var-start) 1) - (let ((exp (concatenate 'simple-string - "(makunbound '" - (region-to-string (region var-start var-end)) - ")"))) - (eval-form-in-server (get-current-eval-server) exp))) - (region-eval form))) - -;;; We use Prin1-To-String in the client so that the expansion gets pretty -;;; printed. Since the expansion can contain unreadable stuff, we can't expect -;;; to be able to read that string back in the editor. We shove the region -;;; at the client Lisp as a string, so it can read from the string with the -;;; right package environment. -;;; - -(defcommand "Macroexpand Expression" (p) - "Show the macroexpansion of the current expression in the null environment. - With an argument, use MACROEXPAND instead of MACROEXPAND-1." - "Show the macroexpansion of the current expression in the null environment. - With an argument, use MACROEXPAND instead of MACROEXPAND-1." - (let ((point (current-point))) - (with-mark ((start point)) - (pre-command-parse-check start) - (with-mark ((end start)) - (unless (form-offset end 1) (editor-error)) - (with-pop-up-display (s) - (write-string - (eval-form-in-server-1 - (get-current-eval-server) - (format nil "(prin1-to-string (~S (read-from-string ~S)))" - (if p 'macroexpand 'macroexpand-1) - (region-to-string (region start end)))) - s)))))) - -(defcommand "Evaluate Expression" (p) - "Prompt for an expression to evaluate." - "Prompt for an expression to evaluate." - (declare (ignore p)) - (let ((exp (prompt-for-string - :prompt "Eval: " - :help "Expression to evaluate."))) - (message "=> ~{~#[~;~A~:;~A, ~]~}" - (eval-form-in-server (get-current-eval-server) exp)))) - -(defcommand "Compile Defun" (p) - "Compiles the current or next top-level form. - First the form is evaluated, then the result of this evaluation - is passed to compile. If the current region is active, compile - the region." - "Evaluates the current or next top-level form." - (declare (ignore p)) - (if (region-active-p) - (compile-region-command nil) - (region-compile (defun-region (current-point))))) - -(defcommand "Compile Region" (p) - "Compiles lisp forms between the point and the mark." - "Compiles lisp forms between the point and the mark." - (declare (ignore p)) - (region-compile (current-region))) - -(defcommand "Evaluate Region" (p) - "Evaluates lisp forms between the point and the mark." - "Evaluates lisp forms between the point and the mark." - (declare (ignore p)) - (region-eval (current-region))) - -(defcommand "Evaluate Buffer" (p) - "Evaluates the text in the current buffer." - "Evaluates the text in the current buffer redirecting *Standard-Output* to - the echo area. The prefix argument is ignored." - (declare (ignore p)) - (let ((b (current-buffer))) - (region-eval (buffer-region b) - :context (format nil - "evaluation of buffer ``~A''" - (buffer-name b))))) - -(defcommand "Load File" (p) - "Prompt for a file to load into the current eval server." - "Prompt for a file to load into the current eval server." - (declare (ignore p)) - (let ((name (truename (prompt-for-file - :default - (or (value load-pathname-defaults) - (buffer-default-pathname (current-buffer))) - :prompt "File to load: " - :help "The name of the file to load")))) - (setv load-pathname-defaults name) - (string-eval (format nil "(load ~S)" - (namestring - (if (value remote-compile-file) - (pathname-for-remote-access name) - name)))))) - -(defcommand "Compile File" (p) - "Prompts for file to compile. Does not compare source and binary write - dates. Does not check any buffer for that file for whether the buffer - needs to be saved." - "Prompts for file to compile." - (declare (ignore p)) - (let ((pn (prompt-for-file :default - (buffer-default-pathname (current-buffer)) - :prompt "File to compile: "))) - (file-compile pn))) - -(defhvar "Compile Buffer File Confirm" - "When set, \"Compile Buffer File\" prompts before doing anything." - :value t) - -(defcommand "Compile Buffer File" (p) - "Compile the file in the current buffer if its associated binary file - (of type .fasl) is older than the source or doesn't exist. When the - binary file is up to date, the user is asked if the source should be - compiled anyway. When the prefix argument is supplied, compile the - file without checking the binary file. When \"Compile Buffer File - Confirm\" is set, this command will ask for confirmation when it - otherwise would not." - "Compile the file in the current buffer if the fasl file isn't up to date. - When p, always do it." - (let* ((buf (current-buffer)) - (pn (buffer-pathname buf))) - (unless pn (editor-error "Buffer has no associated pathname.")) - (cond ((buffer-modified buf) - (when (or (not (value compile-buffer-file-confirm)) - (prompt-for-y-or-n - :default t :default-string "Y" - :prompt (list "Save and compile file ~A? " - (namestring pn)))) - (write-buffer-file buf pn) - (file-compile pn :buffer buf))) - ((older-or-non-existent-fasl-p pn p) - (when (or (not (value compile-buffer-file-confirm)) - (prompt-for-y-or-n - :default t :default-string "Y" - :prompt (list "Compile file ~A? " (namestring pn)))) - (file-compile pn :buffer buf))) - ((or p - (prompt-for-y-or-n - :default t :default-string "Y" - :prompt - "Fasl file up to date, compile source anyway? ")) - (file-compile pn :buffer buf))))) - -(defcommand "Compile Group" (p) - "Compile each file in the current group which needs it. - If a file has type LISP and there is a curresponding file with type - FASL which has been written less recently (or it doesn't exit), then - the file is compiled, with error output directed to the \"Compiler Warnings\" - buffer. If a prefix argument is provided, then all the files are compiled. - All modified files are saved beforehand." - "Do a Compile-File in each file in the current group that seems to need it." - (save-all-files-command ()) - (unless *active-file-group* (editor-error "No active file group.")) - (dolist (file *active-file-group*) - (when (string-equal (pathname-type file) "lisp") - (let ((tn (probe-file file))) - (cond ((not tn) - (message "File ~A not found." (namestring file))) - ((older-or-non-existent-fasl-p tn p) - (file-compile tn))))))) - - - -;;;; Error hacking stuff. - -(defcommand "Flush Compiler Error Information" (p) - "Flushes all infomation about errors encountered while compiling using the - current server" - "Flushes all infomation about errors encountered while compiling using the - current server" - (declare (ignore p)) - (clear-server-errors (get-current-compile-server t))) - -(defcommand "Next Compiler Error" (p) - "Move to the next compiler error for the current server. If an argument is - given, advance that many errors." - "Move to the next compiler error for the current server. If an argument is - given, advance that many errors." - (let* ((server (get-current-compile-server t)) - (errors (server-info-errors server)) - (fp (fill-pointer errors))) - (when (zerop fp) - (editor-error "There are no compiler errors.")) - (let* ((old-index (server-info-error-index server)) - (new-index (+ (or old-index -1) (or p 1)))) - (when (< new-index 0) - (if old-index - (editor-error "Can't back up ~R, only at the ~:R compiler error." - (- p) (1+ old-index)) - (editor-error "Not even at the first compiler error."))) - (when (>= new-index fp) - (if (= (1+ (or old-index -1)) fp) - (editor-error "No more compiler errors.") - (editor-error "Only ~R remaining compiler error~:P." - (- fp old-index 1)))) - (setf (server-info-error-index server) new-index) - ;; Display the silly error. - (let ((error (aref errors new-index))) - (let ((region (error-info-region error))) - (if region - (let* ((start (region-start region)) - (buffer (line-buffer (mark-line start)))) - (change-to-buffer buffer) - (move-mark (buffer-point buffer) start)) - (message "Hmm, no region for this error."))) - (let* ((line (error-info-line error)) - (buffer (line-buffer line))) - (if (and line (bufferp buffer)) - (let ((mark (mark line 0))) - (unless (buffer-windows buffer) - (let ((window (find-if-not - #'(lambda (window) - (or (eq window (current-window)) - (eq window *echo-area-window*))) - *window-list*))) - (if window - (setf (window-buffer window) buffer) - (make-window mark)))) - (move-mark (buffer-point buffer) mark) - (dolist (window (buffer-windows buffer)) - (move-mark (window-display-start window) mark) - (move-mark (window-point window) mark)) - (delete-mark mark)) - (message "Hmm, no line for this error."))))))) - -(defcommand "Previous Compiler Error" (p) - "Move to the previous compiler error. If an argument is given, move back - that many errors." - "Move to the previous compiler error. If an argument is given, move back - that many errors." - (next-compiler-error-command (- (or p 1)))) - - - - -;;;; Operation management commands: - -(defcommand "Abort Operations" (p) - "Abort all operations on current eval server connection." - "Abort all operations on current eval server connection." - (declare (ignore p)) - (let* ((server (get-current-eval-server)) - (wire (server-info-wire server))) - ;; Tell the slave to abort the current operation and to ignore any further - ;; operations. - (dolist (note (server-info-notes server)) - (setf (note-state note) :aborted)) - #+NILGB (ext:send-character-out-of-band (hemlock.wire:wire-fd wire) #\N) - (hemlock.wire:remote-value wire (server-accept-operations)) - ;; Synch'ing with server here, causes any operations queued at the socket or - ;; in the server to be ignored, and the last thing evaluated is an - ;; instruction to go on accepting operations. - (hemlock.wire:wire-force-output wire) - (dolist (note (server-info-notes server)) - (when (eq (note-state note) :pending) - ;; The HEMLOCK.WIRE:REMOTE-VALUE call should have allowed a handshake to - ;; tell the editor anything :pending was aborted. - (error "Operation ~S is still around after we aborted it?" note))) - ;; Forget anything queued in the editor. - (setf (server-info-notes server) nil))) - -(defcommand "List Operations" (p) - "List all eval server operations which have not yet completed." - "List all eval server operations which have not yet completed." - (declare (ignore p)) - (let ((notes nil)) - ;; Collect all notes, reversing them since they act like a queue but - ;; are not in queue order. - (do-strings (str val *server-names*) - (declare (ignore str)) - (setq notes (nconc notes (reverse (server-info-notes val))))) - (if notes - (with-pop-up-display (s) - (dolist (note notes) - (format s "~@(~8A~) ~A on ~A.~%" - (note-state note) - (note-context note) - (server-info-name (note-server note))))) - (message "No uncompleted operations."))) - (values)) - - - -;;;; Describing in the client lisp. - -;;; "Describe Function Call" gets the function name from the current form -;;; as a string. This string is used as the argument to a call to -;;; DESCRIBE-FUNCTION-CALL-AUX which is eval'ed in the client lisp. The -;;; auxiliary function's name is qualified since it is read in the client -;;; Lisp with *package* bound to the buffer's package. The result comes -;;; back as a list of strings, so we read the first string to get out the -;;; string value returned by DESCRIBE-FUNCTION-CALL-AUX in the client Lisp. -;;; -(defcommand "Describe Function Call" (p) - "Describe the current function call." - "Describe the current function call." - (let ((info (value current-eval-server))) - (cond - ((not info) - (message "Describing from the editor Lisp ...") - (editor-describe-function-call-command p)) - (t - (with-mark ((mark1 (current-point)) - (mark2 (current-point))) - (pre-command-parse-check mark1) - (unless (backward-up-list mark1) (editor-error)) - (form-offset (move-mark mark2 (mark-after mark1)) 1) - (let* ((package (value current-package)) - (package-exists - (eval-form-in-server-1 - info - (format nil - "(if (find-package ~S) t (package-name *package*))" - package) - nil))) - (unless (eq package-exists t) - (message "Using package ~S in ~A since ~ - ~:[there is no current package~;~:*~S does not exist~]." - package-exists (server-info-name info) package)) - (with-pop-up-display (s) - (write-string (eval-form-in-server-1 - info - (format nil "(hemlock::describe-function-call-aux ~S)" - (region-to-string (region mark1 mark2))) - (if (eq package-exists t) package nil)) - s)))))))) - -;;; DESCRIBE-FUNCTION-CALL-AUX is always evaluated in a client Lisp to some -;;; editor, relying on the fact that the cores have the same functions. String -;;; is the name of a function that is read (in the client Lisp). The result is -;;; a string of all the output from EDITOR-DESCRIBE-FUNCTION. -;;; -(defun describe-function-call-aux (string) - (let* ((sym (read-from-string string)) - (fun (function-to-describe sym error))) - (with-output-to-string (*standard-output*) - (editor-describe-function fun sym)))) - -;;; "Describe Symbol" gets the symbol name and quotes it as the argument to a -;;; call to DESCRIBE-SYMBOL-AUX which is eval'ed in the client lisp. The -;;; auxiliary function's name is qualified since it is read in the client Lisp -;;; with *package* bound to the buffer's package. The result comes back as a -;;; list of strings, so we read the first string to get out the string value -;;; returned by DESCRIBE-SYMBOL-AUX in the client Lisp. -;;; - -(defcommand "Describe Symbol" (p) - "Describe the previous s-expression if it is a symbol." - "Describe the previous s-expression if it is a symbol." - (declare (ignore p)) - (let ((info (value current-eval-server))) - (cond - ((not info) - (message "Describing from the editor Lisp ...") - (editor-describe-symbol-command nil)) - (t - (with-mark ((mark1 (current-point)) - (mark2 (current-point))) - (mark-symbol mark1 mark2) - (with-pop-up-display (s) - (write-string (eval-form-in-server-1 - info - (format nil "(hemlock::describe-symbol-aux '~A)" - (region-to-string (region mark1 mark2)))) - s))))))) - -(defun describe-symbol-aux (thing) - (with-output-to-string (*standard-output*) - (describe (if (and (consp thing) - (or (eq (car thing) 'quote) - (eq (car thing) 'function)) - (symbolp (cadr thing))) - (cadr thing) - thing)))) Index: anches/ide-1.0/ccl/hemlock/src/mh.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/mh.lisp (revision 6566) +++ (revision ) @@ -1,3180 +1,0 @@ -;;; -*- Package: Hemlock; Log: hemlock.log -*- -;;; -;;; ********************************************************************** -;;; This code was written as part of the CMU Common Lisp project at -;;; Carnegie Mellon University, and has been placed in the public domain. -;;; -#+CMU (ext:file-comment - "$Header$") -;;; -;;; ********************************************************************** -;;; -;;; This is a mailer interface to MH. -;;; -;;; Written by Bill Chiles. -;;; - -(in-package :hemlock) - - - - -;;;; General stuff. - -(defvar *new-mail-buffer* nil) - -(defvar *mh-utility-bit-bucket* (make-broadcast-stream)) - - -(defattribute "Digit" - "This is just a (mod 2) attribute for base 10 digit characters.") -;;; -(dotimes (i 10) - (setf (character-attribute :digit (digit-char i)) 1)) - - -(defmacro number-string (number) - `(let ((*print-base* 10)) - (prin1-to-string ,number))) - - -(defmacro do-headers-buffers ((buffer-var folder &optional hinfo-var) - &rest forms) - "The Forms are evaluated with Buffer-Var bound to each buffer containing - headers lines for folder. Optionally Hinfo-Var is bound to the - headers-information structure." - (let ((folder-var (gensym)) - (hinfo (gensym))) - `(let ((,folder-var ,folder)) - (declare (simple-string ,folder-var)) - (dolist (,buffer-var *buffer-list*) - (when (hemlock-bound-p 'headers-information :buffer ,buffer-var) - (let ((,hinfo (variable-value 'headers-information - :buffer ,buffer-var))) - (when (string= (the simple-string (headers-info-folder ,hinfo)) - ,folder-var) - ,@(if hinfo-var - `((let ((,hinfo-var ,hinfo)) - ,@forms)) - forms)))))))) - -(defmacro do-headers-lines ((hbuffer &key line-var mark-var) &rest forms) - "Forms are evaluated for each non-blank line. When supplied Line-Var and - Mark-Var are to the line and a :left-inserting mark at the beginning of the - line. This works with DELETE-HEADERS-BUFFER-LINE, but one should be careful - using this to modify the hbuffer." - (let ((line-var (or line-var (gensym))) - (mark-var (or mark-var (gensym))) - (id (gensym))) - `(with-mark ((,mark-var (buffer-point ,hbuffer) :left-inserting)) - (buffer-start ,mark-var) - (loop - (let* ((,line-var (mark-line ,mark-var)) - (,id (line-message-id ,line-var))) - (unless (blank-line-p ,line-var) - ,@forms) - (if (or (not (eq ,line-var (mark-line ,mark-var))) - (string/= ,id (line-message-id ,line-var))) - (line-start ,mark-var) - (unless (line-offset ,mark-var 1 0) (return)))))))) - -(defmacro with-headers-mark ((mark-var hbuffer msg) &rest forms) - "Forms are executed with Mark-Var bound to a :left-inserting mark at the - beginning of the headers line representing msg. If no such line exists, - no execution occurs." - (let ((line (gensym))) - `(do-headers-lines (,hbuffer :line-var ,line :mark-var ,mark-var) - (when (string= (the simple-string (line-message-id ,line)) - (the simple-string ,msg)) - ,@forms - (return))))) - - - - -;;;; Headers Mode. - -(defmode "Headers" :major-p t) - -(defhvar "Headers Information" - "This holds the information about the current headers buffer." - :value nil) - -(defstruct (headers-info (:print-function print-headers-info)) - buffer ;Buffer for these headers. - folder ;String name of folder with leading MH "+". - msg-seq ;MH sequence of messages in buffer. - msg-strings ;List of strings representing msg-seq. - other-msg-bufs ;List of message buffers referencing this headers buffer. - draft-bufs ;List of draft buffers referencing this headers buffer. - msg-buffer) - -(defun print-headers-info (obj str n) - (declare (ignore n)) - (format str "#" (headers-info-folder obj))) - -(defmacro line-message-deleted (line) - `(getf (line-plist ,line) 'mh-msg-deleted)) - -(defmacro line-message-id (line) - `(getf (line-plist ,line) 'mh-msg-id)) - -(defun headers-current-message (hinfo) - (let* ((point (buffer-point (headers-info-buffer hinfo))) - (line (mark-line point))) - (unless (blank-line-p line) - (values (line-message-id line) - (copy-mark point))))) - -(defcommand "Message Headers" (p) - "Prompts for a folder and messages, displaying headers in a buffer in the - current window. With an argument, prompt for a pick expression." - "Show some headers." - (let ((folder (prompt-for-folder))) - (new-message-headers - folder - (prompt-for-message :prompt (if p - "MH messages to pick from: " - "MH messages: ") - :folder folder - :messages "all") - p))) - -(defcommand "Pick Headers" (p) - "Further narrow the selection of this folders headers. - Prompts for a pick expression to pick over the headers in the current - buffer. Entering an empty expression displays all the headers for that - folder." - "Prompts for a pick expression to pick over the headers in the current - buffer." - (declare (ignore p)) - (let ((hinfo (value headers-information))) - (unless hinfo - (editor-error "Pick Headers only works in a headers buffer.")) - (pick-message-headers hinfo))) - -;;; PICK-MESSAGE-HEADERS picks messages from info's messages based on an -;;; expression provided by the user. If the expression is empty, we do -;;; headers on all the messages in folder. The buffer's name is changed to -;;; reflect the messages picked over and the expression used. -;;; -(defun pick-message-headers (hinfo) - (let ((folder (headers-info-folder hinfo)) - (msgs (headers-info-msg-strings hinfo))) - (multiple-value-bind (pick user-pick) - (prompt-for-pick-expression) - (let* ((hbuffer (headers-info-buffer hinfo)) - (new-mail-buf-p (eq hbuffer *new-mail-buffer*)) - (region (cond (pick - (message-headers-to-region - folder (pick-messages folder msgs pick))) - (new-mail-buf-p - (maybe-get-new-mail-msg-hdrs folder)) - (t (message-headers-to-region folder - (list "all")))))) - (with-writable-buffer (hbuffer) - (revamp-headers-buffer hbuffer hinfo) - (when region (insert-message-headers hbuffer hinfo region))) - (setf (buffer-modified hbuffer) nil) - (buffer-start (buffer-point hbuffer)) - (setf (buffer-name hbuffer) - (cond (pick (format nil "Headers ~A ~A ~A" folder msgs user-pick)) - (new-mail-buf-p (format nil "Unseen Headers ~A" folder)) - (t (format nil "Headers ~A (all)" folder)))))))) - -;;; NEW-MESSAGE-HEADERS picks over msgs if pickp is non-nil, or it just scans -;;; msgs. It is important to pick and get the message headers region before -;;; making the buffer and info structures since PICK-MESSAGES and -;;; MESSAGE-HEADERS-TO-REGION will call EDITOR-ERROR if they fail. The buffer -;;; name is chosen based on folder, msgs, and an optional pick expression. -;;; -(defun new-message-headers (folder msgs &optional pickp) - (multiple-value-bind (pick-exp user-pick) - (if pickp (prompt-for-pick-expression)) - (let* ((pick (if pick-exp (pick-messages folder msgs pick-exp))) - (region (message-headers-to-region folder (or pick msgs))) - (hbuffer (maybe-make-mh-buffer (format nil "Headers ~A ~A~:[~; ~S~]" - folder msgs pick user-pick) - :headers)) - (hinfo (make-headers-info :buffer hbuffer :folder folder))) - (insert-message-headers hbuffer hinfo region) - (defhvar "Headers Information" - "This holds the information about the current headers buffer." - :value hinfo :buffer hbuffer) - (setf (buffer-modified hbuffer) nil) - (setf (buffer-writable hbuffer) nil) - (buffer-start (buffer-point hbuffer)) - (change-to-buffer hbuffer)))) - -(defhvar "MH Scan Line Form" - "This is a pathname of a file containing an MH format expression for headers - lines." - :value (pathname "library:mh-scan")) - -;;; MESSAGE-HEADERS-TO-REGION uses the MH "scan" utility output headers into -;;; buffer for folder and msgs. -;;; -;;; (value fill-column) should really be done as if the buffer were current, -;;; but Hemlock doesn't let you do this without the buffer being current. -;;; -(defun message-headers-to-region (folder msgs &optional width) - (let ((region (make-empty-region))) - (with-output-to-mark (*standard-output* (region-end region) :full) - (mh "scan" - `(,folder ,@msgs - "-form" ,(namestring (truename (value mh-scan-line-form))) - "-width" ,(number-string (or width (value fill-column))) - "-noheader"))) - region)) - -(defun insert-message-headers (hbuffer hinfo region) - (ninsert-region (buffer-point hbuffer) region) - (let ((seq (set-message-headers-ids hbuffer :return-seq))) - (setf (headers-info-msg-seq hinfo) seq) - (setf (headers-info-msg-strings hinfo) (mh-sequence-strings seq))) - (when (value virtual-message-deletion) - (note-deleted-headers hbuffer - (mh-sequence-list (headers-info-folder hinfo) - "hemlockdeleted")))) - -(defun set-message-headers-ids (hbuffer &optional return-seq) - (let ((msgs nil)) - (do-headers-lines (hbuffer :line-var line) - (let* ((line-str (line-string line)) - (num (parse-integer line-str :junk-allowed t))) - (declare (simple-string line-str)) - (unless num - (editor-error "MH scan lines must contain the message id as the ~ - first thing on the line for the Hemlock interface.")) - (setf (line-message-id line) (number-string num)) - (when return-seq (setf msgs (mh-sequence-insert num msgs))))) - msgs)) - -(defun note-deleted-headers (hbuffer deleted-seq) - (when deleted-seq - (do-headers-lines (hbuffer :line-var line :mark-var hmark) - (if (mh-sequence-member-p (line-message-id line) deleted-seq) - (note-deleted-message-at-mark hmark) - (setf (line-message-deleted line) nil))))) - -;;; PICK-MESSAGES -- Internal Interface. -;;; -;;; This takes a folder (with a + in front of the name), messages to pick -;;; over, and an MH pick expression (in the form returned by -;;; PROMPT-FOR-PICK-EXPRESSION). Sequence is an MH sequence to set to exactly -;;; those messages chosen by the pick when zerop is non-nil; when zerop is nil, -;;; pick adds the messages to the sequence along with whatever messages were -;;; already in the sequence. This returns a list of message specifications. -;;; -(defun pick-messages (folder msgs expression &optional sequence (zerop t)) - (let* ((temp (with-output-to-string (*standard-output*) - (unless - ;; If someone bound *signal-mh-errors* to nil around this - ;; function, MH pick outputs bogus messages (for example, - ;; "0"), and MH would return without calling EDITOR-ERROR. - (mh "pick" `(,folder - ,@msgs - ,@(if sequence `("-sequence" ,sequence)) - ,@(if zerop '("-zero")) - "-list" ; -list must follow -sequence. - ,@expression)) - (return-from pick-messages nil)))) - (len (length temp)) - (start 0) - (result nil)) - (declare (simple-string temp)) - (loop - (let ((end (position #\newline temp :start start :test #'char=))) - (cond ((not end) - (return (nreverse (cons (subseq temp start) result)))) - ((= start end) - (return (nreverse result))) - (t - (push (subseq temp start end) result) - (when (>= (setf start (1+ end)) len) - (return (nreverse result))))))))) - - -(defcommand "Delete Headers Buffer and Message Buffers" (p &optional buffer) - "Prompts for a headers buffer to delete along with its associated message - buffers. Any associated draft buffers are left alone, but their associated - message buffers will be deleted." - "Deletes the current headers buffer and its associated message buffers." - (declare (ignore p)) - (let* ((default (cond ((value headers-information) (current-buffer)) - ((value message-information) (value headers-buffer)))) - (buffer (or buffer - (prompt-for-buffer :default default - :default-string - (if default (buffer-name default)))))) - (unless (hemlock-bound-p 'headers-information :buffer buffer) - (editor-error "Not a headers buffer -- ~A" (buffer-name buffer))) - (let* ((hinfo (variable-value 'headers-information :buffer buffer)) - ;; Copy list since buffer cleanup hook is destructive. - (other-bufs (copy-list (headers-info-other-msg-bufs hinfo))) - (msg-buf (headers-info-msg-buffer hinfo))) - (when msg-buf (delete-buffer-if-possible msg-buf)) - (dolist (b other-bufs) (delete-buffer-if-possible b)) - (delete-buffer-if-possible (headers-info-buffer hinfo))))) - -(defhvar "Expunge Messages Confirm" - "When set (the default), \"Expunge Messages\" and \"Quit Headers\" will ask - for confirmation before expunging messages and packing the folder's message - id's." - :value t) - -(defhvar "Temporary Draft Folder" - "This is the folder name where MH fcc: messages are kept that are intended - to be deleted and expunged when messages are expunged for any other - folder -- \"Expunge Messages\" and \"Quit Headers\"." - :value nil) - -;;; "Quit Headers" doesn't expunge or compact unless there is a deleted -;;; sequence. This collapses other headers buffers into the same folder -;;; differently than "Expunge Messages" since the latter assumes there will -;;; always be one remaining headers buffer. This command folds all headers -;;; buffers into the folder that are not the current buffer or the new mail -;;; buffer into one buffer. When the current buffer is the new mail buffer -;;; we do not check for more unseen headers since we are about to delete -;;; the buffer anyway. The other headers buffers must be deleted before -;;; making the new one due to aliasing the buffer structure and -;;; MAYBE-MAKE-MH-BUFFER. -;;; -(defcommand "Quit Headers" (p) - "Quit headers buffer possibly expunging deleted messages. - This affects the current headers buffer. When there are deleted messages - the user is asked for confirmation on expunging the messages and packing the - folder's message id's. Then the buffer and all its associated message - buffers are deleted. Setting \"Quit Headers Confirm\" to nil inhibits - prompting. When \"Temporary Draft Folder\" is bound, this folder's messages - are deleted and expunged." - "This affects the current headers buffer. When there are deleted messages - the user is asked for confirmation on expunging the messages and packing - the folder. Then the buffer and all its associated message buffers are - deleted." - (declare (ignore p)) - (let* ((hinfo (value headers-information)) - (minfo (value message-information)) - (hdrs-buf (cond (hinfo (current-buffer)) - (minfo (value headers-buffer))))) - (unless hdrs-buf - (editor-error "Not in or associated with any headers buffer.")) - (let* ((folder (cond (hinfo (headers-info-folder hinfo)) - (minfo (message-info-folder minfo)))) - (deleted-seq (mh-sequence-list folder "hemlockdeleted"))) - (when (and deleted-seq - (or (not (value expunge-messages-confirm)) - (prompt-for-y-or-n - :prompt (list "Expunge messages and pack folder ~A? " - folder) - :default t - :default-string "Y"))) - (message "Deleting messages ...") - (mh "rmm" (list folder "hemlockdeleted")) - (let ((*standard-output* *mh-utility-bit-bucket*)) - (message "Compacting folder ...") - (mh "folder" (list folder "-fast" "-pack"))) - (message "Maintaining consistency ...") - (let (hbufs) - (declare (list hbufs)) - (do-headers-buffers (b folder) - (unless (or (eq b hdrs-buf) (eq b *new-mail-buffer*)) - (push b hbufs))) - (dolist (b hbufs) - (delete-headers-buffer-and-message-buffers-command nil b)) - (when hbufs - (new-message-headers folder (list "all")))) - (expunge-messages-fix-draft-buffers folder) - (unless (eq hdrs-buf *new-mail-buffer*) - (expunge-messages-fix-unseen-headers folder)) - (delete-and-expunge-temp-drafts))) - (delete-headers-buffer-and-message-buffers-command nil hdrs-buf))) - -;;; DELETE-AND-EXPUNGE-TEMP-DRAFTS deletes all the messages in the -;;; temporary draft folder if there is one defined. Any headers buffers -;;; into this folder are deleted with their message buffers. We have to -;;; create a list of buffers to delete since buffer deletion destructively -;;; modifies the same list DO-HEADERS-BUFFERS uses. "rmm" is run without -;;; error reporting since it signals an error if there are no messages to -;;; delete. This function must return; for example, "Quit Headers" would -;;; not complete successfully if this ended up calling EDITOR-ERROR. -;;; -(defun delete-and-expunge-temp-drafts () - (let ((temp-draft-folder (value temporary-draft-folder))) - (when temp-draft-folder - (setf temp-draft-folder (coerce-folder-name temp-draft-folder)) - (message "Deleting and expunging temporary drafts ...") - (when (mh "rmm" (list temp-draft-folder "all") :errorp nil) - (let (hdrs) - (declare (list hdrs)) - (do-headers-buffers (b temp-draft-folder) - (push b hdrs)) - (dolist (b hdrs) - (delete-headers-buffer-and-message-buffers-command nil b))))))) - - - - -;;;; Message Mode. - -(defmode "Message" :major-p t) - -(defhvar "Message Information" - "This holds the information about the current message buffer." - :value nil) - -(defstruct message/draft-info - headers-mark) ;Mark pointing to a headers line in a headers buffer. - -(defstruct (message-info (:include message/draft-info) - (:print-function print-message-info)) - folder ;String name of folder with leading MH "+". - msgs ;List of strings representing messages to be shown. - draft-buf ;Possible draft buffer reference. - keep) ;Whether message buffer may be re-used. - -(defun print-message-info (obj str n) - (declare (ignore n)) - (format str "#" - (message-info-folder obj) (message-info-msgs obj))) - - -(defcommand "Next Message" (p) - "Show the next message. - When in a message buffer, shows the next message in the associated headers - buffer. When in a headers buffer, moves point down a line and shows that - message." - "When in a message buffer, shows the next message in the associated headers - buffer. When in a headers buffer, moves point down a line and shows that - message." - (declare (ignore p)) - (show-message-offset 1)) - -(defcommand "Previous Message" (p) - "Show the previous message. - When in a message buffer, shows the previous message in the associated - headers buffer. When in a headers buffer, moves point up a line and shows - that message." - "When in a message buffer, shows the previous message in the associated - headers buffer. When in a headers buffer, moves point up a line and - shows that message." - (declare (ignore p)) - (show-message-offset -1)) - -(defcommand "Next Undeleted Message" (p) - "Show the next undeleted message. - When in a message buffer, shows the next undeleted message in the associated - headers buffer. When in a headers buffer, moves point down to a line - without a deleted message and shows that message." - "When in a message buffer, shows the next undeleted message in the associated - headers buffer. When in a headers buffer, moves point down to a line without - a deleted message and shows that message." - (declare (ignore p)) - (show-message-offset 1 :undeleted)) - -(defcommand "Previous Undeleted Message" (p) - "Show the previous undeleted message. - When in a message buffer, shows the previous undeleted message in the - associated headers buffer. When in a headers buffer, moves point up a line - without a deleted message and shows that message." - "When in a message buffer, shows the previous undeleted message in the - associated headers buffer. When in a headers buffer, moves point up a line - without a deleted message and shows that message." - (declare (ignore p)) - (show-message-offset -1 :undeleted)) - -(defun show-message-offset (offset &optional undeleted) - (let ((minfo (value message-information))) - (cond - ((not minfo) - (let ((hinfo (value headers-information))) - (unless hinfo (editor-error "Not in a message or headers buffer.")) - (show-message-offset-hdrs-buf hinfo offset undeleted))) - ((message-info-keep minfo) - (let ((hbuf (value headers-buffer))) - (unless hbuf (editor-error "Not associated with a headers buffer.")) - (let ((hinfo (variable-value 'headers-information :buffer hbuf)) - (point (buffer-point hbuf))) - (move-mark point (message-info-headers-mark minfo)) - (show-message-offset-hdrs-buf hinfo offset undeleted)))) - (t - (show-message-offset-msg-buf minfo offset undeleted))))) - -(defun show-message-offset-hdrs-buf (hinfo offset undeleted) - (unless hinfo (editor-error "Not in a message or headers buffer.")) - (unless (show-message-offset-mark (buffer-point (headers-info-buffer hinfo)) - offset undeleted) - (editor-error "No ~:[previous~;next~] ~:[~;undeleted ~]message." - (plusp offset) undeleted)) - (show-headers-message hinfo)) - -(defun show-message-offset-msg-buf (minfo offset undeleted) - (let ((msg-mark (message-info-headers-mark minfo))) - (unless msg-mark (editor-error "Not associated with a headers buffer.")) - (unless (show-message-offset-mark msg-mark offset undeleted) - (let ((hbuf (value headers-buffer)) - (mbuf (current-buffer))) - (setf (current-buffer) hbuf) - (setf (window-buffer (current-window)) hbuf) - (delete-buffer-if-possible mbuf)) - (editor-error "No ~:[previous~;next~] ~:[~;undeleted ~]message." - (plusp offset) undeleted)) - (move-mark (buffer-point (line-buffer (mark-line msg-mark))) msg-mark) - (let* ((next-msg (line-message-id (mark-line msg-mark))) - (folder (message-info-folder minfo)) - (mbuffer (current-buffer))) - (with-writable-buffer (mbuffer) - (delete-region (buffer-region mbuffer)) - (setf (buffer-name mbuffer) (get-storable-msg-buf-name folder next-msg)) - (setf (message-info-msgs minfo) next-msg) - (read-mh-file (merge-pathnames next-msg - (merge-relative-pathnames - (strip-folder-name folder) - (mh-directory-pathname))) - mbuffer) - (let ((unseen-seq (mh-profile-component "unseen-sequence"))) - (when unseen-seq - (mark-one-message folder next-msg unseen-seq :delete)))))) - (let ((dbuffer (message-info-draft-buf minfo))) - (when dbuffer - (delete-variable 'message-buffer :buffer dbuffer) - (setf (message-info-draft-buf minfo) nil)))) - -(defun get-storable-msg-buf-name (folder msg) - (let ((name (format nil "Message ~A ~A" folder msg))) - (if (not (getstring name *buffer-names*)) - name - (let ((n 2)) - (loop - (setf name (format nil "Message ~A ~A copy ~D" folder msg n)) - (unless (getstring name *buffer-names*) - (return name)) - (incf n)))))) - -(defun show-message-offset-mark (msg-mark offset undeleted) - (with-mark ((temp msg-mark)) - (let ((winp - (cond (undeleted - (loop - (unless (and (line-offset temp offset 0) - (not (blank-line-p (mark-line temp)))) - (return nil)) - (unless (line-message-deleted (mark-line temp)) - (return t)))) - ((and (line-offset temp offset 0) - (not (blank-line-p (mark-line temp))))) - (t nil)))) - (if winp (move-mark msg-mark temp))))) - - -(defcommand "Show Message" (p) - "Shows the current message. - Prompts for a folder and message(s), displaying this in the current window. - When invoked in a headers buffer, shows the message on the current line." - "Show a message." - (declare (ignore p)) - (let ((hinfo (value headers-information))) - (if hinfo - (show-headers-message hinfo) - (let ((folder (prompt-for-folder))) - (show-prompted-message folder (prompt-for-message :folder folder)))))) - -;;; SHOW-HEADERS-MESSAGE shows the current message for hinfo. If there is a -;;; main message buffer, clobber it, and we don't have to deal with kept -;;; messages or draft associations since those operations should have moved -;;; the message buffer into the others list. Remove the message from the -;;; unseen sequence, and make sure the message buffer is displayed in some -;;; window. -;;; -(defun show-headers-message (hinfo) - (multiple-value-bind (cur-msg cur-mark) - (headers-current-message hinfo) - (unless cur-msg (editor-error "Not on a header line.")) - (let* ((mbuffer (headers-info-msg-buffer hinfo)) - (folder (headers-info-folder hinfo)) - (buf-name (get-storable-msg-buf-name folder cur-msg)) - (writable nil)) - (cond (mbuffer - (setf (buffer-name mbuffer) buf-name) - (setf writable (buffer-writable mbuffer)) - (setf (buffer-writable mbuffer) t) - (delete-region (buffer-region mbuffer)) - (let ((minfo (variable-value 'message-information :buffer mbuffer))) - (move-mark (message-info-headers-mark minfo) cur-mark) - (delete-mark cur-mark) - (setf (message-info-msgs minfo) cur-msg))) - (t (setf mbuffer (maybe-make-mh-buffer buf-name :message)) - (setf (headers-info-msg-buffer hinfo) mbuffer) - (defhvar "Message Information" - "This holds the information about the current headers buffer." - :value (make-message-info :folder folder - :msgs cur-msg - :headers-mark cur-mark) - :buffer mbuffer) - (defhvar "Headers Buffer" - "This is bound in message and draft buffers to their - associated headers buffer." - :value (headers-info-buffer hinfo) :buffer mbuffer))) - (read-mh-file (merge-pathnames - cur-msg - (merge-relative-pathnames (strip-folder-name folder) - (mh-directory-pathname))) - mbuffer) - (setf (buffer-writable mbuffer) writable) - (let ((unseen-seq (mh-profile-component "unseen-sequence"))) - (when unseen-seq (mark-one-message folder cur-msg unseen-seq :delete))) - (get-message-buffer-window mbuffer)))) - -;;; SHOW-PROMPTED-MESSAGE takes an arbitrary message spec and blasts those -;;; messages into a message buffer. First we pick the message to get them -;;; individually specified as normalized message ID's -- all integers and -;;; no funny names such as "last". -;;; -(defun show-prompted-message (folder msgs) - (let* ((msgs (pick-messages folder msgs nil)) - (mbuffer (maybe-make-mh-buffer (format nil "Message ~A ~A" folder msgs) - :message))) - (defhvar "Message Information" - "This holds the information about the current headers buffer." - :value (make-message-info :folder folder :msgs msgs) - :buffer mbuffer) - (let ((*standard-output* (make-hemlock-output-stream (buffer-point mbuffer) - :full))) - (mh "show" `(,folder ,@msgs "-noshowproc" "-noheader")) - (setf (buffer-modified mbuffer) nil)) - (buffer-start (buffer-point mbuffer)) - (setf (buffer-writable mbuffer) nil) - (get-message-buffer-window mbuffer))) - -;;; GET-MESSAGE-BUFFER-WINDOW currently just changes to buffer, unless buffer -;;; has any windows, in which case it uses the first one. It could prompt for -;;; a window, split the current window, split the current window or use the -;;; next one if there is one, funcall an Hvar. It could take a couple -;;; arguments to control its behaviour. Whatever. -;;; -(defun get-message-buffer-window (mbuffer) - (let ((wins (buffer-windows mbuffer))) - (cond (wins - (setf (current-buffer) mbuffer) - (setf (current-window) (car wins))) - (t (change-to-buffer mbuffer))))) - - -(defhvar "Scroll Message Showing Next" - "When this is set, \"Scroll Message\" shows the next message when the end - of the current message is visible." - :value t) - -(defcommand "Scroll Message" (p) - "Scroll the current window down through the current message. - If the end of the message is visible, then show the next undeleted message - if \"Scroll Message Showing Next\" is non-nil." - "Scroll the current window down through the current message." - (if (and (not p) - (displayed-p (buffer-end-mark (current-buffer)) (current-window)) - (value scroll-message-showing-next)) - (show-message-offset 1 :undeleted) - (scroll-window-down-command p))) - - -(defcommand "Keep Message" (p) - "Keeps the current message buffer from being re-used. Also, if the buffer - would be deleted due to a draft completion, it will not be." - "Keeps the current message buffer from being re-used. Also, if the buffer - would be deleted due to a draft completion, it will not be." - (declare (ignore p)) - (let ((minfo (value message-information))) - (unless minfo (editor-error "Not in a message buffer.")) - (let ((hbuf (value headers-buffer))) - (when hbuf - (let ((mbuf (current-buffer)) - (hinfo (variable-value 'headers-information :buffer hbuf))) - (when (eq (headers-info-msg-buffer hinfo) mbuf) - (setf (headers-info-msg-buffer hinfo) nil) - (push mbuf (headers-info-other-msg-bufs hinfo)))))) - (setf (message-info-keep minfo) t))) - -(defcommand "Edit Message Buffer" (p) - "Recursively edit message buffer. - Puts the current message buffer into \"Text\" mode allowing modifications in - a recursive edit. While in this state, the buffer is associated with the - pathname of the message, so saving the file is possible." - "Puts the current message buffer into \"Text\" mode allowing modifications in - a recursive edit. While in this state, the buffer is associated with the - pathname of the message, so saving the file is possible." - (declare (ignore p)) - (let* ((minfo (value message-information))) - (unless minfo (editor-error "Not in a message buffer.")) - (let* ((msgs (message-info-msgs minfo)) - (mbuf (current-buffer)) - (mbuf-name (buffer-name mbuf)) - (writable (buffer-writable mbuf)) - (abortp t)) - (when (consp msgs) - (editor-error - "There appears to be more than one message in this buffer.")) - (unwind-protect - (progn - (setf (buffer-writable mbuf) t) - (setf (buffer-pathname mbuf) - (merge-pathnames - msgs - (merge-relative-pathnames - (strip-folder-name (message-info-folder minfo)) - (mh-directory-pathname)))) - (setf (buffer-major-mode mbuf) "Text") - (do-recursive-edit) - (setf abortp nil)) - (when (and (not abortp) - (buffer-modified mbuf) - (prompt-for-y-or-n - :prompt "Message buffer modified, save it? " - :default t)) - (save-file-command nil mbuf)) - (setf (buffer-modified mbuf) nil) - ;; "Save File", which the user may have used, changes the buffer's name. - (unless (getstring mbuf-name *buffer-names*) - (setf (buffer-name mbuf) mbuf-name)) - (setf (buffer-writable mbuf) writable) - (setf (buffer-pathname mbuf) nil) - (setf (buffer-major-mode mbuf) "Message"))))) - - - - -;;;; Draft Mode. - -(defmode "Draft") - -(defhvar "Draft Information" - "This holds the information about the current draft buffer." - :value nil) - -(defstruct (draft-info (:include message/draft-info) - (:print-function print-draft-info)) - folder ;String name of draft folder with leading MH "+". - message ;String id of draft folder message. - pathname ;Pathname of draft in the draft folder directory. - delivered ;This is set when the draft was really sent. - replied-to-folder ;Folder of message draft is in reply to. - replied-to-msg) ;Message draft is in reply to. - -(defun print-draft-info (obj str n) - (declare (ignore n)) - (format str "#" (draft-info-message obj))) - - -(defhvar "Reply to Message Prefix Action" - "This is one of :cc-all, :no-cc-all, or nil. When an argument is supplied to - \"Reply to Message\", this value determines how arguments passed to the - MH utility." - :value nil) - -(defcommand "Reply to Message" (p) - "Sets up a draft in reply to the current message. - Prompts for a folder and message to reply to. When in a headers buffer, - replies to the message on the current line. When in a message buffer, - replies to that message. With an argument, regard \"Reply to Message Prefix - Action\" for carbon copy arguments to the MH utility." - "Prompts for a folder and message to reply to. When in a headers buffer, - replies to the message on the current line. When in a message buffer, - replies to that message." - (let ((hinfo (value headers-information)) - (minfo (value message-information))) - (cond (hinfo - (multiple-value-bind (cur-msg cur-mark) - (headers-current-message hinfo) - (unless cur-msg (editor-error "Not on a header line.")) - (setup-reply-draft (headers-info-folder hinfo) - cur-msg hinfo cur-mark p))) - (minfo - (setup-message-buffer-draft (current-buffer) minfo :reply p)) - (t - (let ((folder (prompt-for-folder))) - (setup-reply-draft folder - (car (prompt-for-message :folder folder)) - nil nil p)))))) - -;;; SETUP-REPLY-DRAFT takes a folder and msg to draft a reply to. Optionally, -;;; a headers buffer and mark are associated with the draft. First, the draft -;;; buffer is associated with the headers buffer if there is one. Then the -;;; message buffer is created and associated with the drafter buffer and -;;; headers buffer. Argument may be used to pass in the argument from the -;;; command. -;;; -(defun setup-reply-draft (folder msg &optional hinfo hmark argument) - (let* ((dbuffer (sub-setup-message-draft - "repl" :end-of-buffer - `(,folder ,msg - ,@(if argument - (case (value reply-to-message-prefix-action) - (:no-cc-all '("-nocc" "all")) - (:cc-all '("-cc" "all"))))))) - (dinfo (variable-value 'draft-information :buffer dbuffer)) - (h-buf (if hinfo (headers-info-buffer hinfo)))) - (setf (draft-info-replied-to-folder dinfo) folder) - (setf (draft-info-replied-to-msg dinfo) msg) - (when h-buf - (defhvar "Headers Buffer" - "This is bound in message and draft buffers to their associated - headers buffer." - :value h-buf :buffer dbuffer) - (setf (draft-info-headers-mark dinfo) hmark) - (push dbuffer (headers-info-draft-bufs hinfo))) - (let ((msg-buf (maybe-make-mh-buffer (format nil "Message ~A ~A" folder msg) - :message))) - (defhvar "Message Information" - "This holds the information about the current headers buffer." - :value (make-message-info :folder folder :msgs msg - :headers-mark - (if h-buf (copy-mark hmark) hmark) - :draft-buf dbuffer) - :buffer msg-buf) - (when h-buf - (defhvar "Headers Buffer" - "This is bound in message and draft buffers to their associated - headers buffer." - :value h-buf :buffer msg-buf) - (push msg-buf (headers-info-other-msg-bufs hinfo))) - (read-mh-file (merge-pathnames - msg - (merge-relative-pathnames (strip-folder-name folder) - (mh-directory-pathname))) - msg-buf) - (setf (buffer-writable msg-buf) nil) - (defhvar "Message Buffer" - "This is bound in draft buffers to their associated message buffer." - :value msg-buf :buffer dbuffer)) - (get-draft-buffer-window dbuffer))) - - -(defcommand "Forward Message" (p) - "Forward current message. - Prompts for a folder and message to forward. When in a headers buffer, - forwards the message on the current line. When in a message buffer, - forwards that message." - "Prompts for a folder and message to reply to. When in a headers buffer, - replies to the message on the current line. When in a message buffer, - replies to that message." - (declare (ignore p)) - (let ((hinfo (value headers-information)) - (minfo (value message-information))) - (cond (hinfo - (multiple-value-bind (cur-msg cur-mark) - (headers-current-message hinfo) - (unless cur-msg (editor-error "Not on a header line.")) - (setup-forward-draft (headers-info-folder hinfo) - cur-msg hinfo cur-mark))) - (minfo - (setup-message-buffer-draft (current-buffer) minfo :forward)) - (t - (let ((folder (prompt-for-folder))) - (setup-forward-draft folder - (car (prompt-for-message :folder folder)))))))) - -;;; SETUP-FORWARD-DRAFT sets up a draft forwarding folder's msg. When there -;;; is a headers buffer involved (hinfo and hmark), the draft is associated -;;; with it. -;;; -;;; This function is like SETUP-REPLY-DRAFT (in addition to "forw" and -;;; :to-field), but it does not setup a message buffer. If this is added as -;;; something forward drafts want, then SETUP-REPLY-DRAFT should be -;;; parameterized and renamed. -;;; -(defun setup-forward-draft (folder msg &optional hinfo hmark) - (let* ((dbuffer (sub-setup-message-draft "forw" :to-field - (list folder msg))) - (dinfo (variable-value 'draft-information :buffer dbuffer)) - (h-buf (if hinfo (headers-info-buffer hinfo)))) - (when h-buf - (defhvar "Headers Buffer" - "This is bound in message and draft buffers to their associated - headers buffer." - :value h-buf :buffer dbuffer) - (setf (draft-info-headers-mark dinfo) hmark) - (push dbuffer (headers-info-draft-bufs hinfo))) - (get-draft-buffer-window dbuffer))) - - -(defcommand "Send Message" (p) - "Setup a draft buffer. - Setup a draft buffer, reserving a draft folder message. When invoked in a - headers buffer, the current message is available in an associated message - buffer." - "Setup a draft buffer, reserving a draft folder message. When invoked in - a headers buffer, the current message is available in an associated - message buffer." - (declare (ignore p)) - (let ((hinfo (value headers-information)) - (minfo (value message-information))) - (cond (hinfo (setup-headers-message-draft hinfo)) - (minfo (setup-message-buffer-draft (current-buffer) minfo :compose)) - (t (setup-message-draft))))) - -(defun setup-message-draft () - (get-draft-buffer-window (sub-setup-message-draft "comp" :to-field))) - -;;; SETUP-HEADERS-MESSAGE-DRAFT sets up a draft buffer associated with a -;;; headers buffer and a message buffer. The headers current message is -;;; inserted in the message buffer which is also associated with the headers -;;; buffer. The draft buffer is associated with the message buffer. -;;; -(defun setup-headers-message-draft (hinfo) - (multiple-value-bind (cur-msg cur-mark) - (headers-current-message hinfo) - (unless cur-msg (message "Draft not associated with any message.")) - (let* ((dbuffer (sub-setup-message-draft "comp" :to-field)) - (dinfo (variable-value 'draft-information :buffer dbuffer)) - (h-buf (headers-info-buffer hinfo))) - (when cur-msg - (defhvar "Headers Buffer" - "This is bound in message and draft buffers to their associated headers - buffer." - :value h-buf :buffer dbuffer) - (push dbuffer (headers-info-draft-bufs hinfo))) - (when cur-msg - (setf (draft-info-headers-mark dinfo) cur-mark) - (let* ((folder (headers-info-folder hinfo)) - (msg-buf (maybe-make-mh-buffer - (format nil "Message ~A ~A" folder cur-msg) - :message))) - (defhvar "Message Information" - "This holds the information about the current headers buffer." - :value (make-message-info :folder folder :msgs cur-msg - :headers-mark (copy-mark cur-mark) - :draft-buf dbuffer) - :buffer msg-buf) - (defhvar "Headers Buffer" - "This is bound in message and draft buffers to their associated - headers buffer." - :value h-buf :buffer msg-buf) - (push msg-buf (headers-info-other-msg-bufs hinfo)) - (read-mh-file (merge-pathnames - cur-msg - (merge-relative-pathnames (strip-folder-name folder) - (mh-directory-pathname))) - msg-buf) - (setf (buffer-writable msg-buf) nil) - (defhvar "Message Buffer" - "This is bound in draft buffers to their associated message buffer." - :value msg-buf :buffer dbuffer))) - (get-draft-buffer-window dbuffer)))) - -;;; SETUP-MESSAGE-BUFFER-DRAFT takes a message buffer and its message -;;; information. A draft buffer is created according to type, and the two -;;; buffers are associated. Any previous association of the message buffer and -;;; a draft buffer is dropped. Any association between the message buffer and -;;; a headers buffer is propagated to the draft buffer, and if the message -;;; buffer is the headers buffer's main message buffer, it is moved to "other" -;;; status. Argument may be used to pass in the argument from the command. -;;; -(defun setup-message-buffer-draft (msg-buf minfo type &optional argument) - (let* ((msgs (message-info-msgs minfo)) - (cur-msg (if (consp msgs) (car msgs) msgs)) - (folder (message-info-folder minfo)) - (dbuffer - (ecase type - (:reply - (sub-setup-message-draft - "repl" :end-of-buffer - `(,folder ,cur-msg - ,@(if argument - (case (value reply-to-message-prefix-action) - (:no-cc-all '("-nocc" "all")) - (:cc-all '("-cc" "all"))))))) - (:compose - (sub-setup-message-draft "comp" :to-field)) - (:forward - (sub-setup-message-draft "forw" :to-field - (list folder cur-msg))))) - (dinfo (variable-value 'draft-information :buffer dbuffer))) - (when (message-info-draft-buf minfo) - (delete-variable 'message-buffer :buffer (message-info-draft-buf minfo))) - (setf (message-info-draft-buf minfo) dbuffer) - (when (eq type :reply) - (setf (draft-info-replied-to-folder dinfo) folder) - (setf (draft-info-replied-to-msg dinfo) cur-msg)) - (when (hemlock-bound-p 'headers-buffer :buffer msg-buf) - (let* ((hbuf (variable-value 'headers-buffer :buffer msg-buf)) - (hinfo (variable-value 'headers-information :buffer hbuf))) - (defhvar "Headers Buffer" - "This is bound in message and draft buffers to their associated - headers buffer." - :value hbuf :buffer dbuffer) - (setf (draft-info-headers-mark dinfo) - (copy-mark (message-info-headers-mark minfo))) - (push dbuffer (headers-info-draft-bufs hinfo)) - (when (eq (headers-info-msg-buffer hinfo) msg-buf) - (setf (headers-info-msg-buffer hinfo) nil) - (push msg-buf (headers-info-other-msg-bufs hinfo))))) - (defhvar "Message Buffer" - "This is bound in draft buffers to their associated message buffer." - :value msg-buf :buffer dbuffer) - (get-draft-buffer-window dbuffer))) - -(defvar *draft-to-pattern* - (new-search-pattern :string-insensitive :forward "To:")) - -(defun sub-setup-message-draft (utility point-action &optional args) - (mh utility `(,@args "-nowhatnowproc")) - (let* ((folder (mh-draft-folder)) - (draft-msg (mh-current-message folder)) - (msg-pn (merge-pathnames draft-msg (mh-draft-folder-pathname))) - (dbuffer (maybe-make-mh-buffer (format nil "Draft ~A" draft-msg) - :draft))) - (read-mh-file msg-pn dbuffer) - (setf (buffer-pathname dbuffer) msg-pn) - (defhvar "Draft Information" - "This holds the information about the current draft buffer." - :value (make-draft-info :folder (coerce-folder-name folder) - :message draft-msg - :pathname msg-pn) - :buffer dbuffer) - (let ((point (buffer-point dbuffer))) - (ecase point-action - (:to-field - (when (find-pattern point *draft-to-pattern*) - (line-end point))) - (:end-of-buffer (buffer-end point)))) - dbuffer)) - -(defun read-mh-file (pathname buffer) - (unless (probe-file pathname) - (editor-error "No such message -- ~A" (namestring pathname))) - (read-file pathname (buffer-point buffer)) - (setf (buffer-write-date buffer) (file-write-date pathname)) - (buffer-start (buffer-point buffer)) - (setf (buffer-modified buffer) nil)) - - -(defvar *draft-buffer-window-fun* 'change-to-buffer - "This is called by GET-DRAFT-BUFFER-WINDOW to display a new draft buffer. - The default is CHANGE-TO-BUFFER which uses the current window.") - -;;; GET-DRAFT-BUFFER-WINDOW is called to display a new draft buffer. -;;; -(defun get-draft-buffer-window (dbuffer) - (funcall *draft-buffer-window-fun* dbuffer)) - - -(defcommand "Reply to Message in Other Window" (p) - "Reply to message, creating another window for draft buffer. - Prompts for a folder and message to reply to. When in a headers buffer, - replies to the message on the current line. When in a message buffer, - replies to that message. The current window is split displaying the draft - buffer in the new window and the message buffer in the current." - "Prompts for a folder and message to reply to. When in a headers buffer, - replies to the message on the current line. When in a message buffer, - replies to that message." - (let ((*draft-buffer-window-fun* #'draft-buffer-in-other-window)) - (reply-to-message-command p))) - -(defun draft-buffer-in-other-window (dbuffer) - (when (hemlock-bound-p 'message-buffer :buffer dbuffer) - (let ((mbuf (variable-value 'message-buffer :buffer dbuffer))) - (when (not (eq (current-buffer) mbuf)) - (change-to-buffer mbuf)))) - (setf (current-buffer) dbuffer) - (setf (current-window) (make-window (buffer-start-mark dbuffer))) - (defhvar "Split Window Draft" - "Indicates window needs to be cleaned up for draft." - :value t :buffer dbuffer)) - -(defhvar "Deliver Message Confirm" - "When set, \"Deliver Message\" will ask for confirmation before sending the - draft. This is off by default since \"Deliver Message\" is not bound to - any key by default." - :value t) - -(defcommand "Deliver Message" (p) - "Save and deliver the current draft buffer. - When in a draft buffer, this saves the file and uses SEND to deliver the - draft. Otherwise, this prompts for a draft message id, invoking SEND." - "When in a draft buffer, this saves the file and uses SEND to deliver the - draft. Otherwise, this prompts for a draft message id, invoking SEND." - (declare (ignore p)) - (let ((dinfo (value draft-information))) - (cond (dinfo - (deliver-draft-buffer-message dinfo)) - (t - (let* ((folder (coerce-folder-name (mh-draft-folder))) - (msg (prompt-for-message :folder folder))) - (mh "send" `("-draftfolder" ,folder "-draftmessage" ,@msg))))))) - -(defun deliver-draft-buffer-message (dinfo) - (when (draft-info-delivered dinfo) - (editor-error "This draft has already been delivered.")) - (when (or (not (value deliver-message-confirm)) - (prompt-for-y-or-n :prompt "Deliver message? " :default t)) - (let ((dbuffer (current-buffer))) - (when (buffer-modified dbuffer) - (write-buffer-file dbuffer (buffer-pathname dbuffer))) - (message "Delivering draft ...") - (mh "send" `("-draftfolder" ,(draft-info-folder dinfo) - "-draftmessage" ,(draft-info-message dinfo))) - (setf (draft-info-delivered dinfo) t) - (let ((replied-folder (draft-info-replied-to-folder dinfo)) - (replied-msg (draft-info-replied-to-msg dinfo))) - (when replied-folder - (message "Annotating message being replied to ...") - (mh "anno" `(,replied-folder ,replied-msg "-component" "replied")) - (do-headers-buffers (hbuf replied-folder) - (with-headers-mark (hmark hbuf replied-msg) - (mark-to-note-replied-msg hmark) - (with-writable-buffer (hbuf) - (setf (next-character hmark) #\A)))) - (dolist (b *buffer-list*) - (when (and (hemlock-bound-p 'message-information :buffer b) - (buffer-modeline-field-p b :replied-to-message)) - (dolist (w (buffer-windows b)) - (update-modeline-field b w :replied-to-message)))))) - (maybe-delete-extra-draft-window dbuffer (current-window)) - (let ((mbuf (value message-buffer))) - (when (and mbuf - (not (hemlock-bound-p 'netnews-message-info :buffer mbuf))) - (let ((minfo (variable-value 'message-information :buffer mbuf))) - (when (and minfo (not (message-info-keep minfo))) - (delete-buffer-if-possible mbuf))))) - (delete-buffer-if-possible dbuffer)))) - -(defcommand "Delete Draft and Buffer" (p) - "Delete the current draft and associated message and buffer." - "Delete the current draft and associated message and buffer." - (declare (ignore p)) - (let ((dinfo (value draft-information)) - (dbuffer (current-buffer))) - (unless dinfo (editor-error "No draft associated with buffer.")) - (maybe-delete-extra-draft-window dbuffer (current-window)) - (delete-file (draft-info-pathname dinfo)) - (let ((mbuf (value message-buffer))) - (when (and mbuf - (not (hemlock-bound-p 'netnews-message-info :buffer mbuf))) - (let ((minfo (variable-value 'message-information :buffer mbuf))) - (when (and minfo (not (message-info-keep minfo))) - (delete-buffer-if-possible mbuf))))) - (delete-buffer-if-possible dbuffer))) - -;;; MAYBE-DELETE-EXTRA-DRAFT-WINDOW -- Internal. -;;; -;;; This takes a draft buffer and a window into it that should not be deleted. -;;; If "Split Window Draft" is bound in the buffer, and there are at least two -;;; windows in dbuffer-window's group, then we delete some window. Blow away -;;; the variable, so we don't think this is still a split window draft buffer. -;;; -(defun maybe-delete-extra-draft-window (dbuffer dbuffer-window) - (when (and (hemlock-bound-p 'split-window-draft :buffer dbuffer) - ;; Since we know bitmap devices have window groups, this loop is - ;; more correct than testing the length of *window-list* and - ;; accounting for *echo-area-window* being in there. - (do ((start dbuffer-window) - (count 1 (1+ count)) - (w (next-window dbuffer-window) (next-window w))) - ((eq start w) (> count 1)))) - (delete-window (next-window dbuffer-window)) - (delete-variable 'split-window-draft :buffer dbuffer))) - -(defcommand "Remail Message" (p) - "Prompts for a folder and message to remail. Prompts for a resend-to - address string and resend-cc address string. When in a headers buffer, - remails the message on the current line. When in a message buffer, - remails that message." - "Prompts for a folder and message to remail. Prompts for a resend-to - address string and resend-cc address string. When in a headers buffer, - remails the message on the current line. When in a message buffer, - remails that message." - (declare (ignore p)) - (let ((hinfo (value headers-information)) - (minfo (value message-information))) - (cond (hinfo - (multiple-value-bind (cur-msg cur-mark) - (headers-current-message hinfo) - (unless cur-msg (editor-error "Not on a header line.")) - (delete-mark cur-mark) - (remail-message (headers-info-folder hinfo) cur-msg - (prompt-for-string :prompt "Resend To: ") - (prompt-for-string :prompt "Resend Cc: ")))) - (minfo - (remail-message (message-info-folder minfo) - (message-info-msgs minfo) - (prompt-for-string :prompt "Resend To: ") - (prompt-for-string :prompt "Resend Cc: "))) - (t - (let ((folder (prompt-for-folder))) - (remail-message folder - (car (prompt-for-message :folder folder)) - (prompt-for-string :prompt "Resend To: ") - (prompt-for-string :prompt "Resend Cc: ")))))) - (message "Message remailed.")) - - -;;; REMAIL-MESSAGE claims a draft folder message with "dist". This is then -;;; sucked into a buffer and modified by inserting the supplied addresses. -;;; "send" is used to deliver the draft, but it requires certain evironment -;;; variables to make it do the right thing. "mhdist" says the draft is only -;;; remailing information, and "mhaltmsg" is the message to send. "mhannotate" -;;; must be set due to a bug in MH's "send"; it will not notice the "mhdist" -;;; flag unless there is some message to be annotated. This command does not -;;; provide for annotation of the remailed message. -;;; -(defun remail-message (folder msg resend-to resend-cc) - (mh "dist" `(,folder ,msg "-nowhatnowproc")) - (let* ((draft-folder (mh-draft-folder)) - (draft-msg (mh-current-message draft-folder))) - (setup-remail-draft-message draft-msg resend-to resend-cc) - (mh "send" `("-draftfolder" ,draft-folder "-draftmessage" ,draft-msg) - :environment - `((:|mhdist| . "1") - (:|mhannotate| . "1") - (:|mhaltmsg| . ,(namestring - (merge-pathnames msg (merge-relative-pathnames - (strip-folder-name folder) - (mh-directory-pathname))))))))) - -;;; SETUP-REMAIL-DRAFT-MESSAGE takes a draft folder and message that have been -;;; created with the MH "dist" utility. A buffer is created with this -;;; message's pathname, searching for "resent-to:" and "resent-cc:", filling in -;;; the supplied argument values. After writing out the results, the buffer -;;; is deleted. -;;; -(defvar *draft-resent-to-pattern* - (new-search-pattern :string-insensitive :forward "resent-to:")) -(defvar *draft-resent-cc-pattern* - (new-search-pattern :string-insensitive :forward "resent-cc:")) - -(defun setup-remail-draft-message (msg resend-to resend-cc) - (let* ((msg-pn (merge-pathnames msg (mh-draft-folder-pathname))) - (dbuffer (maybe-make-mh-buffer (format nil "Draft ~A" msg) - :draft)) - (point (buffer-point dbuffer))) - (read-mh-file msg-pn dbuffer) - (when (find-pattern point *draft-resent-to-pattern*) - (line-end point) - (insert-string point resend-to)) - (buffer-start point) - (when (find-pattern point *draft-resent-cc-pattern*) - (line-end point) - (insert-string point resend-cc)) - (write-file (buffer-region dbuffer) msg-pn :keep-backup nil) - ;; The draft buffer delete hook expects this to be bound. - (defhvar "Draft Information" - "This holds the information about the current draft buffer." - :value :ignore - :buffer dbuffer) - (delete-buffer dbuffer))) - - - - -;;;; Message and Draft Stuff. - -(defhvar "Headers Buffer" - "This is bound in message and draft buffers to their associated headers - buffer." - :value nil) - -(defcommand "Goto Headers Buffer" (p) - "Selects associated headers buffer if it exists. - The headers buffer's point is moved to the appropriate line, pushing a - buffer mark where point was." - "Selects associated headers buffer if it exists." - (declare (ignore p)) - (let ((h-buf (value headers-buffer))) - (unless h-buf (editor-error "No associated headers buffer.")) - (let ((info (or (value message-information) (value draft-information)))) - (change-to-buffer h-buf) - (push-buffer-mark (copy-mark (current-point))) - (move-mark (current-point) (message/draft-info-headers-mark info))))) - -(defhvar "Message Buffer" - "This is bound in draft buffers to their associated message buffer." - :value nil) - -(defcommand "Goto Message Buffer" (p) - "Selects associated message buffer if it exists." - "Selects associated message buffer if it exists." - (declare (ignore p)) - (let ((msg-buf (value message-buffer))) - (unless msg-buf (editor-error "No associated message buffer.")) - (change-to-buffer msg-buf))) - - -(defhvar "Message Insertion Prefix" - "This is a fill prefix that is used when inserting text from a message buffer - into a draft buffer by \"Insert Message Region\". It defaults to three - spaces." - :value " ") - -(defhvar "Message Insertion Column" - "This is a fill column that is used when inserting text from a message buffer - into a draft buffer by \"Insert Message Region\"." - :value 75) - -(defcommand "Insert Message Region" (p) - "Copy the current region into the associated draft or post buffer. When - in a message buffer that has an associated draft or post buffer, the - current active region is copied into the draft or post buffer. It is - filled using \"Message Insertion Prefix\" and \"Message Insertion - Column\". If an argument is supplied, the filling is inhibited. - If both a draft buffer and post buffer are associated with this, then it - is inserted into the draft buffer." - "When in a message buffer that has an associated draft or post buffer, - the current active region is copied into the post or draft buffer. It is - filled using \"Message Insertion Prefix\" and \"Message Insertion - Column\". If an argument is supplied, the filling is inhibited." - (let* ((minfo (value message-information)) - (nm-info (if (hemlock-bound-p 'netnews-message-info) - (value netnews-message-info))) - (post-buffer (and nm-info (nm-info-post-buffer nm-info))) - (post-info (and post-buffer - (variable-value 'post-info :buffer post-buffer))) - dbuf kind) - (cond (minfo - (setf kind :mail) - (setf dbuf (message-info-draft-buf minfo))) - (nm-info - (setf kind :netnews) - (setf dbuf (or (nm-info-draft-buffer nm-info) - (nm-info-post-buffer nm-info)))) - (t (editor-error "Not in a netnews message or message buffer."))) - (unless dbuf - (editor-error "Message buffer not associated with any draft or post ~ - buffer.")) - (let* ((region (copy-region (current-region))) - (dbuf-point (buffer-point dbuf)) - (dbuf-mark (copy-mark dbuf-point))) - (cond ((and (eq kind :mail) - (hemlock-bound-p 'split-window-draft :buffer dbuf) - (> (length (the list *window-list*)) 2) - (buffer-windows dbuf)) - (setf (current-buffer) dbuf - (current-window) (car (buffer-windows dbuf)))) - ((and (eq kind :netnews) - (and (member (post-info-message-window post-info) - *window-list*) - (member (post-info-reply-window post-info) - *window-list*))) - (setf (current-buffer) dbuf - (current-window) (post-info-reply-window post-info))) - (t (change-to-buffer dbuf))) - (push-buffer-mark dbuf-mark) - (ninsert-region dbuf-point region) - (unless p - (fill-region-by-paragraphs (region dbuf-mark dbuf-point) - (value message-insertion-prefix) - (value message-insertion-column))))) - (setf (last-command-type) :ephemerally-active)) - - -(defhvar "Message Buffer Insertion Prefix" - "This is a line prefix that is inserted at the beginning of every line in - a message buffer when inserting those lines into a draft buffer with - \"Insert Message Buffer\". It defaults to four spaces." - :value " ") - -(defcommand "Insert Message Buffer" (p) - "Insert entire (associated) message buffer into (associated) draft or - post buffer. When in a draft or post buffer with an associated message - buffer, or when in a message buffer that has an associated draft or post - buffer, the message buffer is inserted into the draft buffer. When - there are both an associated draft and post buffer, the text is inserted - into the draft buffer. Each inserted line is modified by prefixing it - with \"Message Buffer Insertion Prefix\". If an argument is supplied - the prefixing is inhibited." - "When in a draft or post buffer with an associated message buffer, or - when in a message buffer that has an associated draft or post buffer, the - message buffer is inserted into the draft buffer. Each inserted line is - modified by prefixing it with \"Message Buffer Insertion Prefix\". If an - argument is supplied the prefixing is inhibited." - (let ((minfo (value message-information)) - (dinfo (value draft-information)) - mbuf dbuf message-kind) - (cond (minfo - (setf message-kind :mail) - (setf dbuf (message-info-draft-buf minfo)) - (unless dbuf - (editor-error - "Message buffer not associated with any draft buffer.")) - (setf mbuf (current-buffer)) - (change-to-buffer dbuf)) - (dinfo - (setf message-kind :mail) - (setf mbuf (value message-buffer)) - (unless mbuf - (editor-error - "Draft buffer not associated with any message buffer.")) - (setf dbuf (current-buffer))) - ((hemlock-bound-p 'netnews-message-info) - (setf message-kind :netnews) - (setf mbuf (current-buffer)) - (let ((nm-info (value netnews-message-info))) - (setf dbuf (or (nm-info-draft-buffer nm-info) - (nm-info-post-buffer nm-info))) - (unless dbuf - (editor-error "Message buffer not associated with any draft ~ - or post buffer."))) - (change-to-buffer dbuf)) - ((hemlock-bound-p 'post-info) - (setf message-kind :netnews) - (let ((post-info (value post-info))) - (setf mbuf (post-info-message-buffer post-info)) - (unless mbuf - (editor-error "Post buffer not associated with any message ~ - buffer."))) - (setf dbuf (current-buffer))) - (t (editor-error "Not in a draft, message, news-message, or post ~ - buffer."))) - (let* ((dbuf-point (buffer-point dbuf)) - (dbuf-mark (copy-mark dbuf-point))) - (push-buffer-mark dbuf-mark) - (insert-region dbuf-point (buffer-region mbuf)) - (unless p - (let ((prefix (value message-buffer-insertion-prefix))) - (with-mark ((temp dbuf-mark :left-inserting)) - (loop - (when (mark>= temp dbuf-point) (return)) - (insert-string temp prefix) - (unless (line-offset temp 1 0) (return))))))) - (ecase message-kind - (:mail - (insert-message-buffer-cleanup-split-draft dbuf mbuf)) - (:netnews - (nn-reply-cleanup-split-windows dbuf)))) - (setf (last-command-type) :ephemerally-active)) - -;;; INSERT-MESSAGE-BUFFER-CLEANUP-SPLIT-DRAFT tries to delete an extra window -;;; due to "Reply to Message in Other Window". Since we just inserted the -;;; message buffer in the draft buffer, we don't need the other window into -;;; the message buffer. -;;; -(defun insert-message-buffer-cleanup-split-draft (dbuf mbuf) - (when (and (hemlock-bound-p 'split-window-draft :buffer dbuf) - (> (length (the list *window-list*)) 2)) - (let ((win (car (buffer-windows mbuf)))) - (cond - (win - (when (eq win (current-window)) - (let ((dwin (car (buffer-windows dbuf)))) - (unless dwin - (editor-error "Couldn't fix windows for split window draft.")) - (setf (current-buffer) dbuf) - (setf (current-window) dwin))) - (delete-window win)) - (t ;; This happens when invoked with the message buffer current. - (let ((dwins (buffer-windows dbuf))) - (when (> (length (the list dwins)) 1) - (delete-window (find-if #'(lambda (w) - (not (eq w (current-window)))) - dwins))))))) - (delete-variable 'split-window-draft :buffer dbuf))) - - -;;; CLEANUP-MESSAGE-BUFFER is called when a buffer gets deleted. It cleans -;;; up references to a message buffer. -;;; -(defun cleanup-message-buffer (buffer) - (let ((minfo (variable-value 'message-information :buffer buffer))) - (when (hemlock-bound-p 'headers-buffer :buffer buffer) - (let* ((hinfo (variable-value 'headers-information - :buffer (variable-value 'headers-buffer - :buffer buffer))) - (msg-buf (headers-info-msg-buffer hinfo))) - (if (eq msg-buf buffer) - (setf (headers-info-msg-buffer hinfo) nil) - (setf (headers-info-other-msg-bufs hinfo) - (delete buffer (headers-info-other-msg-bufs hinfo) - :test #'eq)))) - (delete-mark (message-info-headers-mark minfo)) - ;; - ;; Do this for MAYBE-MAKE-MH-BUFFER since it isn't necessary for GC. - (delete-variable 'headers-buffer :buffer buffer)) - (when (message-info-draft-buf minfo) - (delete-variable 'message-buffer - :buffer (message-info-draft-buf minfo))))) - -;;; CLEANUP-DRAFT-BUFFER is called when a buffer gets deleted. It cleans -;;; up references to a draft buffer. -;;; -(defun cleanup-draft-buffer (buffer) - (let ((dinfo (variable-value 'draft-information :buffer buffer))) - (when (hemlock-bound-p 'headers-buffer :buffer buffer) - (let* ((hinfo (variable-value 'headers-information - :buffer (variable-value 'headers-buffer - :buffer buffer)))) - (setf (headers-info-draft-bufs hinfo) - (delete buffer (headers-info-draft-bufs hinfo) :test #'eq)) - (delete-mark (draft-info-headers-mark dinfo)))) - (when (hemlock-bound-p 'message-buffer :buffer buffer) - (setf (message-info-draft-buf - (variable-value 'message-information - :buffer (variable-value 'message-buffer - :buffer buffer))) - nil)))) - -;;; CLEANUP-HEADERS-BUFFER is called when a buffer gets deleted. It cleans -;;; up references to a headers buffer. -;;; -(defun cleanup-headers-buffer (buffer) - (let* ((hinfo (variable-value 'headers-information :buffer buffer)) - (msg-buf (headers-info-msg-buffer hinfo))) - (when msg-buf - (cleanup-headers-reference - msg-buf (variable-value 'message-information :buffer msg-buf))) - (dolist (b (headers-info-other-msg-bufs hinfo)) - (cleanup-headers-reference - b (variable-value 'message-information :buffer b))) - (dolist (b (headers-info-draft-bufs hinfo)) - (cleanup-headers-reference - b (variable-value 'draft-information :buffer b))))) - -(defun cleanup-headers-reference (buffer info) - (delete-mark (message/draft-info-headers-mark info)) - (setf (message/draft-info-headers-mark info) nil) - (delete-variable 'headers-buffer :buffer buffer) - (when (typep info 'draft-info) - (setf (draft-info-replied-to-folder info) nil) - (setf (draft-info-replied-to-msg info) nil))) - -;;; REVAMP-HEADERS-BUFFER cleans up a headers buffer for immediate re-use. -;;; After deleting the buffer's region, there will be one line in the buffer -;;; because of how Hemlock regions work, so we have to delete that line's -;;; plist. Then we clean up any references to the buffer and delete the -;;; main message buffer. The other message buffers are left alone assuming -;;; they are on the "others" list because they are being used in some -;;; particular way (for example, a draft buffer refers to one or the user has -;;; kept it). Then some slots of the info structure are set to nil. -;;; -(defun revamp-headers-buffer (hbuffer hinfo) - (delete-region (buffer-region hbuffer)) - (setf (line-plist (mark-line (buffer-point hbuffer))) nil) - (let ((msg-buf (headers-info-msg-buffer hinfo))) - ;; Deleting the buffer sets the slot to nil. - (when msg-buf (delete-buffer-if-possible msg-buf)) - (cleanup-headers-buffer hbuffer)) - (setf (headers-info-other-msg-bufs hinfo) nil) - (setf (headers-info-draft-bufs hinfo) nil) - (setf (headers-info-msg-seq hinfo) nil) - (setf (headers-info-msg-strings hinfo) nil)) - - - - -;;;; Incorporating new mail. - -(defhvar "New Mail Folder" - "This is the folder new mail is incorporated into." - :value "+inbox") - -(defcommand "Incorporate New Mail" (p) - "Incorporates new mail into \"New Mail Folder\", displaying INC output in - a pop-up window." - "Incorporates new mail into \"New Mail Folder\", displaying INC output in - a pop-up window." - (declare (ignore p)) - (with-pop-up-display (s) - (incorporate-new-mail s))) - -(defhvar "Unseen Headers Message Spec" - "This is an MH message spec suitable any message prompt. It is used to - supply headers for the unseen headers buffer, in addition to the - unseen-sequence name that is taken from the user's MH profile, when - incorporating new mail and after expunging. This value is a string." - :value nil) - -(defcommand "Incorporate and Read New Mail" (p) - "Incorporates new mail and generates a headers buffer. - Incorporates new mail into \"New Mail Folder\", and creates a headers buffer - with the new messages. To use this, you must define an unseen- sequence in - your profile. Each time this is invoked the unseen-sequence is SCAN'ed, and - the headers buffer's contents are replaced." - "Incorporates new mail into \"New Mail Folder\", and creates a headers - buffer with the new messages. This buffer will be appended to with - successive uses of this command." - (declare (ignore p)) - (let ((unseen-seq (mh-profile-component "unseen-sequence"))) - (unless unseen-seq - (editor-error "No unseen-sequence defined in MH profile.")) - (incorporate-new-mail) - (let* ((folder (value new-mail-folder)) - ;; Stash current message before fetching unseen headers. - (cur-msg (mh-current-message folder)) - (region (get-new-mail-msg-hdrs folder unseen-seq))) - ;; Fetch message headers before possibly making buffer in case we error. - (when (not (and *new-mail-buffer* - (member *new-mail-buffer* *buffer-list* :test #'eq))) - (let ((name (format nil "Unseen Headers ~A" folder))) - (when (getstring name *buffer-names*) - (editor-error "There already is a buffer named ~S!" name)) - (setf *new-mail-buffer* - (make-buffer name :modes (list "Headers") - :delete-hook '(new-mail-buf-delete-hook))) - (setf (buffer-writable *new-mail-buffer*) nil))) - (cond ((hemlock-bound-p 'headers-information - :buffer *new-mail-buffer*) - (let ((hinfo (variable-value 'headers-information - :buffer *new-mail-buffer*))) - (unless (string= (headers-info-folder hinfo) folder) - (editor-error - "An unseen headers buffer already exists but into another ~ - folder. Your mail has already been incorporated into the ~ - specified folder.")) - (with-writable-buffer (*new-mail-buffer*) - (revamp-headers-buffer *new-mail-buffer* hinfo)) - ;; Restore the name in case someone used "Pick Headers". - (setf (buffer-name *new-mail-buffer*) - (format nil "Unseen Headers ~A" folder)) - (insert-new-mail-message-headers hinfo region cur-msg))) - (t - (let ((hinfo (make-headers-info :buffer *new-mail-buffer* - :folder folder))) - (defhvar "Headers Information" - "This holds the information about the current headers buffer." - :value hinfo :buffer *new-mail-buffer*) - (insert-new-mail-message-headers hinfo region cur-msg))))))) - -;;; NEW-MAIL-BUF-DELETE-HOOK is invoked whenever the new mail buffer is -;;; deleted. -;;; -(defun new-mail-buf-delete-hook (buffer) - (declare (ignore buffer)) - (setf *new-mail-buffer* nil)) - -;;; GET-NEW-MAIL-MSG-HDRS takes a folder and the unseen-sequence name. It -;;; returns a region with the unseen message headers and any headers due to -;;; the "Unseen Headers Message Spec" variable. -;;; -(defun get-new-mail-msg-hdrs (folder unseen-seq) - (let* ((unseen-headers-message-spec (value unseen-headers-message-spec)) - (other-msgs (if unseen-headers-message-spec - (breakup-message-spec - (string-trim '(#\space #\tab) - unseen-headers-message-spec)))) - (msg-spec (cond ((null other-msgs) - (list unseen-seq)) - ((member unseen-seq other-msgs :test #'string=) - other-msgs) - (t (cons unseen-seq other-msgs))))) - (message-headers-to-region folder msg-spec))) - -;;; INSERT-NEW-MAIL-MESSAGE-HEADERS inserts region in the new mail buffer. -;;; Then we look for the header line with cur-msg id, moving point there. -;;; There may have been unseen messages before incorporating new mail, and -;;; cur-msg should be the first new message. Then we either switch to the -;;; new mail headers, or show the current message. -;;; -(defun insert-new-mail-message-headers (hinfo region cur-msg) - (declare (simple-string cur-msg)) - (with-writable-buffer (*new-mail-buffer*) - (insert-message-headers *new-mail-buffer* hinfo region)) - (let ((point (buffer-point *new-mail-buffer*))) - (buffer-start point) - (with-headers-mark (cur-mark *new-mail-buffer* cur-msg) - (move-mark point cur-mark))) - (change-to-buffer *new-mail-buffer*)) - - -(defhvar "Incorporate New Mail Hook" - "Functions on this hook are invoked immediately after new mail is - incorporated." - :value nil) - -(defun incorporate-new-mail (&optional stream) - "Incorporates new mail, passing INC's output to stream. When stream is - nil, output is flushed." - (unless (new-mail-p) (editor-error "No new mail.")) - (let ((args `(,(coerce-folder-name (value new-mail-folder)) - ,@(if stream nil '("-silent")) - "-form" ,(namestring (truename (value mh-scan-line-form))) - "-width" ,(number-string (value fill-column))))) - (message "Incorporating new mail ...") - (mh "inc" args)) - (when (value incorporate-new-mail-hook) - (message "Invoking new mail hooks ...")) - (invoke-hook incorporate-new-mail-hook)) - - - - -;;;; Deletion. - -(defhvar "Virtual Message Deletion" - "When set, \"Delete Message\" merely MARK's a message into the - \"hemlockdeleted\" sequence; otherwise, RMM is invoked." - :value t) - -(defcommand "Delete Message and Show Next" (p) - "Delete message and show next undeleted message. - This command is only valid in a headers buffer or a message buffer - associated with some headers buffer. The current message is deleted, and - the next undeleted one is shown." - "Delete the current message and show the next undeleted one." - (declare (ignore p)) - (let ((hinfo (value headers-information)) - (minfo (value message-information))) - (cond (hinfo - (multiple-value-bind (cur-msg cur-mark) - (headers-current-message hinfo) - (unless cur-msg (editor-error "Not on a header line.")) - (delete-mark cur-mark) - (delete-message (headers-info-folder hinfo) cur-msg))) - (minfo - (delete-message (message-info-folder minfo) - (message-info-msgs minfo))) - (t - (editor-error "Not in a headers or message buffer.")))) - (show-message-offset 1 :undeleted)) - -(defcommand "Delete Message and Down Line" (p) - "Deletes the current message, moving point to the next line. - When in a headers buffer, deletes the message on the current line. Then it - moves point to the next non-blank line." - "Deletes current message and moves point down a line." - (declare (ignore p)) - (let ((hinfo (value headers-information))) - (unless hinfo (editor-error "Not in a headers buffer.")) - (multiple-value-bind (cur-msg cur-mark) - (headers-current-message hinfo) - (unless cur-msg (editor-error "Not on a header line.")) - (delete-message (headers-info-folder hinfo) cur-msg) - (when (line-offset cur-mark 1) - (unless (blank-line-p (mark-line cur-mark)) - (move-mark (current-point) cur-mark))) - (delete-mark cur-mark)))) - -;;; "Delete Message" unlike "Headers Delete Message" cannot know for sure -;;; which message id's have been deleted, so when virtual message deletion -;;; is not used, we cannot use DELETE-HEADERS-BUFFER-LINE to keep headers -;;; buffers consistent. However, the message id's in the buffer (if deleted) -;;; will generate MH errors if operations are attempted with them, and -;;; if the user ever packs the folder with "Expunge Messages", the headers -;;; buffer will be updated. -;;; -(defcommand "Delete Message" (p) - "Prompts for a folder, messages to delete, and pick expression. When in - a headers buffer into the same folder specified, the messages prompt - defaults to those messages in the buffer; \"all\" may be entered if this is - not what is desired. When \"Virtual Message Deletion\" is set, messages are - only MARK'ed for deletion. See \"Expunge Messages\". When this feature is - not used, headers and message buffers message id's my not be consistent - with MH." - "Prompts for a folder and message to delete. When \"Virtual Message - Deletion\" is set, messages are only MARK'ed for deletion. See \"Expunge - Messages\"." - (declare (ignore p)) - (let* ((folder (prompt-for-folder)) - (hinfo (value headers-information)) - (temp-msgs (prompt-for-message - :folder folder - :messages - (if (and hinfo - (string= folder - (the simple-string - (headers-info-folder hinfo)))) - (headers-info-msg-strings hinfo)) - :prompt "MH messages to pick from: ")) - (pick-exp (prompt-for-pick-expression)) - (msgs (pick-messages folder temp-msgs pick-exp)) - (virtually (value virtual-message-deletion))) - (declare (simple-string folder)) - (if virtually - (mh "mark" `(,folder ,@msgs "-sequence" "hemlockdeleted" "-add")) - (mh "rmm" `(,folder ,@msgs))) - (if virtually - (let ((deleted-seq (mh-sequence-list folder "hemlockdeleted"))) - (when deleted-seq - (do-headers-buffers (hbuf folder) - (with-writable-buffer (hbuf) - (note-deleted-headers hbuf deleted-seq))))) - (do-headers-buffers (hbuf folder hinfo) - (do-headers-lines (hbuf :line-var line :mark-var hmark) - (when (member (line-message-id line) msgs :test #'string=) - (delete-headers-buffer-line hinfo hmark))))))) - -(defcommand "Headers Delete Message" (p) - "Delete current message. - When in a headers buffer, deletes the message on the current line. When - in a message buffer, deletes that message. When \"Virtual Message - Deletion\" is set, messages are only MARK'ed for deletion. See \"Expunge - Messages\"." - "When in a headers buffer, deletes the message on the current line. When - in a message buffer, deletes that message. When \"Virtual Message - Deletion\" is set, messages are only MARK'ed for deletion. See \"Expunge - Messages\"." - (declare (ignore p)) - (let ((hinfo (value headers-information)) - (minfo (value message-information))) - (cond (hinfo - (multiple-value-bind (cur-msg cur-mark) - (headers-current-message hinfo) - (unless cur-msg (editor-error "Not on a header line.")) - (delete-mark cur-mark) - (delete-message (headers-info-folder hinfo) cur-msg))) - (minfo - (let ((msgs (message-info-msgs minfo))) - (delete-message (message-info-folder minfo) - (if (consp msgs) (car msgs) msgs))) - (message "Message deleted.")) - (t (editor-error "Not in a headers or message buffer."))))) - -;;; DELETE-MESSAGE takes a folder and message id and either flags this message -;;; for deletion or deletes it. All headers buffers into folder are updated, -;;; either by flagging a headers line or deleting it. -;;; -(defun delete-message (folder msg) - (cond ((value virtual-message-deletion) - (mark-one-message folder msg "hemlockdeleted" :add) - (do-headers-buffers (hbuf folder) - (with-headers-mark (hmark hbuf msg) - (with-writable-buffer (hbuf) - (note-deleted-message-at-mark hmark))))) - (t (mh "rmm" (list folder msg)) - (do-headers-buffers (hbuf folder hinfo) - (with-headers-mark (hmark hbuf msg) - (delete-headers-buffer-line hinfo hmark))))) - (dolist (b *buffer-list*) - (when (and (hemlock-bound-p 'message-information :buffer b) - (buffer-modeline-field-p b :deleted-message)) - (dolist (w (buffer-windows b)) - (update-modeline-field b w :deleted-message))))) - -;;; NOTE-DELETED-MESSAGE-AT-MARK takes a mark at the beginning of a valid -;;; headers line, sticks a "D" on the line, and frobs the line's deleted -;;; property. This assumes the headers buffer is modifiable. -;;; -(defun note-deleted-message-at-mark (mark) - (find-attribute mark :digit) - (find-attribute mark :digit #'zerop) - (character-offset mark 2) - (setf (next-character mark) #\D) - (setf (line-message-deleted (mark-line mark)) t)) - -;;; DELETE-HEADERS-BUFFER-LINE takes a headers information and a mark on the -;;; line to be deleted. Before deleting the line, we check to see if any -;;; message or draft buffers refer to the buffer because of the line. Due -;;; to how regions are deleted, line plists get messed up, so they have to -;;; be regenerated. We regenerate them for the whole buffer, so we don't have -;;; to hack the code to know which lines got messed up. -;;; -(defun delete-headers-buffer-line (hinfo hmark) - (delete-headers-line-references hinfo hmark) - (let ((id (line-message-id (mark-line hmark))) - (hbuf (headers-info-buffer hinfo))) - (with-writable-buffer (hbuf) - (with-mark ((end (line-start hmark) :left-inserting)) - (unless (line-offset end 1 0) (buffer-end end)) - (delete-region (region hmark end)))) - (let ((seq (mh-sequence-delete id (headers-info-msg-seq hinfo)))) - (setf (headers-info-msg-seq hinfo) seq) - (setf (headers-info-msg-strings hinfo) (mh-sequence-strings seq))) - (set-message-headers-ids hbuf) - (when (value virtual-message-deletion) - (let ((deleted-seq (mh-sequence-list (headers-info-folder hinfo) - "hemlockdeleted"))) - (do-headers-lines (hbuf :line-var line) - (setf (line-message-deleted line) - (mh-sequence-member-p (line-message-id line) deleted-seq))))))) - - -;;; DELETE-HEADERS-LINE-REFERENCES removes any message buffer or draft buffer -;;; pointers to a headers buffer or marks into the headers buffer. Currently -;;; message buffers and draft buffers are identified differently for no good -;;; reason; probably message buffers should be located in the same way draft -;;; buffers are. Also, we currently assume only one of other-msg-bufs could -;;; refer to the line (similarly for draft-bufs), but this might be bug -;;; prone. The message buffer case couldn't happen since the buffer name -;;; would cause MAYBE-MAKE-MH-BUFFER to re-use the buffer, but you could reply -;;; to the same message twice simultaneously. -;;; -(defun delete-headers-line-references (hinfo hmark) - (let ((msg-id (line-message-id (mark-line hmark))) - (main-msg-buf (headers-info-msg-buffer hinfo))) - (declare (simple-string msg-id)) - (when main-msg-buf - (let ((minfo (variable-value 'message-information :buffer main-msg-buf))) - (when (string= (the simple-string (message-info-msgs minfo)) - msg-id) - (cond ((message-info-draft-buf minfo) - (cleanup-headers-reference main-msg-buf minfo) - (setf (headers-info-msg-buffer hinfo) nil)) - (t (delete-buffer-if-possible main-msg-buf)))))) - (dolist (mbuf (headers-info-other-msg-bufs hinfo)) - (let ((minfo (variable-value 'message-information :buffer mbuf))) - (when (string= (the simple-string (message-info-msgs minfo)) - msg-id) - (cond ((message-info-draft-buf minfo) - (cleanup-headers-reference mbuf minfo) - (setf (headers-info-other-msg-bufs hinfo) - (delete mbuf (headers-info-other-msg-bufs hinfo) - :test #'eq))) - (t (delete-buffer-if-possible mbuf))) - (return))))) - (dolist (dbuf (headers-info-draft-bufs hinfo)) - (let ((dinfo (variable-value 'draft-information :buffer dbuf))) - (when (same-line-p (draft-info-headers-mark dinfo) hmark) - (cleanup-headers-reference dbuf dinfo) - (setf (headers-info-draft-bufs hinfo) - (delete dbuf (headers-info-draft-bufs hinfo) :test #'eq)) - (return))))) - - -(defcommand "Undelete Message" (p) - "Prompts for a folder, messages to undelete, and pick expression. When in - a headers buffer into the same folder specified, the messages prompt - defaults to those messages in the buffer; \"all\" may be entered if this is - not what is desired. This command is only meaningful if you have - \"Virtual Message Deletion\" set." - "Prompts for a folder, messages to undelete, and pick expression. When in - a headers buffer into the same folder specified, the messages prompt - defaults to those messages in the buffer; \"all\" may be entered if this is - not what is desired. This command is only meaningful if you have - \"Virtual Message Deletion\" set." - (declare (ignore p)) - (unless (value virtual-message-deletion) - (editor-error "You don't use virtual message deletion.")) - (let* ((folder (prompt-for-folder)) - (hinfo (value headers-information)) - (temp-msgs (prompt-for-message - :folder folder - :messages - (if (and hinfo - (string= folder - (the simple-string - (headers-info-folder hinfo)))) - (headers-info-msg-strings hinfo)) - :prompt "MH messages to pick from: ")) - (pick-exp (prompt-for-pick-expression)) - (msgs (if pick-exp - (or (pick-messages folder temp-msgs pick-exp) temp-msgs) - temp-msgs))) - (declare (simple-string folder)) - (mh "mark" `(,folder ,@msgs "-sequence" "hemlockdeleted" "-delete")) - (let ((deleted-seq (mh-sequence-list folder "hemlockdeleted"))) - (do-headers-buffers (hbuf folder) - (with-writable-buffer (hbuf) - (do-headers-lines (hbuf :line-var line :mark-var hmark) - (when (and (line-message-deleted line) - (not (mh-sequence-member-p (line-message-id line) - deleted-seq))) - (note-undeleted-message-at-mark hmark)))))))) - -(defcommand "Headers Undelete Message" (p) - "Undelete the current message. - When in a headers buffer, undeletes the message on the current line. When - in a message buffer, undeletes that message. This command is only - meaningful if you have \"Virtual Message Deletion\" set." - "When in a headers buffer, undeletes the message on the current line. When - in a message buffer, undeletes that message. This command is only - meaningful if you have \"Virtual Message Deletion\" set." - (declare (ignore p)) - (unless (value virtual-message-deletion) - (editor-error "You don't use virtual message deletion.")) - (let ((hinfo (value headers-information)) - (minfo (value message-information))) - (cond (hinfo - (multiple-value-bind (cur-msg cur-mark) - (headers-current-message hinfo) - (unless cur-msg (editor-error "Not on a header line.")) - (delete-mark cur-mark) - (undelete-message (headers-info-folder hinfo) cur-msg))) - (minfo - (undelete-message (message-info-folder minfo) - (message-info-msgs minfo)) - (message "Message undeleted.")) - (t (editor-error "Not in a headers or message buffer."))))) - -;;; UNDELETE-MESSAGE takes a folder and a message id. All headers buffers into -;;; folder are updated. -;;; -(defun undelete-message (folder msg) - (mark-one-message folder msg "hemlockdeleted" :delete) - (do-headers-buffers (hbuf folder) - (with-headers-mark (hmark hbuf msg) - (with-writable-buffer (hbuf) - (note-undeleted-message-at-mark hmark)))) - (dolist (b *buffer-list*) - (when (and (hemlock-bound-p 'message-information :buffer b) - (buffer-modeline-field-p b :deleted-message)) - (dolist (w (buffer-windows b)) - (update-modeline-field b w :deleted-message))))) - -;;; NOTE-UNDELETED-MESSAGE-AT-MARK takes a mark at the beginning of a valid -;;; headers line, sticks a space on the line in place of a "D", and frobs the -;;; line's deleted property. This assumes the headers buffer is modifiable. -;;; -(defun note-undeleted-message-at-mark (hmark) - (find-attribute hmark :digit) - (find-attribute hmark :digit #'zerop) - (character-offset hmark 2) - (setf (next-character hmark) #\space) - (setf (line-message-deleted (mark-line hmark)) nil)) - - -(defcommand "Expunge Messages" (p) - "Expunges messages marked for deletion. - This command prompts for a folder, invoking RMM on the \"hemlockdeleted\" - sequence after asking the user for confirmation. Setting \"Quit Headers - Confirm\" to nil inhibits prompting. The folder's message id's are packed - with FOLDER -pack. When in a headers buffer, uses that folder. When in a - message buffer, uses its folder, updating any associated headers buffer. - When \"Temporary Draft Folder\" is bound, this folder's messages are deleted - and expunged." - "Prompts for a folder, invoking RMM on the \"hemlockdeleted\" sequence and - packing the message id's with FOLDER -pack. When in a headers buffer, - uses that folder." - (declare (ignore p)) - (let* ((hinfo (value headers-information)) - (minfo (value message-information)) - (folder (cond (hinfo (headers-info-folder hinfo)) - (minfo (message-info-folder minfo)) - (t (prompt-for-folder)))) - (deleted-seq (mh-sequence-list folder "hemlockdeleted"))) - ;; - ;; Delete the messages if there are any. - ;; This deletes "hemlockdeleted" from sequence file; we don't have to. - (when (and deleted-seq - (or (not (value expunge-messages-confirm)) - (prompt-for-y-or-n - :prompt (list "Expunge messages and pack folder ~A? " - folder) - :default t - :default-string "Y"))) - (message "Deleting messages ...") - (mh "rmm" (list folder "hemlockdeleted")) - ;; - ;; Compact the message id's after deletion. - (let ((*standard-output* *mh-utility-bit-bucket*)) - (message "Compacting folder ...") - (mh "folder" (list folder "-fast" "-pack"))) - ;; - ;; Do a bunch of consistency maintenance. - (let ((new-buf-p (eq (current-buffer) *new-mail-buffer*))) - (message "Maintaining consistency ...") - (expunge-messages-fold-headers-buffers folder) - (expunge-messages-fix-draft-buffers folder) - (expunge-messages-fix-unseen-headers folder) - (when new-buf-p (change-to-buffer *new-mail-buffer*))) - (delete-and-expunge-temp-drafts)))) - -;;; EXPUNGE-MESSAGES-FOLD-HEADERS-BUFFERS deletes all headers buffers into the -;;; compacted folder. We can only update the headers buffers by installing all -;;; headers, so there may as well be only one such buffer. First we get a list -;;; of the buffers since DO-HEADERS-BUFFERS is trying to iterate over a list -;;; being destructively modified by buffer deletions. -;;; -(defun expunge-messages-fold-headers-buffers (folder) - (let (hbufs) - (declare (list hbufs)) - (do-headers-buffers (b folder) - (unless (eq b *new-mail-buffer*) - (push b hbufs))) - (unless (zerop (length hbufs)) - (dolist (b hbufs) - (delete-headers-buffer-and-message-buffers-command nil b)) - (new-message-headers folder (list "all"))))) - -;;; EXPUNGE-MESSAGES-FIX-DRAFT-BUFFERS finds any draft buffer that was set up -;;; as a reply to some message in folder, removing this relationship in case -;;; that message id does not exist after expunge folder compaction. -;;; -(defun expunge-messages-fix-draft-buffers (folder) - (declare (simple-string folder)) - (dolist (b *buffer-list*) - (when (hemlock-bound-p 'draft-information :buffer b) - (let* ((dinfo (variable-value 'draft-information :buffer b)) - (reply-folder (draft-info-replied-to-folder dinfo))) - (when (and reply-folder - (string= (the simple-string reply-folder) folder)) - (setf (draft-info-replied-to-folder dinfo) nil) - (setf (draft-info-replied-to-msg dinfo) nil)))))) - -;;; EXPUNGE-MESSAGES-FIX-UNSEEN-HEADERS specially handles the unseen headers -;;; buffer apart from the other headers buffers into the same folder when -;;; messages have been expunged. We must delete the associated message buffers -;;; since REVAMP-HEADERS-BUFFER does not, and these potentially reference bad -;;; message id's. When doing this we must copy the other-msg-bufs list since -;;; the delete buffer cleanup hook for them is destructive. Then we check for -;;; more unseen messages. -;;; -(defun expunge-messages-fix-unseen-headers (folder) - (declare (simple-string folder)) - (when *new-mail-buffer* - (let ((hinfo (variable-value 'headers-information - :buffer *new-mail-buffer*))) - (when (string= (the simple-string (headers-info-folder hinfo)) - folder) - (let ((other-bufs (copy-list (headers-info-other-msg-bufs hinfo)))) - (dolist (b other-bufs) (delete-buffer-if-possible b))) - (with-writable-buffer (*new-mail-buffer*) - (revamp-headers-buffer *new-mail-buffer* hinfo) - ;; Restore the name in case someone used "Pick Headers". - (setf (buffer-name *new-mail-buffer*) - (format nil "Unseen Headers ~A" folder)) - (let ((region (maybe-get-new-mail-msg-hdrs folder))) - (when region - (insert-message-headers *new-mail-buffer* hinfo region)))))))) - -;;; MAYBE-GET-NEW-MAIL-MSG-HDRS returns a region suitable for a new mail buffer -;;; or nil. Folder is probed for unseen headers, and if there are some, then -;;; we call GET-NEW-MAIL-MSG-HDRS which also uses "Unseen Headers Message Spec". -;;; If there are no unseen headers, we only look for "Unseen Headers Message -;;; Spec" messages. We go through these contortions to keep MH from outputting -;;; errors. -;;; -(defun maybe-get-new-mail-msg-hdrs (folder) - (let ((unseen-seq-name (mh-profile-component "unseen-sequence"))) - (multiple-value-bind (unseen-seq foundp) - (mh-sequence-list folder unseen-seq-name) - (if (and foundp unseen-seq) - (get-new-mail-msg-hdrs folder unseen-seq-name) - (let ((spec (value unseen-headers-message-spec))) - (when spec - (message-headers-to-region - folder - (breakup-message-spec (string-trim '(#\space #\tab) spec))))))))) - - - - -;;;; Folders. - -(defvar *folder-name-table* nil) - -(defun check-folder-name-table () - (unless *folder-name-table* - (message "Finding folder names ...") - (setf *folder-name-table* (make-string-table)) - (let* ((output (with-output-to-string (*standard-output*) - (mh "folders" '("-fast")))) - (length (length output)) - (start 0)) - (declare (simple-string output)) - (loop - (when (> start length) (return)) - (let ((nl (position #\newline output :start start))) - (unless nl (return)) - (unless (= start nl) - (setf (getstring (subseq output start nl) *folder-name-table*) t)) - (setf start (1+ nl))))))) - -(defcommand "List Folders" (p) - "Pop up a list of folders at top-level." - "Pop up a list of folders at top-level." - (declare (ignore p)) - (check-folder-name-table) - (with-pop-up-display (s) - (do-strings (f ignore *folder-name-table*) - (declare (ignore ignore)) - (write-line f s)))) - -(defcommand "Create Folder" (p) - "Creates a folder. If the folder already exists, an error is signaled." - "Creates a folder. If the folder already exists, an error is signaled." - (declare (ignore p)) - (let ((folder (prompt-for-folder :must-exist nil))) - (when (folder-existsp folder) - (editor-error "Folder already exists -- ~S!" folder)) - (create-folder folder))) - -(defcommand "Delete Folder" (p) - "Prompts for a folder and uses RMF to delete it." - "Prompts for a folder and uses RMF to delete it." - (declare (ignore p)) - (let* ((folder (prompt-for-folder)) - (*standard-output* *mh-utility-bit-bucket*)) - (mh "rmf" (list folder)) - ;; RMF doesn't recognize this documented switch. - ;; "-nointeractive")))) - (check-folder-name-table) - (delete-string (strip-folder-name folder) *folder-name-table*))) - - -(defvar *refile-default-destination* nil) - -(defcommand "Refile Message" (p) - "Prompts for a source folder, messages, pick expression, and a destination - folder to refile the messages." - "Prompts for a source folder, messages, pick expression, and a destination - folder to refile the messages." - (declare (ignore p)) - (let* ((src-folder (prompt-for-folder :prompt "Source folder: ")) - (hinfo (value headers-information)) - (temp-msgs (prompt-for-message - :folder src-folder - :messages - (if (and hinfo - (string= src-folder - (the simple-string - (headers-info-folder hinfo)))) - (headers-info-msg-strings hinfo)) - :prompt "MH messages to pick from: ")) - (pick-exp (prompt-for-pick-expression)) - ;; Return pick result or temp-msgs individually specified in a list. - (msgs (pick-messages src-folder temp-msgs pick-exp))) - (declare (simple-string src-folder)) - (refile-message src-folder msgs - (prompt-for-folder :must-exist nil - :prompt "Destination folder: " - :default *refile-default-destination*)))) - -(defcommand "Headers Refile Message" (p) - "Refile the current message. - When in a headers buffer, refiles the message on the current line, and when - in a message buffer, refiles that message, prompting for a destination - folder." - "When in a headers buffer, refiles the message on the current line, and when - in a message buffer, refiles that message, prompting for a destination - folder." - (declare (ignore p)) - (let ((hinfo (value headers-information)) - (minfo (value message-information))) - (cond (hinfo - (multiple-value-bind (cur-msg cur-mark) - (headers-current-message hinfo) - (unless cur-msg (editor-error "Not on a header line.")) - (delete-mark cur-mark) - (refile-message (headers-info-folder hinfo) cur-msg - (prompt-for-folder - :must-exist nil - :prompt "Destination folder: " - :default *refile-default-destination*)))) - (minfo - (refile-message - (message-info-folder minfo) (message-info-msgs minfo) - (prompt-for-folder :must-exist nil - :prompt "Destination folder: " - :default *refile-default-destination*)) - (message "Message refiled.")) - (t - (editor-error "Not in a headers or message buffer."))))) - -;;; REFILE-MESSAGE refiles msg from src-folder to dst-folder. If dst-buffer -;;; doesn't exist, the user is prompted for creating it. All headers buffers -;;; concerning src-folder are updated. When msg is a list, we did a general -;;; message prompt, and we cannot know which headers lines to delete. -;;; -(defun refile-message (src-folder msg dst-folder) - (unless (folder-existsp dst-folder) - (cond ((prompt-for-y-or-n - :prompt "Destination folder doesn't exist. Create it? " - :default t :default-string "Y") - (create-folder dst-folder)) - (t (editor-error "Not refiling message.")))) - (mh "refile" `(,@(if (listp msg) msg (list msg)) - "-src" ,src-folder ,dst-folder)) - (setf *refile-default-destination* (strip-folder-name dst-folder)) - (if (listp msg) - (do-headers-buffers (hbuf src-folder hinfo) - (do-headers-lines (hbuf :line-var line :mark-var hmark) - (when (member (line-message-id line) msg :test #'string=) - (delete-headers-buffer-line hinfo hmark)))) - (do-headers-buffers (hbuf src-folder hinfo) - (with-headers-mark (hmark hbuf msg) - (delete-headers-buffer-line hinfo hmark))))) - - - - -;;;; Miscellaneous commands. - -(defcommand "Mark Message" (p) - "Prompts for a folder, message, and sequence. By default the message is - added, but if an argument is supplied, the message is deleted. When in - a headers buffer or message buffer, only a sequence is prompted for." - "Prompts for a folder, message, and sequence. By default the message is - added, but if an argument is supplied, the message is deleted. When in - a headers buffer or message buffer, only a sequence is prompted for." - (let* ((hinfo (value headers-information)) - (minfo (value message-information))) - (cond (hinfo - (multiple-value-bind (cur-msg cur-mark) - (headers-current-message hinfo) - (unless cur-msg (editor-error "Not on a header line.")) - (delete-mark cur-mark) - (let ((seq-name (prompt-for-string :prompt "Sequence name: " - :trim t))) - (declare (simple-string seq-name)) - (when (string= "" seq-name) - (editor-error "Sequence name cannot be empty.")) - (mark-one-message (headers-info-folder hinfo) - cur-msg seq-name (if p :delete :add))))) - (minfo - (let ((msgs (message-info-msgs minfo)) - (seq-name (prompt-for-string :prompt "Sequence name: " - :trim t))) - (declare (simple-string seq-name)) - (when (string= "" seq-name) - (editor-error "Sequence name cannot be empty.")) - (mark-one-message (message-info-folder minfo) - (if (consp msgs) (car msgs) msgs) - seq-name (if p :delete :add)))) - (t - (let ((folder (prompt-for-folder)) - (seq-name (prompt-for-string :prompt "Sequence name: " - :trim t))) - (declare (simple-string seq-name)) - (when (string= "" seq-name) - (editor-error "Sequence name cannot be empty.")) - (mh "mark" `(,folder ,@(prompt-for-message :folder folder) - "-sequence" ,seq-name - ,(if p "-delete" "-add")))))))) - - -(defcommand "List Mail Buffers" (p) - "Show a list of all mail associated buffers. - If the buffer has an associated message buffer, it is displayed to the right - of the buffer name. If there is no message buffer, but the buffer is - associated with a headers buffer, then it is displayed. If the buffer is - modified then a * is displayed before the name." - "Display the names of all buffers in a with-random-typeout window." - (declare (ignore p)) - (let ((buffers nil)) - (declare (list buffers)) - (do-strings (n b *buffer-names*) - (declare (ignore n)) - (unless (eq b *echo-area-buffer*) - (cond ((hemlock-bound-p 'message-buffer :buffer b) - ;; Catches draft buffers associated with message buffers first. - (push (cons b (variable-value 'message-buffer :buffer b)) - buffers)) - ((hemlock-bound-p 'headers-buffer :buffer b) - ;; Then draft or message buffers associated with headers buffers. - (push (cons b (variable-value 'headers-buffer :buffer b)) - buffers)) - ((or (hemlock-bound-p 'draft-information :buffer b) - (hemlock-bound-p 'message-information :buffer b) - (hemlock-bound-p 'headers-information :buffer b)) - (push b buffers))))) - (with-pop-up-display (s :height (length buffers)) - (dolist (ele (nreverse buffers)) - (let* ((association (if (consp ele) (cdr ele))) - (b (if association (car ele) ele)) - (buffer-pathname (buffer-pathname b)) - (buffer-name (buffer-name b))) - (write-char (if (buffer-modified b) #\* #\space) s) - (if buffer-pathname - (format s "~A ~A~:[~;~50T~:*~A~]~%" - (file-namestring buffer-pathname) - (directory-namestring buffer-pathname) - (if association (buffer-name association))) - (format s "~A~:[~;~50T~:*~A~]~%" - buffer-name - (if association (buffer-name association))))))))) - - -(defcommand "Message Help" (p) - "Show this help." - "Show this help." - (declare (ignore p)) - (describe-mode-command nil "Message")) - -(defcommand "Headers Help" (p) - "Show this help." - "Show this help." - (declare (ignore p)) - (describe-mode-command nil "Headers")) - -(defcommand "Draft Help" (p) - "Show this help." - "Show this help." - (declare (ignore p)) - (describe-mode-command nil "Draft")) - - - - -;;;; Prompting. - -;;; Folder prompting. -;;; - -(defun prompt-for-folder (&key (must-exist t) (prompt "MH Folder: ") - (default (mh-current-folder))) - "Prompts for a folder, using MH's idea of the current folder as a default. - The result will have a leading + in the name." - (check-folder-name-table) - (let ((folder (prompt-for-keyword (list *folder-name-table*) - :must-exist must-exist :prompt prompt - :default default :default-string default - :help "Enter folder name."))) - (declare (simple-string folder)) - (when (string= folder "") (editor-error "Must supply folder!")) - (let ((name (coerce-folder-name folder))) - (when (and must-exist (not (folder-existsp name))) - (editor-error "Folder does not exist -- ~S." name)) - name))) - -(defun coerce-folder-name (folder) - (if (char= (schar folder 0) #\+) - folder - (concatenate 'simple-string "+" folder))) - -(defun strip-folder-name (folder) - (if (char= (schar folder 0) #\+) - (subseq folder 1) - folder)) - - -;;; Message prompting. -;;; - -(defun prompt-for-message (&key (folder (mh-current-folder)) - (prompt "MH messages: ") - messages) - "Prompts for a message spec, using messages as a default. If messages is - not supplied, then the current message for folder is used. The result is - a list of strings which are the message ids, intervals, and/or sequence - names the user entered." - (let* ((cur-msg (cond ((not messages) (mh-current-message folder)) - ((stringp messages) messages) - ((consp messages) - (if (= (length (the list messages)) 1) - (car messages) - (format nil "~{~A~^ ~}" messages)))))) - (breakup-message-spec (prompt-for-string :prompt prompt - :default cur-msg - :default-string cur-msg - :trim t - :help "Enter MH message id(s).")))) - -(defun breakup-message-spec (msgs) - (declare (simple-string msgs)) - (let ((start 0) - (result nil)) - (loop - (let ((end (position #\space msgs :start start :test #'char=))) - (unless end - (return (if (zerop start) - (list msgs) - (nreverse (cons (subseq msgs start) result))))) - (push (subseq msgs start end) result) - (setf start (1+ end)))))) - - -;;; PICK expression prompting. -;;; - -(defhvar "MH Lisp Expression" - "When this is set (the default), MH expression prompts are read in a Lisp - syntax. Otherwise, the input is as if it had been entered on a shell - command line." - :value t) - -;;; This is dynamically bound to nil for argument processing routines. -;;; -(defvar *pick-expression-strings* nil) - -(defun prompt-for-pick-expression () - "Prompts for an MH PICK-like expression that is converted to a list of - strings suitable for EXT:RUN-PROGRAM. As a second value, the user's - expression is as typed in is returned." - (let ((exp (prompt-for-string :prompt "MH expression: " - :help "Expression to PICK over mail messages." - :trim t)) - (*pick-expression-strings* nil)) - (if (value mh-lisp-expression) - (let ((exp (let ((*package* *keyword-package*)) - (read-from-string exp)))) - (if exp - (if (consp exp) - (lisp-to-pick-expression exp) - (editor-error "Lisp PICK expressions cannot be atomic.")))) - (expand-mh-pick-spec exp)) - (values (nreverse *pick-expression-strings*) - exp))) - -(defun lisp-to-pick-expression (exp) - (ecase (car exp) - (:and (lpe-and/or exp "-and")) - (:or (lpe-and/or exp "-or")) - (:not (push "-not" *pick-expression-strings*) - (let ((nexp (cadr exp))) - (unless (consp nexp) (editor-error "Bad expression -- ~S" nexp)) - (lisp-to-pick-expression nexp))) - - (:cc (lpe-output-and-go exp "-cc")) - (:date (lpe-output-and-go exp "-date")) - (:from (lpe-output-and-go exp "-from")) - (:search (lpe-output-and-go exp "-search")) - (:subject (lpe-output-and-go exp "-subject")) - (:to (lpe-output-and-go exp "-to")) - (:-- (lpe-output-and-go (cdr exp) - (concatenate 'simple-string - "--" (string (cadr exp))))) - - (:before (lpe-after-and-before exp "-before")) - (:after (lpe-after-and-before exp "-after")) - (:datefield (lpe-output-and-go exp "-datefield")))) - -(defun lpe-after-and-before (exp op) - (let ((operand (cadr exp))) - (when (numberp operand) - (setf (cadr exp) - (if (plusp operand) - (number-string (- operand)) - (number-string operand))))) - (lpe-output-and-go exp op)) - -(defun lpe-output-and-go (exp op) - (push op *pick-expression-strings*) - (let ((operand (cadr exp))) - (etypecase operand - (string (push operand *pick-expression-strings*)) - (symbol (push (symbol-name operand) - *pick-expression-strings*))))) - -(defun lpe-and/or (exp op) - (push "-lbrace" *pick-expression-strings*) - (dolist (ele (cdr exp)) - (lisp-to-pick-expression ele) - (push op *pick-expression-strings*)) - (pop *pick-expression-strings*) ;Clear the extra "-op" arg. - (push "-rbrace" *pick-expression-strings*)) - -;;; EXPAND-MH-PICK-SPEC takes a string of "words" assumed to be separated -;;; by single spaces. If a "word" starts with a quotation mark, then -;;; everything is grabbed up to the next one and used as a single word. -;;; Currently, this does not worry about extra spaces (or tabs) between -;;; "words". -;;; -(defun expand-mh-pick-spec (spec) - (declare (simple-string spec)) - (let ((start 0)) - (loop - (let ((end (position #\space spec :start start :test #'char=))) - (unless end - (if (zerop start) - (setf *pick-expression-strings* (list spec)) - (push (subseq spec start) *pick-expression-strings*)) - (return)) - (cond ((char= #\" (schar spec start)) - (setf end (position #\" spec :start (1+ start) :test #'char=)) - (unless end (editor-error "Bad quoting syntax.")) - (push (subseq spec (1+ start) end) *pick-expression-strings*) - (setf start (+ end 2))) - (t (push (subseq spec start end) *pick-expression-strings*) - (setf start (1+ end)))))))) - - -;;; Password prompting. -;;; - -(defun prompt-for-password (&optional (prompt "Password: ")) - "Prompts for password with prompt." - (let ((hi::*parse-verification-function* #'(lambda (string) (list string)))) - (let ((hi::*parse-prompt* prompt)) - (hi::display-prompt-nicely)) - (let ((start-window (current-window))) - (move-mark *parse-starting-mark* (buffer-point *echo-area-buffer*)) - (setf (current-window) *echo-area-window*) - (unwind-protect - (use-buffer *echo-area-buffer* - (let ((result ())) - (declare (list result)) - (loop - (let ((key-event (get-key-event *editor-input*))) - (ring-pop hi::*key-event-history*) - (cond ((eq key-event #k"return") - (return (prog1 (coerce (nreverse result) - 'simple-string) - (fill result nil)))) - ((or (eq key-event #k"control-u") - (eq key-event #k"control-U")) - (setf result nil)) - (t (push (ext:key-event-char key-event) result))))))) - (setf (current-window) start-window))))) - - - - - -;;;; Making mail buffers. - -;;; MAYBE-MAKE-MH-BUFFER looks up buffer with name, returning it if it exists -;;; after cleaning it up to a state "good as new". Currently, we don't -;;; believe it is possible to try to make two draft buffers with the same name -;;; since that would mean that composition, draft folder interaction, and -;;; draft folder current message didn't do what we expected -- or some user -;;; was modifying the draft folder in some evil way. -;;; -(defun maybe-make-mh-buffer (name use) - (let ((buf (getstring name *buffer-names*))) - (cond ((not buf) - (ecase use - (:headers (make-buffer name - :modes '("Headers") - :delete-hook '(cleanup-headers-buffer))) - - (:message - (make-buffer name :modes '("Message") - :modeline-fields - (value default-message-modeline-fields) - :delete-hook '(cleanup-message-buffer))) - - (:draft - (let ((buf (make-buffer - name :delete-hook '(cleanup-draft-buffer)))) - (setf (buffer-minor-mode buf "Draft") t) - buf)))) - ((hemlock-bound-p 'headers-information :buffer buf) - (setf (buffer-writable buf) t) - (delete-region (buffer-region buf)) - (cleanup-headers-buffer buf) - (delete-variable 'headers-information :buffer buf) - buf) - ((hemlock-bound-p 'message-information :buffer buf) - (setf (buffer-writable buf) t) - (delete-region (buffer-region buf)) - (cleanup-message-buffer buf) - (delete-variable 'message-information :buffer buf) - buf) - ((hemlock-bound-p 'draft-information :buffer buf) - (error "Attempt to create multiple draft buffers to same draft ~ - folder message -- ~S" - name))))) - - - -;;;; Message buffer modeline fields. - -(make-modeline-field - :name :deleted-message :width 2 - :function - #'(lambda (buffer window) - "Returns \"D \" when message in buffer is deleted." - (declare (ignore window)) - (let* ((minfo (variable-value 'message-information :buffer buffer)) - (hmark (message-info-headers-mark minfo))) - (cond ((not hmark) - (let ((msgs (message-info-msgs minfo))) - (if (and (value virtual-message-deletion) - (mh-sequence-member-p - (if (consp msgs) (car msgs) msgs) - (mh-sequence-list (message-info-folder minfo) - "hemlockdeleted"))) - "D " - ""))) - ((line-message-deleted (mark-line hmark)) - "D ") - (t ""))))) - -(make-modeline-field - :name :replied-to-message :width 1 - :function - #'(lambda (buffer window) - "Returns \"A\" when message in buffer is deleted." - (declare (ignore window)) - (let* ((minfo (variable-value 'message-information :buffer buffer)) - (hmark (message-info-headers-mark minfo))) - (cond ((not hmark) - ;; Could do something nasty here to figure out the right value. - "") - (t - (mark-to-note-replied-msg hmark) - (if (char= (next-character hmark) #\A) - "A" - "")))))) - -;;; MARK-TO-NOTE-REPLIED-MSG moves the headers-buffer mark to a line position -;;; suitable for checking or setting the next character with respect to noting -;;; that a message has been replied to. -;;; -(defun mark-to-note-replied-msg (hmark) - (line-start hmark) - (find-attribute hmark :digit) - (find-attribute hmark :digit #'zerop) - (character-offset hmark 1)) - - -(defhvar "Default Message Modeline Fields" - "This is the default list of modeline-field objects for message buffers." - :value - (list (modeline-field :hemlock-literal) (modeline-field :package) - (modeline-field :modes) (modeline-field :buffer-name) - (modeline-field :replied-to-message) (modeline-field :deleted-message) - (modeline-field :buffer-pathname) (modeline-field :modifiedp))) - - - - -;;;; MH interface. - -;;; Running an MH utility. -;;; - -(defhvar "MH Utility Pathname" - "MH utility names are merged with this. The default is - \"/usr/misc/.mh/bin/\"." - :value (pathname "/usr/misc/.mh/bin/")) - -(defvar *signal-mh-errors* t - "This is the default value for whether MH signals errors. It is useful to - bind this to nil when using PICK-MESSAGES with the \"Incorporate New Mail - Hook\".") - -(defvar *mh-error-output* (make-string-output-stream)) - -(defun mh (utility args &key (errorp *signal-mh-errors*) environment) - "Runs the MH utility with the list of args (suitable for EXT:RUN-PROGRAM), - outputting to *standard-output*. Environment is a list of strings - appended with ext:*environment-list*. This returns t, unless there is - an error. When errorp, this reports any MH errors in the echo area as - an editor error, and this does not return; otherwise, nil and the error - output from the MH utility are returned." - (fresh-line) - (let* ((utility - (namestring - (or (probe-file (merge-pathnames utility - (value mh-utility-pathname))) - utility))) - (proc (ext:run-program - utility args - :output *standard-output* - :error *mh-error-output* - :env (append environment ext:*environment-list*)))) - (fresh-line) - (ext:process-close proc) - (cond ((zerop (ext:process-exit-code proc)) - (values t nil)) - (errorp - (editor-error "MH Error -- ~A" - (get-output-stream-string *mh-error-output*))) - (t (values nil (get-output-stream-string *mh-error-output*)))))) - - - -;;; Draft folder name and pathname. -;;; - -(defun mh-draft-folder () - (let ((drafts (mh-profile-component "draft-folder"))) - (unless drafts - (error "There must be a draft-folder component in your profile.")) - drafts)) - -(defun mh-draft-folder-pathname () - "Returns the pathname of the MH draft folder directory." - (let ((drafts (mh-profile-component "draft-folder"))) - (unless drafts - (error "There must be a draft-folder component in your profile.")) - (merge-relative-pathnames drafts (mh-directory-pathname)))) - - -;;; Current folder name. -;;; - -(defun mh-current-folder () - "Returns the current MH folder from the context file." - (mh-profile-component "current-folder" (mh-context-pathname))) - - -;;; Current message name. -;;; - -(defun mh-current-message (folder) - "Returns the current MH message from the folder's sequence file." - (declare (simple-string folder)) - (let ((folder (strip-folder-name folder))) - (mh-profile-component - "cur" - (merge-pathnames ".mh_sequences" - (merge-relative-pathnames folder - (mh-directory-pathname)))))) - - -;;; Context pathname. -;;; - -(defvar *mh-context-pathname* nil) - -(defun mh-context-pathname () - "Returns the pathname of the MH context file." - (or *mh-context-pathname* - (setf *mh-context-pathname* - (merge-pathnames (or (mh-profile-component "context") "context") - (mh-directory-pathname))))) - - -;;; MH directory pathname. -;;; - -(defvar *mh-directory-pathname* nil) - -;;; MH-DIRECTORY-PATHNAME fetches the "path" MH component and bashes it -;;; appropriately to get an absolute directory pathname. -;;; -(defun mh-directory-pathname () - "Returns the pathname of the MH directory." - (if *mh-directory-pathname* - *mh-directory-pathname* - (let ((path (mh-profile-component "path"))) - (unless path (error "MH profile does not contain a Path component.")) - (setf *mh-directory-pathname* - (truename (merge-relative-pathnames path - (user-homedir-pathname))))))) - -;;; Profile components. -;;; - -(defun mh-profile-component (name &optional (pathname (mh-profile-pathname)) - (error-on-open t)) - "Returns the trimmed string value for the MH profile component name. If - the component is not present, nil is returned. This may be used on MH - context and sequence files as well due to their having the same format. - Error-on-open indicates that errors generated by OPEN should not be ignored, - which is the default. When opening a sequence file, it is better to supply - this as nil since the file may not exist or be readable in another user's - MH folder, and returning nil meaning the sequence could not be found is just - as useful." - (with-open-stream (s (if error-on-open - (open pathname) - (ignore-errors (open pathname)))) - (if s - (loop - (multiple-value-bind (line eofp) (read-line s nil :eof) - (when (eq line :eof) (return nil)) - (let ((colon (position #\: (the simple-string line) :test #'char=))) - (unless colon - (error "Bad record ~S in file ~S." line (namestring pathname))) - (when (string-equal name line :end2 colon) - (return (string-trim '(#\space #\tab) - (subseq line (1+ colon)))))) - (when eofp (return nil))))))) - - -;;; Profile pathname. -;;; - -(defvar *mh-profile-pathname* nil) - -(defun mh-profile-pathname () - "Returns the pathname of the MH profile." - (or *mh-profile-pathname* - (setf *mh-profile-pathname* - (merge-pathnames (or (cdr (assoc :mh ext:*environment-list*)) - ".mh_profile") - (truename (user-homedir-pathname)))))) - - - - -;;;; Sequence handling. - -(declaim (optimize (speed 2))); byte compile off - -(defun mark-one-message (folder msg sequence add-or-delete) - "Msg is added or deleted to the sequence named sequence in the folder's - \".mh_sequence\" file. Add-or-delete is either :add or :delete." - (let ((seq-list (mh-sequence-list folder sequence))) - (ecase add-or-delete - (:add - (write-mh-sequence folder sequence (mh-sequence-insert msg seq-list))) - (:delete - (when (mh-sequence-member-p msg seq-list) - (write-mh-sequence folder sequence - (mh-sequence-delete msg seq-list))))))) - - -(defun mh-sequence-list (folder name) - "Returns a list representing the messages and ranges of id's for the - sequence name in folder from the \".mh_sequences\" file. A second value - is returned indicating whether the sequence was found or not." - (declare (simple-string folder)) - (let* ((folder (strip-folder-name folder)) - (seq-string (mh-profile-component - name - (merge-pathnames ".mh_sequences" - (merge-relative-pathnames - folder (mh-directory-pathname))) - nil))) - (if (not seq-string) - (values nil nil) - (let ((length (length (the simple-string seq-string))) - (result ()) - (intervalp nil) - (start 0)) - (declare (fixnum length start)) - (loop - (multiple-value-bind (msg index) - (parse-integer seq-string - :start start :end length - :junk-allowed t) - (unless msg (return)) - (cond ((or (= index length) - (char/= (schar seq-string index) #\-)) - (if intervalp - (setf (cdar result) msg) - (push (cons msg msg) result)) - (setf intervalp nil) - (setf start index)) - (t - (push (cons msg nil) result) - (setf intervalp t) - (setf start (1+ index))))) - (when (>= start length) (return))) - (values (nreverse result) t))))) - -(defun write-mh-sequence (folder name seq-list) - "Writes seq-list to folder's \".mh_sequences\" file. If seq-list is nil, - the sequence is removed from the file." - (declare (simple-string folder)) - (let* ((folder (strip-folder-name folder)) - (input (merge-pathnames ".mh_sequences" - (merge-relative-pathnames - folder (mh-directory-pathname)))) - (input-dir (pathname (directory-namestring input))) - (output (loop (let* ((sym (gensym)) - (f (merge-pathnames - (format nil "sequence-file-~A.tmp" sym) - input-dir))) - (unless (probe-file f) (return f))))) - (found nil)) - (cond ((not (hemlock-ext:file-writable output)) - (loud-message "Cannot write sequence temp file ~A.~%~ - Aborting output of ~S sequence." - name (namestring output))) - (t - (with-open-file (in input) - (with-open-file (out output :direction :output) - (loop - (multiple-value-bind (line eofp) (read-line in nil :eof) - (when (eq line :eof) - (return nil)) - (let ((colon (position #\: (the simple-string line) - :test #'char=))) - (unless colon - (error "Bad record ~S in file ~S." - line (namestring input))) - (cond ((and (not found) (string-equal name line - :end2 colon)) - (sub-write-mh-sequence - out (subseq line 0 colon) seq-list) - (setf found t)) - (t (write-line line out)))) - (when eofp (return)))) - (unless found - (fresh-line out) - (sub-write-mh-sequence out name seq-list)))) - (hacking-rename-file output input))))) - -(defun sub-write-mh-sequence (stream name seq-list) - (when seq-list - (write-string name stream) - (write-char #\: stream) - (let ((*print-base* 10)) - (dolist (range seq-list) - (write-char #\space stream) - (let ((low (car range)) - (high (cdr range))) - (declare (fixnum low high)) - (cond ((= low high) - (prin1 low stream)) - (t (prin1 low stream) - (write-char #\- stream) - (prin1 high stream)))))) - (terpri stream))) - - -;;; MH-SEQUENCE-< keeps SORT from consing rest args when FUNCALL'ing #'<. -;;; -(defun mh-sequence-< (x y) - (< x y)) - -(defun mh-sequence-insert (item seq-list) - "Inserts item into an mh sequence list. Item can be a string (\"23\"), - number (23), or a cons of two numbers ((23 . 23) or (3 . 5))." - (let ((range (typecase item - (string (let ((id (parse-integer item))) - (cons id id))) - (cons item) - (number (cons item item))))) - (cond (seq-list - (setf seq-list (sort (cons range seq-list) - #'mh-sequence-< :key #'car)) - (coelesce-mh-sequence-ranges seq-list)) - (t (list range))))) - -(defun coelesce-mh-sequence-ranges (seq-list) - (when seq-list - (let* ((current seq-list) - (next (cdr seq-list)) - (current-range (car current)) - (current-end (cdr current-range))) - (declare (fixnum current-end)) - (loop - (unless next - (setf (cdr current-range) current-end) - (setf (cdr current) nil) - (return)) - (let* ((next-range (car next)) - (next-start (car next-range)) - (next-end (cdr next-range))) - (declare (fixnum next-start next-end)) - (cond ((<= (1- next-start) current-end) - ;; - ;; Extend the current range since the next one overlaps. - (when (> next-end current-end) - (setf current-end next-end))) - (t - ;; - ;; Update the current range since the next one doesn't overlap. - (setf (cdr current-range) current-end) - ;; - ;; Make the next range succeed current. Then make it current. - (setf (cdr current) next) - (setf current next) - (setf current-range next-range) - (setf current-end next-end)))) - (setf next (cdr next)))) - seq-list)) - - -(defun mh-sequence-delete (item seq-list) - "Inserts item into an mh sequence list. Item can be a string (\"23\"), - number (23), or a cons of two numbers ((23 . 23) or (3 . 5))." - (let ((range (typecase item - (string (let ((id (parse-integer item))) - (cons id id))) - (cons item) - (number (cons item item))))) - (when seq-list - (do ((id (car range) (1+ id)) - (end (cdr range))) - ((> id end)) - (setf seq-list (sub-mh-sequence-delete id seq-list))) - seq-list))) - -(defun sub-mh-sequence-delete (id seq-list) - (do ((prev nil seq) - (seq seq-list (cdr seq))) - ((null seq)) - (let* ((range (car seq)) - (low (car range)) - (high (cdr range))) - (cond ((> id high)) - ((< id low) - (return)) - ((= id low) - (cond ((/= low high) - (setf (car range) (1+ id))) - (prev - (setf (cdr prev) (cdr seq))) - (t (setf seq-list (cdr seq-list)))) - (return)) - ((= id high) - (setf (cdr range) (1- id)) - (return)) - ((< low id high) - (setf (cdr range) (1- id)) - (setf (cdr seq) (cons (cons (1+ id) high) (cdr seq))) - (return))))) - seq-list) - - -(defun mh-sequence-member-p (item seq-list) - "Returns to or nil whether item is in the mh sequence list. Item can be a - string (\"23\") or a number (23)." - (let ((id (typecase item - (string (parse-integer item)) - (number item)))) - (dolist (range seq-list nil) - (let ((low (car range)) - (high (cdr range))) - (when (<= low id high) (return t)))))) - - -(defun mh-sequence-strings (seq-list) - "Returns a list of strings representing the ranges and messages id's in - seq-list." - (let ((result nil)) - (dolist (range seq-list) - (let ((low (car range)) - (high (cdr range))) - (if (= low high) - (push (number-string low) result) - (push (format nil "~D-~D" low high) result)))) - (nreverse result))) - -(declaim (optimize (speed 0))); byte compile again. - - -;;;; CMU Common Lisp support. - -;;; HACKING-RENAME-FILE renames old to new. This is used instead of Common -;;; Lisp's RENAME-FILE because it merges new pathname with old pathname, -;;; which loses when old has a name and type, and new has only a type (a -;;; Unix-oid "dot" file). -;;; -(defun hacking-rename-file (old new) - (let ((ses-name1 (namestring old)) - (ses-name2 (namestring new))) - (multiple-value-bind (res err) (unix:unix-rename ses-name1 ses-name2) - (unless res - (error "Failed to rename ~A to ~A: ~A." - ses-name1 ses-name2 (unix:get-unix-error-msg err)))))) - - -;;; Folder existence and creation. -;;; - -(defun folder-existsp (folder) - "Returns t if the directory for folder exists. Folder is a simple-string - specifying a folder name relative to the MH mail directoy." - (declare (simple-string folder)) - (let* ((folder (strip-folder-name folder)) - (pathname (merge-relative-pathnames folder (mh-directory-pathname))) - (pf (probe-file pathname))) - (and pf - (null (pathname-name pf)) - (null (pathname-type pf))))) - -(defun create-folder (folder) - "Creates folder directory with default protection #o711 but considers the - MH profile for the \"Folder-Protect\" component. Folder is a simple-string - specifying a folder name relative to the MH mail directory." - (declare (simple-string folder)) - (let* ((folder (strip-folder-name folder)) - (pathname (merge-relative-pathnames folder (mh-directory-pathname))) - (ses-name (namestring pathname)) - (length-1 (1- (length ses-name))) - (name (if (= (position #\/ ses-name :test #'char= :from-end t) - length-1) - (subseq ses-name 0 (1- (length ses-name))) - ses-name)) - (protection (mh-profile-component "folder-protect"))) - (when protection - (setf protection - (parse-integer protection :radix 8 :junk-allowed t))) - (multiple-value-bind (winp err) - (unix:unix-mkdir name (or protection #o711)) - (unless winp - (error "Couldn't make directory ~S: ~A" - name - (unix:get-unix-error-msg err))) - (check-folder-name-table) - (setf (getstring folder *folder-name-table*) t)))) - - -;;; Checking for mail. -;;; - -(defvar *mailbox* nil) - -(defun new-mail-p () - (unless *mailbox* - (setf *mailbox* - (probe-file (or (cdr (assoc :mail ext:*environment-list*)) - (cdr (assoc :maildrop ext:*environment-list*)) - (mh-profile-component "MailDrop") - (merge-pathnames - (cdr (assoc :user ext:*environment-list*)) - "/usr/spool/mail/"))))) - (when *mailbox* - (multiple-value-bind (success dev ino mode nlink uid gid rdev size - atime) - (unix:unix-stat (namestring *mailbox*)) - (declare (ignore dev ino nlink uid gid rdev atime)) - (and success - (plusp (logand unix:s-ifreg mode)) - (not (zerop size)))))) - - - Index: anches/ide-1.0/ccl/hemlock/src/netnews.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/netnews.lisp (revision 6566) +++ (revision ) @@ -1,2407 +1,0 @@ -;;; -*- Package: Hemlock; Log: hemlock.log -*- -;;; -;;; ********************************************************************** -;;; This code was written as part of the CMU Common Lisp project at -;;; Carnegie Mellon University, and has been placed in the public domain. -;;; -#+CMU (ext:file-comment - "$Header$") -;;; -;;; ********************************************************************** -;;; -;;; Written by Blaine Burks -;;; -;;; This file implements the reading of bulletin boards from within Hemlock -;;; via a known NNTP server. Something should probably be done so that -;;; when the server is down Hemlock doesn't hang as I suspect it will. -;;; -;;; Warning: Throughout this file, it may appear I should have bound -;;; the nn-info-stream and nn-info-header-stream slots instead -;;; of making multiple structure accesses. This was done on -;;; purpose because we don't find out if NNTP timed us out until -;;; we make an attempt to execute another command. This code -;;; recovers by resetting the header-stream and stream slots in -;;; the nn-info structure to new streams. If the structure -;;; access were not made again and NNTP had timed us out, we -;;; would be making requests on a defunct stream. -;;; - -(in-package :hemlock) - - - - -;;;; Netnews data structures. - -(defparameter default-netnews-headers-length 1000 - "How long the header-cache and message-ids arrays should be made on startup.") - -(defstruct (netnews-info - (:conc-name nn-info-) - (:print-function - (lambda (nn s d) - (declare (ignore nn d)) - (write-string "#" s)))) - (updatep (ext:required-argument) :type (or null t)) - (from-end-p nil :type (or null t)) - ;; - ;; The string name of the current group. - (current (ext:required-argument) :type simple-string) - ;; - ;; The number of the latest message read in the current group. - (latest nil :type (or null fixnum)) - ;; - ;; The cache of header info for the current group. Each element contains - ;; an association list of header fields to contents of those fields. Indexed - ;; by id offset by the first message in the group. - (header-cache nil :type (or null simple-vector)) - ;; - ;; The number of HEAD requests currently waiting on the header stream. - (batch-count nil :type (or null fixnum)) - ;; - ;; The list of newsgroups to read. - (groups (ext:required-argument) :type cons) - ;; - ;; A vector of message ids indexed by buffer-line for this headers buffer. - (message-ids nil :type (or null vector)) - ;; - ;; Where to insert the next batch of headers. - mark - ;; - ;; The message buffer used to view article bodies. - buffer - ;; - ;; A list of message buffers that have been marked as undeletable by the user. - (other-buffers nil :type (or null cons)) - ;; - ;; The window used to display buffer when \"Netnews Read Style\" is :multiple. - message-window - ;; - ;; The window used to display headers when \"Netnews Read Style\" is - ;; :multiple. - headers-window - ;; - ;; How long the message-ids and header-cache arrays are. Reuse this array, - ;; but don't break if there are more messages than we can handle. - (array-length default-netnews-headers-length :type fixnum) - ;; - ;; The id of the first message in the current group. - (first nil :type (or null fixnum)) - ;; - ;; The id of the last message in the current-group. - (last nil :type (or null fixnum)) - ;; - ;; Article number of the first visible header. - (first-visible nil :type (or null fixnum)) - ;; - ;; Article number of the last visible header. - (last-visible nil :type (or null fixnum)) - ;; - ;; Number of the message that is currently displayed in buffer. Initialize - ;; to -1 so I don't have to constantly check for the nullness of it. - (current-displayed-message -1 :type (or null fixnum)) - ;; - ;; T if the last batch of headers is waiting on the header stream. - ;; This is needed so NN-WRITE-HEADERS-TO-MARK can set the messages-waiting - ;; slot to nil. - (last-batch-p nil :type (or null t)) - ;; - ;; T if there are more headers in the current group. Nil otherwise. - (messages-waiting nil :type (or null t)) - ;; - ;; The stream on which we request headers from NNTP. - header-stream - ;; - ;; The stream on which we request everything but headers from NNTP. - stream) - -(defmode "News-Headers" :major-p t) - - - - -;;;; The netnews-message-info and post-info structures. - -(defstruct (netnews-message-info - (:conc-name nm-info-) - (:print-function - (lambda (nn s d) - (declare (ignore nn d)) - (write-string "#" s)))) - ;; The headers buffer (if there is one) associated with this message buffer. - headers-buffer - ;; The draft buffer (if there is one) associated with this message buffer. - draft-buffer - ;; The post buffer (if there is one) associated with this message buffer. - post-buffer - ;; This is need because we want to display what message this is in the - ;; modeline field of a message buffer. - (message-number nil :type (or null fixnum)) - ;; Set to T when we do not want to reuse this buffer. - keep-p) - -(defstruct (post-info - (:print-function - (lambda (nn s d) - (declare (ignore nn d)) - (write-string "#" s)))) - ;; The NNTP stream over which to send this post. - stream - ;; When replying in another window, the reply window. - reply-window - ;; When replying in another window, the message window. - message-window - ;; The message buffer associated with this post. - message-buffer - ;; The Headers buffer associated with this post. - headers-buffer) - - - - -;;;; Command Level Implementation of "News-Headers" mode. - -(defhvar "Netnews Database File" - "This value is merged with your home directory to get a path to your netnews - pointers file." - :value ".hemlock-netnews") - -(defhvar "Netnews Read Style" - "How you like to read netnews. A value of :single will cause netnews - mode to use a single window for headers and messages, and a value of - :multiple will cause the current window to be split so that Headers take - up \"Netnews Headers Proportion\" of what was the current window, and a - message bodies buffer the remaining portion. Changing the value of this - variable dynamically affects netnews reading." - :value :multiple) - -(unless (modeline-field :netnews-message) - (make-modeline-field - :name :netnews-message - :width 14 - :function #'(lambda (buffer window) - (declare (ignore window)) - (let* ((nm-info (variable-value 'netnews-message-info - :buffer buffer)) - (nn-info (variable-value 'netnews-info - :buffer (nm-info-headers-buffer - nm-info)))) - (format nil "~D of ~D" - (nm-info-message-number nm-info) - (1+ (- (nn-info-last nn-info) - (nn-info-first nn-info)))))))) - -(unless (modeline-field :netnews-header-info) - (make-modeline-field - :name :netnews-header-info - :width 24 - :function - #'(lambda (buffer window) - (declare (ignore window)) - (let ((nn-info (variable-value 'netnews-info :buffer buffer))) - (format nil "~D before, ~D after" - (- (nn-info-first-visible nn-info) (nn-info-first nn-info)) - (- (nn-info-last nn-info) (nn-info-last-visible nn-info))))))) - -(defvar *nn-headers-buffer* nil - "If \"Netnews\" was invoked without an argument an not exited, this - holds the headers buffer for reading netnews.") - -(defvar *netnews-kill-strings* nil) - -(defhvar "Netnews Kill File" - "This value is merged with your home directory to get the pathname of - your netnews kill file. If any of the strings in this file (one per - line) appear in a subject header while reading netnews, they will have a - \"K\" in front of them, and \"Netnews Next Line\" and \"Netnews Previous - Line\" will never land you on one. Use \"Next Line\" and \"Previous - Line\" to read Killed messages. Defaults to \".hemlock-kill\"." - :value ".hemlock-kill") - -(defhvar "Netnews New Group Style" - "Determines what happend when you read a group that you have never read - before. When :from-start, \"Netnews\" will read from the beginning of a - new group forward. When :from-end, the default, \"Netnews\" will read - from the end backward group. Otherwise this variable is a number - indicating that \"Netnews\" should start that many messages from the end - of the group and read forward from there." - :value :from-end) - -(defhvar "Netnews Start Over Threshold" - "If you have read a group before, and the number of new messages exceeds - this number, Hemlock asks whether you want to start reading from the end - of this group. The default is 300." - :value 300) - -(defcommand "Netnews" (p &optional group-name from-end-p browse-buf (updatep t)) - "Enter a headers buffer and read groups from \"Netnews Group File\". - With an argument prompts for a group and reads it." - "Enter a headers buffer and read groups from \"Netnews Group File\". - With an argument prompts for a group and reads it." - (cond - ((and *nn-headers-buffer* (not p) (not group-name)) - (change-to-buffer *nn-headers-buffer*)) - (t - (let* ((single-group (if p (prompt-for-string :prompt "Group to read: " - :help "Type the name of ~ - the group you want ~ - to scan." - :trim t))) - (groups (cond - (group-name (list group-name)) - (single-group (list single-group)) - (t - (let ((group-file (merge-pathnames - (value netnews-group-file) - (user-homedir-pathname)))) - (when (probe-file group-file) - (let ((res nil)) - (with-open-file (s group-file :direction :input) - (loop - (let ((group (read-line s nil nil))) - (unless group (return (nreverse res))) - (pushnew group res))))))))))) - (unless (or p groups) - (editor-error "No groups to read. See \"Netnews Group File\" and ~ - \"Netnews Browse\".")) - (when updatep (nn-assure-database-exists)) - (nn-parse-kill-file) - (multiple-value-bind (stream header-stream) (streams-for-nntp) - (multiple-value-bind - (buffer-name clashp) - (nn-unique-headers-name (car groups)) - (if (and (or p group-name) clashp) - (change-to-buffer (getstring clashp *buffer-names*)) - (let* ((buffer (make-buffer - buffer-name - :modes '("News-Headers") - :modeline-fields - (append (value default-modeline-fields) - (list (modeline-field - :netnews-header-info))) - :delete-hook - (list #'netnews-headers-delete-hook))) - (nn-info (make-netnews-info - :current (car groups) - :groups groups - :updatep updatep - :headers-window (current-window) - :mark (copy-mark (buffer-point buffer)) - :header-stream header-stream - :stream stream))) - (unless (or p group-name) (setf *nn-headers-buffer* buffer)) - (when (and clashp (not (or p group-name))) - (message "Buffer ~S also contains headers for ~A" - clashp (car groups))) - (defhvar "Netnews Info" - "A structure containing the current group, a list of - groups, a book-keeping mark, a stream we get headers on, - and the stream on which we request articles." - :buffer buffer - :value nn-info) - (setf (buffer-writable buffer) nil) - (defhvar "Netnews Browse Buffer" - "This variable is the associated \"News-Browse\" buffer - in a \"News-Headers\" buffer created from - \"News-Browse\" mode." - :buffer buffer - :value browse-buf) - (setup-group (car groups) nn-info buffer from-end-p))))))))) - - -(defun nn-parse-kill-file () - (let ((filename (merge-pathnames (value netnews-kill-file) - (user-homedir-pathname)))) - (when (probe-file filename) - (with-open-file (s filename :direction :input) - (loop - (let ((kill-string (read-line s nil nil))) - (unless kill-string (return)) - (pushnew kill-string *netnews-kill-strings*))))))) - -;;; NETNEWS-HEADERS-DELETE-HOOK closes the stream slots in netnews-info, -;;; deletes the bookkeeping mark into buffer, sets the headers slots of any -;;; associated post-info or netnews-message-info structures to nil so -;;; "Netnews Go To Headers Buffer" will not land you in a buffer that does -;;; not exist, and sets *nn-headers-buffer* to nil so next time we invoke -;;; "Netnews" it will start over. -;;; -(defun netnews-headers-delete-hook (buffer) - (let ((nn-info (variable-value 'netnews-info :buffer buffer))) - ;; Disassociate all message buffers. - ;; - (dolist (buf (nn-info-other-buffers nn-info)) - (setf (nm-info-headers-buffer (variable-value 'netnews-message-info - :buffer buf)) - nil)) - (let ((message-buffer (nn-info-buffer nn-info))) - (when message-buffer - (setf (nm-info-headers-buffer (variable-value 'netnews-message-info - :buffer message-buffer)) - nil))) - (close (nn-info-stream nn-info)) - (close (nn-info-header-stream nn-info)) - (delete-mark (nn-info-mark nn-info)) - (when (eq *nn-headers-buffer* buffer) - (setf *nn-headers-buffer* nil)))) - -(defun nn-unique-headers-name (group-name) - (let ((original-name (concatenate 'simple-string "Netnews " group-name))) - (if (getstring original-name *buffer-names*) - (let ((name nil) - (number 0)) - (loop - (setf name (format nil "Netnews ~A ~D" group-name (incf number))) - (unless (getstring name *buffer-names*) - (return (values name original-name))))) - (values original-name nil)))) - -;;; NN-ASSURE-DATABASE-EXISTS does just that. If the file determined by the -;;; value of "Netnews Database Filename" does not exist, then it gets -;;; created. -;;; -(defun nn-assure-database-exists () - (let ((filename (merge-pathnames (value netnews-database-file) - (user-homedir-pathname)))) - (unless (probe-file filename) - (message "Creating netnews database file.") - (close (open filename :direction :output :if-does-not-exist :create))))) - -(defhvar "Netnews Fetch All Headers" - "When NIL, all netnews reading commands will fetch headers in batches for - increased efficiency. Any other value will cause these commands to fetch - all the headers. This will take a long time if there are a lot." - :value nil) - -(defcommand "Netnews Look at Newsgroup" (p) - "Prompts for the name of a newsgroup and reads it, regardless of what is - in and not modifying the \"Netnews Database File\"." - "Prompts for the name of a newsgroup and reads it, regardless of what is - in and not modifying the \"Netnews Database File\"." - (declare (ignore p)) - (netnews-command nil (prompt-for-string :prompt "Group to look at: " - :help "Type the name of ~ - the group you want ~ - to look at." - :trim t) - nil nil nil)) - -;;; SETUP-GROUP is the guts of this group reader. It sets up a headers -;;; buffer in buffer for group group-name. This consists of sending a group -;;; command to both the header-stream and normal stream and then getting the -;;; last message read in group-name from the database file and setting the -;;; appropriate slots in the nn-info structure. The first batch of messages -;;; is then requested and inserted, and room for message-ids is allocated. -;;; -(defun setup-group (group-name nn-info buffer &optional from-end-p) - ;; Do not bind stream or header-stream because if a timeout has occurred - ;; before these calls are invoked, they would be bogus. - ;; - (nntp-group group-name (nn-info-stream nn-info) - (nn-info-header-stream nn-info)) - (process-status-response (nn-info-stream nn-info) nn-info) - (let ((response (process-status-response (nn-info-header-stream nn-info) - nn-info))) - (cond ((not response) - (message "~A is not the name of a netnews group.~%" - (nn-info-current nn-info)) - (change-to-next-group nn-info buffer)) - (t - (multiple-value-bind (number first last) - (group-response-args response) - (declare (ignore first)) - (message "Setting up ~A" group-name) - ;; If nn-info-updatep is nil, then we fool ourselves into - ;; thinking we've never read this group before by making - ;; last-read nil. We determine first here because the first - ;; that NNTP gives us is way way out of line. - ;; - (let ((last-read (if (nn-info-updatep nn-info) - (nn-last-read-message-number group-name))) - (first (1+ (- last number)))) - ;; Make sure there is at least one new message in this group. - (cond - ((and last-read (= last-read last)) - (message "No new messages in ~A" group-name) - (setf (nn-info-latest nn-info) last) - (change-to-next-group nn-info buffer)) - ((zerop number) - (message "No messages AVAILABLE in ~A" group-name) - (setf (nn-info-latest nn-info) last) - (change-to-next-group nn-info buffer)) - (t - (let ((latest (if (and last-read (> last-read first)) - last-read - first))) - (if (or (and (eq (value netnews-new-group-style) :from-end) - (or (= latest first) - (and (> (- last latest) - (value - netnews-start-over-threshold)) - (prompt-for-y-or-n - :prompt - `("There are ~D new messages. ~ - Read from the end of this ~ - group? " ,(- last latest)) - :default "Y" - :default-string "Y" - :help "Y starts reading from the ~ - end. N starts reading where ~ - you left off many messages ~ - back.")))) - from-end-p) - (setf (nn-info-from-end-p nn-info) t)) - - (cond ((nn-info-from-end-p nn-info) - (setf (nn-info-first-visible nn-info) nil) - (setf (nn-info-last-visible nn-info) last)) - (t - ; (setf (nn-info-first-visible nn-info) latest) - (setf (nn-info-first-visible nn-info) (1+ latest)) - (setf (nn-info-last-visible nn-info) nil))) - (setf (nn-info-first nn-info) first) - (setf (nn-info-last nn-info) last) - (setf (nn-info-latest nn-info) latest)) - ;; - ;; Request the batch before setting message-ids so they start - ;; coming before we need them. - (nn-request-next-batch nn-info - (value netnews-fetch-all-headers)) - (let ((message-ids (nn-info-message-ids nn-info)) - (header-cache (nn-info-header-cache nn-info)) - (length (1+ (- last first)))) - (multiple-value-setq - (message-ids header-cache) - (cond ((> length (nn-info-array-length nn-info)) - (setf (nn-info-array-length nn-info) length) - (values (make-array length :fill-pointer 0) - (make-array length - :initial-element nil))) - (message-ids - (setf (fill-pointer message-ids) 0) - (values message-ids header-cache)) - (t - (values (make-array (nn-info-array-length nn-info) - :fill-pointer 0) - (make-array (nn-info-array-length nn-info) - :initial-element nil))))) - (setf (nn-info-message-ids nn-info) message-ids) - (setf (nn-info-header-cache nn-info) header-cache)) - (nn-write-headers-to-mark nn-info buffer) - (change-to-buffer buffer))))))))) - -;;; NN-LAST-READ-MESSAGE-NUMBER reads the last read message in group-name -;;; from the value of "Netnews Database File". It is SETF'able and the -;;; SETF method is %SET-LAST-READ-MESSAGE-NUMBER. -;;; -(defun nn-last-read-message-number (group-name) - (with-open-file (s (merge-pathnames (value netnews-database-file) - (user-homedir-pathname)) - :direction :input :if-does-not-exist :error) - (loop - (let ((read-group-name (read-line s nil nil))) - (unless read-group-name (return nil)) - (when (string-equal read-group-name group-name) - (let ((last-read (read-line s nil nil))) - (if last-read - (return (parse-integer last-read)) - (error "Should have been a message number ~ - following ~S in database file." - group-name)))))))) - -(defun %set-nn-last-read-message-number (group-name new-value) - (with-open-file (s (merge-pathnames (value netnews-database-file) - (user-homedir-pathname)) - :direction :io :if-does-not-exist :error - :if-exists :overwrite) - (unless (loop - (let ((read-group-name (read-line s nil nil))) - (unless read-group-name (return nil)) - (when (string-equal read-group-name group-name) - ;; File descriptor streams do not do the right thing with - ;; :io/:overwrite streams, so work around it by setting it - ;; explicitly. - ;; - (file-position s (file-position s)) - ;; Justify the number so that if the number of digits in it - ;; changes, we won't overwrite the next group name. - ;; - (format s "~14D~%" new-value) - (return t)))) - (write-line group-name s) - (format s "~14D~%" new-value)))) - -(defsetf nn-last-read-message-number %set-nn-last-read-message-number) - -(defconstant nntp-eof ". -" - "NNTP marks the end of a textual response with this. NNTP also recognizes - this as the end of a post.") - -;;; This macro binds a variable to each successive line of input from NNTP -;;; and exits when it sees the NNTP end-of-file-marker, a period by itself on -;;; a line. -;;; -(defmacro with-input-from-nntp ((var stream) &body body) - "Body is executed with var bound to successive lines of input from nntp. - Exits at the end of a response, returning whatever the last execution of - Body returns, or nil if there was no input. - Take note: this is only to be used for textual responses. Status responses - are of an entirely different nature." - (let ((return-value (gensym))) - `(let ((,return-value nil) - (,var "")) - (declare (simple-string ,var)) - (loop - (setf ,var (read-line ,stream)) - (when (string= ,var nntp-eof) (return ,return-value)) - (setf ,return-value (progn ,@body)))))) - - -;;; Writing the date, from, and subject fields to a mark. - -(defhvar "Netnews Before Date Field Pad" - "How many spaces should be inserted before the date in Netnews. The default - is 1." - :value 1) - -(defhvar "Netnews Date Field Length" - "How long the date field should be in \"News-Headers\" buffers. The - default is 6" - :value 6) - -(defhvar "Netnews Line Field Length" - "How long the line field should be in \"News-Headers\" buffers. The - default is 3" - :value 3) - -(defhvar "Netnews From Field Length" - "How long the from field should be in \"News-Headers\" buffers. The - default is 20." - :value 20) - -(defhvar "Netnews Subject Field Length" - "How long the subject field should be in \"News-Headers\" buffers. The - default is 43." - :value 43) - -(defhvar "Netnews Field Padding" - "How many spaces should be left between the netnews date, from, lines, and - subject fields. The default is 2." - :value 2) - -;;; -(defconstant netnews-space-string - (make-string 70 :initial-element #\space)) -;;; -(defconstant missing-message (cons nil nil) - "Use this as a marker so nn-write-headers-to-mark doesn't try to insert - a message that is not really there.") - -;;; NN-CACHE-HEADER-INFO stashes all header information into an array for -;;; later use. -;;; -(defun nn-cache-header-info (nn-info howmany use-header-stream-p) - (let* ((cache (nn-info-header-cache nn-info)) - (message-ids (nn-info-message-ids nn-info)) - (stream (if use-header-stream-p - (nn-info-header-stream nn-info) - (nn-info-stream nn-info))) - (from-end-p (nn-info-from-end-p nn-info)) - (old-count 0)) - (declare (fixnum old-count)) - (when from-end-p - (setf old-count (length message-ids)) - (do ((i (length message-ids) (1- i))) - ((minusp i) nil) - (setf (aref message-ids (+ i howmany)) (aref message-ids i))) - (setf (fill-pointer message-ids) 0)) - (let ((missing-message-count 0) - (offset (nn-info-first nn-info))) - (dotimes (i howmany) - (let ((response (process-status-response stream))) - (if response - (let* ((id (head-response-args response)) - (index (- id offset))) - (vector-push id message-ids) - (setf (svref cache index) nil) - (with-input-from-nntp (string stream) - (let ((colonpos (position #\: string))) - (when colonpos - (push (cons (subseq string 0 colonpos) - (subseq string - (+ colonpos 2))) - (svref cache index)))))) - (incf missing-message-count)))) - (when from-end-p - (when (plusp missing-message-count) - (dotimes (i old-count) - (setf (aref message-ids (- (+ i howmany) missing-message-count)) - (aref message-ids (+ i howmany))))) - (setf (fill-pointer message-ids) - (- (+ old-count howmany) missing-message-count)))))) - -(defconstant netnews-field-na "NA" - "This string gets inserted when NNTP doesn't find a field.") - -(defconstant netnews-field-na-length (length netnews-field-na) - "The length of netnews-field-na") - -(defun nn-write-headers-to-mark (nn-info buffer &optional fetch-rest-p - out-of-order-p) - (let* ((howmany (nn-info-batch-count nn-info)) - (from-end-p (nn-info-from-end-p nn-info)) - (cache (nn-info-header-cache nn-info)) - (old-point (copy-mark (buffer-point buffer) (if from-end-p - :left-inserting - :right-inserting))) - (messages-waiting (nn-info-messages-waiting nn-info)) - (mark (nn-info-mark nn-info))) - (unless messages-waiting - (return-from nn-write-headers-to-mark nil)) - (if from-end-p - (buffer-start mark) - (buffer-end mark)) - (nn-cache-header-info nn-info howmany (not out-of-order-p)) - (with-writable-buffer (buffer) - (with-mark ((check-point mark :right-inserting)) - (macrolet ((mark-to-pos (mark pos) - `(insert-string ,mark netnews-space-string - 0 (- ,pos (mark-column ,mark)))) - (insert-field (mark field-string field-length) - `(if ,field-string - (insert-string ,mark ,field-string - 0 (min ,field-length - (1- (length ,field-string)))) - (insert-string ,mark netnews-field-na - 0 (min ,field-length - netnews-field-na-length))))) - (let* ((line-start (+ (value netnews-before-date-field-pad) - (value netnews-date-field-length) - (value netnews-field-padding))) - (from-start (+ line-start - (value netnews-line-field-length) - (value netnews-field-padding))) - (subject-start (+ from-start - (value netnews-from-field-length) - (value netnews-field-padding))) - (start (- messages-waiting (nn-info-first nn-info))) - (end (1- (+ start howmany)))) - (do ((i start (1+ i))) - ((> i end)) - (let ((assoc-list (svref cache i))) - (unless (null assoc-list) - (insert-string mark netnews-space-string - 0 (value netnews-before-date-field-pad)) - (let* ((date-field (cdr (assoc "date" assoc-list - :test #'string-equal))) - (universal-date (if date-field - (ext:parse-time date-field - :end (1- (length date-field)))))) - (insert-field - mark - (if universal-date - (string-capitalize - (format-universal-time nil universal-date - :style :government - :print-weekday nil)) - date-field) - (value netnews-date-field-length))) - (mark-to-pos mark line-start) - (insert-field mark (cdr (assoc "lines" assoc-list - :test #'string-equal)) - (value netnews-line-field-length)) - (mark-to-pos mark from-start) - (insert-field mark (cdr (assoc "from" assoc-list - :test #'string-equal)) - (value netnews-from-field-length)) - (mark-to-pos mark subject-start) - (insert-field mark (cdr (assoc "subject" assoc-list - :test #'string-equal)) - (value netnews-subject-field-length)) - (insert-character mark #\newline)))))) - (cond (out-of-order-p - (setf (nn-info-first-visible nn-info) messages-waiting)) - (t - (if (nn-info-from-end-p nn-info) - (setf (nn-info-first-visible nn-info) messages-waiting) - (setf (nn-info-last-visible nn-info) - (1- (+ messages-waiting howmany)))) - (if (nn-info-last-batch-p nn-info) - (setf (nn-info-messages-waiting nn-info) nil) - (nn-request-next-batch nn-info fetch-rest-p)))) - (when (mark= mark check-point) - (message "All messages in last batch were missing, getting more.")) - (move-mark (buffer-point buffer) old-point) - (delete-mark old-point))))) - -;;; NN-MAYBE-GET-MORE-HEADERS gets more headers if the point of the headers -;;; buffer is on an empty line and there are some. Returns whether it got more -;;; headers, i.e., if it is time to go on to the next group. -;;; -(defun nn-maybe-get-more-headers (nn-info) - (let ((headers-buffer (line-buffer (mark-line (nn-info-mark nn-info))))) - (when (empty-line-p (buffer-point headers-buffer)) - (cond ((and (nn-info-messages-waiting nn-info) - (not (nn-info-from-end-p nn-info))) - (nn-write-headers-to-mark nn-info headers-buffer) - t) - (t :go-on))))) - -(defhvar "Netnews Batch Count" - "Determines how many headers the Netnews facility will fetch at a time. - The default is 50." - :value 50) - -;;; NN-REQUEST-NEXT-BATCH requests the next batch of messages in a group. -;;; For safety, don't do anything if there is no next-batch start. -;;; -(defun nn-request-next-batch (nn-info &optional fetch-rest-p) - (if (nn-info-from-end-p nn-info) - (nn-request-backward nn-info fetch-rest-p) - (nn-request-forward nn-info fetch-rest-p))) - -(defun nn-request-forward (nn-info fetch-rest-p) - (let* ((last-visible (nn-info-last-visible nn-info)) - (last (nn-info-last nn-info)) - (batch-start (if last-visible - (1+ (nn-info-last-visible nn-info)) - (1+ (nn-info-latest nn-info)))) - (header-stream (nn-info-header-stream nn-info)) - (batch-end (if fetch-rest-p - last - (1- (+ batch-start (value netnews-batch-count)))))) - ;; If this is the last batch, adjust batch-end appropriately. - ;; - (when (>= batch-end last) - (setf batch-end last) - (setf (nn-info-last-batch-p nn-info) t)) - (setf (nn-info-batch-count nn-info) (1+ (- batch-end batch-start))) - (setf (nn-info-messages-waiting nn-info) batch-start) - (nn-send-many-head-requests header-stream batch-start batch-end nil))) - -(defun nn-request-backward (nn-info fetch-rest-p - &optional (use-header-stream-p t)) - (let* ((first-visible (nn-info-first-visible nn-info)) - (batch-end (if first-visible - (1- (nn-info-first-visible nn-info)) - (nn-info-last nn-info))) - (stream (if use-header-stream-p - (nn-info-header-stream nn-info) - (nn-info-stream nn-info))) - (first (nn-info-first nn-info)) - (batch-start (if fetch-rest-p - first - (1+ (- batch-end (value netnews-batch-count)))))) - ;; If this is the last batch, adjust batch-end appropriately. - ;; - (when (<= batch-start first) - (setf batch-start first) - (setf (nn-info-last-batch-p nn-info) t)) - (setf (nn-info-batch-count nn-info) (1+ (- batch-end batch-start))) - (setf (nn-info-messages-waiting nn-info) batch-start) - (nn-send-many-head-requests stream batch-start batch-end - (not use-header-stream-p)))) - -;;; NN-REQUEST-OUT-OF-ORDER is called when the user is reading a group normally -;;; and decides he wants to see some messages before the first one visible. -;;; To accomplish this without disrupting the normal flow of things, we fool -;;; ourselves into thinking we are reading the group from the end, remembering -;;; several slots that could be modified in requesting thesse messages. -;;; When we are done, return state to what it was for reading a group forward. -;;; -(defun nn-request-out-of-order (nn-info headers-buffer) - (let ((messages-waiting (nn-info-messages-waiting nn-info)) - (batch-count (nn-info-batch-count nn-info)) - (last-batch-p (nn-info-last-batch-p nn-info))) - (nn-request-backward nn-info nil nil) - (setf (nn-info-from-end-p nn-info) t) - (nn-write-headers-to-mark nn-info headers-buffer nil t) - (setf (nn-info-messages-waiting nn-info) messages-waiting) - (setf (nn-info-batch-count nn-info) batch-count) - (setf (nn-info-last-batch-p nn-info) last-batch-p) - (setf (nn-info-from-end-p nn-info) nil))) - -(declaim (special *nn-last-command-issued*)) - -(defun nn-send-many-head-requests (stream first last out-of-order-p) - (do ((i first (1+ i))) - ((> i last)) - (nntp-head i stream)) - (setf *nn-last-command-issued* - (list (if out-of-order-p :out-of-order :header) - first last out-of-order-p))) - -(defvar nn-minimum-header-batch-count 30 - "The minimum number of headers to fetch at any given time.") - - - - -;;;; "News-Message" mode. - -(defmode "News-Message" :major-p t) - - - - -;;;; Commands for viewing articles. - -(defcommand "Netnews Show Article" (p) - "Show the message the point is on. If it is the same message that is - already in the message buffer and \"Netnews Read Style\" is :multiple, - then just scroll the window down prefix argument lines" - "Show the message the point is on. If it is the same message that is - already in the message buffer and \"Netnews Read Style\" is :multiple, - then just scroll the window down prefix argument lines" - (nn-show-article (value netnews-info) p)) - -(defcommand "Netnews Next Article" (p) - "Show the next article in the current newsgroup." - "Shows the article on the line preceeding the point in the headers buffer." - (declare (ignore p)) - (let* ((what-next (netnews-next-line-command nil (nn-get-headers-buffer)))) - (when (and (not (eq what-next :done)) - (or (eq what-next t) - (eq (value netnews-last-header-style) :next-article))) - ;; Reget the headers buffer because the call to netnews-next-line-command - ;; might have moved us into a different buffer. - ;; - (nn-show-article (variable-value 'netnews-info - :buffer (nn-get-headers-buffer)) - t)))) - -(defcommand "Netnews Previous Article" (p) - "Show the previous article in the current newsgroup." - "Shows the article on the line after the point in the headers buffer." - (declare (ignore p)) - (let ((buffer (nn-get-headers-buffer))) - (netnews-previous-line-command nil buffer) - (nn-show-article (variable-value 'netnews-info :buffer buffer) t))) - -;;; NN-SHOW-ARTICLE checks first to see if we need to get more headers. If -;;; NN-MAYBE-GET-MORE-HEADERS returns nil then don't do anything because we -;;; changed to the next group. Then see if the message the user has -;;; requested is already in the message buffer. If the it isn't, put it -;;; there. If it is, and maybe-scroll-down is t, then scroll the window -;;; down p lines in :multiple mode, or just change to the buffer in :single -;;; mode. I use scroll-window down becuase this function is called by -;;; "Netnews Show Article", "Netnews Next Article", and "Netnews Previous -;;; Article". It doesn't make sense to scroll the window down if the guy -;;; just read a message, moved the point up one line and invoked "Netnews -;;; Next Article". He expects to see the article again, not the second -;;; page of it. Also check to make sure there is a message under the -;;; point. If there is not, then get some more headers. If there are no -;;; more headers, then go on to the next group. I can read and write. Hi -;;; Bill. Are you having fun grokking my code? Hope so -- Dude. Nothing -;;; like stream of consciousness is there? Come to think of it, this is -;;; kind of like recursive stream of conscious because I'm writing down my -;;; stream of conscious which is about my stream of conscious. I think I'm -;;; insane. In fact I know I am. -;;; -(defun nn-show-article (nn-info dont-scroll-down &optional p) - (let ((headers-buffer (nn-get-headers-buffer)) - (message-buffer (nn-info-buffer nn-info))) - (cond - ((eq (nn-maybe-get-more-headers nn-info) :go-on) - (case (value netnews-last-header-style) - (:this-headers (change-to-buffer headers-buffer) - (buffer-start (buffer-point headers-buffer)) - (editor-error "Last header.")) - (:next-headers (change-to-next-group nn-info headers-buffer)) - (:next-article (change-to-next-group nn-info headers-buffer) - (netnews-show-article-command nil)))) - (t - (cond ((and (not dont-scroll-down) - (= (nn-info-current-displayed-message nn-info) - (array-element-from-mark (buffer-point headers-buffer) - (nn-info-message-ids nn-info)))) - (ecase (value netnews-read-style) - (:single (buffer-start (buffer-point message-buffer)) - (change-to-buffer message-buffer)) - (:multiple - (multiple-value-bind - (headers-window message-window newp) - (nn-assure-multi-windows nn-info) - (nn-put-buffers-in-windows headers-buffer message-buffer - headers-window message-window - :headers) - ;; If both windows were visible to start with, just scroll - ;; down. If they weren't, then show the message over - ;; again. - ;; - (cond (newp (buffer-start (buffer-point message-buffer)) - (buffer-start (window-point message-window))) - (t (netnews-message-scroll-down-command - p message-buffer message-window))))))) - (t - (nn-put-article-in-buffer nn-info headers-buffer) - (setf message-buffer (nn-info-buffer nn-info)) - (multiple-value-bind - (headers-window message-window) - (ecase (value netnews-read-style) ; Only need windows in - (:single (values nil nil)) ; :multiple mode. - (:multiple (nn-assure-multi-windows nn-info))) - (ecase (value netnews-read-style) - (:multiple - ;; When there is only one window displaying the headers - ;; buffer, move the window point of that buffer to the - ;; buffer-point. - (when (= (length (buffer-windows headers-buffer)) 1) - (move-mark (window-point headers-window) - (buffer-point headers-buffer))) - (buffer-start (window-point message-window)) - (nn-put-buffers-in-windows headers-buffer message-buffer - headers-window message-window - :headers)) - (:single (change-to-buffer message-buffer)))))))))) - -(defcommand "Netnews Message Quit" (p) - "Destroy this message buffer, and pop back to the associated headers buffer." - "Destroy this message buffer, and pop back to the associated headers buffer." - (declare (ignore p)) - (unless (hemlock-bound-p 'netnews-message-info) - (editor-error "Not in a News-Message Buffer")) - (let ((message-buffer (current-buffer))) - (change-to-buffer (nn-get-headers-buffer)) - (delete-buffer-if-possible message-buffer))) - -(defhvar "Netnews Message Header Fields" - "When NIL, the default, all available fields are displayed in the header - of a message. Otherwise, this variable should containt a list of fields - that should be included in the message header when a message is - displayed. Any string name is acceptable. Fields that do not exist are - ignored. If an element of this list is an atom, then it should be the - string name of a field. If it is a cons, then the car should be the - string name of a field, and the cdr should be the length to which this - field should be limited." - :value nil) - - -(defcommand "Netnews Show Whole Header" (p) - "This command will display the entire header of the message currently - being read." - "This command will display the entire header of the message currently - being read." - (declare (ignore p)) - (let* ((headers-buffer (nn-get-headers-buffer)) - (nn-info (variable-value 'netnews-info :buffer headers-buffer)) - (buffer (nn-get-message-buffer nn-info))) - (with-writable-buffer (buffer) - (delete-region (buffer-region buffer)) - (nn-put-article-in-buffer nn-info headers-buffer t)))) - -;;; NN-PUT-ARTICLE-IN-BUFFER puts the article under the point into the -;;; associated message buffer if it is not there already. Uses value of -;;; "Netnews Message Header Fields" to determine what fields should appear -;;; in the message header. Returns the number of the article under the -;;; point. -;;; -(defun nn-put-article-in-buffer (nn-info headers-buffer &optional override) - (let ((stream (nn-info-stream nn-info)) - (article-number (array-element-from-mark - (buffer-point headers-buffer) - (nn-info-message-ids nn-info))) - (message-buffer (nn-get-message-buffer nn-info))) - (setf (nm-info-message-number (variable-value 'netnews-message-info - :buffer message-buffer)) - (1+ (- article-number (nn-info-first nn-info)))) - (cond ((and (= (nn-info-current-displayed-message nn-info) article-number) - (not override)) - (buffer-start (buffer-point message-buffer))) - (t - ;; Request article as soon as possible to avoid waiting for reply. - ;; - (nntp-body article-number stream) - (setf (nn-info-current-displayed-message nn-info) article-number) - (process-status-response stream nn-info) - (with-writable-buffer (message-buffer) - (let ((point (buffer-point message-buffer)) - (info (svref (nn-info-header-cache nn-info) - (- article-number (nn-info-first nn-info)))) - (message-fields (value netnews-message-header-fields)) - key field-length) - (cond ((and message-fields - (not override)) - (dolist (ele message-fields) - (etypecase ele - (atom (setf key ele field-length nil)) - (cons (setf key (car ele) field-length (cdr ele)))) - (let ((field-string (cdr (assoc key info - :test #'string-equal)))) - (when field-string - (insert-string point (string-capitalize key)) - (insert-string point ": ") - (insert-string point field-string - 0 - (max - (if field-length - (min field-length - (1- (length field-string))) - (1- (length field-string))) - 0)) - (insert-character point #\newline))))) - (t - (dolist (ele info) - (insert-string point (string-capitalize (car ele))) - (insert-string point ": ") - (insert-string point (cdr ele) - 0 (max 0 (1- (length (cdr ele))))) - (insert-character point #\newline)))) - (insert-character point #\newline) - (nntp-insert-textual-response point (nn-info-stream nn-info)))) - (buffer-start (buffer-point message-buffer)) - (when (> article-number (nn-info-latest nn-info)) - (setf (nn-info-latest nn-info) article-number)))) - article-number)) - -;;; NN-PUT-BUFFERS-IN-WINDOWS makes sure the message buffer goes in the message -;;; window and the headers buffer in the headers window. If which-current -;;; is :headers, the headers buffer/window will be made current, if it is -;;; :message, the message buffer/window will be made current. -;;; -(defun nn-put-buffers-in-windows (headers-buffer message-buffer headers-window - message-window which-current) - (setf (window-buffer message-window) message-buffer - (window-buffer headers-window) headers-buffer) - (setf (current-window) (ecase which-current - (:headers headers-window) - (:message message-window)) - (current-buffer) (case which-current - (:headers headers-buffer) - (:message message-buffer)))) - -(defhvar "Netnews Headers Proportion" - "Determines how much of the current window will display headers when - \"Netnews Read Style\" is :multiple. Defaults to .25" - :value .25) - -(defun nn-assure-multi-windows (nn-info) - (let ((newp nil)) - (unless (and (member (nn-info-message-window nn-info) *window-list*) - (member (nn-info-headers-window nn-info) *window-list*)) - (setf newp t) - (setf (nn-info-message-window nn-info) (current-window) - (nn-info-headers-window nn-info) - (make-window (buffer-start-mark (nn-get-headers-buffer)) - :proportion (value netnews-headers-proportion)))) - (values (nn-info-headers-window nn-info) - (nn-info-message-window nn-info) - newp))) - -;;; NN-GET-MESSAGE-BUFFER returns the message buffer for an nn-info structure. -;;; If there is not one, this function makes it and sets the slot in nn-info. -;;; -(defun nn-get-message-buffer (nn-info) - (let* ((message-buffer (nn-info-buffer nn-info)) - (nm-info (if message-buffer - (variable-value 'netnews-message-info - :buffer message-buffer)))) - (cond ((and message-buffer (not (nm-info-keep-p nm-info))) - (with-writable-buffer (message-buffer) - (delete-region (buffer-region message-buffer))) - message-buffer) - (t - (let ((buf (make-buffer (nn-unique-message-buffer-name - (nn-info-current nn-info)) - :modeline-fields - (append (value default-modeline-fields) - (list (modeline-field - :netnews-message))) - :modes '("News-Message") - :delete-hook - (list #'nn-message-buffer-delete-hook)))) - (setf (nn-info-buffer nn-info) buf) - (defhvar "Netnews Message Info" - "Structure that keeps track of buffers in \"News-Message\" - mode." - :value (make-netnews-message-info - :headers-buffer (current-buffer)) - :buffer buf) - buf))))) - -;;; The usual. Clean everything up. -;;; -(defun nn-message-buffer-delete-hook (buffer) - (let* ((headers-buffer (nm-info-headers-buffer - (variable-value 'netnews-message-info - :buffer buffer))) - (nn-info (variable-value 'netnews-info :buffer headers-buffer)) - (nm-info (variable-value 'netnews-message-info :buffer buffer))) - (setf (nn-info-buffer nn-info) nil) - (setf (nn-info-current-displayed-message nn-info) -1) - (let ((post-buffer (nm-info-post-buffer nm-info))) - (when post-buffer - (setf (post-info-message-buffer (variable-value - 'post-info :buffer post-buffer)) - nil))))) - - -;;; NN-UNIQUE-MESSAGE-BUFFER-NAME likes to have a simple name, i.e. -;;; "Netnews Message for rec.music.synth". When there is already a buffer -;;; by this name, however, we start counting until the name is unique. -;;; -(defun nn-unique-message-buffer-name (group) - (let ((name (concatenate 'simple-string "Netnews Message for " group)) - (number 0)) - (loop - (unless (getstring name *buffer-names*) (return name)) - (setf name (format nil "Netnews Message ~D" number)) - (incf number)))) - -;;; INSERT-TEXTUAL-RESPONSE inserts a textual response from nntp at mark. -;;; -(defun nntp-insert-textual-response (mark stream) - (with-input-from-nntp (string stream) - (insert-string mark string 0 (1- (length string))) - (insert-character mark #\newline))) - -;;; NN-GET-HEADERS-BUFFER returns the headers buffer if we are in a message or -;;; headers buffer. -;;; -(defun nn-get-headers-buffer () - (cond ((hemlock-bound-p 'netnews-info) - (current-buffer)) - ((hemlock-bound-p 'netnews-message-info) - (nm-info-headers-buffer (value netnews-message-info))) - ((hemlock-bound-p 'post-info) - (post-info-headers-buffer (value post-info))) - (t nil))) - - -(defcommand "Netnews Previous Line" (p &optional - (headers-buffer (current-buffer))) - "Moves the point to the last header before the point that is not in your - kill file. If you move off the end of the buffer and there are more - headers, then get them. Otherwise go on to the next group in \"Netnews - Groups\"." - "Moves the point to the last header before the point that is not in your - kill file. If you move off the end of the buffer and there are more - headers, then get them. Otherwise go on to the next group in \"Netnews - Groups\"." - (declare (ignore p)) - (let ((point (buffer-point headers-buffer)) - (nn-info (variable-value 'netnews-info :buffer headers-buffer))) - (with-mark ((original-position point) - (start point) - (end point)) - (loop - (unless (line-offset point -1) - (cond ((and (nn-info-from-end-p nn-info) - (nn-info-messages-waiting nn-info)) - (nn-write-headers-to-mark nn-info headers-buffer) - (netnews-previous-line-command nil headers-buffer)) - (t - (cond ((= (nn-info-first-visible nn-info) - (nn-info-first nn-info)) - (move-mark point original-position) - (editor-error "No previous unKilled headers.")) - (t - (message "Requesting backward...") - (nn-request-out-of-order nn-info headers-buffer) - (netnews-previous-line-command nil headers-buffer)))))) - (line-start (move-mark start point)) - (character-offset (move-mark end start) 1) - (unless (string= (region-to-string (region start end)) "K") - (return)))))) - -(defhvar "Netnews Last Header Style" - "When you read the last message in a newsgroup, this variable determines - what will happen next. Takes one of three values: :this-headers, - :next-headers, or :next-article. :this-headers, the default means put me - in the headers buffer for this newsgroup. :next-headers means go to the - next newsgroup and put me in that headers buffer. :next-article means go - on to the next newsgroup and show me the first unread article." - :value :next-headers) - -(defcommand "Netnews Next Line" - (p &optional (headers-buffer (current-buffer))) - "Moves the point to the next header that is not in your kill file. If you - move off the end of the buffer and there are more headers, then get them. - Otherwise go on to the next group in \"Netnews Groups\"." - "Moves the point to the next header that is not in your kill file. If you - move off the end of the buffer and there are more headers, then get them. - Otherwise go on to the next group in \"Netnews Groups\". - Returns nil if we have gone on to the next group, :done if there are no - more groups to read, or T if everything is normal." - (declare (ignore p)) - (let* ((nn-info (variable-value 'netnews-info :buffer headers-buffer)) - (point (buffer-point headers-buffer))) - (with-mark ((start point) - (end point)) - (loop - (line-offset point 1) - (cond ((eq (nn-maybe-get-more-headers nn-info) :go-on) - (cond ((eq (value netnews-last-header-style) :this-headers) - (let ((headers-buffer (nn-get-headers-buffer))) - (change-to-buffer headers-buffer)) - (editor-error "Last header.")) - (t - (return (change-to-next-group nn-info headers-buffer))))) - (t - (line-start (move-mark start point)) - (character-offset (move-mark end start) 1) - (unless (string= (region-to-string (region start end)) "K") - (return t)))))))) - -(defcommand "Netnews Headers Scroll Window Up" (p) - "Does what \"Scroll Window Up\" does, but fetches backward when the point - reaches the start of the headers buffer." - "Does what \"Scroll Window Up\" does, but fetches backward when the point - reaches the start of the headers buffer." - (scroll-window-up-command p) - (let ((headers-buffer (current-buffer)) - (nn-info (value netnews-info))) - (when (and (displayed-p (buffer-start-mark headers-buffer) - (current-window)) - (not (= (nn-info-first nn-info) - (nn-info-first-visible nn-info)))) - (buffer-start (current-point)) - (netnews-previous-line-command nil)))) - -(defcommand "Netnews Headers Scroll Window Down" (p) - "Does what \"Scroll Window Down\" does, but when the point reaches the end of - the headers buffer, pending headers are inserted." - "Does what \"Scroll Window Down\" does, but when the point reaches the end of - the headers buffer, pending headers are inserted." - (scroll-window-down-command p) - (let ((headers-buffer (current-buffer)) - (nn-info (value netnews-info))) - (when (and (displayed-p (buffer-end-mark headers-buffer) (current-window)) - (not (= (nn-info-last nn-info) (nn-info-last-visible nn-info)))) - (buffer-end (current-point)) - (netnews-next-line-command nil)))) - -(defcommand "Netnews Message Keep Buffer" (p) - "Specifies that you don't want Hemlock to reuse the current message buffer." - "Specifies that you don't want Hemlock to reuse the current message buffer." - (declare (ignore p)) - (unless (hemlock-bound-p 'netnews-message-info) - (editor-error "Not in a News-Message buffer.")) - (setf (nm-info-keep-p (value netnews-message-info)) t)) - -(defcommand "Netnews Goto Headers Buffer" (p) - "From \"Message Mode\", switch to the associated headers buffer." - "From \"Message Mode\", switch to the associated headers buffer." - (declare (ignore p)) - (unless (hemlock-bound-p 'netnews-message-info) - (editor-error "Not in a message buffer.")) - (let ((headers-buffer (nm-info-headers-buffer (value netnews-message-info)))) - (unless headers-buffer (editor-error "Headers buffer has been deleted")) - (change-to-buffer headers-buffer))) - -(defcommand "Netnews Goto Post Buffer" (p) - "Change to the associated \"Post\" buffer (if there is one) from a - \"News-Message\" buffer." - "Change to the associated \"Post\" buffer (if there is one) from a - \"News-Message\" buffer." - (declare (ignore p)) - (unless (hemlock-bound-p 'netnews-message-info) - (editor-error "Not in a News-Message buffer.")) - (let ((post-buffer (nm-info-post-buffer (value netnews-message-info)))) - (unless post-buffer (editor-error "No associated post buffer.")) - (change-to-buffer post-buffer))) - -(defcommand "Netnews Goto Draft Buffer" (p) - "Change to the associated \"Draft\" buffer (if there is one) from a - \"News-Message\" buffer." - "Change to the associated \"Draft\" buffer (if there is one) from a - \"News-Message\" buffer." - (declare (ignore p)) - (unless (hemlock-bound-p 'netnews-message-info) - (editor-error "Not in a News-Message buffer.")) - (let ((draft-buffer (nm-info-draft-buffer (value netnews-message-info)))) - (unless draft-buffer (editor-error "No associated post buffer.")) - (change-to-buffer draft-buffer))) - -(defcommand "Netnews Select Message Buffer" (p) - "Change to the associated message buffer (if there is one) in \"Post\" or - \"News-Headers\" modes." - "Change to the associated message buffer (if there is one) in \"Post\" or - \"News-Headers\" modes." - (declare (ignore p)) - (let* ((cbuf (current-buffer)) - (mbuf (cond ((hemlock-bound-p 'post-info :buffer cbuf) - (post-info-message-buffer (value post-info))) - ((hemlock-bound-p 'netnews-info :buffer cbuf) - (nn-info-buffer (value netnews-info))) - (t - (editor-error "Not in a \"Post\" or \"News-Headers\" ~ - buffer."))))) - (unless mbuf (editor-error "No assocated message buffer.")) - (change-to-buffer mbuf))) - -;;; CHANGE-TO-NEXT-GROUP deletes nn-info's headers buffer region and sets -;;; up the next group in that buffer. If there are no more groups to read, -;;; exits gracefully. -;;; -(defun change-to-next-group (nn-info headers-buffer) - (when (nn-info-updatep nn-info) - (nn-update-database-file (nn-info-latest nn-info) - (nn-info-current nn-info))) - (let ((next-group (cadr (member (nn-info-current nn-info) - (nn-info-groups nn-info) :test #'string=)))) - (cond (next-group - (message "Going on to ~A" next-group) - (force-output *echo-area-stream*) - (let ((message-buffer (nn-info-buffer nn-info))) - (when message-buffer - (setf (buffer-name message-buffer) - (nn-unique-message-buffer-name next-group)))) - (setf (buffer-name headers-buffer) - (nn-unique-headers-name next-group)) - (setf (nn-info-current nn-info) next-group) - (with-writable-buffer (headers-buffer) - (delete-region (buffer-region headers-buffer))) - (setup-group next-group nn-info headers-buffer) - nil) - (t - (if (eq headers-buffer *nn-headers-buffer*) - (message "This was your last group. Exiting Netnews.") - (message "Done with ~A. Exiting Netnews." - (nn-info-current nn-info))) - (netnews-exit-command nil t headers-buffer) - :done)))) - -(defun nn-update-database-file (latest group-name) - (when latest (setf (nn-last-read-message-number group-name) latest))) - - - - -;;;; More commands. - -(defhvar "Netnews Scroll Show Next Message" - "When non-nil, the default, Hemlock will show the next message in a group - when you scroll off the end of one. Otherwise Hemlock will editor error - that you are at the end of the buffer." - :value T) - -(defcommand "Netnews Message Scroll Down" (p &optional (buffer (current-buffer)) - (window (current-window))) - "Scrolls the current window down one screenful, checking to see if we need - to get the next message." - "Scrolls the current window down one screenful, checking to see if we need - to get the next message." - (if (displayed-p (buffer-end-mark buffer) window) - (if (value netnews-scroll-show-next-message) - (netnews-next-article-command nil) - (editor-error "At end of buffer.")) - (scroll-window-down-command p window))) - -(defcommand "Netnews Go to Next Group" (p) - "Goes on to the next group in \"Netnews Group File\", setting the group - pointer for this group to the the latest message read. With an argument - does not modify the group pointer." - "Goes on to the next group in \"Netnews Group File\", setting the group - pointer for this group to the the latest message read. With an argument - does not modify the group pointer." - (nn-punt-headers (if p :none :latest))) - -(defcommand "Netnews Group Punt Messages" (p) - "Go on to the next group in \"Netnews Group File\" setting the netnews - pointer for this group to the last message. With an argument, set the - pointer to the last visible message in this group." - "Go on to the next group in \"Netnews Group File\" setting the netnews - pointer for this group to the last message. With an argument, set the - pointer to the last visible message in this group." - (nn-punt-headers (if p :last-visible :punt))) - -(defcommand "Netnews Quit Starting Here" (p) - "Go on to the next group in \"Netnews Group File\", setting the group - pointer for this group to the message before the currently displayed one - or the message under the point if none is currently displayed." - "Go on to the next group in \"Netnews Group File\", setting the group - pointer for this group to the message before the currently displayed one - or the message under the point if none is currently displayed." - (declare (ignore p)) - (nn-punt-headers :this-one)) - -(defun nn-punt-headers (pointer-type) - (let* ((headers-buffer (nn-get-headers-buffer)) - (nn-info (variable-value 'netnews-info :buffer headers-buffer)) - (stream (nn-info-header-stream nn-info))) - (message "Exiting ~A" (nn-info-current nn-info)) - (setf (nn-info-latest nn-info) - (ecase pointer-type - (:latest (nn-info-latest nn-info)) - (:punt (nn-info-last nn-info)) - (:last-visible (nn-info-last-visible nn-info)) - (:this-one - (1- (if (minusp (nn-info-current-displayed-message nn-info)) - (array-element-from-mark (buffer-point headers-buffer) - (nn-info-message-ids nn-info)) - (nn-info-current-displayed-message nn-info)))) - (:none nil))) - ;; This clears out all headers that waiting on header-stream. - ;; Must process each response in case a message is not really there. - ;; If it isn't, then the call to WITH-INPUT-FROM-NNTP will gobble up - ;; the error message and the next real article. - ;; - (when (nn-info-messages-waiting nn-info) - (dotimes (i (nn-info-batch-count nn-info)) - (let ((response (process-status-response stream))) - (when response (with-input-from-nntp (string stream)))))) - (change-to-next-group nn-info headers-buffer))) - -(defcommand "Fetch All Headers" (p) - "Fetches the rest of the headers in the current group. - Warning: This will take a while if there are a lot." - "Fetches the rest of the headers in the current group. - Warning: This will take a while if there are a lot." - (declare (ignore p)) - (let* ((headers-buffer (nn-get-headers-buffer)) - (nn-info (variable-value 'netnews-info :buffer headers-buffer))) - (if (nn-info-messages-waiting nn-info) - (message "Fetching the rest of the headers for ~A" - (nn-info-current nn-info)) - (editor-error "All headers are in buffer.")) - ;; The first of these calls writes the headers that are waiting on the - ;; headers stream and requests the rest. The second inserts the rest, if - ;; there are any. - ;; - (nn-write-headers-to-mark nn-info headers-buffer t) - (nn-write-headers-to-mark nn-info headers-buffer))) - - -(defcommand "List All Groups" (p &optional buffer) - "Shows all available newsgroups in a buffer." - "Shows all available newsgroups in a buffer." - (declare (ignore p)) - (let* ((headers-buffer (nn-get-headers-buffer)) - (nn-info (if headers-buffer - (variable-value 'netnews-info :buffer headers-buffer))) - (stream (if headers-buffer - (nn-info-stream nn-info) - (connect-to-nntp)))) - (nntp-list stream) - (message "Fetching group list...") - (process-status-response stream) - (let* ((buffer (or buffer (make-buffer (nn-new-list-newsgroups-name)))) - (point (buffer-point buffer)) - (groups (make-array 1500 :fill-pointer 0 :adjustable t))) - (with-input-from-nntp (string (if headers-buffer - (nn-info-stream nn-info) - stream)) - (vector-push-extend string groups)) - (sort groups #'string<) - (dotimes (i (length groups)) - (let ((group (aref groups i))) - (multiple-value-bind (last first) (list-response-args group) - (declare (ignore first)) - (insert-string point group 0 (position #\space group)) - (insert-string point (format nil ": ~D~%" last))))) - (setf (buffer-modified buffer) nil) - (buffer-start point) - (change-to-buffer buffer)) - (unless headers-buffer (close stream)))) - -(defun nn-new-list-newsgroups-name () - (let ((name "Newsgroups List") - (number 0)) - (declare (simple-string name) - (fixnum number)) - (loop - (unless (getstring name *buffer-names*) (return name)) - (setf name (format nil "Newsgroups List ~D" number)) - (incf number)))) - -(defhvar "Netnews Message File" - "This value is merged with your home directory to get the pathname of the - file to which Hemlock will append messages." - :value "hemlock.messages") - -(defhvar "Netnews Exit Confirm" - "When non-nil, the default, \"Netnews Exit\" will ask you if you really - want to. If this variable is NIL, you will not be prompted." - :value T) - -(defcommand "Netnews Exit" (p &optional no-prompt-p - (headers-buf (nn-get-headers-buffer))) - "Exit Netnews from a netnews headers or netnews message buffer." - "Exit Netnews from a netnews headers or netnews message buffer." - (declare (ignore p)) - (let ((browse-buffer (variable-value 'netnews-browse-buffer - :buffer headers-buf))) - (when (or browse-buffer - no-prompt-p - (not (value netnews-exit-confirm)) - (prompt-for-y-or-n :prompt "Exit Netnews? " - :default "Y" - :default-string "Y" - :help "Yes exits netnews mode.")) - (let* ((nn-info (variable-value 'netnews-info :buffer headers-buf)) - (message-buffer (nn-info-buffer nn-info)) - (headers-window (nn-info-headers-window nn-info)) - (message-window (nn-info-message-window nn-info))) - (when (nn-info-updatep nn-info) - (nn-update-database-file (nn-info-latest nn-info) - (nn-info-current nn-info))) - (when (and (eq (value netnews-read-style) :multiple) - (member headers-window *window-list*) - (member message-window *window-list*)) - (delete-window message-window)) - (when message-buffer (delete-buffer-if-possible message-buffer)) - (delete-buffer-if-possible headers-buf) - (when browse-buffer (change-to-buffer browse-buffer)))))) - - - - -;;;; Commands to append messages to a file or file messages into mail folders. - -(defcommand "Netnews Append to File" (p) - "In a \"News-Headers\" buffer, appends the message under the point onto - the file named by \"Netnews Message File\". In a \"News-Message\" buffer, - appends the message in the current buffer to the same file." - "In a \"News-Headers\" buffer, appends the message under the point onto - the file named by \"Netnews Message File\". In a \"News-Message\" buffer, - appends the message in the current buffer to the same file." - (let* ((filename (merge-pathnames (value netnews-message-file) - (user-homedir-pathname))) - (file (prompt-for-file :prompt "Append to what file: " - :must-exist nil - :default filename - :default-string (namestring filename)))) - (when (and p (probe-file file)) - (delete-file file)) - (message "Appending message to ~S" (namestring file)) - (cond ((hemlock-bound-p 'netnews-info) - (let* ((nn-info (value netnews-info)) - (stream (nn-info-stream nn-info)) - (article-number (array-element-from-mark - (current-point) - (nn-info-message-ids nn-info) - "No header under point."))) - (with-open-file (file file :direction :output - :if-exists :append - :if-does-not-exist :create) - (nntp-article article-number stream) - (process-status-response stream) - (with-input-from-nntp (string (nn-info-stream nn-info)) - (write-line string file :end (1- (length string))))))) - (t - (write-file (buffer-region (current-buffer)) file))) - ;; Put a page separator and some whitespace between messages for - ;; readability when printing or scanning. - ;; - (with-open-file (f file :direction :output :if-exists :append) - (terpri f) - (terpri f) - (write-line " -" f) - (terpri f)))) - -(defcommand "Netnews Headers File Message" (p) - "Files the message under the point into a folder of your choice. If the - folder you select does not exist, it is created." - "Files the message under the point into a folder of your choice. If the - folder you select does not exist, it is created." - (declare (ignore p)) - (nn-file-message (value netnews-info) :headers)) - -(defcommand "Netnews Message File Message" (p) - "Files the message in the current buffer into a folder of your choice. If - folder you select does not exist, it is created." - "Files the message in the current buffer into a folder of your choice. If - folder you select does not exist, it is created." - (declare (ignore p)) - (nn-file-message (variable-value 'netnews-info - :buffer (nn-get-headers-buffer)) - :message)) - -(defun nn-file-message (nn-info kind) - (let ((article-number (array-element-from-mark (current-point) - (nn-info-message-ids nn-info) - "No header under point.")) - (folder (prompt-for-folder :prompt "MH Folder: " - :must-exist nil))) - (unless (folder-existsp folder) - (if (prompt-for-y-or-n - :prompt "Destination folder doesn't exist. Create it? " - :default t :default-string "Y") - (create-folder folder) - (editor-error "Not filing message."))) - (message "Filing message into ~A" folder) - (ecase kind - (:headers (nntp-article article-number (nn-info-stream nn-info)) - (process-status-response (nn-info-stream nn-info)) - (with-open-file (s "/tmp/temp.msg" :direction :output - :if-exists :rename-and-delete - :if-does-not-exist :create) - (with-input-from-nntp (string (nn-info-stream nn-info)) - (write-line string s :end (1- (length string)))))) - (:message (write-file (buffer-region (current-buffer)) "/tmp/temp.msg" - :keep-backup nil))) - (mh "inc" `(,folder "-silent" "-file" "/tmp/temp.msg")) - (message "Done."))) - - - - -;;;; "Post" Mode and supporting commands. - -(defmode "Post" :major-p nil) - -(defun nn-unique-post-buffer-name () - (let ((name "Post") - (number 0)) - (loop - (unless (getstring name *buffer-names*) (return name)) - (setf name (format nil "Post ~D" number)) - (incf number)))) - -;;; We usually know what the subject and newsgroups are, so keep these patterns -;;; around to make finding where to insert the information easy. -;;; -(defvar *draft-subject-pattern* - (new-search-pattern :string-insensitive :forward "Subject:")) - -(defvar *draft-newsgroups-pattern* - (new-search-pattern :string-insensitive :forward "Newsgroups:")) - -(defcommand "Netnews Post Message" (p) - "Set up a buffer for posting to netnews." - "Set up a buffer for posting to netnews." - (declare (ignore p)) - (let ((headers-buf (nn-get-headers-buffer)) - (post-buf (nn-make-post-buffer))) - ;; If we're in a "News-Headers" or "News-Message" buffer, fill in the - ;; newsgroups: slot in the header. - (when headers-buf - (insert-string-after-pattern (buffer-point post-buf) - *draft-newsgroups-pattern* - (nn-info-current - (variable-value - 'netnews-info :buffer headers-buf)))) - (nn-post-message nil post-buf))) - -(defcommand "Netnews Abort Post" (p) - "Abort the current post." - "Abort the current post." - (declare (ignore p)) - (delete-buffer-if-possible (current-buffer))) - -(defun foobie-frob (post-info buffer) - (declare (ignore post-info)) - (change-to-buffer buffer)) -#| - #'(lambda (post-info buffer) - (declare (ignore post-info)) - (print :changing) (force-output) - (change-to-buffer buffer) - (print :changed) (force-output)) -|# -(defvar *netnews-post-frob-windows-hook* #'foobie-frob - "This hook is FUNCALled in NN-POST-MESSAGE with a post-info structure and - the corresponding \"POST\" buffer before a post is done.") - -;;; NN-POST-MESSAGE sets up a buffer for posting. If message buffer is -;;; supplied, it is associated with the post-info structure for the post -;;; buffer. -;;; -(defun nn-post-message (message-buffer &optional (buffer (nn-make-post-buffer))) - (setf (buffer-modified buffer) nil) - (when message-buffer - (setf (nm-info-post-buffer (variable-value 'netnews-message-info - :buffer message-buffer)) - buffer)) - (let ((post-info (make-post-info :stream (connect-to-nntp) - :headers-buffer (nn-get-headers-buffer) - :message-buffer message-buffer))) - (defhvar "Post Info" - "Information needed to manipulate post buffers." - :buffer buffer - :value post-info) - (funcall *netnews-post-frob-windows-hook* post-info buffer))) - -(defun nn-make-post-buffer () - (let* ((buffer (make-buffer (nn-unique-post-buffer-name) - :delete-hook (list #'nn-post-buffer-delete-hook))) - (stream (make-hemlock-output-stream (buffer-point buffer)))) - (setf (buffer-minor-mode buffer "Post") t) - (write-line "Newsgroups: " stream) - (write-line "Subject: " stream) -; (write-string "Date: " stream) -; (format stream "~A~%" (string-capitalize -; (format-universal-time nil (get-universal-time) -; :style :government -; :print-weekday nil))) - (write-char #\newline stream) - (write-char #\newline stream) - buffer)) - -;;; The usual again. NULLify the appropriate stream slots in associated -;;; structures. Also call NN-REPLY-CLEANUP-SPLIT-WINDOWS to see if we -;;; need to delete one of the current windows. -;;; -(defun nn-post-buffer-delete-hook (buffer) - (when (hemlock-bound-p 'post-info) - (nn-reply-cleanup-split-windows buffer) - (let* ((post-info (variable-value 'post-info :buffer buffer)) - (message-buffer (post-info-message-buffer post-info))) - (close (post-info-stream post-info)) - (when message-buffer - (setf (nm-info-post-buffer (variable-value 'netnews-message-info - :buffer message-buffer)) - nil))))) - -;;; NN-REPLY-USING-CURRENT-WINDOW makes sure there is only one window for a -;;; normal reply. *netnews-post-frob-windows-hook* is bound to this when -;;; "Netnews Reply to Group" is invoked." -;;; -(defun nn-reply-using-current-window (post-info buffer) - (declare (ignore post-info)) - ;; Make sure there is only one window in :multiple mode. - ;; - (let* ((nn-info (variable-value 'netnews-info - :buffer (nn-get-headers-buffer))) - (headers-window (nn-info-headers-window nn-info)) - (message-window (nn-info-message-window nn-info))) - (when (and (eq (value netnews-read-style) :multiple) - (member message-window *window-list*) - (member headers-window *window-list*)) - (setf (current-window) message-window) - (delete-window headers-window)) - (change-to-buffer buffer))) - -;;; NN-REPLY-IN-OTHER-WINDOW-HOOK does what NN-REPLY-USING-CURRENT-WINDOW -;;; does, but in addition splits the current window in half, displaying the -;;; message buffer on top, and the reply buffer on the bottom. Also set some -;;; slots in the post info structure so the cleanup function knowd to delete -;;; one of the two windows we've created. -;;; -(defun nn-reply-in-other-window-hook (post-info buffer) - (nn-reply-using-current-window post-info buffer) - (let* ((message-window (current-window)) - (reply-window (make-window (buffer-start-mark buffer)))) - (setf (window-buffer message-window) (post-info-message-buffer post-info) - (current-window) reply-window - (post-info-message-window post-info) message-window - (post-info-reply-window post-info) reply-window))) - -;;; NN-REPLY-CLEANUP-SPLIT-WINDOWS just deletes one of the windows that -;;; "Netnews Reply to Group in Other Window" created, if they still exist. -;;; -(defun nn-reply-cleanup-split-windows (post-buffer) - (let* ((post-info (variable-value 'post-info :buffer post-buffer)) - (message-window (post-info-message-window post-info))) - (when (and (member (post-info-reply-window post-info) *window-list*) - (member message-window *window-list*)) - (delete-window message-window)))) - -(defcommand "Netnews Reply to Group" (p) - "Set up a POST buffer and insert the proper newgroups: and subject: fields. - Should be invoked from a \"News-Message\" or \"News-Headers\" buffer. - In a message buffer, reply to the message in that buffer, in a headers - buffer, reply to the message under the point." - "Set up a POST buffer and insert the proper newgroups: and subject: fields. - Should be invoked from a \"News-Message\" or \"News-Headers\" buffer. - In a message buffer, reply to the message in that buffer, in a headers - buffer, reply to the message under the point." - (declare (ignore p)) - (let ((*netnews-post-frob-windows-hook* #'nn-reply-using-current-window)) - (nn-reply-to-message))) - -(defcommand "Netnews Reply to Group in Other Window" (p) - "Does exactly what \"Netnews Reply to Group\" does, but makes two windows. - One of the windows displays the message being replied to, and the other - displays the reply." - "Does exactly what \"Netnews Reply to Group\" does, but makes two windows. - One of the windows displays the message being replied to, and the other - displays the reply." - (declare (ignore p)) - (let ((*netnews-post-frob-windows-hook* #'nn-reply-in-other-window-hook)) - (nn-reply-to-message))) - - -(defun nn-setup-for-reply-by-mail () - (let* ((headers-buffer (nn-get-headers-buffer)) - (nn-info (variable-value 'netnews-info :buffer headers-buffer)) - (message-buffer (nn-info-buffer nn-info)) - (nm-info (variable-value 'netnews-message-info :buffer message-buffer)) - (draft-buffer (sub-setup-message-draft "comp" :to-field)) - (dinfo (variable-value 'draft-information :buffer draft-buffer))) - (setf (buffer-delete-hook draft-buffer) - (list #'cleanup-netnews-draft-buffer)) - (when (nm-info-draft-buffer nm-info) - (delete-variable 'message-buffer :buffer (nm-info-draft-buffer nm-info))) - (setf (nm-info-draft-buffer nm-info) draft-buffer) - (when headers-buffer - (defhvar "Headers Buffer" - "This is bound in message and draft buffers to their associated - headers-buffer" - :value headers-buffer :buffer draft-buffer)) - (setf (draft-info-headers-mark dinfo) - (copy-mark (buffer-point headers-buffer))) - (defhvar "Message Buffer" - "This is bound in draft buffers to their associated message buffer." - :value message-buffer :buffer draft-buffer) - (values draft-buffer message-buffer))) - - -(defcommand "Netnews Forward Message" (p) - "Creates a Draft buffer and places a copy of the current message in - it, delimited by forwarded message markers." - "Creates a Draft buffer and places a copy of the current message in - it, delimited by forwarded message markers." - (declare (ignore p)) - (multiple-value-bind (draft-buffer message-buffer) - (nn-setup-for-reply-by-mail) - (with-mark ((mark (buffer-point draft-buffer) :left-inserting)) - (buffer-end mark) - (insert-string mark (format nil "~%------- Forwarded Message~%~%")) - (insert-string mark (format nil "~%------- End of Forwarded Message~%")) - (line-offset mark -2 0) - (insert-region mark (buffer-region message-buffer))) - (nn-reply-using-current-window nil draft-buffer))) - - -(defun nn-reply-to-sender () - (let* ((headers-buffer (nn-get-headers-buffer)) - (nn-info (variable-value 'netnews-info :buffer headers-buffer)) - (article (if (and (hemlock-bound-p 'netnews-info) - (minusp (nn-info-current-displayed-message - nn-info))) - (nn-put-article-in-buffer nn-info headers-buffer) - (nn-info-current-displayed-message nn-info)))) - (multiple-value-bind (draft-buffer message-buffer) - (nn-setup-for-reply-by-mail) - (let ((point (buffer-point draft-buffer)) - (to-field (or (nn-get-one-field nn-info "Reply-To" article) - (nn-get-one-field nn-info "From" article)))) - (insert-string-after-pattern point - *draft-to-pattern* - to-field - :end (1- (length to-field))) - (let ((subject-field (nn-subject-replyify - (nn-get-one-field nn-info "Subject" article)))) - (insert-string-after-pattern point - *draft-subject-pattern* - subject-field - :end (1- (length subject-field))))) - (nn-reply-using-current-window nil draft-buffer) - (values draft-buffer message-buffer)))) - -(defcommand "Netnews Reply to Sender" (p) - "Reply to the sender of a message via mail using the Hemlock mailer." - "Reply to the sender of a message via mail using the Hemlock mailer." - (declare (ignore p)) - (nn-reply-to-sender)) - -(defcommand "Netnews Reply to Sender in Other Window" (p) - "Reply to the sender of a message via mail using the Hemlock mailer. The - screen will be split in half, displaying the post and the draft being - composed." - "Reply to the sender of a message via mail using the Hemlock mailer. The - screen will be split in half, displaying the post and the draft being - composed." - (declare (ignore p)) - (multiple-value-bind (draft-buffer message-buffer) - (nn-reply-to-sender) - (let* ((message-window (current-window)) - (reply-window (make-window (buffer-start-mark draft-buffer)))) - (defhvar "Split Window Draft" - "Indicates window needs to be cleaned up for draft." - :value t :buffer draft-buffer) - (setf (window-buffer message-window) message-buffer - (current-window) reply-window)))) - -;;; CLEANUP-NETNEWS-DRAFT-BUFFER replaces the normal draft buffer delete hook -;;; because the generic one tries to set some slots in the related message-info -;;; structure which doesn't exist. This function just sets the draft buffer -;;; slot of netnews-message-info to nil so it won't screw you when you try -;;; to change to the associated draft buffer. -;;; -(defun cleanup-netnews-draft-buffer (buffer) - (when (hemlock-bound-p 'message-buffer :buffer buffer) - (setf (nm-info-draft-buffer - (variable-value 'netnews-message-info - :buffer (variable-value 'message-buffer - :buffer buffer))) - nil))) - -;;; NN-REPLYIFY-SUBJECT simply adds "Re: " to the front of a string if it is -;;; not already there. -;;; -(defun nn-subject-replyify (subject) - (if (>= (length subject) 3) - (if (not (string= subject "Re:" :end1 3 :end2 3)) - (concatenate 'simple-string "Re: " subject) - subject) - (concatenate 'simple-string "Re: " subject))) - -(defun insert-string-after-pattern (mark search-pattern string - &key (start 0) (end (length string))) - (buffer-start mark) - (when (and (plusp end) - (find-pattern mark search-pattern)) - (insert-string (line-end mark) string start end)) - (buffer-end mark)) - -(defun nn-reply-to-message () - (let* ((headers-buffer (nn-get-headers-buffer)) - (nn-info (variable-value 'netnews-info :buffer headers-buffer)) - (article (if (and (hemlock-bound-p 'netnews-info) - (minusp (nn-info-current-displayed-message nn-info))) - (nn-put-article-in-buffer nn-info headers-buffer) - (nn-info-current-displayed-message nn-info))) - (post-buffer (nn-make-post-buffer)) - (point (buffer-point post-buffer))) - - (let ((groups-field (nn-get-one-field nn-info "Newsgroups" article))) - (insert-string-after-pattern point - *draft-newsgroups-pattern* - groups-field - :end (1- (length groups-field)))) - (let ((subject-field (nn-subject-replyify - (nn-get-one-field nn-info "Subject" article)))) - (insert-string-after-pattern point - *draft-subject-pattern* - subject-field - :end (1- (length subject-field)))) - (nn-post-message (nn-info-buffer nn-info) post-buffer))) - -(defun nn-get-one-field (nn-info field article) - (cdr (assoc field (svref (nn-info-header-cache nn-info) - (- article (nn-info-first nn-info))) - :test #'string-equal))) - -(defvar *nntp-timeout-handler* 'nn-recover-from-timeout - "This function gets FUNCALled when NNTP times out on us with the note passed - to PROCESS-STATUS-RESPONSE. The default assumes the note is an NN-INFO - structure and tries to recover from the timeout.") - -(defvar *nn-last-command-issued* nil - "The last string issued to one of the NNTP streams. Used to recover from - a nntp timeout.") - -;;; NN-RECOVER-FROM-POSTING-TIMEOUT is the recover method used when posting. -;;; It just resets the value of \"NNTP Stream\" and issues the last command -;;; again. -;;; -(defun nn-recover-from-posting-timeout (ignore) - (declare (ignore ignore)) - (let ((stream (connect-to-nntp))) - (setf (post-info-stream (value post-info)) stream) - (write-nntp-command *nn-last-command-issued* stream :recover) - (process-status-response stream))) - -(defhvar "Netnews Reply Address" - "What the From: field will be when you post messages. If this is nil, - the From: field will be determined using the association of :USER - in *environment-list* and your machine name." - :value NIL) - -(defhvar "Netnews Signature Filename" - "This value is merged with your home directory to get the pathname your - signature, which is appended to every post you make." - :value ".hemlock-sig") - -(defhvar "Netnews Deliver Post Confirm" - "This determines whether Netnews Deliver Post will ask for confirmation - before posting the current message." - :value t) - -(defcommand "Netnews Deliver Post" (p) - "Deliver the current Post buffer to the NNTP server. If the file named by - the value of \"Netnews Signature Filename\" exists, it is appended to the - end of the message after adding a newline." - "Deliver the current Post buffer to the NNTP server, cleaning up any windows - we need and landing us in the headers buffer if this was a reply." - (declare (ignore p)) - (when (or (not (value netnews-deliver-post-confirm)) - (prompt-for-y-or-n :prompt "Post message? " :default t)) - (let* ((*nntp-timeout-handler* #'nn-recover-from-posting-timeout) - (stream (post-info-stream (value post-info)))) - (nntp-post stream) - (let ((winp (process-status-response stream)) - ;; Rebind stream here because the stream may have been pulled out - ;; from under us by an NNTP timeout. The recover method for posting - ;; resets the Hemlock Variable. - (stream (post-info-stream (value post-info)))) - (unless winp (editor-error "Posting prohibited in this group.")) - (let ((buffer (current-buffer)) - (username (value netnews-reply-address))) - (nn-write-line (format nil "From: ~A" - (if username - username - (string-downcase - (format nil "~A@~A" - (cdr (assoc :user - ext:*environment-list*)) - (machine-instance))))) - stream) - (filter-region #'(lambda (string) - (when (string= string ".") - (write-char #\. stream)) - (nn-write-line string stream)) - (buffer-region buffer)) - ;; Append signature - ;; - (let ((filename (merge-pathnames (value netnews-signature-filename) - (user-homedir-pathname)))) - (when (probe-file filename) - (with-open-file (istream filename :direction :input) - (loop - (let ((line (read-line istream nil nil))) - (unless line (return)) - (nn-write-line line stream)))))) - (write-line nntp-eof stream) - (delete-buffer-if-possible buffer) - (let ((headers-buffer (nn-get-headers-buffer))) - (when headers-buffer (change-to-buffer headers-buffer))) - (message "Message Posted.")))))) - -(defun nn-write-line (line stream) - (write-string line stream) - (write-char #\return stream) - (write-char #\newline stream) - line) - - - - -;;;; News-Browse mode. - -(defmode "News-Browse" :major-p t) - -(defhvar "Netnews Group File" - "If the value of \"Netnews Groups\" is nil, \"Netnews\" merges this - variable with your home directory and looks there for a list of newsgroups - (one per line) to read. Groups may be added using \"Netnews Browse\ and - related commands, or by editing this file." - :value ".hemlock-groups") - -(defcommand "Netnews Browse" (p) - "Puts all netnews groups in a buffer and provides commands for reading them - and adding them to the file specified by the merge of \"Netnews Group File\" - and your home directory." - "Puts all netnews groups in a buffer and provides commands for reading them - and adding them to the file specified by the merge of \"Netnews Group File\" - and your home directory." - (declare (ignore p)) - (let ((buffer (make-buffer "Netnews Browse"))) - (cond (buffer - (list-all-groups-command nil buffer) - (setf (buffer-major-mode buffer) "News-Browse") - (setf (buffer-writable buffer) nil)) - (t (change-to-buffer (getstring "Netnews Browse" *buffer-names*)))))) - -(defcommand "Netnews Quit Browse" (p) - "Exit News-Browse Mode." - "Exit News-Browse Mode." - (declare (ignore p)) - (delete-buffer-if-possible (current-buffer))) - -(defcommand "Netnews Browse Read Group" (p &optional (mark (current-point))) - "Read the group on the line under the current point paying no attention to - the \"Hemlock Database File\" entry for this group. With an argument, use - and modify the database file." - "Read the group on the line under the current point paying no attention to - the \"Hemlock Database File\" entry for this group. With an argument, use - and modify the database file." - (let ((group-info-string (line-string (mark-line mark)))) - (netnews-command nil (subseq group-info-string - 0 (position #\: group-info-string)) - nil (current-buffer) p))) - -(defcommand "Netnews Browse Pointer Read Group" (p) - "Read the group on the line where you just clicked paying no attention to the - \"Hemlock Databse File\" entry for this group. With an argument, use and - modify the databse file." - "Read the group on the line where you just clicked paying no attention to the - \"Hemlock Databse File\" entry for this group. With an argument, use and - modify the databse file." - (multiple-value-bind (x y window) (last-key-event-cursorpos) - (unless window (editor-error "Couldn't figure out where last click was.")) - (unless y (editor-error "There is no group in the modeline.")) - (netnews-browse-read-group-command p (cursorpos-to-mark x y window)))) - -(defcommand "Netnews Browse Add Group to File" (p &optional - (mark (current-point))) - "Append the newsgroup on the line under the point to the file specified by - \"Netnews Group File\". With an argument, delete all groups that were - there to start with." - "Append the newsgroup on the line under the point to the file specified by - \"Netnews Group File\". With an argument, delete all groups that were - there to start with." - (declare (ignore p)) - (let* ((group-info-string (line-string (mark-line mark))) - (group (subseq group-info-string 0 (position #\: group-info-string)))) - (with-open-file (s (merge-pathnames (value netnews-group-file) - (user-homedir-pathname)) - :direction :output - :if-exists :append - :if-does-not-exist :create) - (write-line group s)) - (message "Adding ~S to newsgroup file." group))) - -(defcommand "Netnews Browse Pointer Add Group to File" (p) - "Append the newsgroup you just clicked on to the file specified by - \"Netnews Group File\"." - "Append the newsgroup you just clicked on to the file specified by - \"Netnews Group File\"." - (declare (ignore p)) - (multiple-value-bind (x y window) (last-key-event-cursorpos) - (unless window (editor-error "Couldn't figure out where last click was.")) - (unless y (editor-error "There is no group in the modeline.")) - (netnews-browse-add-group-to-file-command - nil (cursorpos-to-mark x y window)))) - - - - -;;;; Low-level stream operations. - -(defun streams-for-nntp () - (clear-echo-area) - (format *echo-area-stream* "Connecting to NNTP...~%") - (force-output *echo-area-stream*) - (values (connect-to-nntp) (connect-to-nntp))) - - -(defparameter *nntp-port* 119 - "The nntp port number for NNTP as specified in RFC977.") - -(defhvar "Netnews NNTP Server" - "The hostname of the NNTP server to use for reading Netnews." - :value "netnews.srv.cs.cmu.edu") - -(defhvar "Netnews NNTP Timeout Period" - "The number of seconds to wait before timing out when trying to connect - to the NNTP server." - :value 30) - -(defun raw-connect-to-nntp () - (let ((stream (system:make-fd-stream - (ext:connect-to-inet-socket (value netnews-nntp-server) - *nntp-port*) - :input t :output t :buffering :line :name "NNTP" - :timeout (value netnews-nntp-timeout-period)))) - (process-status-response stream) - stream)) - -(defun connect-to-nntp () - (handler-case - (raw-connect-to-nntp) - (io-timeout () - (editor-error "Connection to NNTP timed out. Try again later.")))) - -(defvar *nn-last-command-type* nil - "Used to recover from a nntp timeout.") - -(defun write-nntp-command (command stream type) - (setf *nn-last-command-type* type) - (setf *nn-last-command-issued* command) - (write-string command stream) - (write-char #\return stream) - (write-char #\newline stream) - (force-output stream)) - - - - -;;;; PROCESS-STATUS-RESPONSE and NNTP error handling. - -(defconstant nntp-error-codes '(#\4 #\5) - "These codes signal that NNTP could not complete the request you asked for.") - -(defvar *nntp-error-handlers* nil) - -;;; PROCESS-STATUS-RESPONSE makes sure a response waiting at the server is -;;; valid. If the response code starts with a 4 or 5, then look it up in -;;; *nntp-error-handlers*. If an error handler is defined, then FUNCALL it -;;; on note. Otherwise editor error. If the response is not an error code, -;;; then just return what NNTP returned to us for parsing later. -;;; -(defun process-status-response (stream &optional note) - (let ((str (read-line stream))) - (if (member (schar str 0) nntp-error-codes :test #'char=) - (let ((error-handler (cdr (assoc str *nntp-error-handlers* - :test #'(lambda (string1 string2) - (string= string1 string2 - :end1 3 - :end2 3)))))) - (unless error-handler - (error "NNTP error -- ~A" (subseq str 4 (1- (length str))))) - (funcall error-handler note)) - str))) - -(defun nn-recover-from-timeout (nn-info) - (message "NNTP timed out, attempting to reconnect and continue...") - (let ((stream (nn-info-stream nn-info)) - (header-stream (nn-info-header-stream nn-info))) - ;; If some messages are waiting on the header stream, insert them. - ;; - (when (listen header-stream) - (nn-write-headers-to-mark nn-info (nn-get-headers-buffer))) - (close stream) - (close header-stream) - (setf stream (connect-to-nntp) - header-stream (connect-to-nntp) - (nn-info-stream nn-info) stream - (nn-info-header-stream nn-info) header-stream) - (let ((last-command *nn-last-command-issued*) - (last-command-type *nn-last-command-type*) - (current (nn-info-current nn-info))) - (nntp-group current stream header-stream) - (process-status-response stream) - (process-status-response header-stream) - (if (consp last-command) - (let ((stream-type (car last-command))) - (apply #'nn-send-many-head-requests - (cons (if (eq stream-type :header) header-stream stream) - (cdr last-command)))) - (ecase last-command-type - ((:list :article :body) - (write-nntp-command last-command stream :recover) - (process-status-response stream)) - ((:header-group :normal-group) - (write-nntp-command last-command stream :recover) - (write-nntp-command last-command header-stream :recover))))))) - -;;; DEF-NNTP-ERROR-HANDLER takes a code and a function and associates the two -;;; in *nntp-error-handlers*. If while PROCESSING a STATUS RESPONSE we come -;;; across one of these error codes, then FUNCALL the appropriate handler. -;;; -(defun def-nntp-error-handler (code function) - (pushnew (cons (format nil "~D" code) function) *nntp-error-handlers*)) - -;;; 503 is an NNTP timeout. The code I wrote reconnects and recovers -;;; completely. -;;; -(def-nntp-error-handler 503 #'(lambda (note) - (funcall *nntp-timeout-handler* note))) - -;;; 400 means NNTP is cutting us of for some reason. There is really nothing -;;; we can do. -;;; -(def-nntp-error-handler 400 #'(lambda (ignore) - (declare (ignore ignore)) - (editor-error "NNTP discontinued service. ~ - You should probably quit netnews and try ~ - again later."))) - -;;; Some functions just need to know that something went wrong so they can -;;; do something about it, so let them know by returning nil. -;;; -;;; 411 - The group you tried to read is not a netnews group. -;;; 423 - You requested a message that wasn't really there. -;;; 440 - Posting is not allowed. -;;; 441 - Posting is allowed, but the attempt failed for some other reason. -;;; -(flet ((nil-function (ignore) - (declare (ignore ignore)) - nil)) - (def-nntp-error-handler 423 #'nil-function) - (def-nntp-error-handler 411 #'nil-function) - (def-nntp-error-handler 440 #'nil-function) - (def-nntp-error-handler 441 #'nil-function)) - - - - -;;;; Implementation of NNTP response argument parsing. - -;;; DEF-NNTP-ARG-PARSER returns a form that parses a string for arguments -;;; corresponding to each element of types. For instance, if types is -;;; (:integer :string :integer :integer), this function returns a form that -;;; parses an integer, a string, and two more integers out of an nntp status -;;; response. -;;; -(defmacro def-nntp-arg-parser (types) - (let ((form (gensym)) - (start (gensym)) - (res nil)) - (do ((type types (cdr type))) - ((endp type) form) - (ecase (car type) - (:integer - (push `(parse-integer string :start ,start - :end (setf ,start - (position #\space string - :start (1+ ,start))) - :junk-allowed t) - res)) - (:string - (push `(subseq string (1+ ,start) - (position #\space string - :start (setf ,start (1+ ,start)))) - res)))) - `(let ((,start (position #\space string))) - (values ,@(nreverse res))))) - -(defun def-nntp-xhdr-arg-parser (string) - (let ((position (position #\space string))) - (values (subseq string (1+ position)) - (parse-integer string :start 0 :end position)))) - -(defun xhdr-response-args (string) - (def-nntp-xhdr-arg-parser string)) - -;;; GROUP-RESPONSE-ARGS, ARTICLER-RESPONSE-ARGS, HEAD-RESPONSE-ARGS, -;;; BODY-RESPONSE-ARGS, and STAT-RESPONSE-ARGS define NNTP argument parsers -;;; for the types of arguments each command will return. -;;; -(defun group-response-args (string) - "Group response args are an estimate of how many messages there are, the - number of the first message, the number of the last message, and \"y\" - or \"n\", indicating whether the user has rights to post in this group." - (def-nntp-arg-parser (:integer :integer :integer))) - -(defun list-response-args (string) - (def-nntp-arg-parser (:integer :integer))) - -(defun article-response-args (string) - "Article response args are the message number and the message ID." - (def-nntp-arg-parser (:integer :string))) - -(defun head-response-args (string) - "Head response args are the message number and the message ID." - (def-nntp-arg-parser (:integer :string))) - -(defun body-response-args (string) - "Body response args are the message number and the message ID." - (def-nntp-arg-parser (:integer :string))) - -(defun stat-response-args (string) - "Stat response args are the message number and the message ID." - (def-nntp-arg-parser (:integer :string))) - - - - -;;;; Functions that send standard NNTP commands. - -;;; NNTP-XHDR sends an XHDR command to the NNTP server. We think this is a -;;; local extension, but not using it is not pragmatic. It takes over three -;;; minutes to HEAD every message in a newsgroup. -;;; -(defun nntp-xhdr (field start end stream) - (write-nntp-command (format nil "xhdr ~A ~D-~D" - field - (if (numberp start) start (parse-integer start)) - (if (numberp end) end (parse-integer end))) - stream - :xhdr)) - -(defun nntp-group (group-name stream header-stream) - (let ((command (concatenate 'simple-string "group " group-name))) - (write-nntp-command command stream :normal-group) - (write-nntp-command command header-stream :header-group))) - -(defun nntp-list (stream) - (write-nntp-command "list" stream :list)) - -(defun nntp-head (article stream) - (write-nntp-command (format nil "head ~D" article) stream :head)) - -(defun nntp-article (number stream) - (write-nntp-command (format nil "article ~D" number) stream :article)) - -(defun nntp-body (number stream) - (write-nntp-command (format nil "body ~D" number) stream :body)) - -(defun nntp-post (stream) - (write-nntp-command "post" stream :post)) Index: anches/ide-1.0/ccl/hemlock/src/pascal.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/pascal.lisp (revision 6566) +++ (revision ) @@ -1,46 +1,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock -*- -;;; -;;; ********************************************************************** -;;; This code was written as part of the CMU Common Lisp project at -;;; Carnegie Mellon University, and has been placed in the public domain. -;;; -#+CMU (ext:file-comment - "$Header$") -;;; -;;; ********************************************************************** -;;; -;;; Just barely enough to be a Pascal/C mode. Maybe more some day. -;;; -(in-package :hemlock) - -(defmode "Pascal" :major-p t) -(defcommand "Pascal Mode" (p) - "Put the current buffer into \"Pascal\" mode." - "Put the current buffer into \"Pascal\" mode." - (declare (ignore p)) - (setf (buffer-major-mode (current-buffer)) "Pascal")) - -(defhvar "Indent Function" - "Indentation function which is invoked by \"Indent\" command. - It must take one argument that is the prefix argument." - :value #'generic-indent - :mode "Pascal") - -(defhvar "Auto Fill Space Indent" - "When non-nil, uses \"Indent New Comment Line\" to break lines instead of - \"New Line\"." - :mode "Pascal" :value t) - -(defhvar "Comment Start" - "String that indicates the start of a comment." - :mode "Pascal" :value "(*") - -(defhvar "Comment End" - "String that ends comments. Nil indicates #\newline termination." - :mode "Pascal" :value " *)") - -(defhvar "Comment Begin" - "String that is inserted to begin a comment." - :mode "Pascal" :value "(* ") - -(shadow-attribute :scribe-syntax #\< nil "Pascal") Index: anches/ide-1.0/ccl/hemlock/src/rcs.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/rcs.lisp (revision 6566) +++ (revision ) @@ -1,526 +1,0 @@ -;;; -*- Package: HEMLOCK; Mode: Lisp -*- -;;; -;;; $Header$ -;;; -;;; Various commands for dealing with RCS under Hemlock. -;;; -;;; Written by William Lott and Christopher Hoover. -;;; -(in-package :hemlock) - - - -;;;; - -(defun current-buffer-pathname () - (let ((pathname (buffer-pathname (current-buffer)))) - (unless pathname - (editor-error "The buffer has no pathname.")) - pathname)) - - -(defmacro in-directory (directory &body forms) - (let ((cwd (gensym))) - `(let ((,cwd (ext:default-directory))) - (unwind-protect - (progn - (setf (ext:default-directory) (directory-namestring ,directory)) - ,@forms) - (setf (ext:default-directory) ,cwd))))) - - -(defvar *last-rcs-command-name* nil) -(defvar *last-rcs-command-output-string* nil) -(defvar *rcs-output-stream* (make-string-output-stream)) - -(defmacro do-command (command &rest args) - `(progn - (setf *last-rcs-command-name* ',command) - (get-output-stream-string *rcs-output-stream*) - (let ((process (ext:run-program ',command ,@args - :error *rcs-output-stream*))) - (setf *last-rcs-command-output-string* - (get-output-stream-string *rcs-output-stream*)) - (case (ext:process-status process) - (:exited - (unless (zerop (ext:process-exit-code process)) - (editor-error "~A aborted with an error; ~ - use the ``RCS Last Command Output'' command for ~ - more information" ',command))) - (:signaled - (editor-error "~A killed with signal ~A~@[ (core dumped)]." - ',command - (ext:process-exit-code process) - (ext:process-core-dumped process))) - (t - (editor-error "~S still alive?" process)))))) - -(defun buffer-different-from-file (buffer filename) - (with-open-file (file filename) - (do ((buffer-line (mark-line (buffer-start-mark buffer)) - (line-next buffer-line)) - (file-line (read-line file nil nil) - (read-line file nil nil))) - ((and (or (null buffer-line) - (zerop (line-length buffer-line))) - (null file-line)) - nil) - (when (or (null buffer-line) - (null file-line) - (string/= (line-string buffer-line) file-line)) - (return t))))) - -(defun turn-auto-save-off (buffer) - (setf (buffer-minor-mode buffer "Save") nil) - ;; - ;; William's personal hack - (when (getstring "Ckp" *mode-names*) - (setf (buffer-minor-mode buffer "Ckp") nil))) - - -(defhvar "RCS Lock File Hook" - "RCS Lock File Hook" - :value nil) - -(defun rcs-lock-file (buffer pathname) - (message "Locking ~A ..." (namestring pathname)) - (in-directory pathname - (let ((file (file-namestring pathname))) - (do-command "rcs" `("-l" ,file)) - (multiple-value-bind (won dev ino mode) (unix:unix-stat file) - (declare (ignore ino)) - (cond (won - (unix:unix-chmod file (logior mode unix:writeown))) - (t - (editor-error "UNIX:UNIX-STAT lost in RCS-LOCK-FILE: ~A" - (unix:get-unix-error-msg dev))))))) - (invoke-hook rcs-lock-file-hook buffer pathname)) - - -(defhvar "RCS Unlock File Hook" - "RCS Unlock File Hook" - :value nil) - -(defun rcs-unlock-file (buffer pathname) - (message "Unlocking ~A ..." (namestring pathname)) - (in-directory pathname - (do-command "rcs" `("-u" ,(file-namestring pathname)))) - (invoke-hook rcs-unlock-file-hook buffer pathname)) - - - -;;;; Check In - -(defhvar "RCS Check In File Hook" - "RCS Check In File Hook" - :value nil) - -(defhvar "RCS Keep Around After Unlocking" - "If non-NIL (the default) keep the working file around after unlocking it. - When NIL, the working file and buffer are deleted." - :value t) - -(defun rcs-check-in-file (buffer pathname keep-lock) - (let ((old-buffer (current-buffer)) - (allow-delete nil) - (log-buffer nil)) - (unwind-protect - (when (block in-recursive-edit - (do ((i 0 (1+ i))) - ((not (null log-buffer))) - (setf log-buffer - (make-buffer - (format nil "RCS Log Entry ~D for ~S" i - (file-namestring pathname)) - :modes '("Text") - :delete-hook - (list #'(lambda (buffer) - (declare (ignore buffer)) - (unless allow-delete - (return-from in-recursive-edit t))))))) - (turn-auto-save-off log-buffer) - (change-to-buffer log-buffer) - (do-recursive-edit) - - (message "Checking in ~A~:[~; keeping the lock~] ..." - (namestring pathname) keep-lock) - (let ((log-stream (make-hemlock-region-stream - (buffer-region log-buffer)))) - (sub-check-in-file pathname buffer keep-lock log-stream)) - (invoke-hook rcs-check-in-file-hook buffer pathname) - nil) - (editor-error "Someone deleted the RCS Log Entry buffer.")) - (when (member old-buffer *buffer-list*) - (change-to-buffer old-buffer)) - (setf allow-delete t) - (delete-buffer-if-possible log-buffer)))) - -(defun sub-check-in-file (pathname buffer keep-lock log-stream) - (let* ((filename (file-namestring pathname)) - (rcs-filename (concatenate 'simple-string - "./RCS/" filename ",v")) - (keep-working-copy (or keep-lock - (not (hemlock-bound-p - 'rcs-keep-around-after-unlocking - :buffer buffer)) - (variable-value - 'rcs-keep-around-after-unlocking - :buffer buffer)))) - (in-directory pathname - (do-command "ci" `(,@(if keep-lock '("-l")) - ,@(if keep-working-copy '("-u")) - ,filename) - :input log-stream) - (if keep-working-copy - ;; - ;; Set the times on the user's file to be equivalent to that of - ;; the rcs file. - #-(or hpux svr4) - (multiple-value-bind - (dev ino mode nlink uid gid rdev size atime mtime) - (unix:unix-stat rcs-filename) - (declare (ignore mode nlink uid gid rdev size)) - (cond (dev - (multiple-value-bind - (wonp errno) - (unix:unix-utimes filename atime 0 mtime 0) - (unless wonp - (editor-error "UNIX:UNIX-UTIMES failed: ~A" - (unix:get-unix-error-msg errno))))) - (t - (editor-error "UNIX:UNIX-STAT failed: ~A" - (unix:get-unix-error-msg ino))))) - (delete-buffer-if-possible buffer))))) - - - - -;;;; Check Out - -(defhvar "RCS Check Out File Hook" - "RCS Check Out File Hook" - :value nil) - -(defvar *translate-file-names-before-locking* nil) - -(defun maybe-rcs-check-out-file (buffer pathname lock always-overwrite-p) - (when (and lock *translate-file-names-before-locking*) - (multiple-value-bind (unmatched-dir new-dirs file-name) - (maybe-translate-definition-file pathname) - (when new-dirs - (let ((new-name (translate-definition-file unmatched-dir - (car new-dirs) - file-name))) - (when (probe-file (directory-namestring new-name)) - (setf pathname new-name)))))) - (cond - ((and (not always-overwrite-p) - (let ((pn (probe-file pathname))) - (and pn (hemlock-ext:file-writable pn)))) - ;; File exists and is writable so check and see if the user really - ;; wants to check it out. - (command-case (:prompt - (format nil "The file ~A is writable. Overwrite? " - (file-namestring pathname)) - :help - "Type one of the following single-character commands:") - ((:yes :confirm) - "Overwrite the file." - (rcs-check-out-file buffer pathname lock)) - (:no - "Don't check it out after all.") - ((#\r #\R) - "Rename the file before checking it out." - (let ((new-pathname (prompt-for-file - :prompt "New Filename: " - :default (buffer-default-pathname - (current-buffer)) - :must-exist nil))) - (rename-file pathname new-pathname) - (rcs-check-out-file buffer pathname lock))))) - (t - (rcs-check-out-file buffer pathname lock))) - pathname) - -(defun rcs-check-out-file (buffer pathname lock) - (message "Checking out ~A~:[~; with a lock~] ..." (namestring pathname) lock) - (in-directory pathname - (let* ((file (file-namestring pathname)) - (backup (if (probe-file file) - (lisp::pick-backup-name file)))) - (when backup (rename-file file backup)) - (do-command "co" `(,@(if lock '("-l")) ,file)) - (invoke-hook rcs-check-out-file-hook buffer pathname) - (when backup (delete-file backup))))) - - - -;;;; Last Command Output - -(defcommand "RCS Last Command Output" (p) - "Print the full output of the last RCS command." - "Print the full output of the last RCS command." - (declare (ignore p)) - (unless (and *last-rcs-command-name* *last-rcs-command-output-string*) - (editor-error "No RCS commands have executed!")) - (with-pop-up-display (s :buffer-name "*RCS Command Output*") - (format s "Output from ``~A'':~%~%" *last-rcs-command-name*) - (write-line *last-rcs-command-output-string* s))) - - - -;;;; Commands for Checking In / Checking Out and Locking / Unlocking - -(defun pick-temp-file (defaults) - (let ((index 0)) - (loop - (let ((name (merge-pathnames (format nil ",rcstmp-~D" index) defaults))) - (cond ((probe-file name) - (incf index)) - (t - (return name))))))) - -(defcommand "RCS Lock Buffer File" (p) - "Attempt to lock the file in the current buffer." - "Attempt to lock the file in the current buffer." - (declare (ignore p)) - (let ((file (current-buffer-pathname)) - (buffer (current-buffer)) - (name (pick-temp-file "/tmp/"))) - (rcs-lock-file buffer file) - (unwind-protect - (progn - (in-directory file - (do-command "co" `("-p" ,(file-namestring file)) - :output (namestring name))) - (when (buffer-different-from-file buffer name) - (message - "RCS file is different; be sure to merge in your changes.")) - (setf (buffer-writable buffer) t) - (message "Buffer is now writable.")) - (when (probe-file name) - (delete-file name))))) - -(defcommand "RCS Lock File" (p) - "Prompt for a file, and attempt to lock it." - "Prompt for a file, and attempt to lock it." - (declare (ignore p)) - (rcs-lock-file nil (prompt-for-file :prompt "File to lock: " - :default (buffer-default-pathname - (current-buffer)) - :must-exist nil))) - -(defcommand "RCS Unlock Buffer File" (p) - "Unlock the file in the current buffer." - "Unlock the file in the current buffer." - (declare (ignore p)) - (rcs-unlock-file (current-buffer) (current-buffer-pathname)) - (setf (buffer-writable (current-buffer)) nil) - (message "Buffer is no longer writable.")) - -(defcommand "RCS Unlock File" (p) - "Prompt for a file, and attempt to unlock it." - "Prompt for a file, and attempt to unlock it." - (declare (ignore p)) - (rcs-unlock-file nil (prompt-for-file :prompt "File to unlock: " - :default (buffer-default-pathname - (current-buffer)) - :must-exist nil))) - -(defcommand "RCS Check In Buffer File" (p) - "Checkin the file in the current buffer. With an argument, do not - release the lock." - "Checkin the file in the current buffer. With an argument, do not - release the lock." - (let ((buffer (current-buffer)) - (pathname (current-buffer-pathname))) - (when (buffer-modified buffer) - (save-file-command nil)) - (rcs-check-in-file buffer pathname p) - (when (member buffer *buffer-list*) - ;; If the buffer has not been deleted, make sure it is up to date - ;; with respect to the file. - (visit-file-command nil pathname buffer)))) - -(defcommand "RCS Check In File" (p) - "Prompt for a file, and attempt to check it in. With an argument, do - not release the lock." - "Prompt for a file, and attempt to check it in. With an argument, do - not release the lock." - (rcs-check-in-file nil (prompt-for-file :prompt "File to lock: " - :default - (buffer-default-pathname - (current-buffer)) - :must-exist nil) - p)) - -(defcommand "RCS Check Out Buffer File" (p) - "Checkout the file in the current buffer. With an argument, lock the - file." - "Checkout the file in the current buffer. With an argument, lock the - file." - (let* ((buffer (current-buffer)) - (pathname (current-buffer-pathname)) - (point (current-point)) - (lines (1- (count-lines (region (buffer-start-mark buffer) point))))) - (when (buffer-modified buffer) - (when (not (prompt-for-y-or-n :prompt "Buffer is modified, overwrite? ")) - (editor-error "Aborted."))) - (setf (buffer-modified buffer) nil) - (setf pathname (maybe-rcs-check-out-file buffer pathname p nil)) - (when p - (setf (buffer-writable buffer) t) - (message "Buffer is now writable.")) - (visit-file-command nil pathname) - (unless (line-offset point lines) - (buffer-end point)))) - -(defcommand "RCS Check Out File" (p) - "Prompt for a file and attempt to check it out. With an argument, - lock the file." - "Prompt for a file and attempt to check it out. With an argument, - lock the file." - (let ((pathname (prompt-for-file :prompt "File to check out: " - :default (buffer-default-pathname - (current-buffer)) - :must-exist nil))) - (setf pathname (maybe-rcs-check-out-file nil pathname p nil)) - (find-file-command nil pathname))) - - - -;;;; Log File - -(defhvar "RCS Log Entry Buffer" - "Name of the buffer to put RCS log entries into." - :value "RCS Log") - -(defhvar "RCS Log Buffer Hook" - "RCS Log Buffer Hook" - :value nil) - -(defun get-log-buffer () - (let ((buffer (getstring (value rcs-log-entry-buffer) *buffer-names*))) - (unless buffer - (setf buffer (make-buffer (value rcs-log-entry-buffer))) - (turn-auto-save-off buffer) - (invoke-hook rcs-log-buffer-hook buffer)) - buffer)) - -(defcommand "RCS Buffer File Log Entry" (p) - "Get the RCS Log for the file in the current buffer in a buffer." - "Get the RCS Log for the file in the current buffer in a buffer." - (declare (ignore p)) - (let ((buffer (get-log-buffer)) - (pathname (current-buffer-pathname))) - (delete-region (buffer-region buffer)) - (message "Extracting log info ...") - (with-mark ((mark (buffer-start-mark buffer) :left-inserting)) - (in-directory pathname - (do-command "rlog" (list (file-namestring pathname)) - :output (make-hemlock-output-stream mark)))) - (change-to-buffer buffer) - (buffer-start (current-point)) - (setf (buffer-modified buffer) nil))) - -(defcommand "RCS File Log Entry" (p) - "Prompt for a file and get its RCS log entry in a buffer." - "Prompt for a file and get its RCS log entry in a buffer." - (declare (ignore p)) - (let ((file (prompt-for-file :prompt "File to get log of: " - :default (buffer-default-pathname - (current-buffer)) - :must-exist nil)) - (buffer (get-log-buffer))) - (delete-region (buffer-region buffer)) - (message "Extracing log info ...") - (with-mark ((mark (buffer-start-mark buffer) :left-inserting)) - (in-directory file - (do-command "rlog" (list (file-namestring file)) - :output (make-hemlock-output-stream mark)))) - (change-to-buffer buffer) - (buffer-start (current-point)) - (setf (buffer-modified buffer) nil))) - - - -;;;; Status and Modeline Frobs. - -(defhvar "RCS Status" - "RCS status of this buffer. Either nil, :locked, :out-of-date, or - :unlocked." - :value nil) - -;;; -;;; Note: This doesn't behave correctly w/r/t to branched files. -;;; -(defun rcs-file-status (pathname) - (let* ((directory (directory-namestring pathname)) - (filename (file-namestring pathname)) - (rcs-file (concatenate 'simple-string directory - "RCS/" filename ",v"))) - (if (probe-file rcs-file) - ;; This is an RCS file - (let ((probe-file (probe-file pathname))) - (cond ((and probe-file (hemlock-ext:file-writable probe-file)) - :locked) - ((or (not probe-file) - (< (file-write-date pathname) - (file-write-date rcs-file))) - :out-of-date) - (t - :unlocked)))))) - -(defun rcs-update-buffer-status (buffer &optional tn) - (unless (hemlock-bound-p 'rcs-status :buffer buffer) - (defhvar "RCS Status" - "RCS Status of this buffer." - :buffer buffer - :value nil)) - (let ((tn (or tn (buffer-pathname buffer)))) - (setf (variable-value 'rcs-status :buffer buffer) - (if tn (rcs-file-status tn)))) - (hi::update-modelines-for-buffer buffer)) -;;; -(add-hook read-file-hook 'rcs-update-buffer-status) -(add-hook write-file-hook 'rcs-update-buffer-status) - -(defcommand "RCS Update All RCS Status Variables" (p) - "Update the ``RCS Status'' variable for all buffers." - "Update the ``RCS Status'' variable for all buffers." - (declare (ignore p)) - (dolist (buffer *buffer-list*) - (rcs-update-buffer-status buffer)) - (dolist (window *window-list*) - (update-modeline-fields (window-buffer window) window))) - -;;; -;;; Action Hooks -(defun rcs-action-hook (buffer pathname) - (cond (buffer - (rcs-update-buffer-status buffer)) - (t - (let ((pathname (probe-file pathname))) - (when pathname - (dolist (buffer *buffer-list*) - (let ((buffer-pathname (buffer-pathname buffer))) - (when (equal pathname buffer-pathname) - (rcs-update-buffer-status buffer))))))))) -;;; -(add-hook rcs-check-in-file-hook 'rcs-action-hook) -(add-hook rcs-check-out-file-hook 'rcs-action-hook) -(add-hook rcs-lock-file-hook 'rcs-action-hook) -(add-hook rcs-unlock-file-hook 'rcs-action-hook) - - -;;; -;;; RCS Modeline Field -(make-modeline-field - :name :rcs-status - :function #'(lambda (buffer window) - (declare (ignore buffer window)) - (ecase (value rcs-status) - (:out-of-date "[OLD] ") - (:locked "[LOCKED] ") - (:unlocked "[RCS] ") - ((nil) "")))) Index: anches/ide-1.0/ccl/hemlock/src/screen.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/screen.lisp (revision 6566) +++ (revision ) @@ -1,204 +1,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- -;;; -;;; ********************************************************************** -;;; This code was written as part of the CMU Common Lisp project at -;;; Carnegie Mellon University, and has been placed in the public domain. -;;; -#+CMU (ext:file-comment - "$Header$") -;;; -;;; ********************************************************************** -;;; -;;; Written by Bill Chiles. -;;; -;;; Device independent screen management functions. -;;; - -(in-package :hemlock-internals) - - - -;;;; Screen management initialization. - -(declaim (special *echo-area-buffer*)) - -;;; %INIT-SCREEN-MANAGER creates the initial windows and sets up the data -;;; structures used by the screen manager. The "Main" and "Echo Area" buffer -;;; modelines are set here in case the user modified these Hemlock variables in -;;; his init file. Since these buffers don't have windows yet, these sets -;;; won't cause any updates to occur. This is called from %INIT-REDISPLAY. -;;; -(defun %init-screen-manager (display) - (setf (buffer-modeline-fields *current-buffer*) - (value hemlock::default-modeline-fields)) - (setf (buffer-modeline-fields *echo-area-buffer*) - (value hemlock::default-status-line-fields)) - (if (windowed-monitor-p) - (init-bitmap-screen-manager display) - (init-tty-screen-manager (get-terminal-name)))) - - - - -;;;; Window operations. - -(defun make-window (start &key (modelinep t) (device nil) window - (proportion .5) - (font-family *default-font-family*) - (ask-user nil) x y - (width (value hemlock::default-window-width)) - (height (value hemlock::default-window-height))) - "Make a window that displays text starting at the mark start. The default - action is to make the new window a proportion of the current window's height - to make room for the new window. - - Proportion determines what proportion of the current window's height - the new window will use. The current window retains whatever space left - after accommodating the new one. The default is to split the current window - in half. - - Modelinep specifies whether the window should display buffer modelines. - - Device is the Hemlock device to make the window on. If it is nil, then - the window is made on the same device as CURRENT-WINDOW. - - Window is an X window to be used with the Hemlock window. The supplied - window becomes the parent window for a new group of windows that behave - in a stack orientation as windows do on the terminal. - - Font-Family is the font-family used for displaying text in the window. - - If Ask-User is non-nil, Hemlock prompts the user for missing X, Y, Width, - and Height arguments to make a new group of windows that behave in a stack - orientation as windows do on the terminal. This occurs by invoking - hi::*create-window-hook*. X and Y are supplied as pixels, but Width and - Height are supplied in characters." - - (let* ((device (or device (device-hunk-device (window-hunk (current-window))))) - (window (funcall (device-make-window device) - device start modelinep window font-family - ask-user x y width height proportion))) - (unless window (editor-error "Could not make a window.")) - (invoke-hook hemlock::make-window-hook window) - window)) - -(defun delete-window (window) - "Make Window go away, removing it from the screen. This uses - hi::*delete-window-hook* to get rid of parent windows on a bitmap device - when you delete the last Hemlock window in a group." - (when (<= (length *window-list*) 2) - (error "Cannot kill the only window.")) - (invoke-hook hemlock::delete-window-hook window) - (setq *window-list* (delq window *window-list*)) - (funcall (device-delete-window (device-hunk-device (window-hunk window))) - window) - ;; - ;; Since the programmer's interface fails to allow users to determine if - ;; they're commands delete the current window, this primitive needs to - ;; make sure Hemlock doesn't get screwed. This inadequacy comes from the - ;; bitmap window groups and the vague descriptions of PREVIOUS-WINDOW and - ;; NEXT-WINDOW. - (when (eq window *current-window*) - (let ((window (find-if-not #'(lambda (w) (eq w *echo-area-window*)) - *window-list*))) - (setf (current-buffer) (window-buffer window) - (current-window) window)))) - -(defun next-window (window) - "Return the next window after Window, wrapping around if Window is the - bottom window." - (check-type window window) - (funcall (device-next-window (device-hunk-device (window-hunk window))) - window)) - -(defun previous-window (window) - "Return the previous window after Window, wrapping around if Window is the - top window." - (check-type window window) - (funcall (device-previous-window (device-hunk-device (window-hunk window))) - window)) - - - - -;;;; Random typeout support. - -;;; PREPARE-FOR-RANDOM-TYPEOUT -- Internal -;;; -;;; The WITH-POP-UP-DISPLAY macro calls this just before displaying output -;;; for the user. This goes to some effor to compute the height of the window -;;; in text lines if it is not supplied. Whether it is supplied or not, we -;;; add one to the height for the modeline, and we subtract one line if the -;;; last line is empty. Just before using the height, make sure it is at -;;; least two -- one for the modeline and one for text, so window making -;;; primitives don't puke. -;;; -(defun prepare-for-random-typeout (stream height) - (let* ((buffer (line-buffer (mark-line (random-typeout-stream-mark stream)))) - (real-height (1+ (or height (rt-count-lines buffer)))) - (device (device-hunk-device (window-hunk (current-window))))) - (funcall (device-random-typeout-setup device) device stream - (max (if (and (empty-line-p (buffer-end-mark buffer)) (not height)) - (1- real-height) - real-height) - 2)))) - -;;; RT-COUNT-LINES computes the correct height for a window. This includes -;;; taking wrapping line characters into account. Take the MARK-COLUMN at -;;; the end of each line. This is how many characters long hemlock thinks -;;; the line is. When it is displayed, however, end of line characters are -;;; added to the end of each line that wraps. The second INCF form adds -;;; these to the current line length. Then INCF the current height by the -;;; CEILING of the width of the random typeout window and the line length -;;; (with added line-end chars). Use CEILING because there is always at -;;; least one line. Finally, jump out of the loop if we're at the end of -;;; the buffer. -;;; -(defun rt-count-lines (buffer) - (with-mark ((mark (buffer-start-mark buffer))) - (let ((width (window-width (current-window))) - (count 0)) - (loop - (let* ((column (mark-column (line-end mark))) - (temp (ceiling (incf column (floor (1- column) width)) - width))) - ;; Lines with no characters yield zero temp. - (incf count (if (zerop temp) 1 temp)) - (unless (line-offset mark 1) (return count))))))) - - -;;; RANDOM-TYPEOUT-CLEANUP -- Internal -;;; -;;; Clean up after random typeout. This clears the area where the -;;; random typeout was and redisplays any affected windows. -;;; -(defun random-typeout-cleanup (stream &optional (degree t)) - (let* ((window (random-typeout-stream-window stream)) - (buffer (window-buffer window)) - (device (device-hunk-device (window-hunk window))) - (*more-prompt-action* :normal)) - (update-modeline-field buffer window :more-prompt) - (random-typeout-redisplay window) - (setf (buffer-windows buffer) (delete window (buffer-windows buffer))) - (funcall (device-random-typeout-cleanup device) stream degree) - (when (device-force-output device) - (funcall (device-force-output device))))) - -;;; *more-prompt-action* is bound in random typeout streams before -;;; redisplaying. -;;; -(defvar *more-prompt-action* :normal) -(defvar *random-typeout-ml-fields* - (list (make-modeline-field - :name :more-prompt - :function #'(lambda (buffer window) - (declare (ignore window)) - (ecase *more-prompt-action* - (:more "--More--") - (:flush "--Flush--") - (:empty "") - (:normal - (concatenate 'simple-string - "Random Typeout Buffer [" - (buffer-name buffer) - "]"))))))) Index: anches/ide-1.0/ccl/hemlock/src/scribe.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/scribe.lisp (revision 6566) +++ (revision ) @@ -1,501 +1,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock -*- -;;; -;;; ********************************************************************** -;;; This code was written as part of the CMU Common Lisp project at -;;; Carnegie Mellon University, and has been placed in the public domain. -;;; -#+CMU (ext:file-comment - "$Header$") -;;; -;;; ********************************************************************** -;;; - -(in-package :hemlock) - - - -;;;; Variables. - -(defvar *scribe-para-break-table* (make-hash-table :test #'equal) - "A table of the Scribe commands that should be paragraph delimiters.") -;;; -(dolist (todo '("begin" "newpage" "make" "device" "caption" "tag" "end" - "chapter" "section" "appendix" "subsection" "paragraph" - "unnumbered" "appendixsection" "prefacesection" "heading" - "majorheading" "subheading")) - (setf (gethash todo *scribe-para-break-table*) t)) - -(defhvar "Open Paren Character" - "The open bracket inserted by Scribe commands." - :value #\[) - -(defhvar "Close Paren Character" - "The close bracket inserted by Scribe commands." - :value #\]) - -(defhvar "Escape Character" - "The escape character inserted by Scribe commands." - :value #\@) - -(defhvar "Scribe Bracket Table" - "This table maps a Scribe brackets, open and close, to their opposing - brackets." - :value (make-array char-code-limit)) -;;; -(mapc #'(lambda (x y) - (setf (svref (value scribe-bracket-table) (char-code x)) y) - (setf (svref (value scribe-bracket-table) (char-code y)) x)) - '(#\( #\[ #\{ #\<) '(#\) #\] #\} #\>)) -;;; -(defun opposing-bracket (bracket) - (svref (value scribe-bracket-table) (char-code bracket))) - - - - -;;;; "Scribe Syntax" Attribute. - -(defattribute "Scribe Syntax" - "For Scribe Syntax, Possible types are: - :ESCAPE ; basically #\@. - :OPEN-PAREN ; Characters that open a Scribe paren: #\[, #\{, #\(, #\<. - :CLOSE-PAREN ; Characters that close a Scribe paren: #\], #\}, #\), #\>. - :SPACE ; Delimits end of a Scribe command. - :NEWLINE ; Delimits end of a Scribe command." - 'symbol nil) - -(setf (character-attribute :scribe-syntax #\)) :close-paren) -(setf (character-attribute :scribe-syntax #\]) :close-paren) -(setf (character-attribute :scribe-syntax #\}) :close-paren) -(setf (character-attribute :scribe-syntax #\>) :close-paren) - -(setf (character-attribute :scribe-syntax #\() :open-paren) -(setf (character-attribute :scribe-syntax #\[) :open-paren) -(setf (character-attribute :scribe-syntax #\{) :open-paren) -(setf (character-attribute :scribe-syntax #\<) :open-paren) - -(setf (character-attribute :scribe-syntax #\space) :space) -(setf (character-attribute :scribe-syntax #\newline) :newline) -(setf (character-attribute :scribe-syntax #\@) :escape) - - - - -;;;; "Scribe" mode and setup. - -(defmode "Scribe" :major-p t) - -(shadow-attribute :paragraph-delimiter #\@ 1 "Scribe") -(shadow-attribute :word-delimiter #\' 0 "Scribe") ;from Text Mode -(shadow-attribute :word-delimiter #\backspace 0 "Scribe") ;from Text Mode -(shadow-attribute :word-delimiter #\_ 0 "Scribe") ;from Text Mode - -(define-file-type-hook ("mss") (buffer type) - (declare (ignore type)) - (setf (buffer-major-mode buffer) "Scribe")) - - - - -;;;; Commands. - -(defcommand "Scribe Mode" (p) - "Puts buffer in Scribe mode. Sets up comment variables and has delimiter - matching. The definition of paragraphs is changed to know about scribe - commands." - "Puts buffer in Scribe mode." - (declare (ignore p)) - (setf (buffer-major-mode (current-buffer)) "Scribe")) - -(defcommand "Select Scribe Warnings" (p) - "Goes to the Scribe Warnings buffer if it exists." - "Goes to the Scribe Warnings buffer if it exists." - (declare (ignore p)) - (let ((buffer (getstring "Scribe Warnings" *buffer-names*))) - (if buffer - (change-to-buffer buffer) - (editor-error "There is no Scribe Warnings buffer.")))) - -(defcommand "Add Scribe Paragraph Delimiter" - (p &optional - (word (prompt-for-string - :prompt "Scribe command: " - :help "Name of Scribe command to make delimit paragraphs." - :trim t))) - "Prompts for a name to add to the table of commands that delimit paragraphs - in Scribe mode. If a prefix argument is supplied, then the command name is - removed from the table." - "Add or remove Word in the *scribe-para-break-table*, depending on P." - (setf (gethash word *scribe-para-break-table*) (not p))) - -(defcommand "List Scribe Paragraph Delimiters" (p) - "Pops up a display of the Scribe commands that delimit paragraphs." - "Pops up a display of the Scribe commands that delimit paragraphs." - (declare (ignore p)) - (let (result) - (maphash #'(lambda (k v) - (declare (ignore v)) - (push k result)) - *scribe-para-break-table*) - (setf result (sort result #'string<)) - (with-pop-up-display (s :height (length result)) - (dolist (ele result) (write-line ele s))))) - -(defcommand "Scribe Insert Bracket" (p) - "Inserts a the bracket it is bound to and then shows the matching bracket." - "Inserts a the bracket it is bound to and then shows the matching bracket." - (declare (ignore p)) - (scribe-insert-paren (current-point) - (hemlock-ext:key-event-char *last-key-event-typed*))) - - -(defhvar "Scribe Command Table" - "This is a character dispatching table indicating which Scribe command or - environment to use." - :value (make-hash-table) - :mode "Scribe") - -(defvar *scribe-directive-type-table* - (make-string-table :initial-contents - '(("Command" . :command) - ("Environment" . :environment)))) - -(defcommand "Add Scribe Directive" (p &optional - (command-name nil command-name-p) - type key-event mode) - "Adds a new scribe function to put into \"Scribe Command Table\"." - "Adds a new scribe function to put into \"Scribe Command Table\"." - (declare (ignore p)) - (let ((command-name (if command-name-p - command-name - (or command-name - (prompt-for-string :help "Directive Name" - :prompt "Directive: "))))) - (multiple-value-bind (ignore type) - (if type - (values nil type) - (prompt-for-keyword - (list *scribe-directive-type-table*) - :help "Enter Command or Environment." - :prompt "Command or Environment: ")) - (declare (ignore ignore)) - (let ((key-event (or key-event - (prompt-for-key-event :prompt - "Dispatch Character: ")))) - (setf (gethash key-event - (cond (mode - (variable-value 'scribe-command-table :mode mode)) - ((hemlock-bound-p 'scribe-command-table) - (value scribe-command-table)) - (t (editor-error - "Could not find \"Scribe Command Table\".")))) - (cons type command-name)))))) - -(defcommand "Insert Scribe Directive" (p) - "Prompts for a character to dispatch on. Some indicate \"commands\" versus - \"environments\". Commands are wrapped around the previous or current word. - If there is no previous word, the command is insert, leaving point between - the brackets. Environments are wrapped around the next or current - paragraph, but when the region is active, this wraps the environment around - the region. Each uses \"Open Paren Character\" and \"Close Paren - Character\"." - "Wrap some text with some stuff." - (declare (ignore p)) - (loop - (let ((key-event (prompt-for-key-event :prompt "Dispatch Character: "))) - (if (logical-key-event-p key-event :help) - (directive-help) - (let ((table-entry (gethash key-event (value scribe-command-table)))) - (ecase (car table-entry) - (:command - (insert-scribe-directive (current-point) (cdr table-entry)) - (return)) - (:environment - (enclose-with-environment (current-point) (cdr table-entry)) - (return)) - ((nil) (editor-error "Unknown dispatch character.")))))))) - - - - -;;;; "Insert Scribe Directive" support. - -(defun directive-help () - (let ((commands ()) - (environments ())) - (declare (list commands environments)) - (maphash #'(lambda (k v) - (if (eql (car v) :command) - (push (cons k (cdr v)) commands) - (push (cons k (cdr v)) environments))) - (value scribe-command-table)) - (setf commands (sort commands #'string< :key #'cdr)) - (setf environments (sort environments #'string< :key #'cdr)) - (with-pop-up-display (s :height (1+ (max (length commands) - (length environments)))) - (format s "~2TCommands~47TEnvironments~%") - (do ((commands commands (rest commands)) - (environments environments (rest environments))) - ((and (endp commands) (endp environments))) - (let* ((command (first commands)) - (environment (first environments)) - (cmd-char (first command)) - (cmd-name (rest command)) - (env-char (first environment)) - (env-name (rest environment))) - (write-string " " s) - (when cmd-char - (hemlock-ext:print-pretty-key-event cmd-char s) - (format s "~7T") - (write-string (or cmd-name "") s)) - (when env-char - (format s "~47T") - (hemlock-ext:print-pretty-key-event env-char s) - (format s "~51T") - (write-string (or env-name "") s)) - (terpri s)))))) - -;;; -;;; Inserting and extending :command directives. -;;; - -(defhvar "Insert Scribe Directive Function" - "\"Insert Scribe Directive\" calls this function when the directive type - is :command. The function takes four arguments: a mark pointing to the word - start, the formatting command string, the open-paren character to use, and a - mark pointing to the word end." - :value 'scribe-insert-scribe-directive-fun - :mode "Scribe") - -(defun scribe-insert-scribe-directive-fun (word-start command-string - open-paren-char word-end) - (insert-character word-start (value escape-character)) - (insert-string word-start command-string) - (insert-character word-start open-paren-char) - (insert-character word-end (value close-paren-character))) - -(defhvar "Extend Scribe Directive Function" - "\"Insert Scribe Directive\" calls this function when the directive type is - :command to extend the the commands effect. This function takes a string - and three marks: the first on pointing before the open-paren character for - the directive. The string is the command-string to selected by the user - which this function uses to determine if it is actually extending a command - or inserting a new one. The function must move the first mark before any - command text for the directive and the second mark to the end of any command - text. It moves the third mark to the previous word's start where the - command region should be. If this returns non-nil \"Insert Scribe - Directive\" moves the command region previous one word, and otherwise it - inserts the directive." - :value 'scribe-extend-scribe-directive-fun - :mode "Scribe") - -(defun scribe-extend-scribe-directive-fun (command-string - command-end command-start word-start) - (word-offset (move-mark command-start command-end) -1) - (when (string= (the simple-string (region-to-string - (region command-start command-end))) - command-string) - (mark-before command-start) - (mark-after command-end) - (word-offset (move-mark word-start command-start) -1))) - -;;; INSERT-SCRIBE-DIRECTIVE first looks for the current or previous word at -;;; mark. Word-p says if we found one. If mark is immediately before a word, -;;; we use that word instead of the previous. This is because if mark -;;; corresponds to the CURRENT-POINT, the Hemlock cursor is displayed on the -;;; first character of the word making users think the mark is in the word -;;; instead of before it. If we find a word, then we see if it already has -;;; the given command-string, and if it does, we extend the use of the command- -;;; string to the previous word. At the end, if we hadn't found a word, we -;;; backup the mark one character to put it between the command brackets. -;;; -(defun insert-scribe-directive (mark &optional command-string) - (with-mark ((word-start mark :left-inserting) - (word-end mark :left-inserting)) - (let ((open-paren-char (value open-paren-character)) - (word-p (if (and (zerop (character-attribute - :word-delimiter - (next-character word-start))) - (= (character-attribute - :word-delimiter - (previous-character word-start)) - 1)) - word-start - (word-offset word-start -1))) - (command-string (or command-string - (prompt-for-string - :trim t :prompt "Environment: " - :help "Name of environment to enclose with.")))) - (declare (simple-string command-string)) - (cond - (word-p - (word-offset (move-mark word-end word-start) 1) - (if (test-char (next-character word-end) :scribe-syntax - :close-paren) - (with-mark ((command-start word-start :left-inserting) - (command-end word-end :left-inserting)) - ;; Move command-end from word-end to open-paren of command. - (balance-paren (mark-after command-end)) - (if (funcall (value extend-scribe-directive-function) - command-string command-end command-start word-start) - (let ((region (delete-and-save-region - (region command-start command-end)))) - (word-offset (move-mark word-start command-start) -1) - (ninsert-region word-start region)) - (funcall (value insert-scribe-directive-function) - word-start command-string open-paren-char - word-end))) - (funcall (value insert-scribe-directive-function) - word-start command-string open-paren-char word-end))) - (t - (funcall (value insert-scribe-directive-function) - word-start command-string open-paren-char word-end) - (mark-before mark)))))) - -;;; -;;; Inserting :environment directives. -;;; - -(defun enclose-with-environment (mark &optional environment) - (if (region-active-p) - (let ((region (current-region))) - (with-mark ((top (region-start region) :left-inserting) - (bottom (region-end region) :left-inserting)) - (get-and-insert-environment top bottom environment))) - (with-mark ((bottom-mark mark :left-inserting)) - (let ((paragraphp (paragraph-offset bottom-mark 1))) - (unless (or paragraphp - (and (last-line-p bottom-mark) - (end-line-p bottom-mark) - (not (blank-line-p (mark-line bottom-mark))))) - (editor-error "No paragraph to enclose.")) - (with-mark ((top-mark bottom-mark :left-inserting)) - (paragraph-offset top-mark -1) - (cond ((not (blank-line-p (mark-line top-mark))) - (insert-character top-mark #\Newline) - (mark-before top-mark)) - (t - (insert-character top-mark #\Newline))) - (cond ((and (last-line-p bottom-mark) - (not (blank-line-p (mark-line bottom-mark)))) - (insert-character bottom-mark #\Newline)) - (t - (insert-character bottom-mark #\Newline) - (mark-before bottom-mark))) - (get-and-insert-environment top-mark bottom-mark environment)))))) - -(defun get-and-insert-environment (top-mark bottom-mark environment) - (let ((environment (or environment - (prompt-for-string - :trim t :prompt "Environment: " - :help "Name of environment to enclose with.")))) - (insert-environment top-mark "begin" environment) - (insert-environment bottom-mark "end" environment))) - -(defun insert-environment (mark command environment) - (let ((esc-char (value escape-character)) - (open-paren (value open-paren-character)) - (close-paren (value close-paren-character))) - (insert-character mark esc-char) - (insert-string mark command) - (insert-character mark open-paren) - (insert-string mark environment) - (insert-character mark close-paren))) - - -(add-scribe-directive-command nil nil :Environment #k"Control-l" "Scribe") -(add-scribe-directive-command nil nil :Command #k"Control-w" "Scribe") -(add-scribe-directive-command nil "Begin" :Command #k"b" "Scribe") -(add-scribe-directive-command nil "End" :Command #k"e" "Scribe") -(add-scribe-directive-command nil "Center" :Environment #k"c" "Scribe") -(add-scribe-directive-command nil "Description" :Environment #k"d" "Scribe") -(add-scribe-directive-command nil "Display" :Environment #k"Control-d" "Scribe") -(add-scribe-directive-command nil "Enumerate" :Environment #k"n" "Scribe") -(add-scribe-directive-command nil "Example" :Environment #k"x" "Scribe") -(add-scribe-directive-command nil "FileExample" :Environment #k"y" "Scribe") -(add-scribe-directive-command nil "FlushLeft" :Environment #k"l" "Scribe") -(add-scribe-directive-command nil "FlushRight" :Environment #k"r" "Scribe") -(add-scribe-directive-command nil "Format" :Environment #k"f" "Scribe") -(add-scribe-directive-command nil "Group" :Environment #k"g" "Scribe") -(add-scribe-directive-command nil "Itemize" :Environment #k"Control-i" "Scribe") -(add-scribe-directive-command nil "Multiple" :Environment #k"m" "Scribe") -(add-scribe-directive-command nil "ProgramExample" :Environment #k"p" "Scribe") -(add-scribe-directive-command nil "Quotation" :Environment #k"q" "Scribe") -(add-scribe-directive-command nil "Text" :Environment #k"t" "Scribe") -(add-scribe-directive-command nil "i" :Command #k"i" "Scribe") -(add-scribe-directive-command nil "b" :Command #k"Control-b" "Scribe") -(add-scribe-directive-command nil "-" :Command #k"\-" "Scribe") -(add-scribe-directive-command nil "+" :Command #k"+" "Scribe") -(add-scribe-directive-command nil "u" :Command #k"Control-j" "Scribe") -(add-scribe-directive-command nil "p" :Command #k"Control-p" "Scribe") -(add-scribe-directive-command nil "r" :Command #k"Control-r" "Scribe") -(add-scribe-directive-command nil "t" :Command #k"Control-t" "Scribe") -(add-scribe-directive-command nil "g" :Command #k"Control-a" "Scribe") -(add-scribe-directive-command nil "un" :Command #k"Control-n" "Scribe") -(add-scribe-directive-command nil "ux" :Command #k"Control-x" "Scribe") -(add-scribe-directive-command nil "c" :Command #k"Control-k" "Scribe") - - - - -;;;; Scribe paragraph delimiter function. - -(defhvar "Paragraph Delimiter Function" - "Scribe Mode's way of delimiting paragraphs." - :mode "Scribe" - :value 'scribe-delim-para-function) - -(defun scribe-delim-para-function (mark) - "Returns whether there is a paragraph delimiting Scribe command on the - current line. Add or remove commands for this purpose with the command - \"Add Scribe Paragraph Delimiter\"." - (let ((next-char (next-character mark))) - (when (paragraph-delimiter-attribute-p next-char) - (if (eq (character-attribute :scribe-syntax next-char) :escape) - (with-mark ((begin mark) - (end mark)) - (mark-after begin) - (if (scan-char end :scribe-syntax (or :space :newline :open-paren)) - (gethash (nstring-downcase (region-to-string (region begin end))) - *scribe-para-break-table*) - (editor-error "Unable to find Scribe command ending."))) - t)))) - - - - -;;;; Bracket matching. - -(defun scribe-insert-paren (mark bracket-char) - (insert-character mark bracket-char) - (with-mark ((m mark)) - (if (balance-paren m) - (when (value paren-pause-period) - (unless (show-mark m (current-window) (value paren-pause-period)) - (clear-echo-area) - (message "~A" (line-string (mark-line m))))) - (editor-error)))) - -;;; BALANCE-PAREN moves the mark to the matching open paren character, or -;;; returns nil. The mark must be after the closing paren. -;;; -(defun balance-paren (mark) - (with-mark ((m mark)) - (when (rev-scan-char m :scribe-syntax (or :open-paren :close-paren)) - (mark-before m) - (let ((paren-count 1) - (first-paren (next-character m))) - (loop - (unless (rev-scan-char m :scribe-syntax (or :open-paren :close-paren)) - (return nil)) - (if (test-char (previous-character m) :scribe-syntax :open-paren) - (setq paren-count (1- paren-count)) - (setq paren-count (1+ paren-count))) - (when (< paren-count 0) (return nil)) - (when (= paren-count 0) - ;; OPPOSING-BRACKET calls VALUE (each time around the loop) - (cond ((char= (opposing-bracket (previous-character m)) first-paren) - (mark-before (move-mark mark m)) - (return t)) - (t (editor-error "Scribe paren mismatch.")))) - (mark-before m)))))) Index: anches/ide-1.0/ccl/hemlock/src/shell.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/shell.lisp (revision 6566) +++ (revision ) @@ -1,558 +1,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock -*- -;;; -;;; ********************************************************************** -;;; This code was written as part of the CMU Common Lisp project at -;;; Carnegie Mellon University, and has been placed in the public domain. -;;; -#+CMU (ext:file-comment - "$Header$") -;;; -;;; ********************************************************************** -;;; -;;; Hemlock command level support for processes. -;;; -;;; Written by Blaine Burks. -;;; - -(in-package :hemlock) - - -(defun setup-process-buffer (buffer) - (let ((mark (copy-mark (buffer-point buffer) :right-inserting))) - (defhvar "Buffer Input Mark" - "The buffer input mark for this buffer." - :buffer buffer - :value mark) - (defhvar "Process Output Stream" - "The process structure for this buffer." - :buffer buffer - :value (make-hemlock-output-stream mark :full)) - (defhvar "Interactive History" - "A ring of the regions input to an interactive mode (Eval or Typescript)." - :buffer buffer - :value (make-ring (value interactive-history-length))) - (defhvar "Interactive Pointer" - "Pointer into \"Interactive History\"." - :buffer buffer - :value 0) - (defhvar "Searching Interactive Pointer" - "Pointer into \"Interactive History\"." - :buffer buffer - :value 0) - (unless (buffer-modeline-field-p buffer :process-status) - (setf (buffer-modeline-fields buffer) - (nconc (buffer-modeline-fields buffer) - (list (modeline-field :process-status))))))) - -(defmode "Process" :major-p nil :setup-function #'setup-process-buffer) - - - - -;;;; Shell-filter streams. - -;;; We use shell-filter-streams to capture text going from the shell process to -;;; a Hemlock output stream. They pass character and misc operations through -;;; to the attached hemlock-output-stream. The string output function scans -;;; the string for ^A_____^B, denoting a change of directory. -;;; -;;; The following aliases in a .cshrc file are required for using filename -;;; completion: -;;; alias cd 'cd \!* ; echo ""`pwd`"/"' -;;; alias popd 'popd \!* ; echo ""`pwd`"/"' -;;; alias pushd 'pushd \!* ; echo ""`pwd`"/"' -;;; - -(defstruct (shell-filter-stream - (:include sys:lisp-stream - (:out #'shell-filter-out) - (:sout #'shell-filter-string-out) - (:misc #'shell-filter-output-misc)) - (:print-function print-shell-filter-stream) - (:constructor - make-shell-filter-stream (buffer hemlock-stream))) - ;; The buffer where output will be going - buffer - ;; The Hemlock stream to which output will be directed - hemlock-stream) - - -;;; PRINT-SHELL-FILTER-STREAM -- Internal -;;; -;;; Function for printing a shell-filter-stream. -;;; -(defun print-shell-filter-stream (s stream d) - (declare (ignore d s)) - (write-string "#" stream)) - - -;;; SHELL-FILTER-OUT -- Internal -;;; -;;; This is the character-out handler for the shell-filter-stream. -;;; It writes the character it is given to the underlying -;;; hemlock-output-stream. -;;; -(defun shell-filter-out (stream character) - (write-char character (shell-filter-stream-hemlock-stream stream))) - - -;;; SHELL-FILTER-OUTPUT-MISC -- Internal -;;; -;;; This will also simply pass the output request on the the -;;; attached hemlock-output-stream. -;;; -(defun shell-filter-output-misc (stream operation &optional arg1 arg2) - (let ((hemlock-stream (shell-filter-stream-hemlock-stream stream))) - (funcall (hi::hemlock-output-stream-misc hemlock-stream) - hemlock-stream operation arg1 arg2))) - - -;;; CATCH-CD-STRING -- Internal -;;; -;;; Scans String for the sequence ^A...^B. Returns as multiple values -;;; the breaks in the string. If the second start/end pair is nil, there -;;; was no cd sequence. -;;; -(defun catch-cd-string (string start end) - (declare (simple-string string)) - (let ((cd-start (position (code-char 1) string :start start :end end))) - (if cd-start - (let ((cd-end (position (code-char 2) string :start cd-start :end end))) - (if cd-end - (values start cd-start cd-end end) - (values start end nil nil))) - (values start end nil nil)))) - -;;; SHELL-FILTER-STRING-OUT -- Internal -;;; -;;; The string output function for shell-filter-stream's. -;;; Any string containing a ^A...^B is caught and assumed to be -;;; the path-name of the new current working directory. This is -;;; removed from the orginal string and the result is passed along -;;; to the Hemlock stream. -;;; -(defun shell-filter-string-out (stream string start end) - (declare (simple-string string)) - (let ((hemlock-stream (shell-filter-stream-hemlock-stream stream)) - (buffer (shell-filter-stream-buffer stream))) - - (multiple-value-bind (start1 end1 start2 end2) - (catch-cd-string string start end) - (write-string string hemlock-stream :start start1 :end end1) - (when start2 - (write-string string hemlock-stream :start (+ 2 start2) :end end2) - (let ((cd-string (subseq string (1+ end1) start2))) - (setf (variable-value 'current-working-directory :buffer buffer) - (pathname cd-string))))))) - - -;;; FILTER-TILDES -- Internal -;;; -;;; Since COMPLETE-FILE does not seem to deal with ~'s in the filename -;;; this function expands them to a full path name. -;;; -(defun filter-tildes (name) - (declare (simple-string name)) - (if (char= (schar name 0) #\~) - (concatenate 'simple-string - (if (or (= (length name) 1) - (char= (schar name 1) #\/)) - (cdr (assoc :home *environment-list*)) - "/usr/") - (subseq name 1)) - name)) - - - - -;;;; Support for handling input before the prompt in process buffers. - -(defun unwedge-process-buffer () - (buffer-end (current-point)) - (deliver-signal-to-process :SIGINT (value process)) - (editor-error "Aborted.")) - -(defhvar "Unwedge Interactive Input Fun" - "Function to call when input is confirmed, but the point is not past the - input mark." - :value #'unwedge-process-buffer - :mode "Process") - -(defhvar "Unwedge Interactive Input String" - "String to add to \"Point not past input mark. \" explaining what will - happen if the the user chooses to be unwedged." - :value "Interrupt and throw to end of buffer?" - :mode "Process") - - - - -;;;; Some Global Variables. - -(defhvar "Current Shell" - "The shell to which \"Select Shell\" goes." - :value nil) - -(defhvar "Ask about Old Shells" - "When set (the default), Hemlock prompts for an existing shell buffer in - preference to making a new one when there is no \"Current Shell\"." - :value t) - -(defhvar "Kill Process Confirm" - "When set, Hemlock prompts for confirmation before killing a buffer's process." - :value t) - -(defhvar "Shell Utility" - "The \"Shell\" command uses this as the default command line." - :value "/bin/csh") - -(defhvar "Shell Utility Switches" - "This is a string containing the default command line arguments to the - utility in \"Shell Utility\". This is a string since the utility is - typically \"/bin/csh\", and this string can contain I/O redirection and - other shell directives." - :value "") - - - - -;;;; The Shell, New Shell, and Set Current Shell Commands. - -(defvar *shell-names* (make-string-table) - "A string-table of the string-name of all process buffers and corresponding - buffer structures.") - -(defcommand "Set Current Shell" (p) - "Sets the value of \"Current Shell\", which the \"Shell\" command uses." - "Sets the value of \"Current Shell\", which the \"Shell\" command uses." - (declare (ignore p)) - (set-current-shell)) - -;;; SET-CURRENT-SHELL -- Internal. -;;; -;;; This prompts for a known shell buffer to which it sets "Current Shell". -;;; It signals an error if there are none. -;;; -(defun set-current-shell () - (let ((old-buffer (value current-shell)) - (first-old-shell (do-strings (var val *shell-names* nil) - (declare (ignore val)) - (return var)))) - (when (and (not old-buffer) (not first-old-shell)) - (editor-error "Nothing to set current shell to.")) - (let ((default-shell (if old-buffer - (buffer-name old-buffer) - first-old-shell))) - (multiple-value-bind - (new-buffer-name new-buffer) - (prompt-for-keyword (list *shell-names*) - :must-exist t - :default default-shell - :default-string default-shell - :prompt "Existing Shell: " - :help "Enter the name of an existing shell.") - (declare (ignore new-buffer-name)) - (setf (value current-shell) new-buffer))))) - -(defcommand "Shell" (p) - "This spawns a shell in a buffer. If there already is a \"Current Shell\", - this goes to that buffer. If there is no \"Current Shell\", there are - shell buffers, and \"Ask about Old Shells\" is set, this prompts for one - of them, setting \"Current Shell\" to that shell. Supplying an argument - forces the creation of a new shell buffer." - "This spawns a shell in a buffer. If there already is a \"Current Shell\", - this goes to that buffer. If there is no \"Current Shell\", there are - shell buffers, and \"Ask about Old Shells\" is set, this prompts for one - of them, setting \"Current Shell\" to that shell. Supplying an argument - forces the creation of a new shell buffer." - (let ((shell (value current-shell)) - (no-shells-p (do-strings (var val *shell-names* t) - (declare (ignore var val)) - (return nil)))) - (cond (p (make-new-shell nil no-shells-p)) - (shell (change-to-buffer shell)) - ((and (value ask-about-old-shells) (not no-shells-p)) - (set-current-shell) - (change-to-buffer (value current-shell))) - (t (make-new-shell nil))))) - -(defcommand "Shell Command Line in Buffer" (p) - "Prompts the user for a process and a buffer in which to run the process." - "Prompts the user for a process and a buffer in which to run the process." - (declare (ignore p)) - (make-new-shell t)) - -;;; MAKE-NEW-SHELL -- Internal. -;;; -;;; This makes new shells for us dealing with prompting for various things and -;;; setting "Current Shell" according to user documentation. -;;; -(defun make-new-shell (prompt-for-command-p &optional (set-current-shell-p t) - (command-line (get-command-line) clp)) - (let* ((command (or (and clp command-line) - (if prompt-for-command-p - (prompt-for-string - :default command-line :trim t - :prompt "Command to execute: " - :help "Shell command line to execute.") - command-line))) - (buffer-name (if prompt-for-command-p - (prompt-for-string - :default - (concatenate 'simple-string command " process") - :trim t - :prompt `("Buffer in which to execute ~A? " - ,command) - :help "Where output from this process will appear.") - (new-shell-name))) - (temp (make-buffer - buffer-name - :modes '("Fundamental" "Process") - :delete-hook - (list #'(lambda (buffer) - (when (eq (value current-shell) buffer) - (setf (value current-shell) nil)) - (delete-string (buffer-name buffer) *shell-names*) - (kill-process (variable-value 'process - :buffer buffer)))))) - (buffer (or temp (getstring buffer-name *buffer-names*))) - (stream (variable-value 'process-output-stream :buffer buffer)) - (output-stream - ;; If we re-used an old shell buffer, this isn't necessary. - (if (hemlock-output-stream-p stream) - (setf (variable-value 'process-output-stream :buffer buffer) - (make-shell-filter-stream buffer stream)) - stream))) - (buffer-end (buffer-point buffer)) - (defhvar "Process" - "The process for Shell and Process buffers." - :buffer buffer - :value (ext::run-program "/bin/sh" (list "-c" command) - :wait nil - :pty output-stream - :env (frob-environment-list - (car (buffer-windows buffer))) - :status-hook #'(lambda (process) - (declare (ignore process)) - (update-process-buffer buffer)) - :input t :output t)) - (defhvar "Current Working Directory" - "The pathname of the current working directory for this buffer." - :buffer buffer - :value (default-directory)) - (setf (getstring buffer-name *shell-names*) buffer) - (update-process-buffer buffer) - (when (and (not (value current-shell)) set-current-shell-p) - (setf (value current-shell) buffer)) - (change-to-buffer buffer))) - -;;; GET-COMMAND-LINE -- Internal. -;;; -;;; This just conses up a string to feed to the shell. -;;; -(defun get-command-line () - (concatenate 'simple-string (value shell-utility) " " - (value shell-utility-switches))) - -;;; FROB-ENVIRONMENT-LIST -- Internal. -;;; -;;; This sets some environment variables so the shell will be in the proper -;;; state when it comes up. -;;; -(defun frob-environment-list (window) - (list* (cons :termcap (concatenate 'simple-string - "emacs:co#" - (if window - (lisp::quick-integer-to-string - (window-width window)) - "") - ":tc=unkown:")) - (cons :emacs "t") (cons :term "emacs") - (remove-if #'(lambda (keyword) - (member keyword '(:termcap :emacs :term) - :test #'(lambda (cons keyword) - (eql (car cons) keyword)))) - ext:*environment-list*))) - -;;; NEW-SHELL-NAME -- Internal. -;;; -;;; This returns a unique buffer name for a shell by incrementing the value of -;;; *process-number* until "Process <*process-number*> is not already the name -;;; of a buffer. Perhaps this is being overly cautious, but I've seen some -;;; really stupid users. -;;; -(defvar *process-number* 0) -;;; -(defun new-shell-name () - (loop - (let ((buffer-name (format nil "Shell ~D" (incf *process-number*)))) - (unless (getstring buffer-name *buffer-names*) (return buffer-name))))) - - - -;;;; Modeline support. - -(defun modeline-process-status (buffer window) - (declare (ignore window)) - (when (hemlock-bound-p 'process :buffer buffer) - (let ((process (variable-value 'process :buffer buffer))) - (ecase (ext:process-status process) - (:running "running") - (:stopped "stopped") - (:signaled "killed by signal ~D" (unix:unix-signal-name - (ext:process-exit-code process))) - (:exited (format nil "exited with status ~D" - (ext:process-exit-code process))))))) - - -(make-modeline-field :name :process-status - :function #'modeline-process-status) - -(defun update-process-buffer (buffer) - (when (buffer-modeline-field-p buffer :process-status) - (dolist (window (buffer-windows buffer)) - (update-modeline-field buffer window :process-status))) - (let ((process (variable-value 'process :buffer buffer))) - (unless (ext:process-alive-p process) - (ext:process-close process) - (when (eq (value current-shell) buffer) - (setf (value current-shell) nil))))) - - - -;;;; Supporting Commands. - -(defcommand "Confirm Process Input" (p) - "Evaluate Process Mode input between the point and last prompt." - "Evaluate Process Mode input between the point and last prompt." - (declare (ignore p)) - (unless (hemlock-bound-p 'process :buffer (current-buffer)) - (editor-error "Not in a process buffer.")) - (let* ((process (value process)) - (stream (ext:process-pty process))) - (case (ext:process-status process) - (:running) - (:stopped (editor-error "The process has been stopped.")) - (t (editor-error "The process is dead."))) - (let ((input-region (get-interactive-input))) - (write-line (region-to-string input-region) stream) - (force-output (ext:process-pty process)) - (insert-character (current-point) #\newline) - ;; Move "Buffer Input Mark" to end of buffer. - (move-mark (region-start input-region) (region-end input-region))))) - -(defcommand "Shell Complete Filename" (p) - "Attempts to complete the filename immediately preceding the point. - It will beep if the result of completion is not unique." - "Attempts to complete the filename immediately preceding the point. - It will beep if the result of completion is not unique." - (declare (ignore p)) - (unless (hemlock-bound-p 'current-working-directory) - (editor-error "Shell filename completion only works in shells.")) - (let ((point (current-point))) - (with-mark ((start point)) - (pre-command-parse-check start) - (unless (form-offset start -1) (editor-error "Can't grab filename.")) - (when (member (next-character start) '(#\" #\' #\< #\>)) - (mark-after start)) - (let* ((name-region (region start point)) - (fragment (filter-tildes (region-to-string name-region))) - (dir (default-directory)) - (shell-dir (value current-working-directory))) - (multiple-value-bind (filename unique) - (unwind-protect - (progn - (setf (default-directory) shell-dir) - (complete-file fragment :defaults shell-dir)) - (setf (default-directory) dir)) - (cond (filename - (delete-region name-region) - (insert-string point (namestring filename)) - (when (not unique) - (editor-error))) - (t (editor-error "No such file exists.")))))))) - -(defcommand "Kill Main Process" (p) - "Kills the process in the current buffer." - "Kills the process in the current buffer." - (declare (ignore p)) - (unless (hemlock-bound-p 'process :buffer (current-buffer)) - (editor-error "Not in a process buffer.")) - (when (or (not (value kill-process-confirm)) - (prompt-for-y-or-n :default nil - :prompt "Really blow away shell? " - :default nil - :default-string "no")) - (kill-process (value process)))) - -(defcommand "Stop Main Process" (p) - "Stops the process in the current buffer. With an argument use :SIGSTOP - instead of :SIGTSTP." - "Stops the process in the current buffer. With an argument use :SIGSTOP - instead of :SIGTSTP." - (unless (hemlock-bound-p 'process :buffer (current-buffer)) - (editor-error "Not in a process buffer.")) - (deliver-signal-to-process (if p :SIGSTOP :SIGTSTP) (value process))) - -(defcommand "Continue Main Process" (p) - "Continues the process in the current buffer." - "Continues the process in the current buffer." - (declare (ignore p)) - (unless (hemlock-bound-p 'process :buffer (current-buffer)) - (editor-error "Not in a process buffer.")) - (deliver-signal-to-process :SIGCONT (value process))) - -(defun kill-process (process) - "Self-explanatory." - (deliver-signal-to-process :SIGKILL process)) - -(defun deliver-signal-to-process (signal process) - "Delivers a signal to a process." - (ext:process-kill process signal :process-group)) - -(defcommand "Send EOF to Process" (p) - "Sends a Ctrl-D to the process in the current buffer." - "Sends a Ctrl-D to the process in the current buffer." - (declare (ignore p)) - (unless (hemlock-bound-p 'process :buffer (current-buffer)) - (editor-error "Not in a process buffer.")) - (let ((stream (ext:process-pty (value process)))) - (write-char (code-char 4) stream) - (force-output stream))) - -(defcommand "Interrupt Buffer Subprocess" (p) - "Stop the subprocess currently executing in this shell." - "Stop the subprocess currently executing in this shell." - (declare (ignore p)) - (unless (hemlock-bound-p 'process :buffer (current-buffer)) - (editor-error "Not in a process buffer.")) - (buffer-end (current-point)) - (buffer-end (value buffer-input-mark)) - (deliver-signal-to-subprocess :SIGINT (value process))) - -(defcommand "Kill Buffer Subprocess" (p) - "Kill the subprocess currently executing in this shell." - "Kill the subprocess currently executing in this shell." - (declare (ignore p)) - (unless (hemlock-bound-p 'process :buffer (current-buffer)) - (editor-error "Not in a process buffer.")) - (deliver-signal-to-subprocess :SIGKILL (value process))) - -(defcommand "Quit Buffer Subprocess" (p) - "Quit the subprocess currently executing int his shell." - "Quit the subprocess currently executing int his shell." - (declare (ignore p)) - (unless (hemlock-bound-p 'process :buffer (current-buffer)) - (editor-error "Not in a process buffer.")) - (deliver-signal-to-subprocess :SIGQUIT (value process))) - -(defcommand "Stop Buffer Subprocess" (p) - "Stop the subprocess currently executing in this shell." - "Stop the subprocess currently executing in this shell." - (unless (hemlock-bound-p 'process :buffer (current-buffer)) - (editor-error "Not in a process buffer.")) - (deliver-signal-to-subprocess (if p :SIGSTOP :SIGTSTP) (value process))) - -(defun deliver-signal-to-subprocess (signal process) - "Delivers a signal to a subprocess of a shell." - (ext:process-kill process signal :pty-process-group)) Index: anches/ide-1.0/ccl/hemlock/src/spell-aug.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/spell-aug.lisp (revision 6566) +++ (revision ) @@ -1,237 +1,0 @@ -;;; -*- Log: hemlock.log; Package: Spell -*- -;;; -;;; ********************************************************************** -;;; This code was written as part of the CMU Common Lisp project at -;;; Carnegie Mellon University, and has been placed in the public domain. -;;; -#+CMU (ext:file-comment - "$Header$") -;;; -;;; ********************************************************************** -;;; -;;; Written by Bill Chiles -;;; Designed by Bill Chiles and Rob Maclachlan -;;; -;;; This file contains the code to grow the spelling dictionary in system -;;; space by reading a text file of entries or adding one at a time. This -;;; code relies on implementation dependent code found in Spell-RT.Lisp. - - -(in-package "SPELL") - - - -;;;; Converting Flags to Masks - -(defconstant flag-names-to-masks - `((#\V . ,V-mask) (#\N . ,N-mask) (#\X . ,X-mask) - (#\H . ,H-mask) (#\Y . ,Y-mask) (#\G . ,G-mask) - (#\J . ,J-mask) (#\D . ,D-mask) (#\T . ,T-mask) - (#\R . ,R-mask) (#\Z . ,Z-mask) (#\S . ,S-mask) - (#\P . ,P-mask) (#\M . ,M-mask))) - -(defvar *flag-masks* - (make-array 128 :element-type '(unsigned-byte 16) :initial-element 0) - "This holds the masks for character flags, which is used when reading - a text file of dictionary words. Illegal character flags hold zero.") - -(eval-when (:compile-toplevel :execute) -(defmacro flag-mask (char) - `(aref *flag-masks* (char-code ,char))) -) ;eval-when - -(dolist (e flag-names-to-masks) - (let ((char (car e)) - (mask (cdr e))) - (setf (flag-mask char) mask) - (setf (flag-mask (char-downcase char)) mask))) - - - - -;;;; String and Hashing Macros - -(eval-when (:compile-toplevel :execute) - -(defmacro string-table-replace (src-string dst-start length) - `(sap-replace *string-table* ,src-string 0 ,dst-start (+ ,dst-start ,length))) - -;;; HASH-ENTRY is used in SPELL-ADD-ENTRY to find a dictionary location for -;;; adding a new entry. If a location contains a zero, then it has never been -;;; used, and no entries have ever been "hashed past" it. If a location -;;; contains SPELL-DELETED-ENTRY, then it once contained an entry that has -;;; since been deleted. -;;; -(defmacro hash-entry (entry entry-len) - (let ((loop-loc (gensym)) (loc-contents (gensym)) - (hash (gensym)) (loc (gensym))) - `(let* ((,hash (string-hash ,entry ,entry-len)) - (,loc (rem ,hash (the fixnum *dictionary-size*))) - (,loc-contents (dictionary-ref ,loc))) - (declare (fixnum ,loc ,loc-contents)) - (if (or (zerop ,loc-contents) (= ,loc-contents spell-deleted-entry)) - ,loc - (hash2-loop (,loop-loc ,loc-contents) ,loc ,hash - ,loop-loc nil t))))) - -) ;eval-when - - - - -;;;; Top Level Stuff - -(defun spell-read-dictionary (filename) - "Add entries to dictionary from lines in the file filename." - (with-open-file (s filename :direction :input) - (loop (multiple-value-bind (entry eofp) (read-line s nil nil) - (declare (type (or simple-string null) entry)) - (unless entry (return)) - (spell-add-entry entry) - (if eofp (return)))))) - - -;;; This is used to break up an 18 bit string table index into two parts -;;; for storage in a word descriptor unit. See the documentation at the -;;; top of Spell-Correct.Lisp. -;;; -(defconstant whole-index-low-byte (byte 16 0)) - -(defun spell-add-entry (line &optional - (word-end (or (position #\/ line :test #'char=) - (length line)))) - "Line is of the form \"entry/flag1/flag2\" or \"entry\". It is parsed and - added to the spelling dictionary. Line is desstructively modified." - (declare (simple-string line) (fixnum word-end)) - (nstring-upcase line :end word-end) - (when (> word-end max-entry-length) - (return-from spell-add-entry nil)) - (let ((entry (lookup-entry line word-end))) - (when entry - (add-flags (+ entry 2) line word-end) - (return-from spell-add-entry nil))) - (let* ((hash-loc (hash-entry line word-end)) - (string-ptr *string-table-size*) - (desc-ptr *descriptors-size*) - (desc-ptr+1 (1+ desc-ptr)) - (desc-ptr+2 (1+ desc-ptr+1))) - (declare (fixnum string-ptr)) - (when (not hash-loc) (error "Dictionary Overflow!")) - (when (> 3 *free-descriptor-elements*) (grow-descriptors)) - (when (> word-end *free-string-table-bytes*) (grow-string-table)) - (decf *free-descriptor-elements* 3) - (incf *descriptors-size* 3) - (decf *free-string-table-bytes* word-end) - (incf *string-table-size* word-end) - (setf (dictionary-ref hash-loc) desc-ptr) - (setf (descriptor-ref desc-ptr) - (dpb (the fixnum (ldb new-hash-byte (string-hash line word-end))) - stored-hash-byte - word-end)) - (setf (descriptor-ref desc-ptr+1) - (ldb whole-index-low-byte string-ptr)) - (setf (descriptor-ref desc-ptr+2) - (dpb (the fixnum (ldb whole-index-high-byte string-ptr)) - stored-index-high-byte - 0)) - (add-flags desc-ptr+2 line word-end) - (string-table-replace line string-ptr word-end)) - t) - -(defun add-flags (loc line word-end) - (declare (simple-string line) (fixnum word-end)) - (do ((flag (1+ word-end) (+ 2 flag)) - (line-end (length line))) - ((>= flag line-end)) - (declare (fixnum flag line-end)) - (let ((flag-mask (flag-mask (schar line flag)))) - (declare (fixnum flag-mask)) - (unless (zerop flag-mask) - (setf (descriptor-ref loc) - (logior flag-mask (descriptor-ref loc))))))) - -;;; SPELL-REMOVE-ENTRY destructively uppercases entry in removing it from -;;; the dictionary. First entry is looked up, and if it is found due to a -;;; flag, the flag is cleared in the descriptor table. If entry is a root -;;; word in the dictionary (that is, looked up without the use of a flag), -;;; then the root and all its derivitives are deleted by setting its -;;; dictionary location to spell-deleted-entry. -;;; -(defun spell-remove-entry (entry) - "Removes entry from the dictionary, so it will be an unknown word. Entry - is a simple string and is destructively modified. If entry is a root - word, then all words derived with entry and its flags will also be deleted." - (declare (simple-string entry)) - (nstring-upcase entry) - (let ((entry-len (length entry))) - (declare (fixnum entry-len)) - (when (<= 2 entry-len max-entry-length) - (multiple-value-bind (index flagp) - (spell-try-word entry entry-len) - (when index - (if flagp - (setf (descriptor-ref (+ 2 index)) - (logandc2 (descriptor-ref (+ 2 index)) flagp)) - (let* ((hash (string-hash entry entry-len)) - (hash-and-len (dpb (the fixnum (ldb new-hash-byte hash)) - stored-hash-byte - (the fixnum entry-len))) - (loc (rem hash (the fixnum *dictionary-size*))) - (loc-contents (dictionary-ref loc))) - (declare (fixnum hash hash-and-len loc)) - (cond ((zerop loc-contents) nil) - ((found-entry-p loc-contents entry entry-len hash-and-len) - (setf (dictionary-ref loc) spell-deleted-entry)) - (t - (hash2-loop (loop-loc loc-contents) loc hash - nil - (when (found-entry-p loc-contents entry - entry-len hash-and-len) - (setf (dictionary-ref loop-loc) - spell-deleted-entry) - (return spell-deleted-entry)))))))))))) - -(defun spell-root-flags (index) - "Return the flags associated with the root word corresponding to a - dictionary entry at index." - (let ((desc-word (descriptor-ref (+ 2 index))) - (result ())) - (declare (fixnum desc-word)) - (dolist (ele flag-names-to-masks result) - (unless (zerop (logand (the fixnum (cdr ele)) desc-word)) - (push (car ele) result))))) - - - - -;;;; Growing Dictionary Structures - -;;; GROW-DESCRIPTORS grows the descriptors vector by 10%. -;;; -(defun grow-descriptors () - (let* ((old-size (+ (the fixnum *descriptors-size*) - (the fixnum *free-descriptor-elements*))) - (new-size (truncate (* old-size 1.1))) - (new-bytes (* new-size 2)) - (new-sap (allocate-bytes new-bytes))) - (declare (fixnum new-size old-size)) - (sap-replace new-sap *descriptors* 0 0 - (* 2 (the fixnum *descriptors-size*))) - (deallocate-bytes (system-address *descriptors*) (* 2 old-size)) - (setf *free-descriptor-elements* - (- new-size (the fixnum *descriptors-size*))) - (setf *descriptors* new-sap))) - -;;; GROW-STRING-TABLE grows the string table by 10%. -;;; -(defun grow-string-table () - (let* ((old-size (+ (the fixnum *string-table-size*) - (the fixnum *free-string-table-bytes*))) - (new-size (truncate (* old-size 1.1))) - (new-sap (allocate-bytes new-size))) - (declare (fixnum new-size old-size)) - (sap-replace new-sap *string-table* 0 0 *string-table-size*) - (setf *free-string-table-bytes* - (- new-size (the fixnum *string-table-size*))) - (deallocate-bytes (system-address *string-table*) old-size) - (setf *string-table* new-sap))) Index: anches/ide-1.0/ccl/hemlock/src/spell-corr.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/spell-corr.lisp (revision 6566) +++ (revision ) @@ -1,816 +1,0 @@ -;;; -*- Log: hemlock.log; Package: Spell -*- -;;; -;;; ********************************************************************** -;;; This code was written as part of the CMU Common Lisp project at -;;; Carnegie Mellon University, and has been placed in the public domain. -;;; -#+CMU (ext:file-comment - "$Header$") -;;; -;;; ********************************************************************** -;;; -;;; Written by Bill Chiles -;;; Designed by Bill Chiles and Rob Maclachlan -;;; - -;;; This is the file that deals with checking and correcting words -;;; using a dictionary read in from a binary file. It has been written -;;; from the basic ideas used in Ispell (on DEC-20's) which originated as -;;; Spell on the ITS machines at MIT. There are flags which have proper -;;; uses defined for them that indicate permissible suffixes to entries. -;;; This allows for about three times as many known words than are actually -;;; stored. When checking the spelling of a word, first it is looked up; -;;; if this fails, then possible roots are looked up, and if any has the -;;; appropriate suffix flag, then the word is considered to be correctly -;;; spelled. For an unknown word, the following rules define "close" words -;;; which are possible corrections: -;;; 1] two adjacent letters are transposed to form a correct spelling; -;;; 2] one letter is changed to form a correct spelling; -;;; 3] one letter is added to form a correct spelling; and/or -;;; 4] one letter is removed to form a correct spelling. -;;; There are two restrictions on the length of a word in regards to its -;;; worthiness of recognition: it must be at least more than two letters -;;; long, and if it has a suffix, then it must be at least four letters -;;; long. More will be said about this when the flags are discussed. -;;; This is implemented in as tense a fashion as possible, and it uses -;;; implementation dependent code from Spell-RT.Lisp to accomplish this. -;;; In general the file I/O and structure accesses encompass the system -;;; dependencies. - -;;; This next section will discuss the storage of the dictionary -;;; information. There are three data structures that "are" the -;;; dictionary: a hash table, descriptors table, and a string table. The -;;; hash table is a vector of type '(unsigned-byte 16), whose elements -;;; point into the descriptors table. This is a cyclic hash table to -;;; facilitate dumping it to a file. The descriptors table (also of type -;;; '(unsigned-byte 16)) dedicates three elements to each entry in the -;;; dictionary. Each group of three elements has the following organization -;;; imposed on them: -;;; ---------------------------------------------- -;;; | 15..5 hash code | 4..0 length | -;;; ---------------------------------------------- -;;; | 15..0 character index | -;;; ---------------------------------------------- -;;; | 15..14 character index | 13..0 flags | -;;; ---------------------------------------------- -;;; "Length" is the number of characters in the entry; "hash code" is some -;;; eleven bits from the hash code to allow for quicker lookup, "flags" -;;; indicate possible suffixes for the basic entry, and "character index" -;;; is the index of the start of the entry in the string table. -;;; This was originally adopted due to the Perq's word size (can you guess? -;;; 16 bits, that's right). Note the constraint that is placed on the number -;;; of the entries, 21845, because the hash table could not point to more -;;; descriptor units (16 bits of pointer divided by three). Since a value of -;;; zero as a hash table element indicates an empty location, the zeroth element -;;; of the descriptors table must be unused (it cannot be pointed to). - - -;;; The following is a short discussion with examples of the correct -;;; use of the suffix flags. Let # and @ be symbols that can stand for any -;;; single letter. Upper case letters are constants. "..." stands for any -;;; string of zero or more letters, but note that no word may exist in the -;;; dictionary which is not at least 2 letters long, so, for example, FLY -;;; may not be produced by placing the "Y" flag on "F". Also, no flag is -;;; effective unless the word that it creates is at least 4 letters long, -;;; so, for example, WED may not be produced by placing the "D" flag on -;;; "WE". These flags and examples are from the Ispell documentation with -;;; only slight modifications. Here are the correct uses of the flags: -;;; -;;; "V" flag: -;;; ...E => ...IVE as in create => creative -;;; if # .ne. E, then ...# => ...#IVE as in prevent => preventive -;;; -;;; "N" flag: -;;; ...E => ...ION as in create => creation -;;; ...Y => ...ICATION as in multiply => multiplication -;;; if # .ne. E or Y, then ...# => ...#EN as in fall => fallen -;;; -;;; "X" flag: -;;; ...E => ...IONS as in create => creations -;;; ...Y => ...ICATIONS as in multiply => multiplications -;;; if # .ne. E or Y, ...# => ...#ENS as in weak => weakens -;;; -;;; "H" flag: -;;; ...Y => ...IETH as in twenty => twentieth -;;; if # .ne. Y, then ...# => ...#TH as in hundred => hundredth -;;; -;;; "Y" FLAG: -;;; ... => ...LY as in quick => quickly -;;; -;;; "G" FLAG: -;;; ...E => ...ING as in file => filing -;;; if # .ne. E, then ...# => ...#ING as in cross => crossing -;;; -;;; "J" FLAG" -;;; ...E => ...INGS as in file => filings -;;; if # .ne. E, then ...# => ...#INGS as in cross => crossings -;;; -;;; "D" FLAG: -;;; ...E => ...ED as in create => created -;;; if @ .ne. A, E, I, O, or U, -;;; then ...@Y => ...@IED as in imply => implied -;;; if # = Y, and @ = A, E, I, O, or U, -;;; then ...@# => ...@#ED as in convey => conveyed -;;; if # .ne. E or Y, then ...# => ...#ED as in cross => crossed -;;; -;;; "T" FLAG: -;;; ...E => ...EST as in late => latest -;;; if @ .ne. A, E, I, O, or U, -;;; then ...@Y => ...@IEST as in dirty => dirtiest -;;; if # = Y, and @ = A, E, I, O, or U, -;;; then ...@# => ...@#EST as in gray => grayest -;;; if # .ne. E or Y, then ...# => ...#EST as in small => smallest -;;; -;;; "R" FLAG: -;;; ...E => ...ER as in skate => skater -;;; if @ .ne. A, E, I, O, or U, -;;; then ...@Y => ...@IER as in multiply => multiplier -;;; if # = Y, and @ = A, E, I, O, or U, -;;; then ...@# => ...@#ER as in convey => conveyer -;;; if # .ne. E or Y, then ...# => ...#ER as in build => builder -;;; - -;;; "Z FLAG: -;;; ...E => ...ERS as in skate => skaters -;;; if @ .ne. A, E, I, O, or U, -;;; then ...@Y => ...@IERS as in multiply => multipliers -;;; if # = Y, and @ = A, E, I, O, or U, -;;; then ...@# => ...@#ERS as in slay => slayers -;;; if # .ne. E or Y, then ...@# => ...@#ERS as in build => builders -;;; -;;; "S" FLAG: -;;; if @ .ne. A, E, I, O, or U, -;;; then ...@Y => ...@IES as in imply => implies -;;; if # .eq. S, X, Z, or H, -;;; then ...# => ...#ES as in fix => fixes -;;; if # .ne. S, X, Z, H, or Y, -;;; then ...# => ...#S as in bat => bats -;;; if # = Y, and @ = A, E, I, O, or U, -;;; then ...@# => ...@#S as in convey => conveys -;;; -;;; "P" FLAG: -;;; if # .ne. Y, or @ = A, E, I, O, or U, -;;; then ...@# => ...@#NESS as in late => lateness and -;;; gray => grayness -;;; if @ .ne. A, E, I, O, or U, -;;; then ...@Y => ...@INESS as in cloudy => cloudiness -;;; -;;; "M" FLAG: -;;; ... => ...'S as in DOG => DOG'S - -(in-package "SPELL") - - - -;;;; Some Constants - -(eval-when (:compile-toplevel :execute :load-toplevel) - -(defconstant spell-deleted-entry #xFFFF) - -;;; The next number (using 6 bits) is 63, and that's pretty silly because -;;; "supercalafragalistic" is less than 31 characters long. -;;; -(defconstant max-entry-length 31 - "This the maximum number of characters an entry may have.") - -;;; These are the flags (described above), and an entry is allowed a -;;; certain suffix if the appropriate bit is on in the third element of -;;; its descriptor unit (described above). -;;; -(defconstant V-mask (ash 1 13)) -(defconstant N-mask (ash 1 12)) -(defconstant X-mask (ash 1 11)) -(defconstant H-mask (ash 1 10)) -(defconstant Y-mask (ash 1 9)) -(defconstant G-mask (ash 1 8)) -(defconstant J-mask (ash 1 7)) -(defconstant D-mask (ash 1 6)) -(defconstant T-mask (ash 1 5)) -(defconstant R-mask (ash 1 4)) -(defconstant Z-mask (ash 1 3)) -(defconstant S-mask (ash 1 2)) -(defconstant P-mask (ash 1 1)) -(defconstant M-mask 1) - - -;;; These are the eleven bits of a computed hash that are stored as part of -;;; an entries descriptor unit. The shifting constant is how much the -;;; eleven bits need to be shifted to the right, so they take up the upper -;;; eleven bits of one 16-bit element in a descriptor unit. -;;; -(defconstant new-hash-byte (byte 11 13)) -(defconstant stored-hash-byte (byte 11 5)) - - -;;; The next two constants are used to extract information from an entry's -;;; descriptor unit. The first is the two most significant bits of 18 -;;; bits that hold an index into the string table where the entry is -;;; located. If this is confusing, regard the diagram of the descriptor -;;; units above. -;;; -(defconstant whole-index-high-byte (byte 2 16)) -(defconstant stored-index-high-byte (byte 2 14)) -(defconstant stored-length-byte (byte 5 0)) - - -); eval-when (:compile-toplevel :execute :load-toplevel) - - - -;;;; Some Specials and Accesses - -;;; *spell-aeiou* will have bits on that represent the capital letters -;;; A, E, I, O, and U to be used to determine if some word roots are legal -;;; for looking up. -;;; -(defvar *aeiou* - (make-array 128 :element-type 'bit :initial-element 0)) - -(setf (aref *aeiou* (char-code #\A)) 1) -(setf (aref *aeiou* (char-code #\E)) 1) -(setf (aref *aeiou* (char-code #\I)) 1) -(setf (aref *aeiou* (char-code #\O)) 1) -(setf (aref *aeiou* (char-code #\U)) 1) - - -;;; *sxzh* will have bits on that represent the capital letters -;;; S, X, Z, and H to be used to determine if some word roots are legal for -;;; looking up. -;;; -(defvar *sxzh* - (make-array 128 :element-type 'bit :initial-element 0)) - -(setf (aref *sxzh* (char-code #\S)) 1) -(setf (aref *sxzh* (char-code #\X)) 1) -(setf (aref *sxzh* (char-code #\Z)) 1) -(setf (aref *sxzh* (char-code #\H)) 1) - - -;;; SET-MEMBER-P will be used with *aeiou* and *sxzh* to determine if a -;;; character is in the specified set. -;;; -(eval-when (:compile-toplevel :execute) -(defmacro set-member-p (char set) - `(not (zerop (the fixnum (aref (the simple-bit-vector ,set) - (char-code ,char)))))) -) ;eval-when - - -(defvar *dictionary*) -(defvar *dictionary-size*) -(defvar *descriptors*) -(defvar *descriptors-size*) -(defvar *string-table*) -(defvar *string-table-size*) - - -(eval-when (:compile-toplevel :execute) - -;;; DICTIONARY-REF and DESCRIPTOR-REF are references to implementation -;;; dependent structures. *dictionary* and *descriptors* are "system -;;; area pointers" as a result of the way the binary file is opened for -;;; fast access. -;;; -(defmacro dictionary-ref (idx) - `(sapref *dictionary* ,idx)) - -(defmacro descriptor-ref (idx) - `(sapref *descriptors* ,idx)) - - -;;; DESCRIPTOR-STRING-START access an entry's (indicated by idx) -;;; descriptor unit (described at the beginning of the file) and returns -;;; the start index of the entry in the string table. The second of three -;;; words in the descriptor holds the 16 least significant bits of 18, and -;;; the top two bits of the third word are the 2 most significant bits. -;;; These 18 bits are the index into the string table. -;;; -(defmacro descriptor-string-start (idx) - `(dpb (the fixnum (ldb stored-index-high-byte - (the fixnum (descriptor-ref (+ 2 ,idx))))) - whole-index-high-byte - (the fixnum (descriptor-ref (1+ ,idx))))) - -) ;eval-when - - - - -;;;; Top level Checking/Correcting - -;;; CORRECT-SPELLING can be called from top level to check/correct a words -;;; spelling. It is not used for any other purpose. -;;; -(defun correct-spelling (word) - "Check/correct the spelling of word. Output is done to *standard-output*." - (setf word (coerce word 'simple-string)) - (let ((word (string-upcase (the simple-string word))) - (word-len (length (the simple-string word)))) - (declare (simple-string word) (fixnum word-len)) - (maybe-read-spell-dictionary) - (when (= word-len 1) - (error "Single character words are not in the dictionary.")) - (when (> word-len max-entry-length) - (error "~A is too long for the dictionary." word)) - (multiple-value-bind (idx used-flag-p) - (spell-try-word word word-len) - (if idx - (format t "Found it~:[~; because of ~A~]." used-flag-p - (spell-root-word idx)) - (let ((close-words (spell-collect-close-words word))) - (if close-words - (format *standard-output* - "The possible correct spelling~[~; is~:;s are~]:~ - ~:*~[~; ~{~A~}~;~{ ~A~^ and~}~:;~ - ~{~#[~; and~] ~A~^,~}~]." - (length close-words) - close-words) - (format *standard-output* "Word not found."))))))) - - -(defvar *dictionary-read-p* nil) - -;;; MAYBE-READ-SPELL-DICTIONARY -- Public -;;; -(defun maybe-read-spell-dictionary () - "Read the spelling dictionary if it has not be read already." - (unless *dictionary-read-p* (read-dictionary))) - - -(defun spell-root-word (index) - "Return the root word corresponding to a dictionary entry at index." - (let* ((start (descriptor-string-start index)) - (len (the fixnum (ldb stored-length-byte - (the fixnum (descriptor-ref index))))) - (result (make-string len))) - (declare (fixnum start len) - (simple-string result)) - (sap-replace result (the system-area-pointer *string-table*) - start 0 len) - result)) - - -(eval-when (:compile-toplevel :execute) -(defmacro check-closeness (word word-len closeness-list) - `(if (spell-try-word ,word ,word-len) - (pushnew (subseq ,word 0 ,word-len) ,closeness-list :test #'string=))) -) ;eval-when - -(defconstant spell-alphabet - (list #\A #\B #\C #\D #\E #\F #\G #\H - #\I #\J #\K #\L #\M #\N #\O #\P - #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z)) - -;;; SPELL-COLLECT-CLOSE-WORDS Returns a list of all "close" correctly spelled -;;; words. The definition of "close" is at the beginning of the file, and -;;; there are four sections to this function which collect each of the four -;;; different kinds of close words. -;;; -(defun spell-collect-close-words (word) - "Returns a list of all \"close\" correctly spelled words. This has the - same contraints as SPELL-TRY-WORD, which you have probably already called - if you are calling this." - (declare (simple-string word)) - (let* ((word-len (length word)) - (word-len--1 (1- word-len)) - (word-len-+1 (1+ word-len)) - (result ()) - (correcting-buffer (make-string max-entry-length))) - (declare (simple-string correcting-buffer) - (fixnum word-len word-len--1 word-len-+1)) - (replace correcting-buffer word :end1 word-len :end2 word-len) - - ;; Misspelled because one letter is different. - (dotimes (i word-len) - (do ((save-char (schar correcting-buffer i)) - (alphabet spell-alphabet (cdr alphabet))) - ((null alphabet) - (setf (schar correcting-buffer i) save-char)) - (setf (schar correcting-buffer i) (car alphabet)) - (check-closeness correcting-buffer word-len result))) - - ;; Misspelled because two adjacent letters are transposed. - (dotimes (i word-len--1) - (rotatef (schar correcting-buffer i) (schar correcting-buffer (1+ i))) - (check-closeness correcting-buffer word-len result) - (rotatef (schar correcting-buffer i) (schar correcting-buffer (1+ i)))) - - ;; Misspelled because of extraneous letter. - (replace correcting-buffer word - :start2 1 :end1 word-len--1 :end2 word-len) - (check-closeness correcting-buffer word-len--1 result) - (dotimes (i word-len--1) - (setf (schar correcting-buffer i) (schar word i)) - (replace correcting-buffer word - :start1 (1+ i) :start2 (+ i 2) :end1 word-len--1 :end2 word-len) - (check-closeness correcting-buffer word-len--1 result)) - - ;; Misspelled because a letter is missing. - (replace correcting-buffer word - :start1 1 :end1 word-len-+1 :end2 word-len) - (dotimes (i word-len-+1) - (do ((alphabet spell-alphabet (cdr alphabet))) - ((null alphabet) - (rotatef (schar correcting-buffer i) - (schar correcting-buffer (1+ i)))) - (setf (schar correcting-buffer i) (car alphabet)) - (check-closeness correcting-buffer word-len-+1 result))) - result)) - -;;; SPELL-TRY-WORD The literal 4 is not a constant defined somewhere since it -;;; is part of the definition of the function of looking up words. -;;; TRY-WORD-ENDINGS relies on the guarantee that word-len is at least 4. -;;; -(defun spell-try-word (word word-len) - "See if the word or an appropriate root is in the spelling dicitionary. - Word-len must be inclusively in the range 2..max-entry-length." - (or (lookup-entry word word-len) - (if (>= (the fixnum word-len) 4) - (try-word-endings word word-len)))) - - - - -;;;; Divining Correct Spelling - -(eval-when (:compile-toplevel :execute) - -(defmacro setup-root-buffer (word buffer root-len) - `(replace ,buffer ,word :end1 ,root-len :end2 ,root-len)) - -(defmacro try-root (word root-len flag-mask) - (let ((result (gensym))) - `(let ((,result (lookup-entry ,word ,root-len))) - (if (and ,result (descriptor-flag ,result ,flag-mask)) - (return (values ,result ,flag-mask)))))) - -;;; TRY-MODIFIED-ROOT is used for root words that become truncated -;;; when suffixes are added (e.g., skate => skating). Char-idx is the last -;;; character in the root that has to typically be changed from a #\I to a -;;; #\Y or #\E. -;;; -(defmacro try-modified-root (word buffer root-len flag-mask char-idx new-char) - (let ((root-word (gensym))) - `(let ((,root-word (setup-root-buffer ,word ,buffer ,root-len))) - (setf (schar ,root-word ,char-idx) ,new-char) - (try-root ,root-word ,root-len ,flag-mask)))) - -) ;eval-when - - -(defvar *rooting-buffer* (make-string max-entry-length)) - -;;; TRY-WORD-ENDINGS takes a word that is at least of length 4 and -;;; returns multiple values on success (the index where the word's root's -;;; descriptor starts and :used-flag), otherwise nil. It looks at -;;; characters from the end to the beginning of the word to determine if it -;;; has any known suffixes. This is a VERY simple finite state machine -;;; where all of the suffixes are narrowed down to one possible one in at -;;; most two state changes. This is a PROG form for speed, and in some sense, -;;; readability. The states of the machine are the flag names that denote -;;; suffixes. The two points of branching to labels are the very beginning -;;; of the PROG and the S state. This is a fairly straight forward -;;; implementation of the flag rules presented at the beginning of this -;;; file, with char-idx checks, so we do not index the string below zero. - -(defun try-word-endings (word word-len) - (declare (simple-string word) - (fixnum word-len)) - (prog* ((char-idx (1- word-len)) - (char (schar word char-idx)) - (rooting-buffer *rooting-buffer*) - flag-mask) - (declare (simple-string rooting-buffer) - (fixnum char-idx)) - (case char - (#\S (go S)) ;This covers over half of the possible endings - ;by branching off the second to last character - ;to other flag states that have plural endings. - (#\R (setf flag-mask R-mask) ;"er" and "ier" - (go D-R-Z-FLAG)) - (#\T (go T-FLAG)) ;"est" and "iest" - (#\D (setf flag-mask D-mask) ;"ed" and "ied" - (go D-R-Z-FLAG)) - (#\H (go H-FLAG)) ;"th" and "ieth" - (#\N (setf flag-mask N-mask) ;"ion", "ication", and "en" - (go N-X-FLAG)) - (#\G (setf flag-mask G-mask) ;"ing" - (go G-J-FLAG)) - (#\Y (go Y-FLAG)) ;"ly" - (#\E (go V-FLAG))) ;"ive" - (return nil) - - S - (setf char-idx (1- char-idx)) - (setf char (schar word char-idx)) - (if (char= char #\Y) - (if (set-member-p (schar word (1- char-idx)) *aeiou*) - (try-root word (1+ char-idx) S-mask) - (return nil)) - (if (not (set-member-p char *sxzh*)) - (try-root word (1+ char-idx) S-mask))) - (case char - (#\E (go S-FLAG)) ;"es" and "ies" - (#\R (setf flag-mask Z-mask) ;"ers" and "iers" - (go D-R-Z-FLAG)) - (#\G (setf flag-mask J-mask) ;"ings" - (go G-J-FLAG)) - (#\S (go P-FLAG)) ;"ness" and "iness" - (#\N (setf flag-mask X-mask) ;"ions", "ications", and "ens" - (go N-X-FLAG)) - (#\' (try-root word char-idx M-mask))) - (return nil) - - S-FLAG - (setf char-idx (1- char-idx)) - (setf char (schar word char-idx)) - (if (set-member-p char *sxzh*) - (try-root word (1+ char-idx) S-mask)) - (if (and (char= char #\I) - (not (set-member-p (schar word (1- char-idx)) *aeiou*))) - (try-modified-root word rooting-buffer (1+ char-idx) - S-mask char-idx #\Y)) - (return nil) - - D-R-Z-FLAG - (if (char/= (schar word (1- char-idx)) #\E) (return nil)) - (try-root word char-idx flag-mask) - (if (<= (setf char-idx (- char-idx 2)) 0) (return nil)) - (setf char (schar word char-idx)) - (if (char= char #\Y) - (if (set-member-p (schar word (1- char-idx)) *aeiou*) - (try-root word (1+ char-idx) flag-mask) - (return nil)) - (if (char/= (schar word char-idx) #\E) - (try-root word (1+ char-idx) flag-mask))) - (if (and (char= char #\I) - (not (set-member-p (schar word (1- char-idx)) *aeiou*))) - (try-modified-root word rooting-buffer (1+ char-idx) - flag-mask char-idx #\Y)) - (return nil) - - P-FLAG - (if (or (char/= (schar word (1- char-idx)) #\E) - (char/= (schar word (- char-idx 2)) #\N)) - (return nil)) - (if (<= (setf char-idx (- char-idx 3)) 0) (return nil)) - (setf char (schar word char-idx)) - (if (char= char #\Y) - (if (set-member-p (schar word (1- char-idx)) *aeiou*) - (try-root word (1+ char-idx) P-mask) - (return nil))) - (try-root word (1+ char-idx) P-mask) - (if (and (char= char #\I) - (not (set-member-p (schar word (1- char-idx)) *aeiou*))) - (try-modified-root word rooting-buffer (1+ char-idx) - P-mask char-idx #\Y)) - (return nil) - - G-J-FLAG - (if (< char-idx 3) (return nil)) - (setf char-idx (- char-idx 2)) - (setf char (schar word char-idx)) - (if (or (char/= char #\I) (char/= (schar word (1+ char-idx)) #\N)) - (return nil)) - (if (char/= (schar word (1- char-idx)) #\E) - (try-root word char-idx flag-mask)) - (try-modified-root word rooting-buffer (1+ char-idx) - flag-mask char-idx #\E) - (return nil) - - N-X-FLAG - (setf char-idx (1- char-idx)) - (setf char (schar word char-idx)) - (cond ((char= char #\E) - (setf char (schar word (1- char-idx))) - (if (and (char/= char #\Y) (char/= char #\E)) - (try-root word char-idx flag-mask)) - (return nil)) - ((char= char #\O) - (if (char= (schar word (1- char-idx)) #\I) - (try-modified-root word rooting-buffer char-idx - flag-mask (1- char-idx) #\E) - (return nil)) - (if (< char-idx 5) (return nil)) - (if (or (char/= (schar word (- char-idx 2)) #\T) - (char/= (schar word (- char-idx 3)) #\A) - (char/= (schar word (- char-idx 4)) #\C) - (char/= (schar word (- char-idx 5)) #\I)) - (return nil) - (setf char-idx (- char-idx 4))) - (try-modified-root word rooting-buffer char-idx - flag-mask (1- char-idx) #\Y)) - (t (return nil))) - - T-FLAG - (if (or (char/= (schar word (1- char-idx)) #\S) - (char/= (schar word (- char-idx 2)) #\E)) - (return nil) - (setf char-idx (1- char-idx))) - (try-root word char-idx T-mask) - (if (<= (setf char-idx (- char-idx 2)) 0) (return nil)) - (setf char (schar word char-idx)) - (if (char= char #\Y) - (if (set-member-p (schar word (1- char-idx)) *aeiou*) - (try-root word (1+ char-idx) T-mask) - (return nil)) - (if (char/= (schar word char-idx) #\E) - (try-root word (1+ char-idx) T-mask))) - (if (and (char= char #\I) - (not (set-member-p (schar word (1- char-idx)) *aeiou*))) - (try-modified-root word rooting-buffer (1+ char-idx) - T-mask char-idx #\Y)) - (return nil) - - H-FLAG - (setf char-idx (1- char-idx)) - (setf char (schar word char-idx)) - (if (char/= char #\T) (return nil)) - (if (char/= (schar word (1- char-idx)) #\Y) - (try-root word char-idx H-mask)) - (if (and (char= (schar word (1- char-idx)) #\E) - (char= (schar word (- char-idx 2)) #\I)) - (try-modified-root word rooting-buffer (1- char-idx) - H-mask (- char-idx 2) #\Y)) - (return nil) - - Y-FLAG - (setf char-idx (1- char-idx)) - (setf char (schar word char-idx)) - (if (char= char #\L) - (try-root word char-idx Y-mask)) - (return nil) - - V-FLAG - (setf char-idx (- char-idx 2)) - (setf char (schar word char-idx)) - (if (or (char/= char #\I) (char/= (schar word (1+ char-idx)) #\V)) - (return nil)) - (if (char/= (schar word (1- char-idx)) #\E) - (try-root word char-idx V-mask)) - (try-modified-root word rooting-buffer (1+ char-idx) - V-mask char-idx #\E) - (return nil))) - - - -;;; DESCRIPTOR-FLAG returns t or nil based on whether the flag is on. -;;; From the diagram at the beginning of the file, we see that the flags -;;; are stored two words off of the first word in the descriptor unit for -;;; an entry. -;;; -(defun descriptor-flag (descriptor-start flag-mask) - (not (zerop - (the fixnum - (logand - (the fixnum (descriptor-ref (+ 2 (the fixnum descriptor-start)))) - (the fixnum flag-mask)))))) - - - -;;;; Looking up Trials - -(eval-when (:compile-toplevel :execute) - -;;; SPELL-STRING= determines if string1 and string2 are the same. Before -;;; it is called it is known that they are both of (- end1 0) length, and -;;; string2 is in system space. This is used in FOUND-ENTRY-P. -;;; -(defmacro spell-string= (string1 string2 end1 start2) - (let ((idx1 (gensym)) - (idx2 (gensym))) - `(do ((,idx1 0 (1+ ,idx1)) - (,idx2 ,start2 (1+ ,idx2))) - ((= ,idx1 ,end1) t) - (declare (fixnum ,idx1 ,idx2)) - (unless (= (the fixnum (char-code (schar ,string1 ,idx1))) - (the fixnum (string-sapref ,string2 ,idx2))) - (return nil))))) - -;;; FOUND-ENTRY-P determines if entry is what is described at idx. -;;; Hash-and-length is 16 bits that look just like the first word of any -;;; entry's descriptor unit (see diagram at the beginning of the file). If -;;; the word stored at idx and entry have the same hash bits and length, -;;; then we compare characters to see if they are the same. -;;; -(defmacro found-entry-p (idx entry entry-len hash-and-length) - `(if (= (the fixnum (descriptor-ref ,idx)) - (the fixnum ,hash-and-length)) - (spell-string= ,entry *string-table* ,entry-len - (descriptor-string-start ,idx)))) - -(defmacro hash2-increment (hash) - `(- (the fixnum *dictionary-size*) - 2 - (the fixnum (rem ,hash (- (the fixnum *dictionary-size*) 2))))) - -(defmacro hash2-loop ((location-var contents-var) - loc hash zero-contents-form - &optional body-form (for-insertion-p nil)) - (let ((incr (gensym))) - `(let* ((,incr (hash2-increment ,hash)) - (,location-var ,loc) - (,contents-var 0)) - (declare (fixnum ,location-var ,contents-var ,incr)) - (loop (setf ,location-var - (rem (+ ,location-var ,incr) (the fixnum *dictionary-size*))) - (setf ,contents-var (dictionary-ref ,location-var)) - (if (zerop ,contents-var) (return ,zero-contents-form)) - ,@(if for-insertion-p - `((if (= ,contents-var spell-deleted-entry) - (return ,zero-contents-form)))) - (if (= ,location-var ,loc) (return nil)) - ,@(if body-form `(,body-form)))))) - -) ;eval-when - - -;;; LOOKUP-ENTRY returns the index of the first element of entry's -;;; descriptor unit on success, otherwise nil. -;;; -(defun lookup-entry (entry &optional len) - (declare (simple-string entry)) - (let* ((entry-len (or len (length entry))) - (hash (string-hash entry entry-len)) - (hash-and-len (dpb (the fixnum (ldb new-hash-byte hash)) - stored-hash-byte - (the fixnum entry-len))) - (loc (rem hash (the fixnum *dictionary-size*))) - (loc-contents (dictionary-ref loc))) - (declare (fixnum entry-len hash hash-and-len loc)) - (cond ((zerop loc-contents) nil) - ((found-entry-p loc-contents entry entry-len hash-and-len) - loc-contents) - (t - (hash2-loop (loop-loc loc-contents) loc hash - nil - (if (found-entry-p loc-contents entry entry-len hash-and-len) - (return loc-contents))))))) - - -;;;; Binary File Reading - -(defparameter default-binary-dictionary - "library:spell-dictionary.bin") - -;;; This is the first thing in a spell binary dictionary file to serve as a -;;; quick check of its proposed contents. This particular number is -;;; "BILLS" on a calculator held upside-down. -;;; -(defconstant magic-file-id 57718) - -;;; These constants are derived from the order things are written to the -;;; binary dictionary in Spell-Build.Lisp. -;;; -(defconstant magic-file-id-loc 0) -(defconstant dictionary-size-loc 1) -(defconstant descriptors-size-loc 2) -(defconstant string-table-size-low-byte-loc 3) -(defconstant string-table-size-high-byte-loc 4) -(defconstant file-header-bytes 10) - -;;; Initially, there are no free descriptor elements and string table bytes, -;;; but when these structures are grown, they are grown by more than that -;;; which is necessary. -;;; -(defvar *free-descriptor-elements* 0) -(defvar *free-string-table-bytes* 0) - -;;; READ-DICTIONARY opens the dictionary and sets up the global structures -;;; manifesting the spelling dictionary. When computing the start addresses -;;; of these structures, we multiply by two since their sizes are in 16bit -;;; lengths while the RT is 8bit-byte addressable. -;;; -(defun read-dictionary (&optional (f default-binary-dictionary)) - (when *dictionary-read-p* - (setf *dictionary-read-p* nil) - (deallocate-bytes (system-address *dictionary*) - (* 2 (the fixnum *dictionary-size*))) - (deallocate-bytes (system-address *descriptors*) - (* 2 (the fixnum - (+ (the fixnum *descriptors-size*) - (the fixnum *free-descriptor-elements*))))) - (deallocate-bytes (system-address *string-table*) - (+ (the fixnum *string-table-size*) - (the fixnum *free-string-table-bytes*)))) - (setf *free-descriptor-elements* 0) - (setf *free-string-table-bytes* 0) - (let* ((fd (open-dictionary f)) - (header-info (read-dictionary-structure fd file-header-bytes))) - (unless (= (sapref header-info magic-file-id-loc) magic-file-id) - (deallocate-bytes (system-address header-info) file-header-bytes) - (error "File is not a dictionary: ~S." f)) - (setf *dictionary-size* (sapref header-info dictionary-size-loc)) - (setf *descriptors-size* (sapref header-info descriptors-size-loc)) - (setf *string-table-size* (sapref header-info string-table-size-low-byte-loc)) - (setf (ldb (byte 12 16) (the fixnum *string-table-size*)) - (the fixnum (sapref header-info string-table-size-high-byte-loc))) - (deallocate-bytes (system-address header-info) file-header-bytes) - (setf *dictionary* - (read-dictionary-structure fd (* 2 (the fixnum *dictionary-size*)))) - (setf *descriptors* - (read-dictionary-structure fd (* 2 (the fixnum *descriptors-size*)))) - (setf *string-table* (read-dictionary-structure fd *string-table-size*)) - (setf *dictionary-read-p* t) - (close-dictionary fd))) Index: anches/ide-1.0/ccl/hemlock/src/spell-rt.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/spell-rt.lisp (revision 6566) +++ (revision ) @@ -1,107 +1,0 @@ -;;; -*- Log: hemlock.log; Package: Spell -*- -;;; -;;; ********************************************************************** -;;; This code was written as part of the CMU Common Lisp project at -;;; Carnegie Mellon University, and has been placed in the public domain. -;;; -#+CMU (ext:file-comment - "$Header$") -;;; -;;; ********************************************************************** -;;; -;;; Written by Bill Chiles -;;; -;;; This file contains system dependent primitives for the spelling checking/ -;;; correcting code in Spell-Correct.Lisp, Spell-Augment.Lisp, and -;;; Spell-Build.Lisp. - -(defpackage "SPELL" - (:use "LISP" "EXTENSIONS" "SYSTEM") - (:export spell-try-word spell-root-word spell-collect-close-words - maybe-read-spell-dictionary correct-spelling max-entry-length - spell-read-dictionary spell-add-entry spell-root-flags - spell-remove-entry)) - -(in-package "SPELL") - - - -;;;; System Area Referencing and Setting - -(eval-when (:compile-toplevel :execute) - -;;; MAKE-SAP returns pointers that *dictionary*, *descriptors*, and -;;; *string-table* are bound to. Address is in the system area. -;;; -(defmacro make-sap (address) - `(system:int-sap ,address)) - -(defmacro system-address (sap) - `(system:sap-int ,sap)) - - -(defmacro allocate-bytes (count) - `(system:allocate-system-memory ,count)) - -(defmacro deallocate-bytes (address byte-count) - `(system:deallocate-system-memory (int-sap ,address) ,byte-count)) - - -(defmacro sapref (sap offset) - `(system:sap-ref-16 ,sap (* ,offset 2))) - -(defsetf sapref (sap offset) (value) - `(setf (system:sap-ref-16 ,sap (* ,offset 2)) ,value)) - - -(defmacro sap-replace (dst-string src-string src-start dst-start dst-end) - `(%primitive byte-blt ,src-string ,src-start ,dst-string ,dst-start ,dst-end)) - -(defmacro string-sapref (sap index) - `(system:sap-ref-8 ,sap ,index)) - - - - -;;;; Primitive String Hashing - -;;; STRING-HASH employs the instruction SXHASH-SIMPLE-SUBSTRING which takes -;;; an end argument, so we do not have to use SXHASH. SXHASH would mean -;;; doing a SUBSEQ of entry. -;;; -(defmacro string-hash (string length) - `(ext:truly-the lisp::index - (%primitive sxhash-simple-substring - ,string - (the fixnum ,length)))) - -) ;eval-when - - - - -;;;; Binary Dictionary File I/O - -(defun open-dictionary (f) - (let* ((filename (ext:unix-namestring f)) - (kind (unix:unix-file-kind filename))) - (unless kind (error "Cannot find dictionary -- ~S." filename)) - (multiple-value-bind (fd err) - (unix:unix-open filename unix:o_rdonly 0) - (unless fd - (error "Opening ~S failed: ~A." filename err)) - (multiple-value-bind (winp dev-or-err) (unix:unix-fstat fd) - (unless winp (error "Opening ~S failed: ~A." filename dev-or-err)) - fd)))) - -(defun close-dictionary (fd) - (unix:unix-close fd)) - -(defun read-dictionary-structure (fd bytes) - (let* ((structure (allocate-bytes bytes))) - (multiple-value-bind (read-bytes err) - (unix:unix-read fd structure bytes) - (when (or (null read-bytes) (not (= bytes read-bytes))) - (deallocate-bytes (system-address structure) bytes) - (error "Reading dictionary structure failed: ~A." err)) - structure))) Index: anches/ide-1.0/ccl/hemlock/src/spellcoms.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/spellcoms.lisp (revision 6566) +++ (revision ) @@ -1,822 +1,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock -*- -;;; -;;; ********************************************************************** -;;; This code was written as part of the CMU Common Lisp project at -;;; Carnegie Mellon University, and has been placed in the public domain. -;;; -#+CMU (ext:file-comment - "$Header$") -;;; -;;; ********************************************************************** -;;; -;;; Written by Bill Chiles and Rob Maclachlan. -;;; -;;; This file contains the code to implement commands using the spelling -;;; checking/correcting stuff in Spell-Corr.Lisp and the dictionary -;;; augmenting stuff in Spell-Augment.Lisp. - -(in-package :hemlock) - - - -(defstruct (spell-info (:print-function print-spell-info) - (:constructor make-spell-info (pathname))) - pathname ;Dictionary file. - insertions) ;Incremental insertions for this dictionary. - -(defun print-spell-info (obj str n) - (declare (ignore n)) - (let ((pn (spell-info-pathname obj))) - (format str "#" - (and pn (namestring pn))))) - - -(defattribute "Spell Word Character" - "One if the character is one that is present in the spell dictionary, - zero otherwise.") - -(do-alpha-chars (c :both) - (setf (character-attribute :spell-word-character c) 1)) -(setf (character-attribute :spell-word-character #\') 1) - - -(defvar *spelling-corrections* (make-hash-table :test #'equal) - "Mapping from incorrect words to their corrections.") - -(defvar *ignored-misspellings* (make-hash-table :test #'equal) - "A hashtable with true values for words that will be quietly ignored when - they appear.") - -(defhvar "Spell Ignore Uppercase" - "If true, then \"Check Word Spelling\" and \"Correct Buffer Spelling\" will - ignore unknown words that are all uppercase. This is useful for - abbreviations and cryptic formatter directives." - :value nil) - - - - -;;;; Basic Spelling Correction Command (Esc-$ in EMACS) - -(defcommand "Check Word Spelling" (p) - "Check the spelling of the previous word and offer possible corrections - if the word in unknown. To add words to the dictionary from a text file see - the command \"Augment Spelling Dictionary\"." - "Check the spelling of the previous word and offer possible correct - spellings if the word is known to be misspelled." - (declare (ignore p)) - (spell:maybe-read-spell-dictionary) - (let* ((region (spell-previous-word (current-point) nil)) - (word (if region - (region-to-string region) - (editor-error "No previous word."))) - (folded (string-upcase word))) - (message "Checking spelling of ~A." word) - (unless (check-out-word-spelling word folded) - (get-word-correction (region-start region) word folded)))) - - - -;;;; Auto-Spell mode: - -(defhvar "Check Word Spelling Beep" - "If true, \"Auto Check Word Spelling\" will beep when an unknown word is - found." - :value t) - -(defhvar "Correct Unique Spelling Immediately" - "If true, \"Auto Check Word Spelling\" will immediately attempt to correct any - unknown word, automatically making the correction if there is only one - possible." - :value t) - - -(defhvar "Default User Spelling Dictionary" - "This is the pathname of a dictionary to read the first time \"Spell\" mode - is entered in a given editing session. When \"Set Buffer Spelling - Dictionary\" or the \"dictionary\" file option is used to specify a - dictionary, this default one is read also. It defaults to nil." - :value nil) - -(defvar *default-user-dictionary-read-p* nil) - -(defun maybe-read-default-user-spelling-dictionary () - (let ((default-dict (value default-user-spelling-dictionary))) - (when (and default-dict (not *default-user-dictionary-read-p*)) - (spell:maybe-read-spell-dictionary) - (spell:spell-read-dictionary (truename default-dict)) - (setf *default-user-dictionary-read-p* t)))) - - -(defmode "Spell" - :transparent-p t :precedence 1.0 :setup-function 'spell-mode-setup) - -(defun spell-mode-setup (buffer) - (defhvar "Buffer Misspelled Words" - "This variable holds a ring of marks pointing to misspelled words." - :buffer buffer :value (make-ring 10 #'delete-mark)) - (maybe-read-default-user-spelling-dictionary)) - -(defcommand "Auto Spell Mode" (p) - "Toggle \"Spell\" mode in the current buffer. When in \"Spell\" mode, - the spelling of each word is checked after it is typed." - "Toggle \"Spell\" mode in the current buffer." - (declare (ignore p)) - (setf (buffer-minor-mode (current-buffer) "Spell") - (not (buffer-minor-mode (current-buffer) "Spell")))) - - -(defcommand "Auto Check Word Spelling" (p) - "Check the spelling of the previous word and display a message in the echo - area if the word is not in the dictionary. To add words to the dictionary - from a text file see the command \"Augment Spelling Dictionary\". If a - replacement for an unknown word has previously been specified, then the - replacement will be made immediately. If \"Correct Unique Spelling - Immediately\" is true, then this command will immediately correct words - which have a unique correction. If there is no obvious correction, then we - place the word in a ring buffer for access by the \"Correct Last Misspelled - Word\" command. If \"Check Word Spelling Beep\" is true, then this command - beeps when an unknown word is found, in addition to displaying the message." - "Check the spelling of the previous word, making obvious corrections, or - queuing the word in buffer-misspelled-words if we are at a loss." - (declare (ignore p)) - (unless (eq (last-command-type) :spell-check) - (spell:maybe-read-spell-dictionary) - (let ((region (spell-previous-word (current-point) t))) - (when region - (let* ((word (nstring-upcase (region-to-string region))) - (len (length word))) - (declare (simple-string word)) - (when (and (<= 2 len spell:max-entry-length) - (not (spell:spell-try-word word len))) - (let ((found (gethash word *spelling-corrections*)) - (save (region-to-string region))) - (cond (found - (undoable-replace-word (region-start region) save found) - (message "Corrected ~S to ~S." save found) - (when (value check-word-spelling-beep) (beep))) - ((and (value spell-ignore-uppercase) - (every #'upper-case-p save)) - (unless (gethash word *ignored-misspellings*) - (setf (gethash word *ignored-misspellings*) t) - (message "Ignoring ~S." save))) - (t - (let ((close (spell:spell-collect-close-words word))) - (cond ((and close - (null (rest close)) - (value correct-unique-spelling-immediately)) - (let ((fix (first close))) - (undoable-replace-word (region-start region) - save fix) - (message "Corrected ~S to ~S." save fix))) - (t - (ring-push (copy-mark (region-end region) - :right-inserting) - (value buffer-misspelled-words)) - (let ((nclose - (do ((i 0 (1+ i)) - (words close (cdr words)) - (nwords () (cons (list i (car words)) - nwords))) - ((null words) (nreverse nwords))))) - (message - "Word ~S not found.~ - ~@[ Corrections:~:{ ~D=~A~}~]" - save nclose))))) - (when (value check-word-spelling-beep) (beep)))))))))) - (setf (last-command-type) :spell-check)) - -(defcommand "Correct Last Misspelled Word" (p) - "Fix a misspelling found by \"Auto Check Word Spelling\". This prompts for - a single character command to determine which action to take to correct the - problem." - "Prompt for a single character command to determine how to fix up a - misspelling detected by Check-Word-Spelling-Command." - (declare (ignore p)) - (spell:maybe-read-spell-dictionary) - (do ((info (value spell-information))) - ((sub-correct-last-misspelled-word info)))) - -(defun sub-correct-last-misspelled-word (info) - (let* ((missed (value buffer-misspelled-words)) - (region (cond ((zerop (ring-length missed)) - (editor-error "No recently misspelled word.")) - ((spell-previous-word (ring-ref missed 0) t)) - (t (editor-error "No recently misspelled word.")))) - (word (region-to-string region)) - (folded (string-upcase word)) - (point (current-point)) - (save (copy-mark point)) - (res t)) - (declare (simple-string word)) - (unwind-protect - (progn - (when (check-out-word-spelling word folded) - (delete-mark (ring-pop missed)) - (return-from sub-correct-last-misspelled-word t)) - (move-mark point (region-end region)) - (command-case (:prompt "Action: " - :change-window nil - :help "Type a single character command to do something to the misspelled word.") - (#\c "Try to find a correction for this word." - (unless (get-word-correction (region-start region) word folded) - (reprompt))) - (#\i "Insert this word in the dictionary." - (spell:spell-add-entry folded) - (push folded (spell-info-insertions info)) - (message "~A inserted in the dictionary." word)) - (#\r "Prompt for a word to replace this word with." - (let ((s (prompt-for-string :prompt "Replace with: " - :default word - :help "Type a string to replace occurrences of this word with."))) - (delete-region region) - (insert-string point s) - (setf (gethash folded *spelling-corrections*) s))) - (:cancel "Ignore this word and go to the previous misspelled word." - (setq res nil)) - (:recursive-edit - "Go into a recursive edit and leave when it exits." - (do-recursive-edit)) - ((:exit #\q) "Exit and forget about this word.") - ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) - "Choose this numbered word as the correct spelling." - (let ((num (digit-char-p (ext:key-event-char *last-key-event-typed*))) - (close-words (spell:spell-collect-close-words folded))) - (cond ((> num (length close-words)) - (editor-error "Choice out of range.")) - (t (let ((s (nth num close-words))) - (setf (gethash folded *spelling-corrections*) s) - (undoable-replace-word (region-start region) - word s))))))) - (delete-mark (ring-pop missed)) - res) - (move-mark point save) - (delete-mark save)))) - -(defhvar "Spelling Un-Correct Prompt for Insert" - "When this is set, \"Undo Last Spelling Correction\" will prompt before - inserting the old word into the dictionary." - :value nil) - -(defcommand "Undo Last Spelling Correction" (p) - "Undo the last incremental spelling correction. - The \"correction\" is replaced with the old word, and the old word is - inserted in the dictionary. When \"Spelling Un-Correct Prompt for Insert\" - is set, the user is asked about inserting the old word. Any automatic - replacement for the old word is eliminated." - "Undo the last incremental spelling correction, nuking any undesirable - side-effects." - (declare (ignore p)) - (unless (hemlock-bound-p 'last-spelling-correction-mark) - (editor-error "No last spelling correction.")) - (let ((mark (value last-spelling-correction-mark)) - (words (value last-spelling-correction-words))) - (unless words - (editor-error "No last spelling correction.")) - (let* ((new (car words)) - (old (cdr words)) - (folded (string-upcase old))) - (declare (simple-string old new folded)) - (remhash folded *spelling-corrections*) - (delete-characters mark (length new)) - (insert-string mark old) - (setf (value last-spelling-correction-words) nil) - (when (or (not (value spelling-un-correct-prompt-for-insert)) - (prompt-for-y-or-n - :prompt (list "Insert ~A into spelling dictionary? " folded) - :default t - :default-string "Y")) - (push folded (spell-info-insertions (value spell-information))) - (spell:maybe-read-spell-dictionary) - (spell:spell-add-entry folded) - (message "Added ~S to spelling dictionary." old))))) - - -;;; Check-Out-Word-Spelling -- Internal -;;; -;;; Return Nil if Word is a candidate for correction, otherwise -;;; return T and message as to why it isn't. -;;; -(defun check-out-word-spelling (word folded) - (declare (simple-string word)) - (let ((len (length word))) - (cond ((= len 1) - (message "Single character words are not in the dictionary.") t) - ((> len spell:max-entry-length) - (message "~A is too long for the dictionary." word) t) - (t - (multiple-value-bind (idx flagp) (spell:spell-try-word folded len) - (when idx - (message "Found it~:[~; because of ~A~]." flagp - (spell:spell-root-word idx)) - t)))))) - -;;; Get-Word-Correction -- Internal -;;; -;;; Find all known close words to the either unknown or incorrectly -;;; spelled word we are checking. Word is the unmunged word, and Folded is -;;; the uppercased word. Mark is a mark which points to the beginning of -;;; the offending word. Return True if we successfully corrected the word. -;;; -(defun get-word-correction (mark word folded) - (let ((close-words (spell:spell-collect-close-words folded))) - (declare (list close-words)) - (if close-words - (with-pop-up-display (s :height 3) - (do ((i 0 (1+ i)) - (words close-words (cdr words))) - ((null words)) - (format s "~36R=~A " i (car words))) - (finish-output s) - (let* ((key-event (prompt-for-key-event - :prompt "Correction choice: ")) - (num (digit-char-p (ext:key-event-char key-event) 36))) - (cond ((not num) (return-from get-word-correction nil)) - ((> num (length close-words)) - (editor-error "Choice out of range.")) - (t - (let ((s (nth num close-words))) - (setf (gethash folded *spelling-corrections*) s) - (undoable-replace-word mark word s))))) - (return-from get-word-correction t)) - (with-pop-up-display (s :height 1) - (write-line "No corrections found." s) - nil)))) - - -;;; Undoable-Replace-Word -- Internal -;;; -;;; Like Spell-Replace-Word, but makes annotations in buffer local variables -;;; so that "Undo Last Spelling Correction" can undo it. -;;; -(defun undoable-replace-word (mark old new) - (unless (hemlock-bound-p 'last-spelling-correction-mark) - (let ((buffer (current-buffer))) - (defhvar "Last Spelling Correction Mark" - "This variable holds a park pointing to the last spelling correction." - :buffer buffer :value (copy-mark (buffer-start-mark buffer))) - (defhvar "Last Spelling Correction Words" - "The replacement done for the last correction: (new . old)." - :buffer buffer :value nil))) - (move-mark (value last-spelling-correction-mark) mark) - (setf (value last-spelling-correction-words) (cons new old)) - (spell-replace-word mark old new)) - - - -;;;; Buffer Correction - -(defvar *spell-word-characters* - (make-array char-code-limit :element-type 'bit :initial-element 0) - "Characters that are legal in a word for spelling checking purposes.") - -(do-alpha-chars (c :both) - (setf (sbit *spell-word-characters* (char-code c)) 1)) -(setf (sbit *spell-word-characters* (char-code #\')) 1) - - -(defcommand "Correct Buffer Spelling" (p) - "Correct spelling over whole buffer. A log of the found misspellings is - kept in the buffer \"Spell Corrections\". For each unknown word the - user may accept it, insert it in the dictionary, correct its spelling - with one of the offered possibilities, replace the word with a user - supplied word, or go into a recursive edit. Words may be added to the - dictionary in advance from a text file (see the command \"Augment - Spelling Dictionary\")." - "Correct spelling over whole buffer." - (declare (ignore p)) - (clrhash *ignored-misspellings*) - (let* ((buffer (current-buffer)) - (log (or (make-buffer "Spelling Corrections") - (getstring "Spelling Corrections" *buffer-names*))) - (point (buffer-end (buffer-point log))) - (*standard-output* (make-hemlock-output-stream point)) - (window (or (car (buffer-windows log)) (make-window point)))) - (format t "~&Starting spelling checking of buffer ~S.~2%" - (buffer-name buffer)) - (spell:maybe-read-spell-dictionary) - (correct-buffer-spelling buffer window) - (delete-window window) - (close *standard-output*))) - -;;; CORRECT-BUFFER-SPELLING scans through buffer a line at a time, grabbing the -;;; each line's string and breaking it up into words using the -;;; *spell-word-characters* mask. We try the spelling of each word, and if it -;;; is unknown, we call FIX-WORD and resynchronize when it returns. -;;; -(defun correct-buffer-spelling (buffer window) - (do ((line (mark-line (buffer-start-mark buffer)) (line-next line)) - (info (if (hemlock-bound-p 'spell-information :buffer buffer) - (variable-value 'spell-information :buffer buffer) - (value spell-information))) - (mask *spell-word-characters*) - (word (make-string spell:max-entry-length))) - ((null line)) - (declare (simple-bit-vector mask) (simple-string word)) - (block line - (let* ((string (line-string line)) - (length (length string))) - (declare (simple-string string)) - (do ((start 0 (or skip-apostrophes end)) - (skip-apostrophes nil nil) - end) - (nil) - ;; - ;; Find word start. - (loop - (when (= start length) (return-from line)) - (when (/= (bit mask (char-code (schar string start))) 0) (return)) - (incf start)) - ;; - ;; Find the end. - (setq end (1+ start)) - (loop - (when (= end length) (return)) - (when (zerop (bit mask (char-code (schar string end)))) (return)) - (incf end)) - (multiple-value-setq (end skip-apostrophes) - (correct-buffer-word-end string start end)) - ;; - ;; Check word. - (let ((word-len (- end start))) - (cond - ((= word-len 1)) - ((> word-len spell:max-entry-length) - (format t "Not checking ~S -- too long for dictionary.~2%" - word)) - (t - ;; - ;; Copy the word and uppercase it. - (do* ((i (1- end) (1- i)) - (j (1- word-len) (1- j))) - ((zerop j) - (setf (schar word 0) (char-upcase (schar string i)))) - (setf (schar word j) (char-upcase (schar string i)))) - (unless (spell:spell-try-word word word-len) - (move-to-position (current-point) start line) - (fix-word (subseq word 0 word-len) (subseq string start end) - window info) - (let ((point (current-point))) - (setq end (mark-charpos point) - line (mark-line point) - string (line-string line) - length (length string)))))))))))) - -;;; CORRECT-BUFFER-WORD-END takes a line string from CORRECT-BUFFER-SPELLING, a -;;; start, and a end. It places end to exclude from the word apostrophes used -;;; for quotation marks, possessives, and funny plurals (e.g., A's and AND's). -;;; Every word potentially can be followed by "'s", and any clown can use the -;;; `` '' Scribe ligature. This returns the value to use for end of the word -;;; and the value to use as the end when continuing to find the next word in -;;; string. -;;; -(defun correct-buffer-word-end (string start end) - (cond ((and (> (- end start) 2) - (char= (char-upcase (schar string (1- end))) #\S) - (char= (schar string (- end 2)) #\')) - ;; Use roots of possessives and funny plurals (e.g., A's and AND's). - (values (- end 2) end)) - (t - ;; Maybe backup over apostrophes used for quotation marks. - (do ((i (1- end) (1- i))) - ((= i start) (values end end)) - (when (char/= (schar string i) #\') - (return (values (1+ i) end))))))) - -;;; Fix-Word -- Internal -;;; -;;; Handles the case where the word has a known correction. If is does -;;; not then call Correct-Buffer-Word-Not-Found. In either case, the -;;; point is left at the place to resume checking. -;;; -(defun fix-word (word unfolded-word window info) - (declare (simple-string word unfolded-word)) - (let ((correction (gethash word *spelling-corrections*)) - (mark (current-point))) - (cond (correction - (format t "Replacing ~S with ~S.~%" unfolded-word correction) - (spell-replace-word mark unfolded-word correction)) - ((and (value spell-ignore-uppercase) - (every #'upper-case-p unfolded-word)) - (character-offset mark (length word)) - (unless (gethash word *ignored-misspellings*) - (setf (gethash word *ignored-misspellings*) t) - (format t "Ignoring ~S.~%" unfolded-word))) - (t - (correct-buffer-word-not-found word unfolded-word window info))))) - -(defun correct-buffer-word-not-found (word unfolded-word window info) - (declare (simple-string word unfolded-word)) - (let* ((close-words (spell:spell-collect-close-words word)) - (close-words-len (length (the list close-words))) - (mark (current-point)) - (wordlen (length word))) - (format t "Unknown word: ~A~%" word) - (cond (close-words - (format t "~[~;A~:;Some~]~:* possible correction~[~; is~:;s are~]: " - close-words-len) - (if (= close-words-len 1) - (write-line (car close-words)) - (let ((n 0)) - (dolist (w close-words (terpri)) - (format t "~36R=~A " n w) - (incf n))))) - (t - (write-line "No correction possibilities found."))) - (let ((point (buffer-point (window-buffer window)))) - (unless (displayed-p point window) - (center-window window point))) - (command-case - (:prompt "Action: " - :help "Type a single letter command, or help character for help." - :change-window nil) - (#\i "Insert unknown word into dictionary for future lookup." - (spell:spell-add-entry word) - (push word (spell-info-insertions info)) - (format t "~S added to dictionary.~2%" word)) - (#\c "Correct the unknown word with possible correct spellings." - (unless close-words - (write-line "There are no possible corrections.") - (reprompt)) - (let ((num (if (= close-words-len 1) 0 - (digit-char-p (ext:key-event-char - (prompt-for-key-event - :prompt "Correction choice: ")) - 36)))) - (unless num (reprompt)) - (when (> num close-words-len) - (beep) - (write-line "Response out of range.") - (reprompt)) - (let ((choice (nth num close-words))) - (setf (gethash word *spelling-corrections*) choice) - (spell-replace-word mark unfolded-word choice))) - (terpri)) - (#\a "Accept the word as correct (that is, ignore it)." - (character-offset mark wordlen)) - (#\r "Replace the unknown word with a supplied replacement." - (let ((s (prompt-for-string - :prompt "Replacement Word: " - :default unfolded-word - :help "String to replace the unknown word with."))) - (setf (gethash word *spelling-corrections*) s) - (spell-replace-word mark unfolded-word s)) - (terpri)) - (:recursive-edit - "Go into a recursive edit and resume correction where the point is left." - (do-recursive-edit))))) - -;;; Spell-Replace-Word -- Internal -;;; -;;; Replaces Old with New, starting at Mark. The case of Old is used -;;; to derive the new case. -;;; -(defun spell-replace-word (mark old new) - (declare (simple-string old new)) - (let ((res (cond ((lower-case-p (schar old 0)) - (string-downcase new)) - ((lower-case-p (schar old 1)) - (let ((res (string-downcase new))) - (setf (char res 0) (char-upcase (char res 0))) - res)) - (t - (string-upcase new))))) - (with-mark ((m mark :left-inserting)) - (delete-characters m (length old)) - (insert-string m res)))) - - - -;;;; User Spelling Dictionaries. - -(defvar *pathname-to-spell-info* (make-hash-table :test #'equal) - "This maps dictionary files to spelling information.") - -(defhvar "Spell Information" - "This is the information about a spelling dictionary and its incremental - insertions." - :value (make-spell-info nil)) - -(define-file-option "Dictionary" (buffer file) - (let* ((dict (merge-pathnames - file - (make-pathname :defaults (buffer-default-pathname buffer) - :type "dict"))) - (dictp (probe-file dict))) - (if dictp - (set-buffer-spelling-dictionary-command nil dictp buffer) - (loud-message "Couldn't find dictionary ~A." (namestring dict))))) - -;;; SAVE-DICTIONARY-ON-WRITE is on the "Write File Hook" in buffers with -;;; the "dictionary" file option. -;;; -(defun save-dictionary-on-write (buffer) - (when (hemlock-bound-p 'spell-information :buffer buffer) - (save-spelling-insertions - (variable-value 'spell-information :buffer buffer)))) - - -(defcommand "Save Incremental Spelling Insertions" (p) - "Append incremental spelling dictionary insertions to a file. The file - is prompted for unless \"Set Buffer Spelling Dictionary\" has been - executed in the buffer." - "Append incremental spelling dictionary insertions to a file." - (declare (ignore p)) - (let* ((info (value spell-information)) - (file (or (spell-info-pathname info) - (value default-user-spelling-dictionary) - (prompt-for-file - :prompt "Dictionary File: " - :default (dictionary-name-default) - :must-exist nil - :help - "Name of the dictionary file to append dictionary insertions to.")))) - (save-spelling-insertions info file) - (let* ((ginfo (variable-value 'spell-information :global)) - (insertions (spell-info-insertions ginfo))) - (when (and insertions - (prompt-for-y-or-n - :prompt - `("Global spelling insertions exist.~%~ - Save these to ~A also? " - ,(namestring file) - :default t - :default-string "Y")) - (save-spelling-insertions ginfo file)))))) - -(defun save-spelling-insertions (info &optional - (name (spell-info-pathname info))) - (when (spell-info-insertions info) - (with-open-file (stream name - :direction :output :element-type 'base-char - :if-exists :append :if-does-not-exist :create) - (dolist (w (spell-info-insertions info)) - (write-line w stream))) - (setf (spell-info-insertions info) ()) - (message "Incremental spelling insertions for ~A written." - (namestring name)))) - -(defcommand "Set Buffer Spelling Dictionary" (p &optional file buffer) - "Prompts for the dictionary file to associate with the current buffer. - If this file has not been read for any other buffer, then it is read. - Incremental spelling insertions from this buffer can be appended to - this file with \"Save Incremental Spelling Insertions\"." - "Sets the buffer's spelling dictionary and reads it if necessary." - (declare (ignore p)) - (maybe-read-default-user-spelling-dictionary) - (let* ((file (truename (or file - (prompt-for-file - :prompt "Dictionary File: " - :default (dictionary-name-default) - :help - "Name of the dictionary file to add into the current dictionary.")))) - (file-name (namestring file)) - (spell-info-p (gethash file-name *pathname-to-spell-info*)) - (spell-info (or spell-info-p (make-spell-info file))) - (buffer (or buffer (current-buffer)))) - (defhvar "Spell Information" - "This is the information about a spelling dictionary and its incremental - insertions." - :value spell-info :buffer buffer) - (add-hook write-file-hook 'save-dictionary-on-write) - (unless spell-info-p - (setf (gethash file-name *pathname-to-spell-info*) spell-info) - (read-spelling-dictionary-command nil file)))) - -(defcommand "Read Spelling Dictionary" (p &optional file) - "Adds entries to the dictionary from a file in the following format: - - entry1/flag1/flag2/flag3 - entry2 - entry3/flag1/flag2/flag3/flag4/flag5. - - The flags are single letter indicators of legal suffixes for the entry; - the available flags and their correct use may be found at the beginning - of spell-correct.lisp in the Hemlock sources. There must be exactly one - entry per line, and each line must be flushleft." - "Add entries to the dictionary from a text file in a specified format." - (declare (ignore p)) - (spell:maybe-read-spell-dictionary) - (spell:spell-read-dictionary - (or file - (prompt-for-file - :prompt "Dictionary File: " - :default (dictionary-name-default) - :help - "Name of the dictionary file to add into the current dictionary.")))) - -(defun dictionary-name-default () - (make-pathname :defaults (buffer-default-pathname (current-buffer)) - :type "dict")) - -(defcommand "Add Word to Spelling Dictionary" (p) - "Add the previous word to the spelling dictionary." - "Add the previous word to the spelling dictionary." - (declare (ignore p)) - (spell:maybe-read-spell-dictionary) - (let ((word (region-to-string (spell-previous-word (current-point) nil)))) - ;; - ;; SPELL:SPELL-ADD-ENTRY destructively uppercases word. - (when (spell:spell-add-entry word) - (message "Word ~(~S~) added to the spelling dictionary." word) - (push word (spell-info-insertions (value spell-information)))))) - -(defcommand "Remove Word from Spelling Dictionary" (p) - "Prompts for word to remove from the spelling dictionary." - "Prompts for word to remove from the spelling dictionary." - (declare (ignore p)) - (spell:maybe-read-spell-dictionary) - (let* ((word (prompt-for-string - :prompt "Word to remove from spelling dictionary: " - :trim t)) - (upword (string-upcase word))) - (declare (simple-string word)) - (multiple-value-bind (index flagp) - (spell:spell-try-word upword (length word)) - (unless index - (editor-error "~A not in dictionary." upword)) - (if flagp - (remove-spelling-word upword) - (let ((flags (spell:spell-root-flags index))) - (when (or (not flags) - (prompt-for-y-or-n - :prompt - `("Deleting ~A also removes words formed from this root and these flags: ~% ~ - ~S.~%~ - Delete word anyway? " - ,word ,flags) - :default t - :default-string "Y")) - (remove-spelling-word upword))))))) - -;;; REMOVE-SPELLING-WORD removes the uppercase word word from the spelling -;;; dictionary and from the spelling informations incremental insertions list. -;;; -(defun remove-spelling-word (word) - (let ((info (value spell-information))) - (spell:spell-remove-entry word) - (setf (spell-info-insertions info) - (delete word (spell-info-insertions info) :test #'string=)))) - -(defcommand "List Incremental Spelling Insertions" (p) - "Display the incremental spelling insertions for the current buffer's - associated spelling dictionary file." - "Display the incremental spelling insertions for the current buffer's - associated spelling dictionary file." - (declare (ignore p)) - (let* ((info (value spell-information)) - (file (spell-info-pathname info)) - (insertions (spell-info-insertions info))) - (declare (list insertions)) - (with-pop-up-display (s :height (1+ (length insertions))) - (if file - (format s "Incremental spelling insertions for dictionary ~A:~%" - (namestring file)) - (write-line "Global incremental spelling insertions:" s)) - (dolist (w insertions) - (write-line w s))))) - - - - -;;;; Utilities for above stuff. - -;;; SPELL-PREVIOUS-WORD returns as a region the current or previous word, using -;;; the spell word definition. If there is no such word, return nil. If end-p -;;; is non-nil, then mark ends the word even if there is a non-delimiter -;;; character after it. -;;; -;;; Actually, if mark is between the first character of a word and a -;;; non-spell-word characer, it is considered to be in that word even though -;;; that word is after the mark. This is because Hemlock's cursor is always -;;; displayed over the next character, so users tend to think of a cursor -;;; displayed on the first character of a word as being in that word instead of -;;; before it. -;;; -(defun spell-previous-word (mark end-p) - (with-mark ((point mark) - (mark mark)) - (cond ((or end-p - (zerop (character-attribute :spell-word-character - (next-character point)))) - (unless (reverse-find-attribute mark :spell-word-character) - (return-from spell-previous-word nil)) - (move-mark point mark) - (reverse-find-attribute point :spell-word-character #'zerop)) - (t - (find-attribute mark :spell-word-character #'zerop) - (reverse-find-attribute point :spell-word-character #'zerop))) - (cond ((and (> (- (mark-charpos mark) (mark-charpos point)) 2) - (char= (char-upcase (previous-character mark)) #\S) - (char= (prog1 (previous-character (mark-before mark)) - (mark-after mark)) - #\')) - ;; Use roots of possessives and funny plurals (e.g., A's and AND's). - (character-offset mark -2)) - (t - ;; Maybe backup over apostrophes used for quotation marks. - (loop - (when (mark= point mark) (return-from spell-previous-word nil)) - (when (char/= (previous-character mark) #\') (return)) - (mark-before mark)))) - (region point mark))) Index: anches/ide-1.0/ccl/hemlock/src/ts-buf.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/ts-buf.lisp (revision 6566) +++ (revision ) @@ -1,318 +1,0 @@ -;;; -*- Package: Hemlock; Log: hemlock.log -*- -;;; -;;; ********************************************************************** -;;; This code was written as part of the CMU Common Lisp project at -;;; Carnegie Mellon University, and has been placed in the public domain. -;;; -(hemlock-ext:file-comment - "$Header$") -;;; -;;; ********************************************************************** -;;; -;;; This file contains code for processing input to and output from slaves -;;; using typescript streams. It maintains the stuff that hacks on the -;;; typescript buffer and maintains its state. -;;; -;;; Written by William Lott. -;;; - -(in-package :hemlock) - - -(defhvar "Input Wait Alarm" - "When non-nil, the user is informed when a typescript buffer goes into - an input wait, and it is not visible. Legal values are :message, - :loud-message (the default), and nil." - :value :loud-message) - - - - -;;;; Structures. - -(defstruct (ts-data - (:print-function - (lambda (ts s d) - (declare (ignore ts d)) - (write-string "#" s))) - (:constructor - make-ts-data (buffer - &aux - (fill-mark (copy-mark (buffer-end-mark buffer) - :right-inserting))))) - buffer ; The buffer we are in - stream ; Stream in the slave. - wire ; Wire to slave - server ; Server info struct. - fill-mark ; Mark where output goes. This is actually the - ; "Buffer Input Mark" which is :right-inserting, - ; and we make sure it is :left-inserting for - ; inserting output. - ) - - - -;;;; Output routines. - -;;; TS-BUFFER-OUTPUT-STRING --- internal interface. -;;; -;;; Called by the slave to output stuff in the typescript. Can also be called -;;; by other random parts of hemlock when they want to output stuff to the -;;; buffer. Since this is called for value from the slave, we have to be -;;; careful about what values we return, so the result can be sent back. It is -;;; called for value only as a synchronization thing. -;;; -;;; Whenever the output is gratuitous, we want it to go behind the prompt. -;;; When it's gratuitous, and we're not at the line-start, then we can output -;;; it normally, but we also make sure we end the output in a newline for -;;; visibility's sake. -;;; -(defun ts-buffer-output-string (ts string &optional gratuitous-p) - "Outputs STRING to the typescript described with TS. The output is inserted - before the fill-mark and the current input." - (when (hemlock.wire:remote-object-p ts) - (setf ts (hemlock.wire:remote-object-value ts))) - (hemlock-ext:without-interrupts - (let ((mark (ts-data-fill-mark ts))) - (cond ((and gratuitous-p (not (start-line-p mark))) - (with-mark ((m mark :left-inserting)) - (line-start m) - (insert-string m string) - (unless (start-line-p m) - (insert-character m #\newline)))) - (t - (setf (mark-kind mark) :left-inserting) - (insert-string mark string) - (when (and gratuitous-p (not (start-line-p mark))) - (insert-character mark #\newline)) - (setf (mark-kind mark) :right-inserting))))) - (values)) - -;;; TS-BUFFER-FINISH-OUTPUT --- internal interface. -;;; -;;; Redisplays the windows. Used by ts-stream in order to finish-output. -;;; -(defun ts-buffer-finish-output (ts) - (declare (ignore ts)) - (redisplay) - nil) - -;;; TS-BUFFER-CHARPOS --- internal interface. -;;; -;;; Used by ts-stream in order to find the charpos. -;;; -(defun ts-buffer-charpos (ts) - (mark-charpos (ts-data-fill-mark (if (hemlock.wire:remote-object-p ts) - (hemlock.wire:remote-object-value ts) - ts)))) - -;;; TS-BUFFER-LINE-LENGTH --- internal interface. -;;; -;;; Used by ts-stream to find out the line length. Returns the width of the -;;; first window, or 80 if there are no windows. -;;; -(defun ts-buffer-line-length (ts) - (let* ((ts (if (hemlock.wire:remote-object-p ts) - (hemlock.wire:remote-object-value ts) - ts)) - (window (car (buffer-windows (ts-data-buffer ts))))) - (if window - (window-width window) - 80))) ; Seems like a good number to me. - - - -;;;; Input routines - -(defun ts-buffer-ask-for-input (remote) - (let* ((ts (hemlock.wire:remote-object-value remote)) - (buffer (ts-data-buffer ts))) - (unless (buffer-windows buffer) - (let ((input-wait-alarm - (if (hemlock-bound-p 'input-wait-alarm - :buffer buffer) - (variable-value 'input-wait-alarm - :buffer buffer) - (variable-value 'input-wait-alarm - :global)))) - (when input-wait-alarm - (when (eq input-wait-alarm :loud-message) - (beep)) - (message "Waiting for input in buffer ~A." - (buffer-name buffer)))))) - nil) - -(defun ts-buffer-clear-input (ts) - (let* ((ts (if (hemlock.wire:remote-object-p ts) - (hemlock.wire:remote-object-value ts) - ts)) - (buffer (ts-data-buffer ts)) - (mark (ts-data-fill-mark ts))) - (unless (mark= mark (buffer-end-mark buffer)) - (with-mark ((start mark)) - (line-start start) - (let ((prompt (region-to-string (region start mark))) - (end (buffer-end-mark buffer))) - (unless (zerop (mark-charpos end)) - (insert-character end #\Newline)) - (insert-string end "[Input Cleared]") - (insert-character end #\Newline) - (insert-string end prompt) - (move-mark mark end))))) - nil) - -(defun ts-buffer-set-stream (ts stream) - (let ((ts (if (hemlock.wire:remote-object-p ts) - (hemlock.wire:remote-object-value ts) - ts))) - (setf (ts-data-stream ts) stream) - (hemlock.wire:remote (ts-data-wire ts) - (ts-stream-set-line-length stream (ts-buffer-line-length ts)))) - nil) - - - -;;;; Typescript mode. - -(defun setup-typescript (buffer) - (let ((ts (make-ts-data buffer))) - (defhvar "Current Package" - "The package used for evaluation of Lisp in this buffer." - :buffer buffer - :value nil) - - (defhvar "Typescript Data" - "The ts-data structure for this buffer" - :buffer buffer - :value ts) - - (defhvar "Buffer Input Mark" - "Beginning of typescript input in this buffer." - :value (ts-data-fill-mark ts) - :buffer buffer) - - (defhvar "Interactive History" - "A ring of the regions input to the Hemlock typescript." - :buffer buffer - :value (make-ring (value interactive-history-length))) - - (defhvar "Interactive Pointer" - "Pointer into the Hemlock typescript input history." - :buffer buffer - :value 0) - - (defhvar "Searching Interactive Pointer" - "Pointer into \"Interactive History\"." - :buffer buffer - :value 0))) - -(defmode "Typescript" - :setup-function #'setup-typescript - :documentation "The Typescript mode is used to interact with slave lisps.") - - -;;; TYPESCRIPTIFY-BUFFER -- Internal interface. -;;; -;;; Buffer creation code for eval server connections calls this to setup a -;;; typescript buffer, tie things together, and make some local Hemlock -;;; variables. -;;; -(defun typescriptify-buffer (buffer server wire) - (setf (buffer-minor-mode buffer "Typescript") t) - (let ((info (variable-value 'typescript-data :buffer buffer))) - (setf (ts-data-server info) server) - (setf (ts-data-wire info) wire) - (defhvar "Server Info" - "Server-info structure for this buffer." - :buffer buffer :value server) - (defhvar "Current Eval Server" - "The Server-Info object for the server currently used for evaluation and - compilation." - :buffer buffer :value server) - info)) - -(defun ts-buffer-wire-died (ts) - (setf (ts-data-stream ts) nil) - (setf (ts-data-wire ts) nil) - (buffer-end (ts-data-fill-mark ts) (ts-data-buffer ts)) - (ts-buffer-output-string ts (format nil "~%~%Slave died!~%"))) - -(defun unwedge-typescript-buffer () - (typescript-slave-to-top-level-command nil) - (buffer-end (current-point) (current-buffer))) - -(defhvar "Unwedge Interactive Input Fun" - "Function to call when input is confirmed, but the point is not past the - input mark." - :value #'unwedge-typescript-buffer - :mode "Typescript") - -(defhvar "Unwedge Interactive Input String" - "String to add to \"Point not past input mark. \" explaining what will - happen if the the user chooses to be unwedged." - :value "Cause the slave to throw to the top level? " - :mode "Typescript") - -;;; TYPESCRIPT-DATA-OR-LOSE -- internal -;;; -;;; Return the typescript-data for the current buffer, or die trying. -;;; -(defun typescript-data-or-lose () - (if (hemlock-bound-p 'typescript-data) - (let ((ts (value typescript-data))) - (if ts - ts - (editor-error "Can't find the typescript data?"))) - (editor-error "Not in a typescript buffer."))) - -(defcommand "Confirm Typescript Input" (p) - "Send the current input to the slave typescript." - "Send the current input to the slave typescript." - (declare (ignore p)) - (let ((ts (typescript-data-or-lose))) - (let ((input (get-interactive-input))) - (when input - (let ((string (region-to-string input))) - (declare (simple-string string)) - (insert-character (current-point) #\NewLine) - (hemlock.wire:remote (ts-data-wire ts) - (ts-stream-accept-input (ts-data-stream ts) - (concatenate 'simple-string - string - (string #\newline)))) - (hemlock.wire:wire-force-output (ts-data-wire ts)) - (buffer-end (ts-data-fill-mark ts) - (ts-data-buffer ts))))))) - -(defcommand "Typescript Slave Break" (p) - "Interrupt the slave Lisp process associated with this interactive buffer, - causing it to invoke BREAK." - "Interrupt the slave Lisp process associated with this interactive buffer, - causing it to invoke BREAK." - (declare (ignore p)) - (send-oob-to-slave "B")) - -(defcommand "Typescript Slave to Top Level" (p) - "Interrupt the slave Lisp process associated with this interactive buffer, - causing it to throw to the top level REP loop." - "Interrupt the slave Lisp process associated with this interactive buffer, - causing it to throw to the top level REP loop." - (declare (ignore p)) - (send-oob-to-slave "T")) - -(defcommand "Typescript Slave Status" (p) - "Interrupt the slave and cause it to print status information." - "Interrupt the slave and cause it to print status information." - (declare (ignore p)) - (send-oob-to-slave "S")) - -#+NIL -(defun send-oob-to-slave (string) - (let* ((ts (typescript-data-or-lose)) - (wire (ts-data-wire ts)) - (socket (hemlock.wire:wire-fd wire))) - (unless socket - (editor-error "The slave is no longer alive.")) - (error "SEND-OOB-TO-SLAVE seeks an implementation.") - #+NIL - (hemlock-ext:send-character-out-of-band socket (schar string 0)))) Index: anches/ide-1.0/ccl/hemlock/src/ts-stream.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/ts-stream.lisp (revision 6566) +++ (revision ) @@ -1,422 +1,0 @@ -;;; -*- Package: Hemlock; Log: hemlock.log -*- -;;; -;;; ********************************************************************** -;;; This code was written as part of the CMU Common Lisp project at -;;; Carnegie Mellon University, and has been placed in the public domain. -;;; -(hemlock-ext:file-comment - "$Header$") -;;; -;;; ********************************************************************** -;;; -;;; This file implements typescript streams. -;;; -;;; A typescript stream is a bidirectional stream which uses remote -;;; function calls to interact with a Hemlock typescript buffer. That -;;; is: the code in this file is executed on the slave side. -;;; -;;; Written by William Lott. -;;; - -(in-package :hemlock) - - - -;;;; Ts-streams. - -(defconstant ts-stream-output-buffer-size 512) - -(defclass ts-stream (hi::fundamental-character-output-stream - hi::fundamental-character-input-stream) - ((wire - :initarg :wire - :initform nil - :accessor ts-stream-wire) - - (typescript - :initarg :typescript - :initform nil - :accessor ts-stream-typescript) - - (output-buffer - :initarg :output-buffer - :initform (make-string ts-stream-output-buffer-size) - :accessor ts-stream-output-buffer - :type simple-string) - - (output-buffer-index - :initarg :output-buffer-index - :initform 0 - :accessor ts-stream-output-buffer-index - :type fixnum) - - (char-pos - :initarg :char-pos - :initform 0 - :accessor ts-stream-char-pos - :type fixnum - :documentation "The current output character position on the line, returned by the :CHARPOS method.") - - (line-length - :initarg :line-length - :initform 80 - :accessor ts-stream-line-length - :documentation "The current length of a line of output. Returned by STREAM-LINE-LENGTH method.") - - (current-input - :initarg :current-input - :initform nil - :accessor ts-stream-current-input - :type list - :documentation "This is a list of strings and stream-commands whose order manifests the - input provided by remote procedure calls into the slave of - TS-STREAM-ACCEPT-INPUT.") - - (input-read-index - :initarg :input-read-index - :initform 0 - :accessor ts-stream-input-read-index - :type fixnum))) - -(defun make-ts-stream (wire typescript) - (make-instance 'ts-stream :wire wire :typescript typescript)) - - - -;;;; Conditions. - -(define-condition unexpected-stream-command (error) - ;; Context is a string to be plugged into the report text. - ((context :reader unexpected-stream-command-context :initarg :context)) - (:report (lambda (condition stream) - (format stream "~&Unexpected stream-command while ~A." - (unexpected-stream-command-context condition))))) - - - - -;;;; Editor remote calls into slave. - -;;; TS-STREAM-ACCEPT-INPUT -- Internal Interface. -;;; -;;; The editor calls this remotely in the slave to indicate that the user has -;;; provided input. Input is a string, symbol, or list. If it is a list, the -;;; the CAR names the command, and the CDR is the arguments. -;;; -(defun ts-stream-accept-input (remote input) - (let ((stream (hemlock.wire:remote-object-value remote))) - (hemlock-ext:without-interrupts - (hemlock-ext:without-gcing - (setf (ts-stream-current-input stream) - (nconc (ts-stream-current-input stream) - (list (etypecase input - (string - (let ((newline - (position #\newline input :from-end t))) - (setf (ts-stream-char-pos stream) - (if newline - (- (length input) newline 1) - (length input))) - input)) - #+NILGB - (cons - (ext:make-stream-command (car input) - (cdr input))) - #+NILGB - (symbol - (ext:make-stream-command input))))))))) - nil) - -;;; TS-STREAM-SET-LINE-LENGTH -- Internal Interface. -;;; -;;; This function is called by the editor to indicate that the line-length for -;;; a TS stream should now be Length. -;;; -(defun ts-stream-set-line-length (remote length) - (let ((stream (hemlock.wire:remote-object-value remote))) - (setf (ts-stream-line-length stream) length))) - - - - -;;;; Stream methods. - -;;; %TS-STREAM-LISTEN -- Internal. -;;; -;;; Determine if there is any input available. If we don't think so, process -;;; all pending events, and look again. -;;; -(defmethod hi::stream-listen ((stream ts-stream)) - (flet ((check () - (hemlock-ext:without-interrupts - (hemlock-ext:without-gcing - (loop - (let* ((current (ts-stream-current-input stream)) - (first (first current))) - (cond ((null current) - (return nil)) - #+NILGB - ((ext:stream-command-p first) - (return t)) - ((>= (ts-stream-input-read-index stream) - (length (the simple-string first))) - (pop (ts-stream-current-input stream)) - (setf (ts-stream-input-read-index stream) 0)) - (t - (return t))))))))) - (or (check) - (progn - #+NILGB (system:serve-all-events 0) - (check))))) - -;;; %TS-STREAM-IN -- Internal. -;;; -;;; The READ-CHAR stream method. -;;; -(defmethod hi::stream-read-char ((stream ts-stream)) - (hi::stream-force-output stream) - (wait-for-typescript-input stream) - (hemlock-ext:without-interrupts - (hemlock-ext:without-gcing - (let ((first (first (ts-stream-current-input stream)))) - (etypecase first - (string - (prog1 (schar first (ts-stream-input-read-index stream)) - (incf (ts-stream-input-read-index stream)))) - #+NILGB - (ext:stream-command - (error 'unexpected-stream-command - :context "in the READ-CHAR method"))))))) - -;;; %TS-STREAM-READ-LINE -- Internal. -;;; -;;; The READ-LINE stream method. Note: here we take advantage of the fact that -;;; newlines will only appear at the end of strings. -;;; - -(defmethod stream-read-line (stream) - (macrolet - ((next-str () - '(progn - (wait-for-typescript-input stream) - (hemlock-ext:without-interrupts - (hemlock-ext:without-gcing - (let ((first (first (ts-stream-current-input stream)))) - (etypecase first - (string - (prog1 (if (zerop (ts-stream-input-read-index stream)) - (pop (ts-stream-current-input stream)) - (subseq (pop (ts-stream-current-input stream)) - (ts-stream-input-read-index stream))) - (setf (ts-stream-input-read-index stream) 0))) - #+NILGB - (ext:stream-command - (error 'unexpected-stream-command - :context "in the READ-CHAR method"))))))))) - (do ((result (next-str) (concatenate 'simple-string result (next-str)))) - ((char= (schar result (1- (length result))) #\newline) - (values (subseq result 0 (1- (length result))) - nil)) - (declare (simple-string result))))) - -;;; WAIT-FOR-TYPESCRIPT-INPUT -- Internal. -;;; -;;; Keep calling server until some input shows up. -;;; -(defun wait-for-typescript-input (stream) - (unless (hi::stream-listen stream) ;for some reasons in CLISP CL:LISTEN calls STREAM-READ-CHAR :-/ - (let ((wire (ts-stream-wire stream)) - (ts (ts-stream-typescript stream))) - (hemlock-ext:without-interrupts - (hemlock-ext:without-gcing - (hemlock.wire:remote wire (ts-buffer-ask-for-input ts)) - (hemlock.wire:wire-force-output wire))) - (loop - #+:hemlock.serve-event (hemlock.wire::serve-all-events) - #-:hemlock.serve-event (hemlock.wire:wire-get-object wire) - #+NILGB (sleep .1) ;### - (when (hi::stream-listen stream) - (return)))))) - -;;; %TS-STREAM-FLSBUF --- internal. -;;; -;;; Flush the output buffer associated with stream. This should only be used -;;; inside a without-interrupts and without-gcing. -;;; -(defun %ts-stream-flsbuf (stream) - (when (and (ts-stream-wire stream) - (ts-stream-output-buffer stream) - (not (zerop (ts-stream-output-buffer-index stream)))) - (hemlock.wire:remote (ts-stream-wire stream) - (ts-buffer-output-string - (ts-stream-typescript stream) - (subseq (the simple-string (ts-stream-output-buffer stream)) - 0 - (ts-stream-output-buffer-index stream)))) - (setf (ts-stream-output-buffer-index stream) 0))) - -;;; %TS-STREAM-OUT --- internal. -;;; -;;; Output a single character to stream. -;;; -(defmethod hi::stream-write-char ((stream ts-stream) char) - (declare (base-char char)) - (hemlock-ext:without-interrupts - (hemlock-ext:without-gcing - (when (= (ts-stream-output-buffer-index stream) - ts-stream-output-buffer-size) - (%ts-stream-flsbuf stream)) - (setf (schar (ts-stream-output-buffer stream) - (ts-stream-output-buffer-index stream)) - char) - (incf (ts-stream-output-buffer-index stream)) - (incf (ts-stream-char-pos stream)) - (when (= (char-code char) - (char-code #\Newline)) - (%ts-stream-flsbuf stream) - (setf (ts-stream-char-pos stream) 0) - (hemlock.wire:wire-force-output (ts-stream-wire stream))) - char))) - -;;; %TS-STREAM-SOUT --- internal. -;;; -;;; Output a string to stream. -;;; -(defmethod hi::stream-write-string ((stream ts-stream) string &optional (start 0) (end (length string))) - ;; This can't be true generally: --GB - #+NIL (declare (simple-string string)) - (declare (fixnum start end)) - (let ((wire (ts-stream-wire stream)) - (newline (position #\Newline string :start start :end end :from-end t)) - (length (- end start))) - (when wire - (hemlock-ext:without-interrupts - (hemlock-ext:without-gcing - (let ((index (ts-stream-output-buffer-index stream))) - (cond ((> (+ index length) - ts-stream-output-buffer-size) - (%ts-stream-flsbuf stream) - (hemlock.wire:remote wire - (ts-buffer-output-string (ts-stream-typescript stream) - (subseq string start end))) - (when newline - (hemlock.wire:wire-force-output wire))) - (t - (replace (the simple-string (ts-stream-output-buffer stream)) - string - :start1 index - :end1 (+ index length) - :start2 start - :end2 end) - (incf (ts-stream-output-buffer-index stream) - length) - (when newline - (%ts-stream-flsbuf stream) - (hemlock.wire:wire-force-output wire))))) - (setf (ts-stream-char-pos stream) - (if newline - (- end newline 1) - (+ (ts-stream-char-pos stream) - length)))))))) - -;;; %TS-STREAM-UNREAD -- Internal. -;;; -;;; Unread a single character. -;;; -(defmethod hi::stream-unread-char ((stream ts-stream) char) - (hemlock-ext:without-interrupts - (hemlock-ext:without-gcing - (let ((first (first (ts-stream-current-input stream)))) - (cond ((and (stringp first) - (> (ts-stream-input-read-index stream) 0)) - (setf (schar first (decf (ts-stream-input-read-index stream))) - char)) - (t - (push (string char) (ts-stream-current-input stream)) - (setf (ts-stream-input-read-index stream) 0))))))) - -;;; %TS-STREAM-CLOSE --- internal. -;;; -;;; Can't do much, 'cause the wire is shared. -;;; -(defmethod close ((stream ts-stream) &key abort) - (unless abort - (force-output stream)) - #+NILGB (lisp::set-closed-flame stream) ;Hugh!? what is that? --GB - ) - -;;; %TS-STREAM-CLEAR-INPUT -- Internal. -;;; -;;; Pass the request to the editor and clear any buffered input. -;;; -(defmethod hi::stream-clear-input ((stream ts-stream)) - (hemlock-ext:without-interrupts - (hemlock-ext:without-gcing - (when (ts-stream-wire stream) - (hemlock.wire:remote-value (ts-stream-wire stream) - (ts-buffer-clear-input (ts-stream-typescript stream)))) - (setf (ts-stream-current-input stream) nil - (ts-stream-input-read-index stream) 0)))) - -(defmethod hi::stream-finish-output ((stream ts-stream)) - (when (ts-stream-wire stream) - (hemlock-ext:without-interrupts - (hemlock-ext:without-gcing - (%ts-stream-flsbuf stream) - ;; Note: for the return value to come back, - ;; all pending RPCs must have completed. - ;; Therefore, we know it has synced. - (hemlock.wire:remote-value (ts-stream-wire stream) - (ts-buffer-finish-output (ts-stream-typescript stream)))))) - t) - -(defmethod hi::stream-force-output ((stream ts-stream)) - (when (ts-stream-wire stream) - (hemlock-ext:without-interrupts - (hemlock-ext:without-gcing - (%ts-stream-flsbuf stream) - (hemlock.wire:wire-force-output (ts-stream-wire stream))))) - t) - -(defmethod hi::stream-line-column ((stream ts-stream)) - (ts-stream-char-pos stream)) - -(defmethod hi::stream-line-length ((stream ts-stream)) - (ts-stream-line-length stream)) - -#+NILGB ;; -- hmm. -(defmethod interactive-stream-p ((stream ts-stream)) - t) - -(defmethod hi::stream-clear-output ((stream ts-stream)) - (setf (ts-stream-output-buffer-index stream) 0)) - -;;; %TS-STREAM-MISC -- Internal. -;;; -;;; The misc stream method. -;;; -#+NILGB -(defun %ts-stream-misc (stream operation &optional arg1 arg2) - (case operation - (:get-command - (wait-for-typescript-input stream) - (hemlock-ext:without-interrupts - (hemlock-ext:without-gcing - (etypecase (first (ts-stream-current-input stream)) - (stream-command - (setf (ts-stream-input-read-index stream) 0) - (pop (ts-stream-current-input stream))) - (string nil))))) - )) - -;; $Log$ -;; Revision 1.1 2003/10/19 08:57:16 gb -;; Initial revision -;; -;; Revision 1.1.2.1 2003/08/10 19:11:40 gb -;; New files, imported from upstream CVS as of 03/08/09. -;; -;; Revision 1.3 2003/08/05 19:51:13 gilbert -;; initial slave lisp support, still not ready for prime time. -;; -;; Index: anches/ide-1.0/ccl/hemlock/src/unixcoms.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/unixcoms.lisp (revision 6566) +++ (revision ) @@ -1,258 +1,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock -*- -;;; -;;; ********************************************************************** -;;; This code was written as part of the CMU Common Lisp project at -;;; Carnegie Mellon University, and has been placed in the public domain. -;;; -#+CMU (ext:file-comment - "$Header$") -;;; -;;; ********************************************************************** -;;; -;;; -;;; This file contains Commands useful when running on a Unix box. Hopefully -;;; there are no CMU Unix dependencies though there are probably CMU Common -;;; Lisp dependencies, such as RUN-PROGRAM. -;;; -;;; Written by Christopher Hoover. - -(in-package :hemlock) - - - - -;;;; Region and File printing commands. - -(defhvar "Print Utility" - "UNIX(tm) program to invoke (via EXT:RUN-PROGRAM) to do printing. - The program should act like lpr: if a filename is given as an argument, - it should print that file, and if no name appears, standard input should - be assumed." - :value "lpr") - -(defhvar "Print Utility Switches" - "Switches to pass to the \"Print Utility\" program. This should be a list - of strings." - :value ()) - - -;;; PRINT-SOMETHING calls RUN-PROGRAM on the utility-name and args. Output -;;; and error output are done to the echo area, and errors are ignored for -;;; now. Run-program-keys are other keywords to pass to RUN-PROGRAM in -;;; addition to :wait, :output, and :error. -;;; -(defmacro print-something (&optional (run-program-keys) - (utility-name '(value print-utility)) - (args '(value print-utility-switches))) - (let ((pid (gensym)) - (error-code (gensym))) - `(multiple-value-bind (,pid ,error-code) - (ext:run-program ,utility-name ,args - ,@run-program-keys - :wait t - :output *echo-area-stream* - :error *echo-area-stream*) - (declare (ignore ,pid ,error-code)) - (force-output *echo-area-stream*) - ;; Keep the echo area from being cleared at the top of the command loop. - (setf (buffer-modified *echo-area-buffer*) nil)))) - - -;;; PRINT-REGION -- Interface -;;; -;;; Takes a region and outputs the text to the program defined by -;;; the hvar "Print Utility" with options form the hvar "Print -;;; Utility Options" using PRINT-SOMETHING. -;;; -(defun print-region (region) - (with-input-from-region (s region) - (print-something (:input s)))) - - -(defcommand "Print Buffer" (p) - "Prints the current buffer using the program defined by the hvar - \"Print Utility\" with the options from the hvar \"Print Utility - Options\". Errors appear in the echo area." - "Prints the contents of the buffer." - (declare (ignore p)) - (message "Printing buffer...~%") - (print-region (buffer-region (current-buffer)))) - -(defcommand "Print Region" (p) - "Prints the current region using the program defined by the hvar - \"Print Utility\" with the options from the hvar \"Print Utility - Options\". Errors appear in the echo area." - "Prints the current region." - (declare (ignore p)) - (message "Printing region...~%") - (print-region (current-region))) - -(defcommand "Print File" (p) - "Prompts for a file and prints it usings the program defined by - the hvar \"Print Utility\" with the options from the hvar \"Print - Utility Options\". Errors appear in the echo area." - "Prints a file." - (declare (ignore p)) - (let* ((pn (prompt-for-file :prompt "File to print: " - :help "Name of file to print." - :default (buffer-default-pathname (current-buffer)) - :must-exist t)) - (ns (namestring (truename pn)))) - (message "Printing file...~%") - (print-something () (value print-utility) - (append (value print-utility-switches) (list ns))))) - - - -;;;; Scribe. - -(defcommand "Scribe File" (p) - "Scribe a file with the default directory set to the directory of the - specified file. The output from running Scribe is sent to the - \"Scribe Warnings\" buffer. See \"Scribe Utility\" and \"Scribe Utility - Switches\"." - "Scribe a file with the default directory set to the directory of the - specified file." - (declare (ignore p)) - (scribe-file (prompt-for-file :prompt "Scribe file: " - :default - (buffer-default-pathname (current-buffer))))) - -(defhvar "Scribe Buffer File Confirm" - "When set, \"Scribe Buffer File\" prompts for confirmation before doing - anything." - :value t) - -(defcommand "Scribe Buffer File" (p) - "Scribe the file associated with the current buffer. The default directory - set to the directory of the file. The output from running Scribe is sent to - the \"Scribe Warnings\" buffer. See \"Scribe Utility\" and \"Scribe Utility - Switches\". Before doing anything the user is asked to confirm saving and - Scribe'ing the file. This prompting can be inhibited by with \"Scribe Buffer - File Confirm\"." - "Scribe a file with the default directory set to the directory of the - specified file." - (declare (ignore p)) - (let* ((buffer (current-buffer)) - (pathname (buffer-pathname buffer)) - (modified (buffer-modified buffer))) - (when (or (not (value scribe-buffer-file-confirm)) - (prompt-for-y-or-n - :default t :default-string "Y" - :prompt (list "~:[S~;Save and s~]cribe file ~A? " - modified (namestring pathname)))) - (when modified (write-buffer-file buffer pathname)) - (scribe-file pathname)))) - -(defhvar "Scribe Utility" - "Program name to invoke (via EXT:RUN-PROGRAM) to do text formatting." - :value "scribe") - -(defhvar "Scribe Utility Switches" - "Switches to pass to the \"Scribe Utility\" program. This should be a list - of strings." - :value ()) - -(defun scribe-file (pathname) - (let* ((pathname (truename pathname)) - (out-buffer (or (getstring "Scribe Warnings" *buffer-names*) - (make-buffer "Scribe Warnings"))) - (out-point (buffer-end (buffer-point out-buffer))) - (stream (make-hemlock-output-stream out-point :line)) - (orig-cwd (default-directory))) - (buffer-end out-point) - (insert-character out-point #\newline) - (insert-character out-point #\newline) - (unwind-protect - (progn - (setf (default-directory) (directory-namestring pathname)) - (ext:run-program (namestring (value scribe-utility)) - (list* (namestring pathname) - (value scribe-utility-switches)) - :output stream :error stream - :wait nil)) - (setf (default-directory) orig-cwd)))) - - - -;;;; UNIX Filter Region - -(defcommand "Unix Filter Region" (p) - "Unix Filter Region prompts for a UNIX program and then passes the current - region to the program as standard input. The standard output from the - program is used to replace the region. This command is undo-able." - "UNIX-FILTER-REGION-COMMAND is not intended to be called from normal - Hemlock commands; use UNIX-FILTER-REGION instead." - (declare (ignore p)) - (let* ((region (current-region)) - (filter-and-args (prompt-for-string - :prompt "Filter: " - :help "Unix program to filter the region through.")) - (filter-and-args-list (listify-unix-filter-string filter-and-args)) - (filter (car filter-and-args-list)) - (args (cdr filter-and-args-list)) - (new-region (unix-filter-region region filter args)) - (start (copy-mark (region-start region) :right-inserting)) - (end (copy-mark (region-end region) :left-inserting)) - (old-region (region start end)) - (undo-region (delete-and-save-region old-region))) - (ninsert-region end new-region) - (make-region-undo :twiddle "Unix Filter Region" old-region undo-region))) - -(defun unix-filter-region (region command args) - "Passes the region REGION as standard input to the program COMMAND - with arguments ARGS and returns the standard output as a freshly - cons'ed region." - (let ((new-region (make-empty-region))) - (with-input-from-region (input region) - (with-output-to-mark (output (region-end new-region) :full) - (ext:run-program command args - :input input - :output output - :error output))) - new-region)) - -(defun listify-unix-filter-string (str) - (declare (simple-string str)) - (let ((result nil) - (lastpos 0)) - (loop - (let ((pos (position #\Space str :start lastpos :test #'char=))) - (push (subseq str lastpos pos) result) - (unless pos - (return)) - (setf lastpos (1+ pos)))) - (nreverse result))) - - - - -;;;; Man pages. - -(defcommand "Manual Page" (p) - "Read the Unix manual pages in a View buffer. - If given an argument, this will put the man page in a Pop-up display." - "Read the Unix manual pages in a View buffer. - If given an argument, this will put the man page in a Pop-up display." - (let ((topic (prompt-for-string :prompt "Man topic: "))) - (if p - (with-pop-up-display (stream) - (execute-man topic stream)) - (let* ((buf-name (format nil "Man Page ~a" topic)) - (new-buffer (make-buffer buf-name :modes '("Fundamental" "View"))) - (buffer (or new-buffer (getstring buf-name *buffer-names*))) - (point (buffer-point buffer))) - (change-to-buffer buffer) - (when new-buffer - (setf (value view-return-function) #'(lambda ())) - (with-writable-buffer (buffer) - (with-output-to-mark (s point :full) - (execute-man topic s)))) - (buffer-start point buffer))))) - -(defun execute-man (topic stream) - (ext:run-program - "/bin/sh" - (list "-c" - (format nil "man ~a| ul -t adm3" topic)) - :output stream)) Index: anches/ide-1.0/ccl/hemlock/src/window.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/window.lisp (revision 6566) +++ (revision ) @@ -1,690 +1,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- -;;; -;;; ********************************************************************** -;;; This code was written as part of the CMU Common Lisp project at -;;; Carnegie Mellon University, and has been placed in the public domain. -;;; -#+CMU (ext:file-comment - "$Header$") -;;; -;;; ********************************************************************** -;;; -;;; This file contains implementation independent code which implements -;;; the Hemlock window primitives and most of the code which defines -;;; other aspects of the interface to redisplay. -;;; -;;; Written by Bill Chiles and Rob MacLachlan. -;;; - -(in-package :hemlock-internals) - -(defconstant unaltered-bits #b000 - "This is the value of the dis-line-flags when a line is neither moved nor - changed nor new.") -(defconstant changed-bit #b001 - "This bit is set in the dis-line-flags when a line is found to be changed.") -(defconstant moved-bit #b010 - "This bit is set in the dis-line-flags when a line is found to be moved.") -(defconstant new-bit #b100 - "This bit is set in the dis-line-flags when a line is found to be new.") - - - -;;;; CURRENT-WINDOW. - -(defvar *current-window* nil "The current window object.") -(defvar *window-list* () "A list of all window objects.") - -(declaim (inline current-window)) - -(defun current-window () - "Return the current window. The current window is specially treated by - redisplay in several ways, the most important of which is that is does - recentering, ensuring that the Buffer-Point of the current window's - Window-Buffer is always displayed. This may be set with Setf." - *current-window*) - -(defun %set-current-window (new-window) - (invoke-hook hemlock::set-window-hook new-window) - (move-mark (window-point *current-window*) - (buffer-point (window-buffer *current-window*))) - (move-mark (buffer-point (window-buffer new-window)) - (window-point new-window)) - (setq *current-window* new-window)) - - - - -;;;; Window structure support. - -(defun %print-hwindow (obj stream depth) - (declare (ignore depth)) - (write-string "#" stream)) - - -(defun window-buffer (window) - "Return the buffer which is displayed in Window." - (window-%buffer window)) - -(defun %set-window-buffer (window new-buffer) - (unless (bufferp new-buffer) (error "~S is not a buffer." new-buffer)) - (unless (windowp window) (error "~S is not a window." window)) - (unless (eq new-buffer (window-buffer window)) - (invoke-hook hemlock::window-buffer-hook window new-buffer) - ;; - ;; Move the window's marks to the new start. - (let ((buffer (window-buffer window))) - (setf (buffer-windows buffer) (delete window (buffer-windows buffer))) - (move-mark (buffer-display-start buffer) (window-display-start window)) - (push window (buffer-windows new-buffer)) - (move-mark (window-point window) (buffer-point new-buffer)) - (move-mark (window-display-start window) (buffer-display-start new-buffer)) - (move-mark (window-display-end window) (buffer-display-start new-buffer))) - ;; - ;; Delete all the dis-lines, and nil out the line and chars so they get - ;; gc'ed. - (let ((first (window-first-line window)) - (last (window-last-line window)) - (free (window-spare-lines window))) - (unless (eq (cdr first) *the-sentinel*) - (shiftf (cdr last) free (cdr first) *the-sentinel*)) - (dolist (dl free) - (setf (dis-line-line dl) nil (dis-line-old-chars dl) nil)) - (setf (window-spare-lines window) free)) - ;; - ;; Set the last line and first&last changed so we know there's nothing there. - (setf (window-last-line window) *the-sentinel* - (window-first-changed window) *the-sentinel* - (window-last-changed window) *the-sentinel*) - ;; - ;; Make sure the window gets updated, and set the buffer. - (setf (window-tick window) -3) - (setf (window-%buffer window) new-buffer))) - - - - -;;; %INIT-REDISPLAY sets up redisplay's internal data structures. We create -;;; initial windows, setup some hooks to cause modeline recomputation, and call -;;; any device init necessary. This is called from ED. -;;; -(defun %init-redisplay (display) - (%init-screen-manager display) - (add-hook hemlock::buffer-major-mode-hook 'queue-buffer-change) - (add-hook hemlock::buffer-minor-mode-hook 'queue-buffer-change) - (add-hook hemlock::buffer-name-hook 'queue-buffer-change) - (add-hook hemlock::buffer-pathname-hook 'queue-buffer-change) - (add-hook hemlock::buffer-modified-hook 'queue-buffer-change) - (add-hook hemlock::window-buffer-hook 'queue-window-change) - (let ((device (device-hunk-device (window-hunk (current-window))))) - (funcall (device-init device) device)) - (center-window *current-window* (current-point))) - - - - -;;;; Modelines-field structure support. - -(defun print-modeline-field (obj stream ignore) - (declare (ignore ignore)) - (write-string "#" stream)) - -(defun print-modeline-field-info (obj stream ignore) - (declare (ignore ignore)) - (write-string "#" stream)) - - -(defvar *modeline-field-names* (make-hash-table)) - -(defun make-modeline-field (&key name width function) - "Returns a modeline-field object." - (unless (or (eq width nil) (and (integerp width) (plusp width))) - (error "Width must be nil or a positive integer.")) - (when (gethash name *modeline-field-names*) - (with-simple-restart (continue - "Use the new definition for this modeline field.") - (error "Modeline field ~S already exists." - (gethash name *modeline-field-names*)))) - (setf (gethash name *modeline-field-names*) - (%make-modeline-field name function width))) - -(defun modeline-field (name) - "Returns the modeline-field object named name. If none exists, return nil." - (gethash name *modeline-field-names*)) - - -(declaim (inline modeline-field-name modeline-field-width - modeline-field-function)) - -(defun modeline-field-name (ml-field) - "Returns the name of a modeline field object." - (modeline-field-%name ml-field)) - -(defun %set-modeline-field-name (ml-field name) - (check-type ml-field modeline-field) - (when (gethash name *modeline-field-names*) - (error "Modeline field ~S already exists." - (gethash name *modeline-field-names*))) - (remhash (modeline-field-%name ml-field) *modeline-field-names*) - (setf (modeline-field-%name ml-field) name) - (setf (gethash name *modeline-field-names*) ml-field)) - -(defun modeline-field-width (ml-field) - "Returns the width of a modeline field." - (modeline-field-%width ml-field)) - -(declaim (special *buffer-list*)) - -(defun %set-modeline-field-width (ml-field width) - (check-type ml-field modeline-field) - (unless (or (eq width nil) (and (integerp width) (plusp width))) - (error "Width must be nil or a positive integer.")) - (unless (eql width (modeline-field-%width ml-field)) - (setf (modeline-field-%width ml-field) width) - (dolist (b *buffer-list*) - (when (buffer-modeline-field-p b ml-field) - (dolist (w (buffer-windows b)) - (update-modeline-fields b w))))) - width) - -(defun modeline-field-function (ml-field) - "Returns the function of a modeline field object. It returns a string." - (modeline-field-%function ml-field)) - -(defun %set-modeline-field-function (ml-field function) - (check-type ml-field modeline-field) - (check-type function (or symbol function)) - (setf (modeline-field-%function ml-field) function) - (dolist (b *buffer-list*) - (when (buffer-modeline-field-p b ml-field) - (dolist (w (buffer-windows b)) - (update-modeline-field b w ml-field)))) - function) - - - - -;;;; Modelines maintenance. - -;;; Each window stores a modeline-buffer which is a string hunk-width-limit -;;; long. Whenever a field is updated, we must maintain a maximally long -;;; representation of the modeline in case the window is resized. Updating -;;; then first gets the modeline-buffer setup, and second blasts the necessary -;;; portion into the window's modeline-dis-line, setting the dis-line's changed -;;; flag. -;;; - -(defun update-modeline-fields (buffer window) - "Recompute all the fields of buffer's modeline for window, so the next - redisplay will reflect changes." - (let ((ml-buffer (window-modeline-buffer window))) - (declare (simple-string ml-buffer)) - (when ml-buffer - (let* ((ml-buffer-len - (do ((finfos (buffer-%modeline-fields buffer) (cdr finfos)) - (start 0 (blt-modeline-field-buffer - ml-buffer (car finfos) buffer window start))) - ((null finfos) start))) - (dis-line (window-modeline-dis-line window)) - (len (min (window-width window) ml-buffer-len))) - (replace (the simple-string (dis-line-chars dis-line)) ml-buffer - :end1 len :end2 len) - (setf (window-modeline-buffer-len window) ml-buffer-len) - (setf (dis-line-length dis-line) len) - (setf (dis-line-flags dis-line) changed-bit))))) - -;;; UPDATE-MODELINE-FIELD must replace the entire dis-line-chars with ml-buffer -;;; after blt'ing into buffer. Otherwise it has to do all the work -;;; BLT-MODELINE-FIELD-BUFFER to figure out how to adjust dis-line-chars. It -;;; isn't worth it. Since things could have shifted around, after calling -;;; BLT-MODELINE-FIELD-BUFFER, we get the last field's end to know how long -;;; the buffer is now. -;;; -(defun update-modeline-field (buffer window field) - "Recompute the field of the buffer's modeline for window, so the next - redisplay will reflect the change. Field is either a modeline-field object - or the name of one for buffer." - (let ((finfo (internal-buffer-modeline-field-p buffer field))) - (unless finfo - (error "~S is not a modeline-field or the name of one for buffer ~S." - field buffer)) - (let ((ml-buffer (window-modeline-buffer window)) - (dis-line (window-modeline-dis-line window))) - (declare (simple-string ml-buffer)) - (blt-modeline-field-buffer ml-buffer finfo buffer window - (ml-field-info-start finfo) t) - (let* ((ml-buffer-len (ml-field-info-end - (car (last (buffer-%modeline-fields buffer))))) - (dis-len (min (window-width window) ml-buffer-len))) - (replace (the simple-string (dis-line-chars dis-line)) ml-buffer - :end1 dis-len :end2 dis-len) - (setf (window-modeline-buffer-len window) ml-buffer-len) - (setf (dis-line-length dis-line) dis-len) - (setf (dis-line-flags dis-line) changed-bit))))) - -(defvar *truncated-field-char* #\!) - -;;; BLT-MODELINE-FIELD-BUFFER takes a Hemlock buffer, Hemlock window, the -;;; window's modeline buffer, a modeline-field-info object, a start in the -;;; modeline buffer, and an optional indicating whether a variable width field -;;; should be handled carefully. When the field is fixed-width, this is -;;; simple. When it is variable, we possibly have to shift all the text in the -;;; buffer right or left before storing the new string, updating all the -;;; finfo's after the one we're updating. It is an error for the -;;; modeline-field-function to return anything but a simple-string with -;;; standard-chars. This returns the end of the field blasted into ml-buffer. -;;; -(defun blt-modeline-field-buffer (ml-buffer finfo buffer window start - &optional fix-other-fields-p) - (declare (simple-string ml-buffer)) - (let* ((f (ml-field-info-field finfo)) - (width (modeline-field-width f)) - (string (funcall (modeline-field-function f) buffer window)) - (str-len (length string))) - (declare (simple-string string)) - (setf (ml-field-info-start finfo) start) - (setf (ml-field-info-end finfo) - (cond - ((not width) - (let ((end (min (+ start str-len) hunk-width-limit)) - (last-end (ml-field-info-end finfo))) - (when (and fix-other-fields-p (/= end last-end)) - (blt-ml-field-buffer-fix ml-buffer finfo buffer window - end last-end)) - (replace ml-buffer string :start1 start :end1 end :end2 str-len) - end)) - ((= str-len width) - (let ((end (min (+ start width) hunk-width-limit))) - (replace ml-buffer string :start1 start :end1 end :end2 width) - end)) - ((> str-len width) - (let* ((end (min (+ start width) hunk-width-limit)) - (end-1 (1- end))) - (replace ml-buffer string :start1 start :end1 end-1 :end2 width) - (setf (schar ml-buffer end-1) *truncated-field-char*) - end)) - (t - (let ((buf-replace-end (min (+ start str-len) hunk-width-limit)) - (buf-field-end (min (+ start width) hunk-width-limit))) - (replace ml-buffer string - :start1 start :end1 buf-replace-end :end2 str-len) - (fill ml-buffer #\space :start buf-replace-end :end buf-field-end) - buf-field-end)))))) - -;;; BLT-ML-FIELD-BUFFER-FIX shifts the contents of ml-buffer in the direction -;;; of last-end to end. finfo is a modeline-field-info structure in buffer's -;;; list of these. If there are none following finfo, then we simply store the -;;; new end of the buffer. After blt'ing the text around, we have to update -;;; all the finfos' starts and ends making sure nobody gets to stick out over -;;; the ml-buffer's end. -;;; -(defun blt-ml-field-buffer-fix (ml-buffer finfo buffer window end last-end) - (declare (simple-string ml-buffer)) - (let ((finfos (do ((f (buffer-%modeline-fields buffer) (cdr f))) - ((null f) (error "This field must be here.")) - (if (eq (car f) finfo) - (return (cdr f)))))) - (cond - ((not finfos) - (setf (window-modeline-buffer-len window) (min end hunk-width-limit))) - (t - (let ((buffer-len (window-modeline-buffer-len window))) - (replace ml-buffer ml-buffer - :start1 end - :end1 (min (+ end (- buffer-len last-end)) hunk-width-limit) - :start2 last-end :end2 buffer-len) - (let ((diff (- end last-end))) - (macrolet ((frob (f) - `(setf ,f (min (+ ,f diff) hunk-width-limit)))) - (dolist (f finfos) - (frob (ml-field-info-start f)) - (frob (ml-field-info-end f))) - (frob (window-modeline-buffer-len window))))))))) - - - - -;;;; Default modeline and update hooks. - -(make-modeline-field :name :hemlock-literal :width 8 - :function #'(lambda (buffer window) - "Returns \"Hemlock \"." - (declare (ignore buffer window)) - "Hemlock ")) - -(make-modeline-field - :name :package - :function #'(lambda (buffer window) - "Returns the value of buffer's \"Current Package\" followed - by a colon and two spaces, or a string with one space." - (declare (ignore window)) - (if (hemlock-bound-p 'hemlock::current-package :buffer buffer) - (let ((val (variable-value 'hemlock::current-package - :buffer buffer))) - (if val - (format nil "~A: " val) - " ")) - " "))) - -(make-modeline-field - :name :modes - :function #'(lambda (buffer window) - "Returns buffer's modes followed by one space." - (declare (ignore window)) - (format nil "~A " (buffer-modes buffer)))) - -(make-modeline-field - :name :modifiedp - :function #'(lambda (buffer window) - "Returns \"* \" if buffer is modified, or the empty string." - (declare (ignore window)) - (let ((modifiedp (buffer-modified buffer))) - (if modifiedp - "* " - "")))) - -(make-modeline-field - :name :buffer-name - :function #'(lambda (buffer window) - "Returns buffer's name followed by a colon and a space if the - name is not derived from the buffer's pathname, or the empty - string." - (declare (ignore window)) - (let ((pn (buffer-pathname buffer)) - (name (buffer-name buffer))) - (cond ((not pn) - (format nil "~A: " name)) - ((string/= (hemlock::pathname-to-buffer-name pn) name) - (format nil "~A: " name)) - (t ""))))) - - -;;; MAXIMUM-MODELINE-PATHNAME-LENGTH-HOOK is called whenever "Maximum Modeline -;;; Pathname Length" is set. -;;; -(defun maximum-modeline-pathname-length-hook (name kind where new-value) - (declare (ignore name new-value)) - (if (eq kind :buffer) - (hi::queue-buffer-change where) - (dolist (buffer *buffer-list*) - (when (and (buffer-modeline-field-p buffer :buffer-pathname) - (buffer-windows buffer)) - (hi::queue-buffer-change buffer))))) - -(defun buffer-pathname-ml-field-fun (buffer window) - "Returns the namestring of buffer's pathname if there is one. When - \"Maximum Modeline Pathname Length\" is set, and the namestring is too long, - return a truncated namestring chopping off leading directory specifications." - (declare (ignore window)) - (let ((pn (buffer-pathname buffer))) - (if pn - (let* ((name (namestring pn)) - (length (length name)) - ;; Prefer a buffer local value over the global one. - ;; Because variables don't work right, blow off looking for - ;; a value in the buffer's modes. In the future this will - ;; be able to get the "current" value as if buffer were current. - (max (if (hemlock-bound-p 'hemlock::maximum-modeline-pathname-length - :buffer buffer) - (variable-value 'hemlock::maximum-modeline-pathname-length - :buffer buffer) - (variable-value 'hemlock::maximum-modeline-pathname-length - :global)))) - (declare (simple-string name)) - (if (or (not max) (<= length max)) - name - (let* ((extra-chars (+ (- length max) 3)) - (slash (or (position #\/ name :start extra-chars) - ;; If no slash, then file-namestring is very - ;; long, and we should include all of it: - (position #\/ name :from-end t - :end extra-chars)))) - (if slash - (concatenate 'simple-string "..." (subseq name slash)) - name)))) - ""))) - -(make-modeline-field - :name :buffer-pathname - :function 'buffer-pathname-ml-field-fun) - - -(defvar *default-modeline-fields* - (list (modeline-field :hemlock-literal) - (modeline-field :package) - (modeline-field :modes) - (modeline-field :modifiedp) - (modeline-field :buffer-name) - (modeline-field :buffer-pathname)) - "This is the default value for \"Default Modeline Fields\".") - - - -;;; QUEUE-BUFFER-CHANGE is used for various buffer hooks (e.g., mode changes, -;;; name changes, etc.), so it takes some arguments to ignore. These hooks are -;;; invoked at a bad time to update the actual modeline-field, and user's may -;;; have fields that change as a function of the changes this function handles. -;;; This makes his update easier. It doesn't cost much update the entire line -;;; anyway. -;;; -(defun queue-buffer-change (buffer &optional something-else another-else) - (declare (ignore something-else another-else)) - (push (list #'update-modelines-for-buffer buffer) *things-to-do-once*)) - -(defun update-modelines-for-buffer (buffer) - (unless (eq buffer *echo-area-buffer*) - (dolist (w (buffer-windows buffer)) - (update-modeline-fields buffer w)))) - - -;;; QUEUE-WINDOW-CHANGE is used for the "Window Buffer Hook". We ignore the -;;; argument since this hook function is invoked before any changes are made, -;;; and the changes must be made before the fields can be set according to the -;;; window's buffer's properties. Therefore, we must queue the change to -;;; happen sometime before redisplay but after the change takes effect. -;;; -(defun queue-window-change (window &optional something-else) - (declare (ignore something-else)) - (push (list #'update-modeline-for-window window) *things-to-do-once*)) - -(defun update-modeline-for-window (window) - (update-modeline-fields (window-buffer window) window)) - - - - -;;;; Bitmap setting up new windows and modifying old. - -(defvar dummy-line (make-window-dis-line "") - "Dummy dis-line that we put at the head of window's dis-lines") -(setf (dis-line-position dummy-line) -1) - - -;;; WINDOW-FOR-HUNK makes a Hemlock window and sets up its dis-lines and marks -;;; to display starting at start. -;;; -(defun window-for-hunk (hunk start modelinep) - (check-type start mark) - (setf (bitmap-hunk-changed-handler hunk) #'window-changed) - (let ((buffer (line-buffer (mark-line start))) - (first (cons dummy-line *the-sentinel*)) - (width (bitmap-hunk-char-width hunk)) - (height (bitmap-hunk-char-height hunk))) - (when (or (< height minimum-window-lines) - (< width minimum-window-columns)) - (error "Window too small.")) - (unless buffer (error "Window start is not in a buffer.")) - (let ((window - (internal-make-window - :hunk hunk - :display-start (copy-mark start :right-inserting) - :old-start (copy-mark start :temporary) - :display-end (copy-mark start :right-inserting) - :%buffer buffer - :point (copy-mark (buffer-point buffer)) - :height height - :width width - :first-line first - :last-line *the-sentinel* - :first-changed *the-sentinel* - :last-changed first - :tick -1))) - (push window *window-list*) - (push window (buffer-windows buffer)) - ;; - ;; Make the dis-lines. - (do ((i (- height) (1+ i)) - (res () - (cons (make-window-dis-line (make-string width)) res))) - ((= i height) (setf (window-spare-lines window) res))) - ;; - ;; Make the image up to date. - (update-window-image window) - (setf (bitmap-hunk-start hunk) (cdr (window-first-line window))) - ;; - ;; If there is a modeline, set it up. - (when modelinep - (setup-modeline-image buffer window) - (setf (bitmap-hunk-modeline-dis-line hunk) - (window-modeline-dis-line window))) - window))) - -;;; SETUP-MODELINE-IMAGE sets up the modeline-dis-line for window using the -;;; modeline-fields list. This is used by tty redisplay too. -;;; -(defun setup-modeline-image (buffer window) - (setf (window-modeline-buffer window) (make-string hunk-width-limit)) - (setf (window-modeline-dis-line window) - (make-window-dis-line (make-string (window-width window)))) - (update-modeline-fields buffer window)) - -;;; Window-Changed -- Internal -;;; -;;; The bitmap-hunk changed handler for windows. This is only called if -;;; the hunk is not locked. We invalidate the window image and change its -;;; size, then do a full redisplay. -;;; -(defun window-changed (hunk) - (let ((window (bitmap-hunk-window hunk))) - ;; - ;; Nuke all the lines in the window image. - (unless (eq (cdr (window-first-line window)) *the-sentinel*) - (shiftf (cdr (window-last-line window)) - (window-spare-lines window) - (cdr (window-first-line window)) - *the-sentinel*)) - (setf (bitmap-hunk-start hunk) (cdr (window-first-line window))) - ;; - ;; Add some new spare lines if needed. If width is greater, - ;; reallocate the dis-line-chars. - (let* ((res (window-spare-lines window)) - (new-width (bitmap-hunk-char-width hunk)) - (new-height (bitmap-hunk-char-height hunk)) - (width (length (the simple-string (dis-line-chars (car res)))))) - (declare (list res)) - (when (> new-width width) - (setq width new-width) - (dolist (dl res) - (setf (dis-line-chars dl) (make-string new-width)))) - (setf (window-height window) new-height (window-width window) new-width) - (do ((i (- (* new-height 2) (length res)) (1- i))) - ((minusp i)) - (push (make-window-dis-line (make-string width)) res)) - (setf (window-spare-lines window) res) - ;; - ;; Force modeline update. - (let ((ml-buffer (window-modeline-buffer window))) - (when ml-buffer - (let ((dl (window-modeline-dis-line window)) - (chars (make-string new-width)) - (len (min new-width (window-modeline-buffer-len window)))) - (setf (dis-line-old-chars dl) nil) - (setf (dis-line-chars dl) chars) - (replace chars ml-buffer :end1 len :end2 len) - (setf (dis-line-length dl) len) - (setf (dis-line-flags dl) changed-bit))))) - ;; - ;; Prepare for redisplay. - (setf (window-tick window) (tick)) - (update-window-image window) - (when (eq window *current-window*) (maybe-recenter-window window)) - hunk)) - - - - -;;; EDITOR-FINISH-OUTPUT is used to synch output to a window with the rest of the -;;; system. -;;; -(defun editor-finish-output (window) - (let* ((device (device-hunk-device (window-hunk window))) - (finish-output (device-finish-output device))) - (when finish-output - (funcall finish-output device window)))) - - - - -;;;; Tty setting up new windows and modifying old. - -;;; setup-window-image -- Internal -;;; -;;; Set up the dis-lines and marks for Window to display starting -;;; at Start. Height and Width are the number of lines and columns in -;;; the window. -;;; -(defun setup-window-image (start window height width) - (check-type start mark) - (let ((buffer (line-buffer (mark-line start))) - (first (cons dummy-line *the-sentinel*))) - (unless buffer (error "Window start is not in a buffer.")) - (setf (window-display-start window) (copy-mark start :right-inserting) - (window-old-start window) (copy-mark start :temporary) - (window-display-end window) (copy-mark start :right-inserting) - (window-%buffer window) buffer - (window-point window) (copy-mark (buffer-point buffer)) - (window-height window) height - (window-width window) width - (window-first-line window) first - (window-last-line window) *the-sentinel* - (window-first-changed window) *the-sentinel* - (window-last-changed window) first - (window-tick window) -1) - (push window *window-list*) - (push window (buffer-windows buffer)) - ;; - ;; Make the dis-lines. - (do ((i (- height) (1+ i)) - (res () - (cons (make-window-dis-line (make-string width)) res))) - ((= i height) (setf (window-spare-lines window) res))) - ;; - ;; Make the image up to date. - (update-window-image window))) - -;;; change-window-image-height -- Internal -;;; -;;; Milkshake. -;;; -(defun change-window-image-height (window new-height) - ;; Nuke all the lines in the window image. - (unless (eq (cdr (window-first-line window)) *the-sentinel*) - (shiftf (cdr (window-last-line window)) - (window-spare-lines window) - (cdr (window-first-line window)) - *the-sentinel*)) - ;; Add some new spare lines if needed. - (let* ((res (window-spare-lines window)) - (width (length (the simple-string (dis-line-chars (car res)))))) - (declare (list res)) - (setf (window-height window) new-height) - (do ((i (- (* new-height 2) (length res)) (1- i))) - ((minusp i)) - (push (make-window-dis-line (make-string width)) res)) - (setf (window-spare-lines window) res))) Index: anches/ide-1.0/ccl/hemlock/src/winimage.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/winimage.lisp (revision 6566) +++ (revision ) @@ -1,327 +1,0 @@ -;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- -;;; -;;; ********************************************************************** -;;; This code was written as part of the CMU Common Lisp project at -;;; Carnegie Mellon University, and has been placed in the public domain. -;;; -#+CMU (ext:file-comment - "$Header$") -;;; -;;; ********************************************************************** -;;; -;;; Written by Rob MacLachlan -;;; -;;; This file contains implementation independant functions that -;;; build window images from the buffer structure. -;;; -(in-package :hemlock-internals) - -(defvar *the-sentinel* - (list (make-window-dis-line "")) - "This dis-line, which has several interesting properties, is used to end - lists of dis-lines.") -(setf (dis-line-line (car *the-sentinel*)) - (make-line :number most-positive-fixnum :chars "")) -(setf (dis-line-position (car *the-sentinel*)) most-positive-fixnum) -(setf (dis-line-old-chars (car *the-sentinel*)) :unique-thing) - - - - - -;;; move-lines -- Internal -;;; -;;; This function is called by Maybe-Change-Window when it believes that -;;; a line needs to be inserted or deleted. When called it finishes the -;;; image-update for the entire rest of the window. Here and many other -;;; places the phrase "dis-line" is often used to mean a pointer into the -;;; window's list of dis-lines. -;;; -;;; Window - The window whose image needs to be updated. -;;; Changed - True if the first-changed line has already been set, if false -;;; we must set it. -;;; String - The overhang string to be added to the beginning of the first -;;; line image we build. If no overhang then this is NIL. -;;; Underhang - The number of trailing chars of String to use. -;;; Line - The line at which we are to continue building the image. This -;;; may be NIL, in which case we are at the end of the buffer. -;;; Offset - The charpos within Line to continue at. -;;; Current - The dis-line which caused Maybe-Change-Window to choke; it -;;; may be *the-sentinel*, it may not be the dummy line at head of the -;;; window's dis-lines. This is the dis-line at which Maybe-Change-Window -;;; turns over control, it should not be one whose image it built. -;;; Trail - This is the dis-line which immediately precedes Current in the -;;; dis-line list. It may be the dummy dis-line, it may not be the sentinel. -;;; Width - (window-width window) -(defun move-lines (window changed string underhang line offset trail current - width) - - (do* ((delta 0) - (cc (car current)) - (old-line (dis-line-line cc)) - ;; Can't use current, since might be *the-sentinel*. - (pos (1+ (dis-line-position (car trail)))) - ;; Are we on an extension line? - (is-wrapped (eq line (dis-line-line (car trail)))) - (last (window-last-line window)) - (last-line (dis-line-line (car last))) - (save trail) - (height (window-height window)) - (spare-lines (window-spare-lines window)) - ;; Make *the-sentinel* in this buffer so we don't delete it. - (buffer (setf (line-%buffer (dis-line-line (car *the-sentinel*))) - (window-buffer window))) - (start offset) new-num) - ((or (= pos height) (null line)) - ;; If we have run off the bottom or run out of lines then we are - ;; done. At this point Trail is the last line displayed and Current is - ;; whatever comes after it, possibly *the-sentinel*. - ;; We always say that last-changed is the last line so that we - ;; don't have to max in the old last-changed. - (setf (window-last-changed window) trail) - ;; If there are extra lines at the end that need to be deleted - ;; and haven't been already then link them into the free-list. - (unless (eq last trail) - ;; This test works, because if the old last line was either - ;; deleted or another line was inserted after it then it's - ;; cdr would be something else. - (when (eq (cdr last) *the-sentinel*) - (shiftf (cdr last) spare-lines (cdr trail) *the-sentinel*)) - (setf (window-last-line window) trail)) - (setf (window-spare-lines window) spare-lines) - ;; If first-changed has not been set then we set the first-changed - ;; to the first line we looked at if it does not come after the - ;; new position of the old first-changed. - (unless changed - (when (> (dis-line-position (car (window-first-changed window))) - (dis-line-position (car save))) - (setf (window-first-changed window) (cdr save))))) - - (setq new-num (line-number line)) - ;; If a line has been deleted, it's line-%buffer is smashed; we unlink - ;; any dis-line which displayed such a line. - (cond - ((neq (line-%buffer old-line) buffer) - (do ((ptr (cdr current) (cdr ptr)) - (prev current ptr)) - ((eq (line-%buffer (dis-line-line (car ptr))) buffer) - (setq delta (- pos (1+ (dis-line-position (car prev))))) - (shiftf (cdr trail) (cdr prev) spare-lines current ptr))) - (setq cc (car current) old-line (dis-line-line cc))) - ;; If the line-number of the old line is less than the line-number - ;; of the line we want to display then the old line must be off the top - ;; of the screen - delete it. *The-Sentinel* fails this test because - ;; it's line-number is most-positive-fixnum. - ((< (line-number old-line) new-num) - (do ((ptr (cdr current) (cdr ptr)) - (prev current ptr)) - ((>= (line-number (dis-line-line (car ptr))) new-num) - (setq delta (- pos (1+ (dis-line-position (car prev))))) - (shiftf (cdr trail) (cdr prev) spare-lines current ptr))) - (setq cc (car current) old-line (dis-line-line cc))) - ;; New line comes before old line, insert it, punting when - ;; we hit the bottom of the screen. - ((neq line old-line) - (do ((chars (unless is-wrapped (line-%chars line)) nil) new) - (()) - (setq new (car spare-lines)) - (setf (dis-line-old-chars new) chars - (dis-line-position new) pos - (dis-line-line new) line - (dis-line-delta new) 0 - (dis-line-flags new) new-bit) - (setq pos (1+ pos) delta (1+ delta)) - (multiple-value-setq (string underhang start) - (compute-line-image string underhang line start new width)) - (rotatef (cdr trail) spare-lines (cdr spare-lines)) - (setq trail (cdr trail)) - (cond ((= pos height) - (return nil)) - ((null underhang) - (setq start 0 line (line-next line)) - (return nil)))) - (setq is-wrapped nil)) - ;; The line is the same, possibly moved. We add in the delta and - ;; or in the moved bit so that if redisplay punts in the middle - ;; the information is not lost. - ((eq (line-%chars line) (dis-line-old-chars cc)) - ;; If the line is the old bottom line on the screen and it has moved and - ;; is full length, then mash the old-chars and quit so that the image - ;; will be recomputed the next time around the loop, since the line might - ;; have been wrapped off the bottom of the screen. - (cond - ((and (eq line last-line) - (= (dis-line-length cc) width) - (not (zerop delta))) - (setf (dis-line-old-chars cc) :another-unique-thing)) - (t - (do () - ((= pos height)) - (unless (zerop delta) - (setf (dis-line-position cc) pos) - (incf (dis-line-delta cc) delta) - (setf (dis-line-flags cc) (logior (dis-line-flags cc) moved-bit))) - (shiftf trail current (cdr current)) - (setq cc (car current) old-line (dis-line-line cc) pos (1+ pos)) - (when (not (eq old-line line)) - (setq start 0 line (line-next line)) - (return nil)))))) - ;; The line is changed, possibly moved. - (t - (do ((chars (line-%chars line) nil)) - (()) - (multiple-value-setq (string underhang start) - (compute-line-image string underhang line start cc width)) - (setf (dis-line-flags cc) (logior (dis-line-flags cc) changed-bit) - (dis-line-old-chars cc) chars - (dis-line-position cc) pos) - (unless (zerop delta) - (incf (dis-line-delta cc) delta) - (setf (dis-line-flags cc) (logior (dis-line-flags cc) moved-bit))) - (shiftf trail current (cdr current)) - (setq cc (car current) old-line (dis-line-line cc) pos (1+ pos)) - (cond ((= pos height) - (return nil)) - ((null underhang) - (setq start 0 line (line-next line)) - (return nil)) - ((not (eq old-line line)) - (setq is-wrapped t) - (return nil)))))))) - - - -;;; maybe-change-window -- Internal -;;; -;;; This macro is "Called" in update-window-image whenever it finds that -;;; the chars of the line and the dis-line don't match. This may happen for -;;; several reasons: -;;; -;;; 1] The previous line was unchanged, but wrapped, so the dis-line-chars -;;; are nil. In this case we just skip over the extension lines. -;;; -;;; 2] A line is changed but not moved; update the line noting whether the -;;; next line is moved because of this, and bugging out to Move-Lines if -;;; it is. -;;; -;;; 3] A line is deleted, off the top of the screen, or moved. Bug out -;;; to Move-Lines. -;;; -;;; There are two possible results, either we return NIL, and Line, -;;; Trail and Current are updated, or we return T, in which case -;;; Update-Window-Image should terminate immediately. Changed is true -;;; if a changed line changed lines has been found. -;;; -(eval-when (:compile-toplevel :execute) -(defmacro maybe-change-window (window changed line offset trail current width) - `(let* ((cc (car ,current)) - (old-line (dis-line-line cc))) - (cond - ;; We have run into a continuation line, skip over any. - ((and (null (dis-line-old-chars cc)) - (eq old-line (dis-line-line (car ,trail)))) - (do ((ptr (cdr ,current) (cdr ptr)) - (prev ,current ptr)) - ((not (eq (dis-line-line (car ptr)) old-line)) - (setq ,trail prev ,current ptr) nil))) - ;; A line is changed. - ((eq old-line ,line) - (unless ,changed - (when (< (dis-line-position cc) - (dis-line-position (car (window-first-changed ,window)))) - (setf (window-first-changed ,window) ,current) - (setq ,changed t))) - (do ((chars (line-%chars ,line) nil) - (start ,offset) string underhang) - (()) - (multiple-value-setq (string underhang start) - (compute-line-image string underhang ,line start cc ,width)) - (setf (dis-line-flags cc) (logior (dis-line-flags cc) changed-bit)) - (setf (dis-line-old-chars cc) chars) - (setq ,trail ,current ,current (cdr ,current) cc (car ,current)) - (cond - ((eq (dis-line-line cc) ,line) - (unless underhang - (move-lines ,window t nil 0 (line-next ,line) 0 ,trail ,current - ,width) - (return t))) - (underhang - (move-lines ,window t string underhang ,line start ,trail - ,current ,width) - (return t)) - (t - (setq ,line (line-next ,line)) - (when (> (dis-line-position (car ,trail)) - (dis-line-position (car (window-last-changed ,window)))) - (setf (window-last-changed ,window) ,trail)) - (return nil))))) - (t - (move-lines ,window ,changed nil 0 ,line ,offset ,trail ,current - ,width) - t)))) -); eval-when - - -;;; update-window-image -- Internal -;;; -;;; This is the function which redisplay calls when it wants to ensure that -;;; a window-image is up-to-date. The main loop here is just to zoom through -;;; the lines and dis-lines, bugging out to Maybe-Change-Window whenever -;;; something interesting happens. -;;; -(defun update-window-image (window) - (let* ((trail (window-first-line window)) - (current (cdr trail)) - (display-start (window-display-start window)) - (line (mark-line display-start)) - (width (window-width window)) changed) - (cond - ;; If the first line or its charpos has changed then bug out. - ((cond ((and (eq (dis-line-old-chars (car current)) (line-%chars line)) - (mark= display-start (window-old-start window))) - (setq trail current current (cdr current) line (line-next line)) - nil) - (t - ;; Force the line image to be invalid in case the start moved - ;; and the line wrapped onto the screen. If we started at the - ;; beginning of the line then we don't need to. - (unless (zerop (mark-charpos (window-old-start window))) - (unless (eq current *the-sentinel*) - (setf (dis-line-old-chars (car current)) :another-unique-thing))) - (let ((start-charpos (mark-charpos display-start))) - (move-mark (window-old-start window) display-start) - (maybe-change-window window changed line start-charpos - trail current width))))) - (t - (prog () - (go TOP) - STEP - (setf (dis-line-line (car current)) line) - (setq trail current current (cdr current) line (line-next line)) - TOP - (cond ((null line) - (go DONE)) - ((eq (line-%chars line) (dis-line-old-chars (car current))) - (go STEP))) - ;; - ;; We found a suspect line. - ;; See if anything needs to be updated, if we bugged out, punt. - (when (and (eq current *the-sentinel*) - (= (dis-line-position (car trail)) - (1- (window-height window)))) - (return nil)) - (when (maybe-change-window window changed line 0 trail current width) - (return nil)) - (go TOP) - - DONE - ;; - ;; We hit the end of the buffer. If lines need to be deleted bug out. - (unless (eq current *the-sentinel*) - (maybe-change-window window changed line 0 trail current width)) - (return nil)))) - ;; - ;; Update the display-end mark. - (let ((dl (car (window-last-line window)))) - (move-to-position (window-display-end window) (dis-line-end dl) - (dis-line-line dl)))))