;; headers and summary to be added.


;; This is a global variable.  
;; It might have been more efficient to make this a buffer-local variable
;; and remove one level of nesting in this data structure, but some
;; processes have no primary buffer associated with them.
;;
;; process buffers may safely contain a buffer-local version of this
;; variable to attempt to speed up searching, but it probably won't be a
;; significant improvement.
(defvar mbp-process-alist nil
  "Alist associating secondary buffers with a process.
The car of each member should be a process object, and the cdr should be
another alist composed of secondary buffer objects \(preferably not names,
since buffers may get renamed\) and two functions or regexp strings that
describe what parts of the output stream should go in that buffer.
The semantics of these functions are regexps are documented by the function
`foo'.")

;; This is buffer-local to secondary process buffers.
(defvar mbp-process nil 
  "The process with which this secondary buffer is associated.")

;; This is buffer-local to secondary process buffers.
(defvar mbp-mark nil
  "The mark separating the end of process output from the start of user input.

In the primary buffer associated with a process, there is a special mark
(the process mark) for this purpose.  There can only be one for a given
process and it's nonsensical to use it in another buffer anyway, so a
separate mark must be used in secondary buffers.")

;; Declare these permanently local to prevent kill-all-local-variables from
;; actually killing them.  Most major modes call that function.
(put 'mbp-process-alist 'permanent-local t)
(put 'mbp-process 'permanent-local t)
(put 'mbp-mark 'permanent-local t)


;; MBP error conditions
;; The hierarchy of conditions is as follows:
;;
;;  error
;;    mbp-error
;;      mbp-buffer-in-use
;;

(put 'mbp-error 'error-conditons '(mbp-error error))
(put 'mbp-error 'error-message 
     "Generic multi-buffer process error")

(put 'mbp-buffer-in-use 'error-conditons '(mbp-buffer-in-use mbp-error error))
(put 'mbp-buffer-in-use 'error-message 
     "Buffer is already in use by another process.")


(defun mbp-define-secondary-process-buffer (proc buf &optional re-beg re-end)
  (and (mbp-secondary-buffer-p buf)
       (signal 'mbp-buffer-in-use (list (get-buffer buf))))
  (mbp-set-secondary-process-buffer proc buf re-beg re-end))
    
(defun mbp-set-secondary-process-buffer (proc buf &optional re-beg re-end)
  (setq buf (mbp-get-secondary-buffer-create buf))
  (let ((orig-buf (current-buffer))
        (proc-buf (process-buffer proc))
        tem)

    (set-buffer proc-buf)
    (setq tem (assq buf mbp-secondary-buffer-alist))
    (cond
     ((null tem)
      (setq mbp-secondary-buffer-alist
            (cons (list buf re-beg re-end)
                  mbp-secondary-buffer-alist)))
     (tem
      (or (cdr tem)
          (setcdr tem (cons nil nil)))
      (setq tem (cdr tem))
      (setcar tem re-beg)

      (or (cdr tem)
          (setcdr tem (cons nil nil)))
      (setq tem (cdr tem))
      (setcar tem re-end)))

    (set-buffer buf)
    (if (and (boundp 'mbp-process)
             (processp mbp-process)
             (process-buf mbp-process))
        (setq tem (process-buffer mbp-process))
      (setq tem nil))
    (setq mbp-process proc)
    ;; The mark is already initialized by mbp-get-secondary-buffer-create
    ;; if necessary.
    ;(setq mbp-mark (set-marker (make-marker) (point-max)))

    (cond
     (tem 
      (set-buffer tem)
      (setq mbp-secondary-buffer-alist
            (delq (assq buf mbp-secondary-buffer-alist)
                  mbp-secondary-buffer-alist))))

    (set-buffer orig-buf)))


(defun mbp-get-secondary-process-buffer-create (buffer)
  "Get the buffer named BUFFER, or create one and return it.

If BUFFER is a buffer object, just return that object.

If it is a name and no buffer by that name exists, create one and return
it.  Also, make sure the buffer is initialized with attributes necessary
for use as a secondary process buffer, e.g. a marker delimiting the end of
process output and the beginning of current user input.

This function does not associate a secondary buffer with a primary process.
Use mbp-set-secondary-buffer-process or mbp-define-secondary-buffer for
that."
  (cond
   ((bufferp buffer))
   ((and (stringp buffer) 
         (get-buffer buffer))
    (setq buffer (get-buffer buffer)))
   ((stringp buffer)
    (setq buffer (get-buffer-create buffer))
    (let ((orig-buffer (current-buffer)))
      (set-buffer buffer)
      (mbp-make-local-variables 'mbp-process 'mbp-mark)
      ;; Make sure the mark has a sensible value.
      (cond
       ((and (boundp 'mbp-mark)
             (markerp mbp-mark)
             (eq buffer (marker-buffer mbp-mark))))
       (t
        (setq mbp-mark (set-marker (make-marker) (point-max)))))
      (set-buffer orig-buffer)))
   (t
    (signal 'wrong-type-argument (list 'buffer-or-string-p buffer))))
  buffer)

(defun mbp-get-buffer-create (buffer)
  (cond
   ((bufferp buffer))
   ((stringp buffer)
    (setq buffer (get-buffer-create buf)))
   (t
    (signal 'wrong-type-argument (list 'buffer-or-string-p buffer)))))


(defun mbp-make-local-variables (&rest symlist)
  "Make all variables SYM1, SYM2, ... SYMn buffer-local in the current buffer.
If any variable is already buffer-local, don't do anything further to it.
Otherwise, if there is a global value for the symbol and it is a sequence,
initialize the local variable with a shallow copy of the global value."
  (let (sym)
    (while symlist
      (setq sym (car symlist))
      (cond
       ((assq sym (buffer-local-variables)))
       ((and (boundp sym)
             (sequencep sym))
        (make-local-variable sym)
        (set sym (copy-sequence (default-value sym))))
       (t
        (make-local-variable sym)))
      (setq symlist (cdr symlist)))))

(defun mbp-secondary-buffer-p (&optional buffer)
  "Return non-`nil' if BUFFER is a secondary process buffer.
In fact, if BUFFER is a secondary process buffer (i.e. it has a live
process associated with it but is not the `process-buffer', return the
process object with which it is associated."
  (or buffer (setq buffer (current-buffer)))
  (and (get-buffer buffer)
       (let ((orig-buffer (current-buffer)))
         (set-buffer buffer)
         (prog1
             (if (and (boundp 'mbp-process)
                      (processp mbp-process)
                      (not (memq (process-status mbp-process) 
                                 '(exit closed))))
                 t
               nil)
           (set-buffer orig-buffer)))))

(defun mbp-function-p (x)
  "Return `t' if X is a function, `nil' otherwise.
X may be a subr, a byte-compiled function, or a lambda expression.
In the last case, no attempt is made to determine if the lambda expression
is actually well-formed (i.e. syntactically valid as a function)."
  (cond
   ((subrp x))
   ((and (fboundp 'byte-code-function-p)
         (byte-code-function-p x)))
   ((and (consp x)
         (eq (car x) 'lambda)))
   (t nil)))

;; It's not clear I'll need this.
(defun mbp-matched-substring (n &optional string)
  "Return the Nth subexpression matched by the last regexp search or match.
If the optional argument STRING is given, return the nth matched substring
of that string.  Otherwise, return a substring of the current buffer
matched by the last search."
  (if string
      (substring string (match-beginning n) (match-end n))
    (buffer-substring (match-beginning n) (match-end n))))

;; Take `matcher', a regexp string or a function, and apply it to `string'.
;; If a match is found for some substring in `string', return a cons
;; indicating the starting and ending positions in string for the match.
;; If `results' is a cons, store the results in that instead of allocating
;; a new cons.
;;
;; If `matcher' is a function, it is expected to return such a cons itself,
;; or nil.  The data from the returned cons is copied to `results' (or a
;; fresh cons) in case the matcher function also reuses the cons it returned.
;; If the matcher function alters the match data, it must restore it itself.
;; If `matcher' is just a regexp, the match data is preserved.
;;
;; If `matcher' is neither a function nor a string, signal an error.
;; If no match is found, return nil and leave `results' unchanged.
;;
;; This function is mainly intended for use by mbp-process-filter.
(defun mbp-matcher-boundary (matcher string &optional results)
  (cond
   ((stringp matcher)
    (let ((data (match-data))
          beg end)
      (prog1
          (and (setq beg (string-match matcher string))
               (cond ((consp results)
                      (setcar results beg)
                      (setcdr results (match-end 0))
                      results)
                     (t
                      (setq results (cons beg (match-end 0)))
                      results)))
        (store-match-data data))))
   ((mbp-function-p matcher)
    (let ((cell (funcall matcher string)))
      (and (consp cell)
           (cond ((consp results)
                  (setcar results (car cell))
                  (setcdr results (cdr cell))
                  results)
                 (t
                  (setq results (cons (car cell) (cdr cell)))
                  results)))))
   (t
    (signal 'wrong-type-argument
            (list 'string-or-function-p matcher string)))))


;; The clearinghouse for receiving process output and distributing portions
;; to the proper buffers.
(defun mbp-process-filter (proc string)
  (let ((orig-buffer (current-buffer))
        (proc-buffer (process-buffer proc)))
    ;; Although mbp-process-alist is usually global to handle processes
    ;; which have no primary buffer, it could be made buffer-local to speed
    ;; up searching, so switch to the process buffer's context if possible.
    (and proc-buffer
         (set-buffer proc-buffer))
    (let* ((alist (assq proc mbp-process-alist))
           (stream-cons (cdr alist))
           (last-buffer-cons (cdr stream-cons))
           (buffer-alist (cdr last-buffer-cons)))
      (cond
       ((or (null alist)
            (null buffer-alist))
        (mbp-insert-string proc string))
       (t
        (and (car stream-cons)
             (setq string (concat (car stream-cons string))))
        (setcar stream-cons string)

        (cond
         ;; If the object at last-buffer-cons is a buffer, then it means
         ;; the last block of process output went to this buffer but it
         ;; failed to match the end-regexp for the buffer, meaning more
         ;; output is expected for it.  
         ;; Dump all the current output to that buffer up to (and
         ;; including) the end of the desired matched data.  
         ;; If we find the end of the data intended for that buffer in the
         ;; current batch of output, send just that amount, save the rest,
         ;; and set the car of last-buffer-cons to nil to indicate that on
         ;; the next pass, try the beginning matcher for each buffer again.
         ((bufferp (car last-buffer-cons))
          (let ((result-cons (cons nil nil))
                matcher 
                beg-pos 
                end-pos)
                            
            (setq alist (assq (car last-buffer-cons) buffer-alist))
            (setq matcher (nth 2 (car alist)))

            (and (mbp-matcher-boundary matcher string result-cons)
                 (progn
                   (setq beg-pos (car result-cons))
                   (setq end-pos (cdr result-cons))))

            (cond
             ((or (null end-pos)
                  (= end-pos (length string)))
              (setcar stream-cons nil)
              (mbp-insert-string (car last-buffer-cons) string))
             (t
              (setcar stream-cons (substring string end-pos))
              (mbp-insert-string (car last-buffer-cons)
                                 (substring string 0 end-pos))
              (setcar last-buffer-cons nil)))))
         (t
          (let ((result-cons (cons nil nil))
                output-buffer 
                beg-matcher 
                end-matcher
                beg-pos
                end-pos)
            
            (setq alist buffer-alist)
            (while alist
              (setq output-buffer (nth 0 (car alist)))
              (setq beg-matcher (nth 1 (car alist)))
              (setq end-matcher (nth 2 (car alist)))

              (and (mbp-matcher-boundary beg-matcher string result-cons)
                   (progn
                     (setq beg-pos (car result-cons))
                     (setq end-pos (cdr result-cons))))

              ;; TODO: FINISH ME
              )))))))
    (set-buffer orig-buffer)))
    
(defun mpb-insert-string (proc-or-buffer string)
  (let* ((orig-buffer (current-buffer))
         (buffer (cond
                  ((bufferp proc-or-buffer)
                   proc-or-buffer)
                  ((and (processp proc-or-buffer)
                        (process-buffer proc-or-buffer)))
                  ((and (stringp proc-or-buffer)
                        (get-buffer proc-or-buffer)))
                  (t
                   (signal 'mbp-no-process-buffer
                           (list proc-or-buffer string)))))
         (window (get-buffer-window buffer))
         ;; initialize to buffer's process mark if there is one.
         (marker (cond
                  ((processp proc-or-buffer)
                   (process-mark proc-or-buffer))
                  ((get-buffer-process buffer)
                   (process-mark (get-buffer-process buffer)))))
         saved-point)
    (unwind-protect
        (progn
          (set-buffer buffer)

          ;; If no process mark, try using mbp-marker or point-max as a
          ;; last resort.
          (cond
           ((markerp marker))
           ((and (boundp 'mbp-marker)
                 (markerp mbp-marker))
            mbp-marker)
           (t 
            (point-max)))
          
          ;; save point as a marker in case point comes after marker; then
          ;; insert-before-markers will move point along with unsent user input.
          (setq saved-point (point-marker))

          (save-restriction
            (widen)
            (narrow-to-region marker marker)
            
            (goto-char (point-min))
            (insert-before-markers string)
            ;; however, inserting text off-window because window-start
            ;; begins in the same place is obnoxious; scroll back some.
            (and window
                 (= (marker-position marker) 
                    (marker-position (window-start window)))
                 (set-window-start window (point-min) 'noforce))
        
            (let ((fns (and (boundp 'mbp-output-filter-functions)
                            mbp-output-filter-functions)))
              (while fns
                (goto-char (point-min))
                (funcall (car fns) string)
                (setq fns (cdr fns)))))
          (goto-char saved-point))
      (set-buffer orig-buffer))))


(provide 'mpb)

;; mpb.el ends here