comparison lisp/server.el @ 84601:c38a9291ef0a

(server-clients): Only keep procs, no properties any more. (server-client): Remove. (server-client-get, server-client-set): Remove, replace all callers by process-get and process-put resp. (server-clients-with, server-add-client, server-delete-client) (server-create-tty-frame, server-create-window-system-frame) (server-process-filter, server-execute, server-visit-files) (server-buffer-done, server-kill-buffer-query-function) (server-kill-emacs-query-function, server-switch-buffer) (server-save-buffers-kill-terminal): Update accordingly.

84600:6cce7d77ef38

(defvar server-process nil
  "The current server process.")

(defvar server-clients nil
  "List of current server clients.
Each element is (PROC PROPERTIES...) where PROC is a process object,
and PROPERTIES is an association list of client properties.")

(defvar server-buffer-clients nil
  "List of client processes requesting editing of current buffer.")
(make-variable-buffer-local 'server-buffer-clients)
;; Changing major modes should not erase this local.

(defvar server-socket-dir nil
  "The directory in which to place the server socket.
Initialized by `server-start'.")

(defun server-client (proc)
  "Return the Emacs client corresponding to PROC.
PROC must be a process object.
The car of the result is PROC; the cdr is an association list.
See `server-client-get' and `server-client-set'."
  (assq proc server-clients))

(defun server-client-get (client property)
  "Get the value of PROPERTY in CLIENT.
CLIENT may be a process object, or a client returned by `server-client'.
Return nil if CLIENT has no such property."
  (or (listp client) (setq client (server-client client)))
  (cdr (assq property (cdr client))))

(defun server-client-set (client property value)
  "Set the PROPERTY to VALUE in CLIENT, and return VALUE.
CLIENT may be a process object, or a client returned by `server-client'."
  (let (p proc)
    (if (listp client)
	(setq proc (car client))
      (setq proc client
	    client (server-client client)))
    (setq p (assq property client))
    (cond
     (p (setcdr p value))
     (client (setcdr client (cons (cons property value) (cdr client))))
     (t (setq server-clients
	      `((,proc (,property . ,value)) . ,server-clients))))
    value))

(defun server-clients-with (property value)
  "Return a list of clients with PROPERTY set to VALUE."
  (let (result)
    (dolist (client server-clients result)
      (when (equal value (server-client-get client property))
	(setq result (cons (car client) result))))))

(defun server-add-client (proc)
  "Create a client for process PROC, if it doesn't already have one.
New clients have no properties."
  (unless (server-client proc)
    (setq server-clients (cons (cons proc nil)
			       server-clients))))

(defun server-getenv-from (env variable)
  "Get the value of VARIABLE in ENV.
VARIABLE should be a string.  Value is nil if VARIABLE is
undefined in ENV.  Otherwise, value is a string.

                     ,var
                   (concat ,var "=" ,value))
                 process-environment)))
       (progn ,@body))))

(defun server-delete-client (client &optional noframe)
  "Delete CLIENT, including its buffers, terminals and frames.
If NOFRAME is non-nil, let the frames live.  (To be used from
`delete-frame-functions'.)"
  (server-log (concat "server-delete-client" (if noframe " noframe"))
	      client)
  ;; Force a new lookup of client (prevents infinite recursion).
  (setq client (server-client
		(if (listp client) (car client) client)))
  (let ((proc (car client))
	(buffers (server-client-get client 'buffers)))
    (when client

      ;; Kill the client's buffers.
      (dolist (buf buffers)
	(when (buffer-live-p buf)
	  (with-current-buffer buf

	    ;; Prevent `server-handle-delete-frame' from calling us
	    ;; recursively.
	    (set-frame-parameter frame 'client nil)
	    (delete-frame frame))))

      (setq server-clients (delq client server-clients))

      ;; Delete the client's tty.
      (let ((terminal (server-client-get client 'terminal)))
	(when (eq (terminal-live-p terminal) t)
	  (delete-terminal terminal)))

      ;; Delete the client's process.
      (if (eq (process-status (car client)) 'open)
	  (delete-process (car client)))

      (server-log "Deleted" proc))))

(defun server-log (string &optional client)
  "If a *server* buffer exists, write STRING to it for logging purposes.

  "Notify the emacsclient process to suspend itself when its tty device is suspended."
  (dolist (proc (server-clients-with 'terminal terminal))
    (server-log (format "server-handle-suspend-tty, terminal %s" terminal) proc)
    (condition-case err
	(server-send-string proc "-suspend \n")
      (file-error (condition-case nil (server-delete-client proc) (error nil))))))

(defun server-unquote-arg (arg)
  "Remove &-quotation from ARG.
See `server-quote-arg' and `server-process-filter'."
  (replace-regexp-in-string

               "COLORFGBG" "COLORTERM")
           (make-frame-on-tty tty type
                              ;; Ignore nowait here; we always need to
                              ;; clean up opened ttys when the client dies.
                              `((client . ,proc)
                                (environment . ,(process-get proc 'env))))))
        (client (server-client proc)))
  
    (set-frame-parameter frame 'display-environment-variable
                         (server-getenv-from (process-get proc 'env) "DISPLAY"))
    (select-frame frame)
    (server-client-set client 'frame frame)
    (server-client-set client 'tty (terminal-name frame))
    (server-client-set client 'terminal (frame-terminal frame))

    ;; Display *scratch* by default.
    (switch-to-buffer (get-buffer-create "*scratch*") 'norecord)

    ;; Reply with our pid.

           (frame (make-frame-on-display
                   (or display
                       (frame-parameter nil 'display)
                       (getenv "DISPLAY")
                       (error "Please specify display"))
                   params))
           (client (server-client proc)))
      (server-log (format "%s created" frame) proc)
      ;; XXX We need to ensure the parameters are
      ;; really set because Emacs forgets unhandled
      ;; initialization parameters for X frames at
      ;; the moment.
      (modify-frame-parameters frame params)
      (set-frame-parameter frame 'display-environment-variable 
                           (server-getenv-from (process-get proc 'env) "DISPLAY"))
      (select-frame frame)
      (server-client-set client 'frame frame)
      (server-client-set client 'terminal (frame-terminal frame))

      ;; Display *scratch* by default.
      (switch-to-buffer (get-buffer-create "*scratch*") 'norecord)
      frame)))

          (assert (eq (match-end 0) (length string)))
	  (let ((request (substring string 0 (match-beginning 0)))
		(coding-system (and default-enable-multibyte-characters
				    (or file-name-coding-system
					default-file-name-coding-system)))
		(client (server-client proc))
		nowait ; t if emacsclient does not want to wait for us.
		frame ; The frame that was opened for the client (if any).
		display		     ; Open the frame on this display.
		dontkill       ; t if the client should not be killed.
                (commands ())

                  (setq dontkill t)
                  (setq tty-name 'window-system))

		 ;; -resume:  Resume a suspended tty frame.
		 ((equal "-resume" arg)
		  (lexical-let ((terminal (server-client-get client 'terminal)))
		    (setq dontkill t)
                    (push (lambda ()
                            (when (eq (terminal-live-p terminal) t)
                              (resume-tty terminal)))
                          commands)))

		 ;; -suspend:  Suspend the client's frame.  (In case we
		 ;; get out of sync, and a C-z sends a SIGTSTP to
		 ;; emacsclient.)
		 ((equal "-suspend" arg)
		  (lexical-let ((terminal (server-client-get client 'terminal)))
		    (setq dontkill t)
                    (push (lambda ()
                            (when (eq (terminal-live-p terminal) t)
                              (suspend-tty terminal)))
                          commands)))

    ;; condition-case
    (error (server-return-error proc err))))

(defun server-execute (proc files nowait commands dontkill frame tty-name)
  (condition-case err
      (let* ((client (server-client proc))
             (buffers
              (when files
                (run-hooks 'pre-command-hook)
                (prog1 (server-visit-files files client nowait)
                  (run-hooks 'post-command-hook)))))

        (mapc 'funcall (nreverse commands))
              
        ;; Delete the client if necessary.

  (goto-line (nth 1 file-line-col))
  (let ((column-number (nth 2 file-line-col)))
    (if (> column-number 0)
	(move-to-column (1- column-number)))))

(defun server-visit-files (files client &optional nowait)
  "Find FILES and return a list of buffers created.
FILES is an alist whose elements are (FILENAME LINENUMBER COLUMNNUMBER).
CLIENT is the client that requested this operation.
NOWAIT non-nil means this client is not waiting for the results,
so don't mark these buffers specially, just visit them normally."
  ;; Bind last-nonmenu-event to force use of keyboard, not mouse, for queries.
  (let ((last-nonmenu-event t) client-record)
    ;; Restore the current buffer afterward, but not using save-excursion,

	    (server-goto-line-column file)
	    (run-hooks 'server-visit-hook)))
	(unless nowait
	  ;; When the buffer is killed, inform the clients.
	  (add-hook 'kill-buffer-hook 'server-kill-buffer nil t)
	  (push (car client) server-buffer-clients))
	(push (current-buffer) client-record)))
    (unless nowait
      (server-client-set
       client 'buffers
       (nconc (server-client-get client 'buffers) client-record)))
    client-record))

(defun server-buffer-done (buffer &optional for-killing)
  "Mark BUFFER as \"done\" for its client(s).
This buries the buffer, then returns a list of the form (NEXT-BUFFER KILLED).

or nil.  KILLED is t if we killed BUFFER (typically, because it was visiting
a temp file).
FOR-KILLING if non-nil indicates that we are called from `kill-buffer'."
  (let ((next-buffer nil)
	(killed nil))
    (dolist (client server-clients)
      (let ((buffers (server-client-get client 'buffers)))
	(or next-buffer
	    (setq next-buffer (nth 1 (memq buffer buffers))))
	(when buffers			; Ignore bufferless clients.
	  (setq buffers (delq buffer buffers))
	  ;; Delete all dead buffers from CLIENT.
	  (dolist (b buffers)
	    (and (bufferp b)
		 (not (buffer-live-p b))
		 (setq buffers (delq b buffers))))
	  (server-client-set client 'buffers buffers)
	  ;; If client now has no pending buffers,
	  ;; tell it that it is done, and forget it entirely.
	  (unless buffers
	    (server-log "Close" client)
	    (server-delete-client client)))))
    (when (and (bufferp buffer) (buffer-name buffer))
      ;; We may or may not kill this buffer;
      ;; if we do, do not call server-buffer-done recursively
      ;; from kill-buffer-hook.
      (let ((server-kill-buffer-running t))

(defun server-kill-buffer-query-function ()
  "Ask before killing a server buffer."
  (or (not server-buffer-clients)
      (let ((res t))
	(dolist (proc server-buffer-clients res)
	  (let ((client (server-client proc)))
	    (when (and client (eq (process-status proc) 'open))
	      (setq res nil)))))
      (yes-or-no-p (format "Buffer `%s' still has clients; kill it? "
			   (buffer-name (current-buffer))))))

(defun server-kill-emacs-query-function ()
  "Ask before exiting Emacs it has live clients."
  (or (not server-clients)
      (let (live-client)
	(dolist (client server-clients live-client)
	  (when (memq t (mapcar 'buffer-live-p (server-client-get
						client 'buffers)))
	    (setq live-client t))))
      (yes-or-no-p "This Emacs session has clients; exit anyway? ")))

(defvar server-kill-buffer-running nil
  "Non-nil while `server-kill-buffer' or `server-buffer-done' is running.")

done that."
  (if (null next-buffer)
      (progn
	(let ((rest server-clients))
	  (while (and rest (not next-buffer))
	    (let ((client (car rest)))
	      ;; Only look at frameless clients.
	      (when (not (server-client-get client 'frame))
		(setq next-buffer (car (server-client-get client 'buffers))))
	      (setq rest (cdr rest)))))
	(and next-buffer (server-switch-buffer next-buffer killed-one))
	(unless (or next-buffer killed-one (window-dedicated-p (selected-window)))
	  ;; (switch-to-buffer (other-buffer))
	  (message "No server buffers remain to edit")))

With prefix arg, silently save all file-visiting buffers, then kill.

If emacsclient was started with a list of filenames to edit, then
only these files will be asked to be saved."
  (let ((buffers (server-client-get proc 'buffers)))
    ;; If client is bufferless, emulate a normal Emacs session
    ;; exit and offer to save all buffers.  Otherwise, offer to
    ;; save only the buffers belonging to the client.
    (save-some-buffers arg
		       (if buffers

84601:c38a9291ef0a

(defvar server-process nil
  "The current server process.")

(defvar server-clients nil
  "List of current server clients.
Each element is a process.")

(defvar server-buffer-clients nil
  "List of client processes requesting editing of current buffer.")
(make-variable-buffer-local 'server-buffer-clients)
;; Changing major modes should not erase this local.

(defvar server-socket-dir nil
  "The directory in which to place the server socket.
Initialized by `server-start'.")

(defun server-clients-with (property value)
  "Return a list of clients with PROPERTY set to VALUE."
  (let (result)
    (dolist (proc server-clients result)
      (when (equal value (process-get proc property))
	(push proc result)))))

(defun server-add-client (proc)
  "Create a client for process PROC, if it doesn't already have one.
New clients have no properties."
  (add-to-list 'server-clients proc))

(defun server-getenv-from (env variable)
  "Get the value of VARIABLE in ENV.
VARIABLE should be a string.  Value is nil if VARIABLE is
undefined in ENV.  Otherwise, value is a string.

                     ,var
                   (concat ,var "=" ,value))
                 process-environment)))
       (progn ,@body))))

(defun server-delete-client (proc &optional noframe)
  "Delete CLIENT, including its buffers, terminals and frames.
If NOFRAME is non-nil, let the frames live.  (To be used from
`delete-frame-functions'.)"
  (server-log (concat "server-delete-client" (if noframe " noframe"))
	      proc)
  ;; Force a new lookup of client (prevents infinite recursion).
  (when (memq proc server-clients)
    (let ((buffers (process-get proc 'buffers)))

      ;; Kill the client's buffers.
      (dolist (buf buffers)
	(when (buffer-live-p buf)
	  (with-current-buffer buf

	    ;; Prevent `server-handle-delete-frame' from calling us
	    ;; recursively.
	    (set-frame-parameter frame 'client nil)
	    (delete-frame frame))))

      (setq server-clients (delq proc server-clients))

      ;; Delete the client's tty.
      (let ((terminal (process-get proc 'terminal)))
	(when (eq (terminal-live-p terminal) t)
	  (delete-terminal terminal)))

      ;; Delete the client's process.
      (if (eq (process-status proc) 'open)
	  (delete-process proc))

      (server-log "Deleted" proc))))

(defun server-log (string &optional client)
  "If a *server* buffer exists, write STRING to it for logging purposes.

  "Notify the emacsclient process to suspend itself when its tty device is suspended."
  (dolist (proc (server-clients-with 'terminal terminal))
    (server-log (format "server-handle-suspend-tty, terminal %s" terminal) proc)
    (condition-case err
	(server-send-string proc "-suspend \n")
      (file-error (ignore-errors (server-delete-client proc))))))

(defun server-unquote-arg (arg)
  "Remove &-quotation from ARG.
See `server-quote-arg' and `server-process-filter'."
  (replace-regexp-in-string

               "COLORFGBG" "COLORTERM")
           (make-frame-on-tty tty type
                              ;; Ignore nowait here; we always need to
                              ;; clean up opened ttys when the client dies.
                              `((client . ,proc)
                                (environment . ,(process-get proc 'env)))))))
  
    (set-frame-parameter frame 'display-environment-variable
                         (server-getenv-from (process-get proc 'env) "DISPLAY"))
    (select-frame frame)
    (process-put proc 'frame frame)
    (process-put proc 'tty (terminal-name frame))
    (process-put proc 'terminal (frame-terminal frame))

    ;; Display *scratch* by default.
    (switch-to-buffer (get-buffer-create "*scratch*") 'norecord)

    ;; Reply with our pid.

           (frame (make-frame-on-display
                   (or display
                       (frame-parameter nil 'display)
                       (getenv "DISPLAY")
                       (error "Please specify display"))
                   params)))
      (server-log (format "%s created" frame) proc)
      ;; XXX We need to ensure the parameters are
      ;; really set because Emacs forgets unhandled
      ;; initialization parameters for X frames at
      ;; the moment.
      (modify-frame-parameters frame params)
      (set-frame-parameter frame 'display-environment-variable 
                           (server-getenv-from (process-get proc 'env) "DISPLAY"))
      (select-frame frame)
      (process-put proc 'frame frame)
      (process-put proc 'terminal (frame-terminal frame))

      ;; Display *scratch* by default.
      (switch-to-buffer (get-buffer-create "*scratch*") 'norecord)
      frame)))

          (assert (eq (match-end 0) (length string)))
	  (let ((request (substring string 0 (match-beginning 0)))
		(coding-system (and default-enable-multibyte-characters
				    (or file-name-coding-system
					default-file-name-coding-system)))
		nowait ; t if emacsclient does not want to wait for us.
		frame ; The frame that was opened for the client (if any).
		display		     ; Open the frame on this display.
		dontkill       ; t if the client should not be killed.
                (commands ())

                  (setq dontkill t)
                  (setq tty-name 'window-system))

		 ;; -resume:  Resume a suspended tty frame.
		 ((equal "-resume" arg)
		  (lexical-let ((terminal (process-get proc 'terminal)))
		    (setq dontkill t)
                    (push (lambda ()
                            (when (eq (terminal-live-p terminal) t)
                              (resume-tty terminal)))
                          commands)))

		 ;; -suspend:  Suspend the client's frame.  (In case we
		 ;; get out of sync, and a C-z sends a SIGTSTP to
		 ;; emacsclient.)
		 ((equal "-suspend" arg)
		  (lexical-let ((terminal (process-get proc 'terminal)))
		    (setq dontkill t)
                    (push (lambda ()
                            (when (eq (terminal-live-p terminal) t)
                              (suspend-tty terminal)))
                          commands)))

    ;; condition-case
    (error (server-return-error proc err))))

(defun server-execute (proc files nowait commands dontkill frame tty-name)
  (condition-case err
      (let* ((buffers
              (when files
                (run-hooks 'pre-command-hook)
                (prog1 (server-visit-files files proc nowait)
                  (run-hooks 'post-command-hook)))))

        (mapc 'funcall (nreverse commands))
              
        ;; Delete the client if necessary.

  (goto-line (nth 1 file-line-col))
  (let ((column-number (nth 2 file-line-col)))
    (if (> column-number 0)
	(move-to-column (1- column-number)))))

(defun server-visit-files (files proc &optional nowait)
  "Find FILES and return a list of buffers created.
FILES is an alist whose elements are (FILENAME LINENUMBER COLUMNNUMBER).
PROC is the client that requested this operation.
NOWAIT non-nil means this client is not waiting for the results,
so don't mark these buffers specially, just visit them normally."
  ;; Bind last-nonmenu-event to force use of keyboard, not mouse, for queries.
  (let ((last-nonmenu-event t) client-record)
    ;; Restore the current buffer afterward, but not using save-excursion,

	    (server-goto-line-column file)
	    (run-hooks 'server-visit-hook)))
	(unless nowait
	  ;; When the buffer is killed, inform the clients.
	  (add-hook 'kill-buffer-hook 'server-kill-buffer nil t)
	  (push proc server-buffer-clients))
	(push (current-buffer) client-record)))
    (unless nowait
      (process-put proc 'buffers
                   (nconc (process-get proc 'buffers) client-record)))
    client-record))

(defun server-buffer-done (buffer &optional for-killing)
  "Mark BUFFER as \"done\" for its client(s).
This buries the buffer, then returns a list of the form (NEXT-BUFFER KILLED).

or nil.  KILLED is t if we killed BUFFER (typically, because it was visiting
a temp file).
FOR-KILLING if non-nil indicates that we are called from `kill-buffer'."
  (let ((next-buffer nil)
	(killed nil))
    (dolist (proc server-clients)
      (let ((buffers (process-get proc 'buffers)))
	(or next-buffer
	    (setq next-buffer (nth 1 (memq buffer buffers))))
	(when buffers			; Ignore bufferless clients.
	  (setq buffers (delq buffer buffers))
	  ;; Delete all dead buffers from PROC.
	  (dolist (b buffers)
	    (and (bufferp b)
		 (not (buffer-live-p b))
		 (setq buffers (delq b buffers))))
	  (process-put proc 'buffers buffers)
	  ;; If client now has no pending buffers,
	  ;; tell it that it is done, and forget it entirely.
	  (unless buffers
	    (server-log "Close" proc)
	    (server-delete-client proc)))))
    (when (and (bufferp buffer) (buffer-name buffer))
      ;; We may or may not kill this buffer;
      ;; if we do, do not call server-buffer-done recursively
      ;; from kill-buffer-hook.
      (let ((server-kill-buffer-running t))

(defun server-kill-buffer-query-function ()
  "Ask before killing a server buffer."
  (or (not server-buffer-clients)
      (let ((res t))
	(dolist (proc server-buffer-clients res)
          (when (and (memq proc server-clients)
                     (eq (process-status proc) 'open))
            (setq res nil))))
      (yes-or-no-p (format "Buffer `%s' still has clients; kill it? "
			   (buffer-name (current-buffer))))))

(defun server-kill-emacs-query-function ()
  "Ask before exiting Emacs it has live clients."
  (or (not server-clients)
      (let (live-client)
	(dolist (proc server-clients live-client)
	  (when (memq t (mapcar 'buffer-live-p (process-get
						proc 'buffers)))
	    (setq live-client t))))
      (yes-or-no-p "This Emacs session has clients; exit anyway? ")))

(defvar server-kill-buffer-running nil
  "Non-nil while `server-kill-buffer' or `server-buffer-done' is running.")

done that."
  (if (null next-buffer)
      (progn
	(let ((rest server-clients))
	  (while (and rest (not next-buffer))
	    (let ((proc (car rest)))
	      ;; Only look at frameless clients.
	      (when (not (process-get proc 'frame))
		(setq next-buffer (car (process-get proc 'buffers))))
	      (setq rest (cdr rest)))))
	(and next-buffer (server-switch-buffer next-buffer killed-one))
	(unless (or next-buffer killed-one (window-dedicated-p (selected-window)))
	  ;; (switch-to-buffer (other-buffer))
	  (message "No server buffers remain to edit")))

With prefix arg, silently save all file-visiting buffers, then kill.

If emacsclient was started with a list of filenames to edit, then
only these files will be asked to be saved."
  (let ((buffers (process-get proc 'buffers)))
    ;; If client is bufferless, emulate a normal Emacs session
    ;; exit and offer to save all buffers.  Otherwise, offer to
    ;; save only the buffers belonging to the client.
    (save-some-buffers arg
		       (if buffers