Changeset 14216


Ignore:
Timestamp:
Aug 26, 2010, 1:34:02 AM (9 years ago)
Author:
gb
Message:

Changes to support "background" listener processes (processes where
*TERMINAL-IO* and its synonym streams are bound to lazily-created
hemlock-listener streams, with associated document/window/buffer etc.)

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/cocoa-ide/cocoa-listener.lisp

    r13901 r14216  
    250250     (backtrace-contexts :initform nil
    251251                         :accessor cocoa-listener-process-backtrace-contexts)
    252      (window :reader cocoa-listener-process-window)))
     252     (window :reader cocoa-listener-process-window :initform nil)))
    253253 
    254254(defloadvar *first-listener* t)
     
    280280           :initial-function
    281281           #'(lambda ()
    282                (setq ccl::*listener-autorelease-pool* (create-autorelease-pool))
    283                (when (and *standalone-cocoa-ide*
     282               (setq ccl::*listener-autorelease-pool* (create-autorelease-pool))               (when (and *standalone-cocoa-ide*
    284283                        (prog1 *first-listener* (setq *first-listener* nil)))
    285284                 (ccl::startup-ccl (ccl::application-init-file ccl::*application*))
     
    302301  (declare (ignorable edited)))
    303302
     303(objc:defmethod (#/windowShouldClose: #>BOOL) ((w hemlock-listener-frame)
     304                                               sender)
     305  (let* ((doc (#/document w)))
     306    (if (or (%null-ptr-p doc)
     307            (and (hemlock-document-process doc)
     308                 (perform-close-kills-process-p doc)))
     309      t
     310      (progn
     311        (#/orderOut: w sender)
     312        nil))))
     313
     314
    304315
    305316(defclass hemlock-listener-window-controller (hemlock-editor-window-controller)
     
    333344
    334345(defclass hemlock-listener-document (hemlock-editor-document)
    335   ((process :reader %hemlock-document-process :writer (setf hemlock-document-process)))
     346  ((process :reader %hemlock-document-process :writer (setf hemlock-document-process) :initform nil))
    336347  (:metaclass ns:+ns-object))
    337348(declaim (special hemlock-listener-document))
     
    369380
    370381(objc:defmethod #/topListener ((self +hemlock-listener-document))
    371   (let* ((all-documents (#/orderedDocuments *NSApp*)))
    372     (dotimes (i (#/count all-documents) +null-ptr+)
    373       (let* ((doc (#/objectAtIndex: all-documents i)))
    374         (when (eql (#/class doc) self)
    375           (return doc))))))
     382  (let* ((all-windows (#/orderedWindows *NSApp*)))
     383    (dotimes (i (#/count all-windows) +null-ptr+)
     384      (let* ((w (#/objectAtIndex: all-windows i)))
     385        (when (#/isVisible w)
     386          (let* ((wc (#/windowController w))
     387                 (doc (#/document wc)))
     388            (when (#/isKindOfClass: doc self)
     389              (return doc))))))))
    376390
    377391(defun symbol-value-in-top-listener-process (symbol)
     
    421435(defloadvar *next-listener-y-pos* nil) ; likewise
    422436
    423 (objc:defmethod (#/close :void) ((self hemlock-listener-document))
     437(objc:defmethod (#/dealloc :void) ((self hemlock-listener-document))
    424438  (if (zerop (decf *cocoa-listener-count*))
    425439    (setq *next-listener-x-pos* nil
     
    429443      (process-kill p)))
    430444  (call-next-method))
     445
    431446
    432447
     
    473488    (#/addWindowController: self controller)
    474489    (#/release controller)
    475     (setf (hemlock-document-process self)
    476           (new-cocoa-listener-process listener-name window))
     490    (unless (hemlock-document-process self)
     491      (setf (hemlock-document-process self)
     492            (new-cocoa-listener-process listener-name window)))
    477493    (when path
    478494      (unless (#/setFrameAutosaveName: window path)
     
    485501                                        (+ (ns:ns-rect-y frame)
    486502                                           (ns:ns-rect-height frame)))
    487                         (let* ((next-point (#/cascadeTopLeftFromPoint:
    488                                             window
    489                                             current-point)))
    490                      (setq *next-listener-x-pos*
    491                            (ns:ns-point-x next-point)
    492                            *next-listener-y-pos*
    493                            (ns:ns-point-y next-point)))))
     503                       (let* ((next-point (#/cascadeTopLeftFromPoint:
     504                                           window
     505                                           current-point)))
     506                         (setq *next-listener-x-pos*
     507                               (ns:ns-point-x next-point)
     508                               *next-listener-y-pos*
     509                               (ns:ns-point-y next-point)))))
    494510                   t))
    495511      (ns:with-ns-point (current-point
     
    635651      (call-next-method item))))
    636652
     653(defmethod perform-close-kills-process-p ((self hemlock-listener-document))
     654  t)
     655
    637656(defun shortest-package-name (package)
    638657  (let* ((name (package-name package))
     
    710729
    711730       
    712  
     731;;; Support for background processes that acquire listener window/document/
     732;;; buffer infrastructure iff they try to do I/O to *TERMINAL-IO*.
     733
     734(defclass hemlock-background-listener-document (hemlock-listener-document)
     735    ()
     736  (:metaclass ns:+ns-object))
     737
     738(defmethod perform-close-kills-process-p ((self hemlock-background-listener-document))
     739  nil)
     740
     741(defstruct deferred-cocoa-listener-stream-info
     742  real-input-stream
     743  real-output-stream
     744  process
     745  window)
     746
     747   
     748(defclass deferred-cocoa-listener-stream (fundamental-character-stream)
     749    ((info :initarg :info :accessor deferred-cocoa-listener-stream-info)))
     750
     751(defmethod ensure-deferred-stream-info-for-io ((s deferred-cocoa-listener-stream))
     752  (let* ((info (slot-value s 'info)))
     753    (when info
     754      (unless (deferred-cocoa-listener-stream-info-window info)
     755        (with-autorelease-pool
     756            (let* ((doc (make-instance 'hemlock-background-listener-document))
     757                   (buffer (hemlock-buffer doc))
     758                   (process (deferred-cocoa-listener-stream-info-process info)))
     759              (setf (hi::buffer-name buffer)
     760                    (format nil "~a(~d)" (process-name process) (process-serial-number process))
     761                    (hemlock-document-process doc) process)
     762              (execute-in-gui (lambda () (#/makeWindowControllers doc)))
     763              (let* ((wc (#/lastObject (#/windowControllers doc)))
     764                     (window (#/window wc)))
     765                (setf
     766                 (deferred-cocoa-listener-stream-info-real-input-stream info)
     767                 (make-instance 'cocoa-listener-input-stream)
     768                 (deferred-cocoa-listener-stream-info-real-output-stream info)
     769                 (make-instance 'cocoa-listener-output-stream
     770                                :hemlock-view (hemlock-view window))
     771                 (deferred-cocoa-listener-stream-info-window info)
     772                 window
     773                 (slot-value process 'window) window)
     774                (ui-object-note-package *nsapp* *package*))))))
     775    info))
     776               
     777                     
     778
     779(defclass deferred-cocoa-listener-output-stream
     780          (fundamental-character-output-stream deferred-cocoa-listener-stream)
     781    ())
     782
     783(defmethod stream-element-type ((s deferred-cocoa-listener-output-stream))
     784  'character)
     785
     786
     787(defmethod underlying-output-stream ((s deferred-cocoa-listener-output-stream))
     788  (let* ((info (ensure-deferred-stream-info-for-io s)))
     789    (if info
     790      (progn
     791        (let* ((window (deferred-cocoa-listener-stream-info-window info)))
     792          (unless (#/isVisible window)
     793            (execute-in-gui
     794             (lambda ()
     795               (#/makeKeyAndOrderFront: window (%null-ptr)))))
     796          (deferred-cocoa-listener-stream-info-real-output-stream info)))
     797      (ccl::stream-is-closed s))))
     798
     799(defmethod ccl:stream-write-char ((s deferred-cocoa-listener-output-stream)
     800                                   char)
     801  (with-autorelease-pool
     802      (stream-write-char (underlying-output-stream s) char)))
     803
     804(defmethod ccl:stream-line-column ((s deferred-cocoa-listener-output-stream))
     805  (stream-line-column (underlying-output-stream s)))
     806
     807(defmethod ccl:stream-fresh-line ((s deferred-cocoa-listener-output-stream))
     808  (stream-fresh-line (underlying-output-stream s)))
     809
     810(defmethod ccl::stream-finish-output ((s deferred-cocoa-listener-output-stream))
     811  (stream-force-output s))
     812
     813(defmethod ccl:stream-force-output ((s deferred-cocoa-listener-output-stream))
     814  (let* ((info (slot-value s 'info)))
     815    (if info
     816      (let* ((out (deferred-cocoa-listener-stream-info-real-output-stream info)))
     817        (if out
     818          (stream-force-output out)))
     819      (ccl::stream-is-closed s))))
     820
     821(defmethod ccl:stream-clear-output ((s deferred-cocoa-listener-output-stream))
     822  (stream-clear-output (underlying-output-stream s)))
     823
     824(defmethod ccl:stream-line-length ((s deferred-cocoa-listener-output-stream))
     825  (stream-line-length (underlying-output-stream s)))
     826
     827(defmethod close ((s deferred-cocoa-listener-output-stream)
     828                  &key abort)
     829  (let* ((info (slot-value s 'info)))
     830    (when info
     831      (let* ((out (deferred-cocoa-listener-stream-info-real-output-stream info)))
     832        (when out
     833          (stream-force-output out)
     834          (close out :abort abort)))
     835      (setf (slot-value s 'info) nil)
     836      t)))
     837         
     838
     839(defclass deferred-cocoa-listener-input-stream
     840          (fundamental-character-input-stream deferred-cocoa-listener-stream)
     841    ((reading-line :initform nil :accessor hi:input-stream-reading-line)))
     842
     843
     844(defmethod underlying-input-stream ((s deferred-cocoa-listener-input-stream))
     845  (let* ((info (ensure-deferred-stream-info-for-io s)))
     846    (if info
     847      (progn
     848        (let* ((window (deferred-cocoa-listener-stream-info-window info)))
     849          (unless (#/isVisible window)
     850            (execute-in-gui
     851             (lambda ()
     852               (#/makeKeyAndOrderFront: window (%null-ptr)))))
     853          (deferred-cocoa-listener-stream-info-real-input-stream info)))
     854      (ccl::stream-is-closed s))))
     855
     856(defmethod interactive-stream-p ((s deferred-cocoa-listener-input-stream))
     857  t)
     858
     859(defmethod ccl::read-toplevel-form ((s deferred-cocoa-listener-input-stream)
     860                                    &key eof-value)
     861  (ccl::read-toplevel-form (underlying-input-stream s) :eof-value eof-value))
     862
     863(defmethod enqueue-toplevel-form ((s deferred-cocoa-listener-input-stream) string &rest args)
     864  (apply #'enqueue-toplevel-form (underlying-input-stream s) string args))
     865
     866(defmethod enqueue-listener-input ((s deferred-cocoa-listener-input-stream) string)
     867  (enqueue-listener-input (underlying-input-stream s) string))
     868
     869(defmethod stream-read-char-no-hang ((s deferred-cocoa-listener-input-stream))
     870  (stream-read-char-no-hang (underlying-input-stream s)))
     871
     872(defmethod stream-read-char ((s deferred-cocoa-listener-input-stream))
     873  (stream-read-char (underlying-input-stream s)))
     874
     875(defmethod stream-unread-char ((s deferred-cocoa-listener-input-stream) char)
     876  (stream-unread-char (underlying-input-stream s) char))
     877
     878(defmethod stream-clear-input ((s deferred-cocoa-listener-input-stream))
     879  (stream-clear-input (underlying-input-stream s)))
     880
     881(defmethod stream-read-line ((s deferred-cocoa-listener-input-stream))
     882  (let* ((old-reading-line (hi:input-stream-reading-line s)))
     883    (unwind-protect
     884         (progn
     885           (setf (hi::input-stream-reading-line s) t)
     886           (stream-read-line (underlying-input-stream s)))
     887      (setf (hi:input-stream-reading-line s) old-reading-line))))
     888
     889(defclass background-cocoa-listener-process (cocoa-listener-process)
     890    ())
     891
     892(defun background-process-run-function (name function)
     893  (let* ((process (make-process name :class 'background-cocoa-listener-process))
     894         (info (make-deferred-cocoa-listener-stream-info :process process))
     895         (input-stream (make-instance 'deferred-cocoa-listener-input-stream
     896                                      :info info))
     897         (output-stream (make-instance 'deferred-cocoa-listener-output-stream
     898                                       :info info)))
     899    (setf (slot-value process 'input-stream) input-stream
     900          (slot-value process 'output-stream) output-stream)
     901    (process-preset process
     902                    (lambda ()
     903                      (let* ((*terminal-io* (make-two-way-stream input-stream output-stream)))
     904                        (ccl::add-auto-flush-stream output-stream)
     905                        (unwind-protect
     906                             (funcall function)
     907                          (remove-auto-flush-stream output-stream)
     908                          (let* ((w (slot-value process 'window)))
     909                            (when w
     910                              (let* ((doc (#/document w)))
     911                                (unless (%null-ptr-p doc)
     912                                  (when (eq *current-process*
     913                                            (hemlock-document-process doc))
     914                                    (setf (hemlock-document-process doc) nil))))
     915                              (cond ((#/isVisible w)
     916                                     (format output-stream "~%~%{process ~s exiting}~%" *current-process*))
     917                                    (t
     918                                     (#/performSelectorOnMainThread:withObject:waitUntilDone:
     919                                      w
     920                                      (@selector #/close)
     921                                      +null-ptr+
     922                                      t)))
     923                              (close input-stream)
     924                              (close output-stream)))))))
     925    (process-enable process)))
Note: See TracChangeset for help on using the changeset viewer.