/[climacs]/climacs/gui.lisp
ViewVC logotype

Diff of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.214 by dmurray, Sat May 13 17:19:10 2006 UTC revision 1.215 by crhodes, Sun May 14 17:42:21 2006 UTC
# Line 223  Line 223 
223        (clim-sys:make-process #'run :name process-name)        (clim-sys:make-process #'run :name process-name)
224        (run))))        (run))))
225    
226    (define-presentation-type read-only ())
227    (define-presentation-method highlight-presentation
228        ((type read-only) record stream state)
229      nil)
230    (define-presentation-type modified ())
231    (define-presentation-method highlight-presentation
232        ((type modified) record stream state)
233      nil)
234    
235    (define-command (com-toggle-read-only :name t :command-table base-table)
236        ((buffer 'buffer))
237      (setf (read-only-p buffer) (not (read-only-p buffer))))
238    (define-presentation-to-command-translator toggle-read-only
239        (read-only com-toggle-read-only base-table
240         :gesture :menu)
241        (object)
242      (list object))
243    
244    (define-command (com-toggle-modified :name t :command-table base-table)
245        ((buffer 'buffer))
246      (setf (needs-saving buffer) (not (needs-saving buffer))))
247    (define-presentation-to-command-translator toggle-modified
248        (modified com-toggle-modified base-table
249         :gesture :menu)
250        (object)
251      (list object))
252    
253  (defun display-info (frame pane)  (defun display-info (frame pane)
254    (let* ((master-pane (master-pane pane))    (let* ((master-pane (master-pane pane))
255           (buffer (buffer master-pane))           (buffer (buffer master-pane))
# Line 230  Line 257 
257           (top (top master-pane))           (top (top master-pane))
258           (bot (bot master-pane)))           (bot (bot master-pane)))
259      (princ "   " pane)      (princ "   " pane)
260      (princ (cond ((and (needs-saving buffer)      (with-output-as-presentation (pane buffer 'read-only)
261                         (read-only-p buffer)        (princ (cond
262                         "%*"))                 ((read-only-p buffer) "%")
263                   ((needs-saving buffer) "**")                 ((needs-saving buffer) "*")
264                   ((read-only-p buffer) "%%")                 (t "-"))
265                   (t "--"))               pane))
266             pane)      (with-output-as-presentation (pane buffer 'modified)
267          (princ (cond
268                   ((needs-saving buffer) "*")
269                   ((read-only-p buffer) "%")
270                   (t "-"))
271                 pane))
272      (princ "  " pane)      (princ "  " pane)
273      (with-text-face (pane :bold)      (with-text-face (pane :bold)
274        (format pane "~25A" (name buffer)))        (with-output-as-presentation (pane buffer 'buffer)
275            (format pane "~A" (name buffer)))
276          ;; FIXME: bare 25.
277          (format pane "~V@T" (- 25 (length (name buffer)))))
278      (format pane "  ~A  "      (format pane "  ~A  "
279              (cond ((and (mark= size bot)              (cond ((and (mark= size bot)
280                          (mark= 0 top))                          (mark= 0 top))
# Line 305  Line 340 
340          (beep) (display-message "Buffer is read only")))))          (beep) (display-message "Buffer is read only")))))
341    
342  (defmethod execute-frame-command :after ((frame climacs) command)  (defmethod execute-frame-command :after ((frame climacs) command)
343    (loop for buffer in (buffers frame)    (when (eq frame *application-frame*)
344          do (update-syntax buffer (syntax buffer))      (loop for buffer in (buffers frame)
345          do (when (modified-p buffer)            do (when (syntax buffer)
346               (setf (needs-saving buffer) t))))                 (update-syntax buffer (syntax buffer)))
347              do (when (modified-p buffer)
348                   (setf (needs-saving buffer) t)))))
349    
350  (defmethod find-applicable-command-table ((frame climacs))  (defmethod find-applicable-command-table ((frame climacs))
351    (or    (or
# Line 482  If the a buffer with that name does not Line 519  If the a buffer with that name does not
519  (defmethod kill-buffer ((symbol (eql 'nil)))  (defmethod kill-buffer ((symbol (eql 'nil)))
520    (kill-buffer (buffer (current-window))))    (kill-buffer (buffer (current-window))))
521    
522  (define-command (com-kill-buffer :name t :command-table pane-table) ()  (define-command (com-kill-buffer :name t :command-table pane-table)
523        ((buffer 'buffer
524                 :prompt "Kill buffer"
525                 :default (buffer (current-window))
526                 :default-type 'buffer))
527    "Prompt for a buffer name and kill that buffer.    "Prompt for a buffer name and kill that buffer.
528  If the buffer needs saving, will prompt you to do so before killing it. Uses the current buffer as a default."  If the buffer needs saving, will prompt you to do so before killing it. Uses the current buffer as a default."
529    (let ((buffer (accept 'buffer    (kill-buffer buffer))
                         :prompt "Kill buffer"  
                         :default (buffer (current-window))  
                         :default-type 'buffer)))  
     (kill-buffer buffer)))  
530    
531  (set-key 'com-kill-buffer  (set-key `(com-kill-buffer ,*unsupplied-argument-marker*)
532           'pane-table           'pane-table
533           '((#\x :control) (#\k)))           '((#\x :control) (#\k)))
534    
535    #+sbcl
536    (defun ed-in-climacs (thing)
537      (let ((frame-manager (find-frame-manager)))
538        (when frame-manager
539          (let ((climacs-frame (find-if (lambda (x) (typep x 'climacs))
540                                        (frame-manager-frames frame-manager))))
541            (when climacs-frame
542              (typecase thing
543                ((or pathname string)
544                 (execute-frame-command
545                  climacs-frame `(com-find-file ,(pathname thing)))
546                 t)
547                ((or symbol cons)
548                 ;; FIXME: do something
549                 nil)))))))
550    
551    #+sbcl
552    (pushnew 'ed-in-climacs sb-ext:*ed-functions*)
553    
554  ;;; For the ESA help functions.  ;;; For the ESA help functions.
555    
556  (defmethod help-stream ((frame climacs) title)  (defmethod help-stream ((frame climacs) title)

Legend:
Removed from v.1.214  
changed lines
  Added in v.1.215

  ViewVC Help
Powered by ViewVC 1.1.5