1 files changed, 173 insertions, 144 deletions
diff --git a/lisp/server.el b/lisp/server.el
index 816a072bf75..cb1903ad96c 100644
--- a/lisp/server.el
+++ b/lisp/server.el
@@ -1,8 +1,6 @@
 ;;; server.el --- Lisp code for GNU Emacs running as server process
 
-;; Copyright (C) 1986, 1987, 1992, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
-;;   2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;;   Free Software Foundation, Inc.
+;; Copyright (C) 1986-1987, 1992, 1994-2011  Free Software Foundation, Inc.
 
 ;; Author: William Sommerfeld <wesommer@athena.mit.edu>
 ;; Maintainer: FSF
@@ -110,8 +108,19 @@ If set, the server accepts remote connections; otherwise it is local."
           (string :tag "Name or IP address")
           (const :tag "Local" nil))
   :version "22.1")
+;;;###autoload
 (put 'server-host 'risky-local-variable t)
 
+(defcustom server-port nil
+  "The port number that the server process should listen on."
+  :group 'server
+  :type '(choice
+          (string :tag "Port number")
+          (const :tag "Random" nil))
+  :version "24.1")
+;;;###autoload
+(put 'server-port 'risky-local-variable t)
+
 (defcustom server-auth-dir (locate-user-emacs-file "server/")
   "Directory for server authentication files.
 
@@ -122,6 +131,7 @@ directory residing in a NTFS partition instead."
   :group 'server
   :type 'directory
   :version "22.1")
+;;;###autoload
 (put 'server-auth-dir 'risky-local-variable t)
 
 (defcustom server-raise-frame t
@@ -344,7 +354,8 @@ If CLIENT is non-nil, add a description of it to the logged message."
   ;; for possible servers before doing anything, so it *should* be ours.
   (and (process-contact proc :server)
        (eq (process-status proc) 'closed)
-       (ignore-errors (delete-file (process-get proc :server-file))))
+       (ignore-errors
+	(delete-file (process-get proc :server-file))))
   (server-log (format "Status changed to %s: %s" (process-status proc) msg) proc)
   (server-delete-client proc))
 
@@ -528,7 +539,9 @@ To force-start a server, do \\[server-force-delete] and then
       ;; Delete the socket files made by previous server invocations.
       (if (not (eq t (server-running-p server-name)))
 	  ;; Remove any leftover socket or authentication file
-	  (ignore-errors (delete-file server-file))
+	  (ignore-errors
+	   (let (delete-by-moving-to-trash)
+	     (delete-file server-file)))
 	(setq server-mode nil) ;; already set by the minor mode code
 	(display-warning
 	 'server
@@ -572,8 +585,8 @@ server or call `M-x server-force-delete' to forcibly disconnect it.")
 		       ;; The other args depend on the kind of socket used.
 		       (if server-use-tcp
 			   (list :family 'ipv4  ;; We're not ready for IPv6 yet
-				 :service t
-				 :host (or server-host "127.0.0.1") ;; See bug#6781
+				 :service (or server-port t)
+				 :host (or server-host 'local)
 				 :plist '(:authenticated nil))
 			 (list :family 'local
 			       :service server-file
@@ -585,7 +598,7 @@ server or call `M-x server-force-delete' to forcibly disconnect it.")
 		   (loop
 		      ;; The auth key is a 64-byte string of random chars in the
 		      ;; range `!'..`~'.
-		      for i below 64
+		      repeat 64
 		      collect (+ 33 (random 94)) into auth
 		      finally return (concat auth))))
 	      (process-put server-process :auth-key auth-key)
