Mercurial > emacs

comparison lisp/server.el @ 84600:6cce7d77ef38

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
(server-with-environment): Simplify. (server-select-display, server-unselect-display): Re-add functions that seem to have been lost in the multi-tty merge. (server-eval-and-print, server-create-tty-frame) (server-create-window-system-frame, server-goto-toplevel) (server-execute, server-return-error): New functions extracted from server-process-filter. (server-execute-continuation): New functions. (server-process-filter): Restructure so that all arguments are analysed first and then acted upon in a subsequent stage This way server-goto-toplevel can be executed later, when we know if it's necessary. Remove the "-version" and "-version-good" support.
author Stefan Monnier <monnier@iro.umontreal.ca>
date Sun, 16 Sep 2007 04:53:39 +0000
parents dab32bc3edc8
children c38a9291ef0a
comparison
equal deleted inserted replaced
84599:1d3d8782bd49 84600:6cce7d77ef38
267 The environment variables are then restored to their previous values. 267 The environment variables are then restored to their previous values.
268 268
269 VARS should be a list of strings. 269 VARS should be a list of strings.
270 ENV should be in the same format as `process-environment'." 270 ENV should be in the same format as `process-environment'."
271 (declare (indent 2)) 271 (declare (indent 2))
272 (let ((old-env (make-symbol "old-env")) 272 (let ((var (make-symbol "var"))
273 (var (make-symbol "var")) 273 (value (make-symbol "value")))
274 (value (make-symbol "value")) 274 `(let ((process-environment process-environment))
275 (pair (make-symbol "pair")))
276 `(let ((,old-env process-environment))
277 (dolist (,var ,vars) 275 (dolist (,var ,vars)
278 (let ((,value (server-getenv-from ,env ,var))) 276 (let ((,value (server-getenv-from ,env ,var)))
279 (setq process-environment 277 (push (if (null ,value)
280 (cons (if (null ,value) 278 ,var
281 ,var 279 (concat ,var "=" ,value))
282 (concat ,var "=" ,value)) 280 process-environment)))
283 process-environment)))) 281 (progn ,@body))))
284 (unwind-protect
285 (progn ,@body)
286 (setq process-environment ,old-env)))))
287 282
288 (defun server-delete-client (client &optional noframe) 283 (defun server-delete-client (client &optional noframe)
289 "Delete CLIENT, including its buffers, terminals and frames. 284 "Delete CLIENT, including its buffers, terminals and frames.
290 If NOFRAME is non-nil, let the frames live. (To be used from 285 If NOFRAME is non-nil, let the frames live. (To be used from
291 `delete-frame-functions'.)" 286 `delete-frame-functions'.)"
369 ;; (and (process-contact proc :server) 364 ;; (and (process-contact proc :server)
370 ;; (eq (process-status proc) 'closed) 365 ;; (eq (process-status proc) 'closed)
371 ;; (ignore-errors (delete-file (process-get proc :server-file)))) 366 ;; (ignore-errors (delete-file (process-get proc :server-file))))
372 (server-log (format "Status changed to %s: %s" (process-status proc) msg) proc) 367 (server-log (format "Status changed to %s: %s" (process-status proc) msg) proc)
373 (server-delete-client proc)) 368 (server-delete-client proc))
369
370 (defun server-select-display (display)
371 ;; If the current frame is on `display' we're all set.
372 (unless (equal (frame-parameter (selected-frame) 'display) display)
373 ;; Otherwise, look for an existing frame there and select it.
374 (dolist (frame (frame-list))
375 (when (equal (frame-parameter frame 'display) display)
376 (select-frame frame)))
377 ;; If there's no frame on that display yet, create and select one.
378 (unless (equal (frame-parameter (selected-frame) 'display) display)
379 (let* ((buffer (generate-new-buffer " *server-dummy*"))
380 (frame (make-frame-on-display
381 display
382 ;; Make it display (and remember) some dummy buffer, so
383 ;; we can detect later if the frame is in use or not.
384 `((server-dummmy-buffer . ,buffer)
385 ;; This frame may be deleted later (see
386 ;; server-unselect-display) so we want it to be as
387 ;; unobtrusive as possible.
388 (visibility . nil)))))
389 (select-frame frame)
390 (set-window-buffer (selected-window) buffer)
391 frame))))
392
393 (defun server-unselect-display (frame)
394 (when (frame-live-p frame)
395 ;; If the temporary frame is in use (displays something real), make it
396 ;; visible. If not (which can happen if the user's customizations call
397 ;; pop-to-buffer etc.), delete it to avoid preserving the connection after
398 ;; the last real frame is deleted.
399 (if (and (eq (frame-first-window frame)
400 (next-window (frame-first-window frame) 'nomini))
401 (eq (window-buffer (frame-first-window frame))
402 (frame-parameter frame 'server-dummy-buffer)))
403 ;; The temp frame still only shows one buffer, and that is the
404 ;; internal temp buffer.
405 (delete-frame frame)
406 (set-frame-parameter frame 'visibility t))
407 (kill-buffer (frame-parameter frame 'server-dummy-buffer))
408 (set-frame-parameter frame 'server-dummy-buffer nil)))
374 409
375 (defun server-handle-delete-frame (frame) 410 (defun server-handle-delete-frame (frame)
376 "Delete the client connection when the emacsclient frame is deleted." 411 "Delete the client connection when the emacsclient frame is deleted."
377 (let ((proc (frame-parameter frame 'client))) 412 (let ((proc (frame-parameter frame 'client)))
378 (when (and (frame-live-p frame) 413 (when (and (frame-live-p frame)
538 :version "22.1" 573 :version "22.1"
539 ;; Fixme: Should this check for an existing server socket and do 574 ;; Fixme: Should this check for an existing server socket and do
540 ;; nothing if there is one (for multiple Emacs sessions)? 575 ;; nothing if there is one (for multiple Emacs sessions)?
541 (server-start (not server-mode))) 576 (server-start (not server-mode)))
542 577
578 (defun server-eval-and-print (expr proc)
579 "Eval EXPR and send the result back to client PROC."
580 (let ((v (eval (car (read-from-string expr)))))
581 (when (and v proc)
582 (with-temp-buffer
583 (let ((standard-output (current-buffer)))
584 (pp v)
585 (let ((text (buffer-substring-no-properties
586 (point-min) (point-max))))
587 (server-send-string
588 proc (format "-print %s\n"
589 (server-quote-arg text)))))))))
590
591 (defun server-create-tty-frame (tty type proc)
592 (let ((frame
593 (server-with-environment (process-get proc 'env)
594 '("LANG" "LC_CTYPE" "LC_ALL"
595 ;; For tgetent(3); list according to ncurses(3).
596 "BAUDRATE" "COLUMNS" "ESCDELAY" "HOME" "LINES"
597 "NCURSES_ASSUMED_COLORS" "NCURSES_NO_PADDING"
598 "NCURSES_NO_SETBUF" "TERM" "TERMCAP" "TERMINFO"
599 "TERMINFO_DIRS" "TERMPATH"
600 ;; rxvt wants these
601 "COLORFGBG" "COLORTERM")
602 (make-frame-on-tty tty type
603 ;; Ignore nowait here; we always need to
604 ;; clean up opened ttys when the client dies.
605 `((client . ,proc)
606 (environment . ,(process-get proc 'env))))))
607 (client (server-client proc)))
608
609 (set-frame-parameter frame 'display-environment-variable
610 (server-getenv-from (process-get proc 'env) "DISPLAY"))
611 (select-frame frame)
612 (server-client-set client 'frame frame)
613 (server-client-set client 'tty (terminal-name frame))
614 (server-client-set client 'terminal (frame-terminal frame))
615
616 ;; Display *scratch* by default.
617 (switch-to-buffer (get-buffer-create "*scratch*") 'norecord)
618
619 ;; Reply with our pid.
620 (server-send-string proc (concat "-emacs-pid "
621 (number-to-string (emacs-pid)) "\n"))
622 frame))
623
624 (defun server-create-window-system-frame (display nowait proc)
625 (if (not (fboundp 'x-create-frame))
626 (progn
627 ;; This emacs does not support X.
628 (server-log "Window system unsupported" proc)
629 (server-send-string proc "-window-system-unsupported \n")
630 nil)
631 ;; Flag frame as client-created, but use a dummy client.
632 ;; This will prevent the frame from being deleted when
633 ;; emacsclient quits while also preventing
634 ;; `server-save-buffers-kill-terminal' from unexpectedly
635 ;; killing emacs on that frame.
636 (let* ((params `((client . ,(if nowait 'nowait proc))
637 (environment . ,(process-get proc 'env))))
638 (frame (make-frame-on-display
639 (or display
640 (frame-parameter nil 'display)
641 (getenv "DISPLAY")
642 (error "Please specify display"))
643 params))
644 (client (server-client proc)))
645 (server-log (format "%s created" frame) proc)
646 ;; XXX We need to ensure the parameters are
647 ;; really set because Emacs forgets unhandled
648 ;; initialization parameters for X frames at
649 ;; the moment.
650 (modify-frame-parameters frame params)
651 (set-frame-parameter frame 'display-environment-variable
652 (server-getenv-from (process-get proc 'env) "DISPLAY"))
653 (select-frame frame)
654 (server-client-set client 'frame frame)
655 (server-client-set client 'terminal (frame-terminal frame))
656
657 ;; Display *scratch* by default.
658 (switch-to-buffer (get-buffer-create "*scratch*") 'norecord)
659 frame)))
660
661
662 (defun server-goto-toplevel (proc)
663 (condition-case nil
664 ;; If we're running isearch, we must abort it to allow Emacs to
665 ;; display the buffer and switch to it.
666 (dolist (buffer (buffer-list))
667 (with-current-buffer buffer
668 (when (bound-and-true-p isearch-mode)
669 (isearch-cancel))))
670 ;; Signaled by isearch-cancel.
671 (quit (message nil)))
672 (when (> (recursion-depth) 0)
673 ;; We're inside a minibuffer already, so if the emacs-client is trying
674 ;; to open a frame on a new display, we might end up with an unusable
675 ;; frame because input from that display will be blocked (until exiting
676 ;; the minibuffer). Better exit this minibuffer right away.
677 ;; Similarly with recursive-edits such as the splash screen.
678 (run-with-timer 0 nil (lexical-let ((proc proc))
679 (lambda () (server-execute-continuation proc))))
680 (top-level)))
681
682 ;; We use various special properties on process objects:
683 ;; - `env' stores the info about the environment of the emacsclient process.
684 ;; - `continuation' is a no-arg function that we need to execute. It contains
685 ;; commands we wanted to execute in some earlier invocation of the process
686 ;; filter but that we somehow were unable to process at that time
687 ;; (e.g. because we first need to throw to the toplevel).
688
689 (defun server-execute-continuation (proc)
690 (let ((continuation (process-get proc 'continuation)))
691 (process-put proc 'continuation nil)
692 (if continuation (ignore-errors (funcall continuation)))))
693
543 (defun* server-process-filter (proc string) 694 (defun* server-process-filter (proc string)
544 "Process a request from the server to edit some files. 695 "Process a request from the server to edit some files.
545 PROC is the server process. STRING consists of a sequence of 696 PROC is the server process. STRING consists of a sequence of
546 commands prefixed by a dash. Some commands have arguments; these 697 commands prefixed by a dash. Some commands have arguments; these
547 are &-quoted and need to be decoded by `server-unquote-arg'. The 698 are &-quoted and need to be decoded by `server-unquote-arg'. The
549 700
550 To illustrate the protocol, here is an example command that 701 To illustrate the protocol, here is an example command that
551 emacsclient sends to create a new X frame (note that the whole 702 emacsclient sends to create a new X frame (note that the whole
552 sequence is sent on a single line): 703 sequence is sent on a single line):
553 704
554 -version 21.3.50 xterm
555 -env HOME /home/lorentey 705 -env HOME /home/lorentey
556 -env DISPLAY :0.0 706 -env DISPLAY :0.0
557 ... lots of other -env commands 707 ... lots of other -env commands
558 -display :0.0 708 -display :0.0
559 -window-system 709 -window-system
560 710
561 The server normally sends back the single command `-good-version'
562 as a response.
563
564 The following commands are accepted by the server: 711 The following commands are accepted by the server:
565 712
566 `-auth AUTH-STRING' 713 `-auth AUTH-STRING'
567 Authenticate the client using the secret authentication string 714 Authenticate the client using the secret authentication string
568 AUTH-STRING. 715 AUTH-STRING.
569
570 `-version CLIENT-VERSION'
571 Check version numbers between server and client, and signal an
572 error if there is a mismatch. The server replies with
573 `-good-version' to confirm the match.
574 716
575 `-env NAME=VALUE' 717 `-env NAME=VALUE'
576 An environment variable on the client side. 718 An environment variable on the client side.
577 719
578 `-dir DIRNAME' 720 `-dir DIRNAME'
619 Do nothing, but put the comment in the server 761 Do nothing, but put the comment in the server
620 log. Useful for debugging. 762 log. Useful for debugging.
621 763
622 764
623 The following commands are accepted by the client: 765 The following commands are accepted by the client:
624
625 `-good-version'
626 Signals a version match between the client and the server.
627 766
628 `-emacs-pid PID' 767 `-emacs-pid PID'
629 Describes the process id of the Emacs process; 768 Describes the process id of the Emacs process;
630 used to forward window change signals to it. 769 used to forward window change signals to it.
631 770
657 (server-send-string 796 (server-send-string
658 proc (concat "-error " (server-quote-arg "Authentication failed"))) 797 proc (concat "-error " (server-quote-arg "Authentication failed")))
659 (delete-process proc) 798 (delete-process proc)
660 ;; We return immediately 799 ;; We return immediately
661 (return-from server-process-filter))) 800 (return-from server-process-filter)))
662 (when (> (recursion-depth) 0)
663 ;; We're inside a minibuffer already, so if the emacs-client is trying
664 ;; to open a frame on a new display, we might end up with an unusable
665 ;; frame because input from that display will be blocked (until exiting
666 ;; the minibuffer). Better exit this minibuffer right away.
667 ;; Similarly with recursive-edits such as the splash screen.
668 (process-put proc :previous-string string)
669 (run-with-timer 0 nil (lexical-let ((proc proc))
670 (lambda () (server-process-filter proc ""))))
671 (top-level))
672 (condition-case nil
673 ;; If we're running isearch, we must abort it to allow Emacs to
674 ;; display the buffer and switch to it.
675 (mapc #'(lambda (buffer)
676 (with-current-buffer buffer
677 (when (bound-and-true-p isearch-mode)
678 (isearch-cancel))))
679 (buffer-list))
680 ;; Signaled by isearch-cancel
681 (quit (message nil)))
682 (let ((prev (process-get proc 'previous-string))) 801 (let ((prev (process-get proc 'previous-string)))
683 (when prev 802 (when prev
684 (setq string (concat prev string)) 803 (setq string (concat prev string))
685 (process-put proc 'previous-string nil))) 804 (process-put proc 'previous-string nil)))
686 (condition-case err 805 (condition-case err
687 (progn 806 (progn
688 (server-add-client proc) 807 (server-add-client proc)
689 ;; If the input is multiple lines, 808 (if (not (string-match "\n" string))
690 ;; process each line individually. 809 ;; Save for later any partial line that remains.
691 (while (string-match "\n" string) 810 (when (> (length string) 0)
811 (process-put proc 'previous-string string))
812
813 ;; In earlier versions of server.el (where we used an `emacsserver'
814 ;; process), there could be multiple lines. Nowadays this is not
815 ;; supported any more.
816 (assert (eq (match-end 0) (length string)))
692 (let ((request (substring string 0 (match-beginning 0))) 817 (let ((request (substring string 0 (match-beginning 0)))
693 (coding-system (and default-enable-multibyte-characters 818 (coding-system (and default-enable-multibyte-characters
694 (or file-name-coding-system 819 (or file-name-coding-system
695 default-file-name-coding-system))) 820 default-file-name-coding-system)))
696 (client (server-client proc)) 821 (client (server-client proc))
697 current-frame
698 nowait ; t if emacsclient does not want to wait for us. 822 nowait ; t if emacsclient does not want to wait for us.
699 frame ; The frame that was opened for the client (if any). 823 frame ; The frame that was opened for the client (if any).
700 display ; Open the frame on this display. 824 display ; Open the frame on this display.
701 dontkill ; t if the client should not be killed. 825 dontkill ; t if the client should not be killed.
702 env 826 (commands ())
703 dir 827 dir
828 (tty-name nil) ;nil, `window-system', or the tty name.
829 tty-type ;string.
704 (files nil) 830 (files nil)
705 (lineno 1) 831 (lineno 1)
706 (columnno 0)) 832 (columnno 0))
707 ;; Remove this line from STRING. 833 ;; Remove this line from STRING.
708 (setq string (substring string (match-end 0))) 834 (setq string (substring string (match-end 0)))
709 (while (string-match " *[^ ]* " request) 835 (while (string-match " *[^ ]* " request)
710 (let ((arg (substring request (match-beginning 0) (1- (match-end 0))))) 836 (let ((arg (substring request (match-beginning 0)
837 (1- (match-end 0)))))
711 (setq request (substring request (match-end 0))) 838 (setq request (substring request (match-end 0)))
712 (cond 839 (cond
713 ;; -version CLIENT-VERSION: 840 ;; -version CLIENT-VERSION: obsolete at birth.
714 ;; Check version numbers, signal an error if there is a mismatch. 841 ((and (equal "-version" arg) (string-match "[^ ]+ " request))
715 ((and (equal "-version" arg) 842 (setq request (substring request (match-end 0))))
716 (string-match "\\([0-9.]+\\) " request))
717 (let* ((client-version (match-string 1 request))
718 (truncated-emacs-version
719 (substring emacs-version 0 (length client-version))))
720 (setq request (substring request (match-end 0)))
721 (if (equal client-version truncated-emacs-version)
722 (progn
723 (server-send-string proc "-good-version \n")
724 (server-client-set client 'version client-version))
725 (error (concat "Version mismatch: Emacs is "
726 truncated-emacs-version
727 ", emacsclient is " client-version)))))
728 843
729 ;; -nowait: Emacsclient won't wait for a result. 844 ;; -nowait: Emacsclient won't wait for a result.
730 ((equal "-nowait" arg) (setq nowait t)) 845 ((equal "-nowait" arg) (setq nowait t))
731 846
732 ;; -current-frame: Don't create frames. 847 ;; -current-frame: Don't create frames.
733 ((equal "-current-frame" arg) (setq current-frame t)) 848 ((equal "-current-frame" arg) (setq tty-name nil))
734 849
735 ;; -display DISPLAY: 850 ;; -display DISPLAY:
736 ;; Open X frames on the given display instead of the default. 851 ;; Open X frames on the given display instead of the default.
737 ((and (equal "-display" arg) (string-match "\\([^ ]*\\) " request)) 852 ((and (equal "-display" arg)
853 (string-match "\\([^ ]*\\) " request))
738 (setq display (match-string 1 request) 854 (setq display (match-string 1 request)
739 request (substring request (match-end 0)))) 855 request (substring request (match-end 0))))
740 856
741 ;; -window-system: Open a new X frame. 857 ;; -window-system: Open a new X frame.
742 ((equal "-window-system" arg) 858 ((equal "-window-system" arg)
743 (unless (server-client-get client 'version) 859 (setq dontkill t)
744 (error "Protocol error; make sure to use the correct version of emacsclient")) 860 (setq tty-name 'window-system))
745 (unless current-frame
746 (if (fboundp 'x-create-frame)
747 (let ((params (if nowait
748 ;; Flag frame as client-created, but use a dummy client.
749 ;; This will prevent the frame from being deleted when
750 ;; emacsclient quits while also preventing
751 ;; `server-save-buffers-kill-terminal' from unexpectedly
752 ;; killing emacs on that frame.
753 (list (cons 'client 'nowait) (cons 'environment env))
754 (list (cons 'client proc) (cons 'environment env)))))
755 (setq frame (make-frame-on-display
756 (or display
757 (frame-parameter nil 'display)
758 (getenv "DISPLAY")
759 (error "Please specify display"))
760 params))
761 (server-log (format "%s created" frame) proc)
762 ;; XXX We need to ensure the parameters are
763 ;; really set because Emacs forgets unhandled
764 ;; initialization parameters for X frames at
765 ;; the moment.
766 (modify-frame-parameters frame params)
767 (set-frame-parameter frame 'display-environment-variable
768 (server-getenv-from env "DISPLAY"))
769 (select-frame frame)
770 (server-client-set client 'frame frame)
771 (server-client-set client 'terminal (frame-terminal frame))
772
773 ;; Display *scratch* by default.
774 (switch-to-buffer (get-buffer-create "*scratch*") 'norecord)
775
776 (setq dontkill t))
777 ;; This emacs does not support X.
778 (server-log "Window system unsupported" proc)
779 (server-send-string proc "-window-system-unsupported \n")
780 (setq dontkill t))))
781 861
782 ;; -resume: Resume a suspended tty frame. 862 ;; -resume: Resume a suspended tty frame.
783 ((equal "-resume" arg) 863 ((equal "-resume" arg)
784 (let ((terminal (server-client-get client 'terminal))) 864 (lexical-let ((terminal (server-client-get client 'terminal)))
785 (setq dontkill t) 865 (setq dontkill t)
786 (when (eq (terminal-live-p terminal) t) 866 (push (lambda ()
787 (resume-tty terminal)))) 867 (when (eq (terminal-live-p terminal) t)
868 (resume-tty terminal)))
869 commands)))
788 870
789 ;; -suspend: Suspend the client's frame. (In case we 871 ;; -suspend: Suspend the client's frame. (In case we
790 ;; get out of sync, and a C-z sends a SIGTSTP to 872 ;; get out of sync, and a C-z sends a SIGTSTP to
791 ;; emacsclient.) 873 ;; emacsclient.)
792 ((equal "-suspend" arg) 874 ((equal "-suspend" arg)
793 (let ((terminal (server-client-get client 'terminal))) 875 (lexical-let ((terminal (server-client-get client 'terminal)))
794 (setq dontkill t) 876 (setq dontkill t)
795 (when (eq (terminal-live-p terminal) t) 877 (push (lambda ()
796 (suspend-tty terminal)))) 878 (when (eq (terminal-live-p terminal) t)
879 (suspend-tty terminal)))
880 commands)))
797 881
798 ;; -ignore COMMENT: Noop; useful for debugging emacsclient. 882 ;; -ignore COMMENT: Noop; useful for debugging emacsclient.
799 ;; (The given comment appears in the server log.) 883 ;; (The given comment appears in the server log.)
800 ((and (equal "-ignore" arg) (string-match "\\([^ ]*\\) " request)) 884 ((and (equal "-ignore" arg) (string-match "[^ ]* " request))
801 (setq dontkill t 885 (setq dontkill t
802 request (substring request (match-end 0)))) 886 request (substring request (match-end 0))))
803 887
804 ;; -tty DEVICE-NAME TYPE: Open a new tty frame at the client. 888 ;; -tty DEVICE-NAME TYPE: Open a new tty frame at the client.
805 ((and (equal "-tty" arg) (string-match "\\([^ ]*\\) \\([^ ]*\\) " request)) 889 ((and (equal "-tty" arg)
806 (let ((tty (server-unquote-arg (match-string 1 request))) 890 (string-match "\\([^ ]*\\) \\([^ ]*\\) " request))
807 (type (server-unquote-arg (match-string 2 request)))) 891 (setq tty-name (match-string 1 request))
808 (setq request (substring request (match-end 0))) 892 (setq tty-type (match-string 2 request))
809 (unless (server-client-get client 'version) 893 (setq dontkill t)
810 (error "Protocol error; make sure you use the correct version of emacsclient")) 894 (setq request (substring request (match-end 0))))
811 (unless current-frame 895
812 (server-with-environment env 896 ;; -position LINE[:COLUMN]: Set point to the given
813 '("LANG" "LC_CTYPE" "LC_ALL" 897 ;; position in the next file.
814 ;; For tgetent(3); list according to ncurses(3). 898 ((and (equal "-position" arg)
815 "BAUDRATE" "COLUMNS" "ESCDELAY" "HOME" "LINES" 899 (string-match "\\+\\([0-9]+\\)\\(?::\\([0-9]+\\)\\)? "
816 "NCURSES_ASSUMED_COLORS" "NCURSES_NO_PADDING" 900 request))
817 "NCURSES_NO_SETBUF" "TERM" "TERMCAP" "TERMINFO" 901 (setq lineno (string-to-number (match-string 1 request))
818 "TERMINFO_DIRS" "TERMPATH" 902 columnno (if (null (match-end 2)) 0
819 ;; rxvt wants these 903 (string-to-number (match-string 2 request)))
820 "COLORFGBG" "COLORTERM")
821 (setq frame (make-frame-on-tty tty type
822 ;; Ignore nowait here; we always need to clean
823 ;; up opened ttys when the client dies.
824 `((client . ,proc)
825 (environment . ,env)))))
826
827 (set-frame-parameter frame 'display-environment-variable
828 (server-getenv-from env "DISPLAY"))
829 (select-frame frame)
830 (server-client-set client 'frame frame)
831 (server-client-set client 'tty (terminal-name frame))
832 (server-client-set client 'terminal (frame-terminal frame))
833
834 ;; Display *scratch* by default.
835 (switch-to-buffer (get-buffer-create "*scratch*") 'norecord)
836
837 ;; Reply with our pid.
838 (server-send-string proc (concat "-emacs-pid " (number-to-string (emacs-pid)) "\n"))
839 (setq dontkill t))))
840
841 ;; -position LINE: Go to the given line in the next file.
842 ((and (equal "-position" arg) (string-match "\\(\\+[0-9]+\\) " request))
843 (setq lineno (string-to-number (substring (match-string 1 request) 1))
844 request (substring request (match-end 0)))) 904 request (substring request (match-end 0))))
845 905
846 ;; -position LINE:COLUMN: Set point to the given position in the next file.
847 ((and (equal "-position" arg) (string-match "\\+\\([0-9]+\\):\\([0-9]+\\) " request))
848 (setq lineno (string-to-number (match-string 1 request))
849 columnno (string-to-number (match-string 2 request))
850 request (substring request (match-end 0))))
851
852 ;; -file FILENAME: Load the given file. 906 ;; -file FILENAME: Load the given file.
853 ((and (equal "-file" arg) (string-match "\\([^ ]+\\) " request)) 907 ((and (equal "-file" arg)
908 (string-match "\\([^ ]+\\) " request))
854 (let ((file (server-unquote-arg (match-string 1 request)))) 909 (let ((file (server-unquote-arg (match-string 1 request))))
855 (setq request (substring request (match-end 0))) 910 (setq request (substring request (match-end 0)))
856 (if coding-system 911 (if coding-system
857 (setq file (decode-coding-string file coding-system))) 912 (setq file (decode-coding-string file coding-system)))
858 (setq file (command-line-normalize-file-name file)) 913 (setq file (command-line-normalize-file-name file))
859 (push (list file lineno columnno) files) 914 (push (list file lineno columnno) files)
860 (server-log (format "New file: %s (%d:%d)" file lineno columnno) proc)) 915 (server-log (format "New file: %s (%d:%d)"
916 file lineno columnno) proc))
861 (setq lineno 1 917 (setq lineno 1
862 columnno 0)) 918 columnno 0))
863 919
864 ;; -eval EXPR: Evaluate a Lisp expression. 920 ;; -eval EXPR: Evaluate a Lisp expression.
865 ((and (equal "-eval" arg) (string-match "\\([^ ]+\\) " request)) 921 ((and (equal "-eval" arg)
866 (let ((expr (server-unquote-arg (match-string 1 request)))) 922 (string-match "\\([^ ]+\\) " request))
923 (lexical-let ((expr (server-unquote-arg
924 (match-string 1 request))))
867 (setq request (substring request (match-end 0))) 925 (setq request (substring request (match-end 0)))
868 (if coding-system 926 (if coding-system
869 (setq expr (decode-coding-string expr coding-system))) 927 (setq expr (decode-coding-string expr coding-system)))
870 (let ((v (eval (car (read-from-string expr))))) 928 (push (lambda () (server-eval-and-print expr proc))
871 (when (and (not frame) v) 929 commands)
872 (with-temp-buffer
873 (let ((standard-output (current-buffer)))
874 (pp v)
875 (server-send-string
876 proc (format "-print %s\n"
877 (server-quote-arg
878 (buffer-substring-no-properties (point-min)
879 (point-max)))))))))
880 (setq lineno 1 930 (setq lineno 1
881 columnno 0))) 931 columnno 0)))
882 932
883 ;; -env NAME=VALUE: An environment variable. 933 ;; -env NAME=VALUE: An environment variable.
884 ((and (equal "-env" arg) (string-match "\\([^ ]+\\) " request)) 934 ((and (equal "-env" arg) (string-match "\\([^ ]+\\) " request))
885 (let ((var (server-unquote-arg (match-string 1 request)))) 935 (let ((var (server-unquote-arg (match-string 1 request))))
886 ;; XXX Variables should be encoded as in getenv/setenv. 936 ;; XXX Variables should be encoded as in getenv/setenv.
887 (setq request (substring request (match-end 0))) 937 (setq request (substring request (match-end 0)))
888 (setq env (cons var env)))) 938 (process-put proc 'env
939 (cons var (process-get proc 'env)))))
889 940
890 ;; -dir DIRNAME: The cwd of the emacsclient process. 941 ;; -dir DIRNAME: The cwd of the emacsclient process.
891 ((and (equal "-dir" arg) (string-match "\\([^ ]+\\) " request)) 942 ((and (equal "-dir" arg) (string-match "\\([^ ]+\\) " request))
892 (setq dir (server-unquote-arg (match-string 1 request))) 943 (setq dir (server-unquote-arg (match-string 1 request)))
893 (setq request (substring request (match-end 0))) 944 (setq request (substring request (match-end 0)))
895 (setq dir (decode-coding-string dir coding-system))) 946 (setq dir (decode-coding-string dir coding-system)))
896 (setq dir (command-line-normalize-file-name dir))) 947 (setq dir (command-line-normalize-file-name dir)))
897 948
898 ;; Unknown command. 949 ;; Unknown command.
899 (t (error "Unknown command: %s" arg))))) 950 (t (error "Unknown command: %s" arg)))))
900 951
901 (let (buffers) 952 (setq frame
902 (when files 953 (case tty-name
903 (run-hooks 'pre-command-hook) 954 ((nil) (if display (server-select-display display)))
904 (setq buffers (server-visit-files files client nowait)) 955 ((window-system)
905 (run-hooks 'post-command-hook)) 956 (server-create-window-system-frame display nowait proc))
906 957 (t (server-create-tty-frame tty-name tty-type proc))))
907 ;; Delete the client if necessary. 958
908 (cond 959 (process-put proc 'continuation
909 (nowait 960 (lexical-let ((proc proc)
910 ;; Client requested nowait; return immediately. 961 (files files)
911 (server-log "Close nowait client" proc) 962 (nowait nowait)
912 (server-delete-client proc)) 963 (commands commands)
913 ((and (not dontkill) (null buffers)) 964 (dontkill dontkill)
914 ;; This client is empty; get rid of it immediately. 965 (frame frame)
915 (server-log "Close empty client" proc) 966 (tty-name tty-name))
916 (server-delete-client proc))) 967 (lambda ()
917 (cond 968 (server-execute proc files nowait commands
918 ((or isearch-mode (minibufferp)) 969 dontkill frame tty-name))))
919 nil) 970
920 ((and frame (null buffers)) 971 (when (or frame files)
921 (message "%s" (substitute-command-keys 972 (server-goto-toplevel proc))
922 "When done with this frame, type \\[delete-frame]"))) 973
923 ((not (null buffers)) 974 (server-execute-continuation proc))))
924 (server-switch-buffer (car buffers))
925 (run-hooks 'server-switch-hook)
926 (unless nowait
927 (message "%s" (substitute-command-keys
928 "When done with a buffer, type \\[server-edit]"))))))))
929
930 ;; Save for later any partial line that remains.
931 (when (> (length string) 0)
932 (process-put proc 'previous-string string)))
933 ;; condition-case 975 ;; condition-case
934 (error (ignore-errors 976 (error (server-return-error proc err))))
935 (server-send-string 977
936 proc (concat "-error " (server-quote-arg (error-message-string err)))) 978 (defun server-execute (proc files nowait commands dontkill frame tty-name)
937 (setq string "") 979 (condition-case err
938 (server-log (error-message-string err) proc) 980 (let* ((client (server-client proc))
939 (delete-process proc))))) 981 (buffers
982 (when files
983 (run-hooks 'pre-command-hook)
984 (prog1 (server-visit-files files client nowait)
985 (run-hooks 'post-command-hook)))))
986
987 (mapc 'funcall (nreverse commands))
988
989 ;; Delete the client if necessary.
990 (cond
991 (nowait
992 ;; Client requested nowait; return immediately.
993 (server-log "Close nowait client" proc)
994 (server-delete-client proc))
995 ((and (not dontkill) (null buffers))
996 ;; This client is empty; get rid of it immediately.
997 (server-log "Close empty client" proc)
998 (server-delete-client proc)))
999 (cond
1000 ((or isearch-mode (minibufferp))
1001 nil)
1002 ((and frame (null buffers))
1003 (message "%s" (substitute-command-keys
1004 "When done with this frame, type \\[delete-frame]")))
1005 ((not (null buffers))
1006 (server-switch-buffer (car buffers))
1007 (run-hooks 'server-switch-hook)
1008 (unless nowait
1009 (message "%s" (substitute-command-keys
1010 "When done with a buffer, type \\[server-edit]")))))
1011 (when (and frame (null tty-name))
1012 (server-unselect-display frame)))
1013 (error (server-return-error proc err))))
1014
1015 (defun server-return-error (proc err)
1016 (ignore-errors
1017 (server-send-string
1018 proc (concat "-error " (server-quote-arg
1019 (error-message-string err))))
1020 (server-log (error-message-string err) proc)
1021 (delete-process proc)))
940 1022
941 (defun server-goto-line-column (file-line-col) 1023 (defun server-goto-line-column (file-line-col)
942 "Move point to the position indicated in FILE-LINE-COL. 1024 "Move point to the position indicated in FILE-LINE-COL.
943 FILE-LINE-COL should be a three-element list as described in 1025 FILE-LINE-COL should be a three-element list as described in
944 `server-visit-files'." 1026 `server-visit-files'."