Changeset 13162


Ignore:
Timestamp:
Nov 2, 2009, 6:02:06 PM (10 years ago)
Author:
rme
Message:

Update from http://clozure.com/pipermail/openmcl-devel/2009-October/010665.html

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/contrib/paine/workpersistence.lisp

    r12771 r13162  
    33;;; Clozure CL Hemlock editor windows persistence
    44;;; ie. on restart of CCL re-open (and position) the last session's open files.
    5 ;;; LGPL   c/o Peter Paine 20080611
    6 ;;; Update 20090906: fix not saving closed windows, fix resizing in gui thread, save in home dir.
    7 ;;; ToDo: how to read window from buffer (without external search via path)?
    8 ;;; To use: add (load ~this-file~) to your home:ccl-init.lisp file.
     5;;;
     6;;; LLGPL Copyright (c) Peter Paine 20080611
     7;;; Maintainer: gmail: p2.edoc
     8;;; To use: add (require :workpersistence) to your home:ccl-init.lisp file,
     9;;          or (load ~this-file~)
     10;;; Updates
     11;;; 20091018: restore original window order
     12;;;           option to save independently per platform and CLZ-version
     13;;; 20090906: fix not saving closed windows, fix resizing in gui thread, save in home dir.
     14;;; 20090928: re-select Listener
     15;;; ToDo:
     16;;;   - how to read window from buffer (without external search via path)?
     17;;;   - if on quit, an unsaved buffers prompt, remember-hemlock-files not called (or doesn't save)
     18;;;   - multiple choice menu of buffers to save
     19;;;   - add auto backup process: auto save modified files as file name variant, check/restore on restart
    920
    10 ;; Allows separation of working file sets for different CLZ versions.
    11 (defvar *separate-ccl-working-file-sets-p* T)
     21#-(and clozure-common-lisp hemlock) (error "Workpersistence only runs under CLZ ~
     22                                           Hemlock Nextstep/Cocoa API")
    1223
    13 (defvar *work-persistence-file*
    14   (if *separate-ccl-working-file-sets-p*
    15     (format nil "home:.ccl-workpersistence-~A.text" (ccl::platform-description))
    16     "home:.ccl-workpersistence.text")
    17   "per user")
     24;; Allows separation of working file sets for different platform versions.
     25(defvar *separate-ccl-working-file-sets-by-platform-p* T)
     26
     27;; Independently save working file sets by major/minor version of CLZ.
     28(defvar *separate-ccl-working-file-sets-by-ccl-version-p* nil)
     29
     30(defun work-persistence-file (&optional version)
     31  (setq version (if version (format nil "-~A" version) ""))
     32  (let ((ccl-version
     33         (if *separate-ccl-working-file-sets-by-ccl-version-p*
     34           (format nil "-~D-~D" ccl::*openmcl-major-version* ccl::*openmcl-minor-version*)
     35           "")))
     36  (if *separate-ccl-working-file-sets-by-platform-p*
     37    (format nil "home:.ccl-workpersistence-~A~A~A.text" (ccl::platform-description) ccl-version version)
     38    (format nil "home:.ccl-workpersistence~A~A.text" ccl-version version))))
     39
     40(defvar *work-persistence-file* (work-persistence-file) "per user")
    1841;; (ed *work-persistence-file*)
    1942
     43(defun copy-work-persistence ()
     44  (when (probe-file *work-persistence-file*)
     45    (copy-file *work-persistence-file* (work-persistence-file "copy") :if-exists :overwrite)))
     46;; (ed (work-persistence-file "copy"))
     47
    2048(defun remember-hemlock-files ()
    21     (with-open-file (*standard-output*
    22                      *work-persistence-file*
    23                      :direction :output :if-exists :supersede)
    24       (loop for buffer in (hi::all-buffers)
    25          do (let* ((path (hi:buffer-pathname buffer)))
    26               (when path
    27                 (let ((frame (slot-value (find-file-buffer-window path) 'ns:_frame)))
    28                   (loop initially (format T "~&(")
    29                     for fn in '(ns:ns-rect-x ns:ns-rect-y ns:ns-rect-width ns:ns-rect-height)
    30                     do (format T "~5D " (floor (funcall fn frame)))
    31                     finally (format T "~S)" path))))))))
     49  (with-open-file (*standard-output*
     50                   *work-persistence-file*
     51                   :direction :output :if-exists :supersede)
     52    (loop for buffer in (hi::all-buffers)
     53      do (let* ((path (hi:buffer-pathname buffer)))
     54           (when path
     55             (let ((frame (slot-value (find-file-buffer-window path) 'ns:_frame)))
     56               (loop initially (format T "~&(")
     57                 for fn in '(ns:ns-rect-x ns:ns-rect-y ns:ns-rect-width ns:ns-rect-height)
     58                 do (format T "~5D " (floor (funcall fn frame)))
     59                 finally (format T "~S)" path))))))))
    3260
    3361(defun find-file-buffer-window (path)
     
    4169     return win))
    4270
     71(defun find-listener () ; there must be a standard way to do this
     72  ;; only saves first listener found
     73  (loop with win-arr = (#/orderedWindows ccl::*NSApp*)
     74    for i below (#/count win-arr)
     75    for win = (#/objectAtIndex: win-arr i)
     76    when (typep win 'gui::hemlock-listener-frame)
     77    return win))
     78
     79(defun select-listener ()
     80  (process-wait "Wait for Listener" 'find-listener)
     81  (let ((listener (find-listener)))
     82    (#/performSelectorOnMainThread:withObject:waitUntilDone:
     83     listener (objc:@selector "makeKeyAndOrderFront:") nil nil)))
     84
    4385(defun open-remembered-hemlock-files ()
    44    (with-open-file (buffer-persistence-stream
    45                     *work-persistence-file*
    46                     :direction :input :if-does-not-exist nil)
    47      (when buffer-persistence-stream
    48        (loop for item = (read buffer-persistence-stream nil)
    49          while item
    50          do (destructuring-bind (posx posy width height path) item
    51               (when (probe-file path)
    52                 (gui::execute-in-gui #'(lambda () (gui::find-or-make-hemlock-view path)))
    53                 (let ((window (find-file-buffer-window path))) ; round about way*
    54                   ;;* how to get from hemlock-view
    55                   (when window
    56                     ;; should check whether coords are still in screen bounds
    57                     ;; (could have changed screen realestate since)
    58                     (let ((rect (ns:make-ns-rect posx posy width height)))
    59                       (gui::execute-in-gui
    60                        #'(lambda ()
    61                            (#/setFrame:display: window rect t))))))))))))
    62 
     86  (let (old-file-specs)
     87    (with-open-file (buffer-persistence-stream
     88                     *work-persistence-file*
     89                     :direction :input :if-does-not-exist nil)
     90      (when buffer-persistence-stream ;; reverse order
     91        (loop for item = (read buffer-persistence-stream nil)
     92                while item do (push item old-file-specs))))
     93    (gui::execute-in-gui
     94     #'(lambda ()
     95         (dolist (old-file-spec old-file-specs)
     96           (destructuring-bind (posx posy width height path) old-file-spec
     97             (when (probe-file path)
     98               (gui::find-or-make-hemlock-view path)
     99               (let ((window (find-file-buffer-window path))) ; round about way*
     100                 ;;* how to get from hemlock-view
     101                 (when window
     102                   ;; should check whether coords are still in screen bounds
     103                   ;; (could have changed screen realestate since)
     104                   (let ((rect (ns:make-ns-rect posx posy width height)))
     105                     (#/setFrame:display: window rect t)))))))
     106         (select-listener)))))
     107   
     108         
    63109(pushnew 'remember-hemlock-files *lisp-cleanup-functions*)
    64110(pushnew 'open-remembered-hemlock-files *lisp-startup-functions*)
Note: See TracChangeset for help on using the changeset viewer.