@@ -594,7 +607,7 @@ server or call `M-x server-force-delete' to forcibly disconnect it.")
 		(setq buffer-file-coding-system 'no-conversion)
 		(insert (format-network-address
 			 (process-contact server-process :local))
-			" " (int-to-string (emacs-pid))
+			" " (number-to-string (emacs-pid)) ; Kept for compatibility
 			"\n" auth-key)))))))))
 
 (defun server-force-stop ()
@@ -616,7 +629,7 @@ NAME defaults to `server-name'.  With argument, ask for NAME."
 				    server-auth-dir
 				  server-socket-dir))))
     (condition-case nil
-	(progn
+	(let (delete-by-moving-to-trash)
 	  (delete-file file)
 	  (message "Connection file %S deleted" file))
       (file-error
@@ -719,12 +732,9 @@ Server mode runs a process that accepts commands from the
     ;; Display *scratch* by default.
     (switch-to-buffer (get-buffer-create "*scratch*") 'norecord)
 
-    ;; Reply with our pid.
-    (server-send-string proc (concat "-emacs-pid "
-                                     (number-to-string (emacs-pid)) "\n"))
     frame))
 
-(defun server-create-window-system-frame (display nowait proc)
+(defun server-create-window-system-frame (display nowait proc parent-id)
   (add-to-list 'frame-inherited-parameters 'client)
   (if (not (fboundp 'make-frame-on-display))
       (progn
@@ -740,12 +750,14 @@ Server mode runs a process that accepts commands from the
     (let* ((params `((client . ,(if nowait 'nowait proc))
                      ;; This is a leftover, see above.
                      (environment . ,(process-get proc 'env))))
-           (frame (make-frame-on-display
-                   (or display
-                       (frame-parameter nil 'display)
-                       (getenv "DISPLAY")
-                       (error "Please specify display"))
-                   params)))
+	   (display (or display
+			(frame-parameter nil 'display)
+			(getenv "DISPLAY")
+			(error "Please specify display")))
+	   frame)
+      (if parent-id
+	  (push (cons 'parent-id (string-to-number parent-id)) params))
+      (setq frame (make-frame-on-display display params))
       (server-log (format "%s created" frame) proc)
       (select-frame frame)
       (process-put proc 'frame frame)
@@ -890,6 +902,9 @@ The following commands are accepted by the client:
       (server-log "Authentication failed" proc)
       (server-send-string
        proc (concat "-error " (server-quote-arg "Authentication failed")))
+      ;; Before calling `delete-process', give emacsclient time to
+      ;; receive the error string and shut down on its own.
+      (sit-for 1)
       (delete-process proc)
       ;; We return immediately
       (return-from server-process-filter)))
@@ -900,6 +915,9 @@ The following commands are accepted by the client:
   (condition-case err
       (progn
 	(server-add-client proc)
+	;; Send our pid
+	(server-send-string proc (concat "-emacs-pid "
+					 (number-to-string (emacs-pid)) "\n"))
 	(if (not (string-match "\n" string))
             ;; Save for later any partial line that remains.
             (when (> (length string) 0)
@@ -913,131 +931,134 @@ The following commands are accepted by the client:
 		(coding-system (and (default-value '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.
+		nowait     ; t if emacsclient does not want to wait for us.
+		frame      ; Frame opened for the client (if any).
+		display    ; Open frame on this display.
+		parent-id  ; Window ID for XEmbed
+		dontkill   ; t if client should not be killed.
 		commands
 		dir
 		use-current-frame
-		tty-name       ;nil, `window-system', or the tty name.
-		tty-type             ;string.
+		tty-name   ; nil, `window-system', or the tty name.
+		tty-type   ; string.
 		files
 		filepos
-		command-line-args-left
-		arg)
+		args-left)
 	    ;; Remove this line from STRING.
 	    (setq string (substring string (match-end 0)))
-	    (setq command-line-args-left
+	    (setq args-left
 		  (mapcar 'server-unquote-arg (split-string request " " t)))
-	    (while (setq arg (pop command-line-args-left))
-		(cond
-		 ;; -version CLIENT-VERSION: obsolete at birth.
-		 ((and (equal "-version" arg) command-line-args-left)
-		  (pop command-line-args-left))
-
-		 ;; -nowait:  Emacsclient won't wait for a result.
-		 ((equal "-nowait" arg) (setq nowait t))
-
-		 ;; -current-frame:  Don't create frames.
-		 ((equal "-current-frame" arg) (setq use-current-frame t))
-
-		 ;; -display DISPLAY:
-		 ;; Open X frames on the given display instead of the default.
-		 ((and (equal "-display" arg) command-line-args-left)
-		  (setq display (pop command-line-args-left))
-                  (if (zerop (length display)) (setq display nil)))
-
-		 ;; -window-system:  Open a new X frame.
-		 ((equal "-window-system" arg)
-                  (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)))
-
-		 ;; -ignore COMMENT:  Noop; useful for debugging emacsclient.
-		 ;; (The given comment appears in the server log.)
-		 ((and (equal "-ignore" arg) command-line-args-left
-		  (setq dontkill t)
-		  (pop command-line-args-left)))
-
-		 ;; -tty DEVICE-NAME TYPE:  Open a new tty frame at the client.
-		 ((and (equal "-tty" arg)
-                       (cdr command-line-args-left))
-                  (setq tty-name (pop command-line-args-left)
-			tty-type (pop command-line-args-left)
-			dontkill (or dontkill
-				     (not use-current-frame))))
-
-		 ;; -position LINE[:COLUMN]:  Set point to the given
-		 ;;  position in the next file.
-		 ((and (equal "-position" arg)
-		       command-line-args-left
-                       (string-match "\\+\\([0-9]+\\)\\(?::\\([0-9]+\\)\\)?"
-                                     (car command-line-args-left)))
-		  (setq arg (pop command-line-args-left))
-		  (setq filepos
-                        (cons (string-to-number (match-string 1 arg))
-                              (string-to-number (or (match-string 2 arg) "")))))
-
-		 ;; -file FILENAME:  Load the given file.
-		 ((and (equal "-file" arg)
-		       command-line-args-left)
-		  (let ((file (pop command-line-args-left)))
-		    (if coding-system
-			(setq file (decode-coding-string file coding-system)))
-                    (setq file (expand-file-name file dir))
-		    (push (cons file filepos) files)
-		    (server-log (format "New file: %s %s"
-                                        file (or filepos "")) proc))
-		  (setq filepos nil))
-
-		 ;; -eval EXPR:  Evaluate a Lisp expression.
-		 ((and (equal "-eval" arg)
-                       command-line-args-left)
-		  (if use-current-frame
-		      (setq use-current-frame 'always))
-		  (lexical-let ((expr (pop command-line-args-left)))
-		    (if coding-system
-			(setq expr (decode-coding-string expr coding-system)))
-                    (push (lambda () (server-eval-and-print expr proc))
-                          commands)
-		    (setq filepos nil)))
-
-		 ;; -env NAME=VALUE:  An environment variable.
-		 ((and (equal "-env" arg) command-line-args-left)
-		  (let ((var (pop command-line-args-left)))
-		    ;; XXX Variables should be encoded as in getenv/setenv.
-                    (process-put proc 'env
-                                 (cons var (process-get proc 'env)))))
-
-		 ;; -dir DIRNAME:  The cwd of the emacsclient process.
-		 ((and (equal "-dir" arg) command-line-args-left)
-		  (setq dir (pop command-line-args-left))
-		  (if coding-system
-		      (setq dir (decode-coding-string dir coding-system)))
-		  (setq dir (command-line-normalize-file-name dir)))
-
-		 ;; Unknown command.
-		 (t (error "Unknown command: %s" arg))))
+	    (while args-left
+              (pcase (pop args-left)
+                ;; -version CLIENT-VERSION: obsolete at birth.
+                (`"-version" (pop args-left))
+
+                ;; -nowait:  Emacsclient won't wait for a result.
+                (`"-nowait" (setq nowait t))
+
+                ;; -current-frame:  Don't create frames.
+                (`"-current-frame" (setq use-current-frame t))
+
+                ;; -display DISPLAY:
+                ;; Open X frames on the given display instead of the default.
+                (`"-display"
+                 (setq display (pop args-left))
+                 (if (zerop (length display)) (setq display nil)))
+
+                ;; -parent-id ID:
+                ;; Open X frame within window ID, via XEmbed.
+                (`"-parent-id"
+                 (setq parent-id (pop args-left))
+                 (if (zerop (length parent-id)) (setq parent-id nil)))
+
+                ;; -window-system:  Open a new X frame.
+                (`"-window-system"
+                 (setq dontkill t)
+                 (setq tty-name 'window-system))
+
+                ;; -resume:  Resume a suspended tty frame.
+                (`"-resume"
+                 (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.)
+                (`"-suspend"
+                 (lexical-let ((terminal (process-get proc 'terminal)))
+                   (setq dontkill t)
+                   (push (lambda ()
+                           (when (eq (terminal-live-p terminal) t)
+                             (suspend-tty terminal)))
+                         commands)))
+
+                ;; -ignore COMMENT:  Noop; useful for debugging emacsclient.
+                ;; (The given comment appears in the server log.)
+                (`"-ignore"
+                 (setq dontkill t)
+                 (pop args-left))
+
+                ;; -tty DEVICE-NAME TYPE:  Open a new tty frame at the client.
+                (`"-tty"
+                 (setq tty-name (pop args-left)
+                       tty-type (pop args-left)
+                       dontkill (or dontkill
+                                    (not use-current-frame))))
+
+                ;; -position LINE[:COLUMN]:  Set point to the given
+                ;;  position in the next file.
+                (`"-position"
+                 (if (not (string-match "\\+\\([0-9]+\\)\\(?::\\([0-9]+\\)\\)?"
+                                        (car args-left)))
+                     (error "Invalid -position command in client args"))
+                 (let ((arg (pop args-left)))
+                   (setq filepos
+                         (cons (string-to-number (match-string 1 arg))
+                               (string-to-number (or (match-string 2 arg)
+                                                     ""))))))
+
+                ;; -file FILENAME:  Load the given file.
+                (`"-file"
+                 (let ((file (pop args-left)))
+                   (if coding-system
+                       (setq file (decode-coding-string file coding-system)))
+                   (setq file (expand-file-name file dir))
+                   (push (cons file filepos) files)
+                   (server-log (format "New file: %s %s"
+                                       file (or filepos "")) proc))
+                 (setq filepos nil))
+
+                ;; -eval EXPR:  Evaluate a Lisp expression.
+                (`"-eval"
+                 (if use-current-frame
+                     (setq use-current-frame 'always))
+                 (lexical-let ((expr (pop args-left)))
+                   (if coding-system
+                       (setq expr (decode-coding-string expr coding-system)))
+                   (push (lambda () (server-eval-and-print expr proc))
+                         commands)
+                   (setq filepos nil)))
+
+                ;; -env NAME=VALUE:  An environment variable.
+                (`"-env"
+                 (let ((var (pop args-left)))
+                   ;; XXX Variables should be encoded as in getenv/setenv.
+                   (process-put proc 'env
+                                (cons var (process-get proc 'env)))))
+
+                ;; -dir DIRNAME:  The cwd of the emacsclient process.
+                (`"-dir"
+                 (setq dir (pop args-left))
+                 (if coding-system
+                     (setq dir (decode-coding-string dir coding-system)))
+                 (setq dir (command-line-normalize-file-name dir)))
+
+                ;; Unknown command.
+                (arg (error "Unknown command: %s" arg))))
 
 	    (setq frame
 		  (cond
@@ -1052,7 +1073,8 @@ The following commands are accepted by the client:
 		    (setq tty-name nil tty-type nil)
 		    (if display (server-select-display display)))
 		   ((eq tty-name 'window-system)
-		    (server-create-window-system-frame display nowait proc))
+		    (server-create-window-system-frame display nowait proc
+						       parent-id))
 		   ;; When resuming on a tty, tty-name is nil.
 		   (tty-name
 		    (server-create-tty-frame tty-name tty-type proc))))
@@ -1096,9 +1118,7 @@ The following commands are accepted by the client:
     (condition-case err
         (let* ((buffers
                 (when files
-                  (run-hooks 'pre-command-hook)
-                  (prog1 (server-visit-files files proc nowait)
-                    (run-hooks 'post-command-hook)))))
+                  (server-visit-files files proc nowait))))
 
           (mapc 'funcall (nreverse commands))
 
@@ -1134,6 +1154,9 @@ The following commands are accepted by the client:
      proc (concat "-error " (server-quote-arg
                              (error-message-string err))))
     (server-log (error-message-string err) proc)
+    ;; Before calling `delete-process', give emacsclient time to
+    ;; receive the error string and shut down on its own.
+    (sit-for 5)
     (delete-process proc)))
 
 (defun server-goto-line-column (line-col)
@@ -1169,8 +1192,13 @@ so don't mark these buffers specially, just visit them normally."
 	       (obuf (get-file-buffer filen)))
 	  (add-to-history 'file-name-history filen)
 	  (if (null obuf)
-              (set-buffer (find-file-noselect filen))
+	      (progn
+		(run-hooks 'pre-command-hook)  
+		(set-buffer (find-file-noselect filen)))
             (set-buffer obuf)
+	    ;; separately for each file, in sync with post-command hooks,
+	    ;; with the new buffer current:
+	    (run-hooks 'pre-command-hook)  
             (cond ((file-exists-p filen)
                    (when (not (verify-visited-file-modtime obuf))
                      (revert-buffer t nil)))
@@ -1182,7 +1210,9 @@ so don't mark these buffers specially, just visit them normally."
             (unless server-buffer-clients
               (setq server-existing-buffer t)))
           (server-goto-line-column (cdr file))
-          (run-hooks 'server-visit-hook))
+          (run-hooks 'server-visit-hook)
+	  ;; hooks may be specific to current buffer:
+	  (run-hooks 'post-command-hook)) 
 	(unless nowait
 	  ;; When the buffer is killed, inform the clients.
 	  (add-hook 'kill-buffer-hook 'server-kill-buffer nil t)
@@ -1465,5 +1495,4 @@ only these files will be asked to be saved."
 
 (provide 'server)
 
-;; arch-tag: 1f7ecb42-f00a-49f8-906d-61995d84c8d6
 ;;; server.el ends here