comparison lisp/server.el @ 91085:880960b70474

Merge from emacs--devo--0 Revision: [e-mail]/emacs--unicode--0--patch-283

91084:a4347a111894

                   (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).

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

(defun server-log (string &optional client)
  "If a *server* buffer exists, write STRING to it for logging purposes.
If CLIENT is non-nil, add a description of it to the logged
message."
  (when (get-buffer "*server*")
    (with-current-buffer "*server*"
      (goto-char (point-max))
      (insert (current-time-string)
	      (cond

	(letf (((default-file-modes) ?\700))
	  (add-hook 'suspend-tty-functions 'server-handle-suspend-tty)
	  (add-hook 'delete-frame-functions 'server-handle-delete-frame)
	  (add-hook 'kill-buffer-query-functions 'server-kill-buffer-query-function)
	  (add-hook 'kill-emacs-query-functions 'server-kill-emacs-query-function)
	  (setq server-process
		(apply #'make-network-process
		       :name server-name
		       :server t
		       :noquery t

             '("LANG" "LC_CTYPE" "LC_ALL"
               ;; For tgetent(3); list according to ncurses(3).
               "BAUDRATE" "COLUMNS" "ESCDELAY" "HOME" "LINES"
               "NCURSES_ASSUMED_COLORS" "NCURSES_NO_PADDING"
               "NCURSES_NO_SETBUF" "TERM" "TERMCAP" "TERMINFO"
               "TERMINFO_DIRS" "TERMPATH" 
               ;; rxvt wants these
               "COLORFGBG" "COLORTERM")
           (make-frame-on-tty tty type
                              ;; Ignore nowait here; we always need to
                              ;; clean up opened ttys when the client dies.

                                ;; process-environment interact with client
                                ;; envvars, and then to change the
                                ;; C functions `child_setup' and
                                ;; `getenv_internal' accordingly.
                                (environment . ,(process-get proc 'env)))))))
  
    ;; ttys don't use the `display' parameter, but callproc.c does to set
    ;; the DISPLAY environment on subprocesses.
    (set-frame-parameter frame 'display
                         (getenv-internal "DISPLAY" (process-get proc 'env)))
    (select-frame frame)

  Suspend this tty frame.  The client sends this string in
  response to SIGTSTP and SIGTTOU.  The server must cease all I/O
  on this tty until it gets a -resume command.

`-resume'
  Resume this tty frame. The client sends this string when it
  gets the SIGCONT signal and it is the foreground process on its
  controlling tty.

`-ignore COMMENT'
  Do nothing, but put the comment in the server

`-emacs-pid PID'
  Describes the process id of the Emacs process;
  used to forward window change signals to it.

`-window-system-unsupported'
  Signals that the server does not
  support creating X frames; the client must try again with a tty
  frame.

`-print STRING'
  Print STRING on stdout.  Used to send values
  returned by -eval.

`-error DESCRIPTION'
  Signal an error (but continue processing).

`-suspend'
  Suspend this terminal, i.e., stop the client process.  Sent
  when the user presses C-z."
  (server-log (concat "Received " string) proc)
  ;; First things first: let's check the authentication
  (unless (process-get proc :authenticated)
    (if (and (string-match "-auth \\(.*?\\)\n" string)
	     (equal (match-string 1 string) (process-get proc :auth-key)))

	(server-add-client proc)
	(if (not (string-match "\n" string))
            ;; Save for later any partial line that remains.
            (when (> (length string) 0)
              (process-put proc 'previous-string string))
            
          ;; In earlier versions of server.el (where we used an `emacsserver'
          ;; process), there could be multiple lines.  Nowadays this is not
          ;; supported any more.
          (assert (eq (match-end 0) (length string)))
	  (let ((request (substring string 0 (match-beginning 0)))

		      (setq dir (decode-coding-string dir coding-system)))
		  (setq dir (command-line-normalize-file-name dir)))

		 ;; Unknown command.
		 (t (error "Unknown command: %s" arg)))))
            
            (setq frame
                  (case tty-name
                    ((nil) (if display (server-select-display display)))
                    ((window-system)
                     (server-create-window-system-frame display nowait proc))

                (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.
        (cond
         (nowait
          ;; Client requested nowait; return immediately.
          (server-log "Close nowait client" proc)

  "Move point to the position indicated in FILE-LINE-COL.
FILE-LINE-COL should be a three-element list as described in
`server-visit-files'."
  (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.

            (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)))

			 t))
    (server-delete-client proc)))

(define-key ctl-x-map "#" 'server-edit)

(defun server-unload-hook ()
  "Unload the server library."
  (server-mode -1)
  (remove-hook 'suspend-tty-functions 'server-handle-suspend-tty)
  (remove-hook 'delete-frame-functions 'server-handle-delete-frame)
  (remove-hook 'kill-buffer-query-functions 'server-kill-buffer-query-function)
  (remove-hook 'kill-emacs-query-functions 'server-kill-emacs-query-function)
  (remove-hook 'kill-buffer-hook 'server-kill-buffer))

(add-hook 'kill-emacs-hook (lambda () (server-mode -1))) ;Cleanup upon exit.
(add-hook 'server-unload-hook 'server-unload-hook)

(provide 'server)

;; arch-tag: 1f7ecb42-f00a-49f8-906d-61995d84c8d6
;;; server.el ends here

91085:880960b70474

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

(defun server-delete-client (proc &optional noframe)
  "Delete PROC, 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).

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

(defun server-log (string &optional client)
  "If a *server* buffer exists, write STRING to it for logging purposes.
If CLIENT is non-nil, add a description of it to the logged message."
  (when (get-buffer "*server*")
    (with-current-buffer "*server*"
      (goto-char (point-max))
      (insert (current-time-string)
	      (cond

	(letf (((default-file-modes) ?\700))
	  (add-hook 'suspend-tty-functions 'server-handle-suspend-tty)
	  (add-hook 'delete-frame-functions 'server-handle-delete-frame)
	  (add-hook 'kill-buffer-query-functions 'server-kill-buffer-query-function)
	  (add-hook 'kill-emacs-query-functions 'server-kill-emacs-query-function)
	  (add-hook 'kill-emacs-hook (lambda () (server-mode -1))) ;Cleanup upon exit.
	  (setq server-process
		(apply #'make-network-process
		       :name server-name
		       :server t
		       :noquery t

             '("LANG" "LC_CTYPE" "LC_ALL"
               ;; For tgetent(3); list according to ncurses(3).
               "BAUDRATE" "COLUMNS" "ESCDELAY" "HOME" "LINES"
               "NCURSES_ASSUMED_COLORS" "NCURSES_NO_PADDING"
               "NCURSES_NO_SETBUF" "TERM" "TERMCAP" "TERMINFO"
               "TERMINFO_DIRS" "TERMPATH"
               ;; rxvt wants these
               "COLORFGBG" "COLORTERM")
           (make-frame-on-tty tty type
                              ;; Ignore nowait here; we always need to
                              ;; clean up opened ttys when the client dies.

                                ;; process-environment interact with client
                                ;; envvars, and then to change the
                                ;; C functions `child_setup' and
                                ;; `getenv_internal' accordingly.
                                (environment . ,(process-get proc 'env)))))))

    ;; ttys don't use the `display' parameter, but callproc.c does to set
    ;; the DISPLAY environment on subprocesses.
    (set-frame-parameter frame 'display
                         (getenv-internal "DISPLAY" (process-get proc 'env)))
    (select-frame frame)

  Suspend this tty frame.  The client sends this string in
  response to SIGTSTP and SIGTTOU.  The server must cease all I/O
  on this tty until it gets a -resume command.

`-resume'
  Resume this tty frame.  The client sends this string when it
  gets the SIGCONT signal and it is the foreground process on its
  controlling tty.

`-ignore COMMENT'
  Do nothing, but put the comment in the server

`-emacs-pid PID'
  Describes the process id of the Emacs process;
  used to forward window change signals to it.

`-window-system-unsupported'
  Signals that the server does not support creating X frames;
  the client must try again with a tty frame.

`-print STRING'
  Print STRING on stdout.  Used to send values
  returned by -eval.

`-error DESCRIPTION'
  Signal an error (but continue processing).

`-suspend'
  Suspend this terminal, i.e., stop the client process.
  Sent when the user presses C-z."
  (server-log (concat "Received " string) proc)
  ;; First things first: let's check the authentication
  (unless (process-get proc :authenticated)
    (if (and (string-match "-auth \\(.*?\\)\n" string)
	     (equal (match-string 1 string) (process-get proc :auth-key)))

	(server-add-client proc)
	(if (not (string-match "\n" string))
            ;; Save for later any partial line that remains.
            (when (> (length string) 0)
              (process-put proc 'previous-string string))

          ;; In earlier versions of server.el (where we used an `emacsserver'
          ;; process), there could be multiple lines.  Nowadays this is not
          ;; supported any more.
          (assert (eq (match-end 0) (length string)))
	  (let ((request (substring string 0 (match-beginning 0)))

		      (setq dir (decode-coding-string dir coding-system)))
		  (setq dir (command-line-normalize-file-name dir)))

		 ;; Unknown command.
		 (t (error "Unknown command: %s" arg)))))

            (setq frame
                  (case tty-name
                    ((nil) (if display (server-select-display display)))
                    ((window-system)
                     (server-create-window-system-frame display nowait proc))

                (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.
        (cond
         (nowait
          ;; Client requested nowait; return immediately.
          (server-log "Close nowait client" proc)

  "Move point to the position indicated in FILE-LINE-COL.
FILE-LINE-COL should be a three-element list as described in
`server-visit-files'."
  (goto-line (nth 1 file-line-col))
  (let ((column-number (nth 2 file-line-col)))
    (when (> 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.

            (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 if 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)))

			 t))
    (server-delete-client proc)))

(define-key ctl-x-map "#" 'server-edit)

(defun server-unload-function ()
  "Unload the server library."
  (server-mode -1)
  (substitute-key-definition 'server-edit nil ctl-x-map)
  (save-current-buffer
    (dolist (buffer (buffer-list))
      (set-buffer buffer)
      (remove-hook 'kill-buffer-hook 'server-kill-buffer t)))
  ;; continue standard unloading
  nil)


(provide 'server)

;; arch-tag: 1f7ecb42-f00a-49f8-906d-61995d84c8d6
;;; server.el ends here