;;; 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 Free Software Foundation, Inc.
+;; 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
;; Author: William Sommerfeld <wesommer@athena.mit.edu>
;; Maintainer: FSF
(put 'server-host 'risky-local-variable t)
(defcustom server-auth-dir (locate-user-emacs-file "server/")
- "Directory for server authentication files."
+ "Directory for server authentication files.
+
+NOTE: On FAT32 filesystems, directories are not secure;
+files can be read and modified by any user or process.
+It is strongly suggested to set `server-auth-dir' to a
+directory residing in a NTFS partition instead."
:group 'server
:type 'directory
:version "22.1")
;; 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))
- it's owned by us
- it's not readable/writable by anybody else."
(setq dir (directory-file-name dir))
- (let ((attrs (file-attributes dir)))
+ (let ((attrs (file-attributes dir 'integer)))
(unless attrs
(letf (((default-file-modes) ?\700)) (make-directory dir t))
- (setq attrs (file-attributes dir)))
+ (setq attrs (file-attributes dir 'integer)))
+
;; Check that it's safe for use.
- (unless (and (eq t (car attrs)) (eql (nth 2 attrs) (user-uid))
- (or (eq system-type 'windows-nt)
- (zerop (logand ?\077 (file-modes dir)))))
- (error "The directory %s is unsafe" dir))))
+ (let* ((uid (nth 2 attrs))
+ (w32 (eq system-type 'windows-nt))
+ (safe (catch :safe
+ (unless (eq t (car attrs)) ; is a dir?
+ (throw :safe nil))
+ (when (and w32 (zerop uid)) ; on FAT32?
+ (display-warning
+ 'server
+ (format "Using `%s' to store Emacs-server authentication files.
+Directories on FAT32 filesystems are NOT secure against tampering.
+See variable `server-auth-dir' for details."
+ (file-name-as-directory dir))
+ :warning)
+ (throw :safe t))
+ (unless (eql uid (user-uid)) ; is the dir ours?
+ (throw :safe nil))
+ (when w32 ; on NTFS?
+ (throw :safe t))
+ (unless (zerop (logand ?\077 (file-modes dir)))
+ (throw :safe nil))
+ t)))
+ (unless safe
+ (error "The directory `%s' is unsafe" dir)))))
;;;###autoload
(defun server-start (&optional leave-dead)
;; 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
- (format "Emacs server named %S already running" server-name)
- :warning)
+ (display-warning
+ 'server
+ (concat "Unable to start the Emacs server.\n"
+ (format "There is an existing Emacs server, named %S.\n"
+ server-name)
+ "To start the server in this Emacs process, stop the existing
+server or call `M-x server-force-delete' to forcibly disconnect it.")
+ :warning)
(setq leave-dead t))
;; If this Emacs already had a server, clear out associated status.
(while server-clients
:coding 'raw-text-unix
;; The other args depend on the kind of socket used.
(if server-use-tcp
- (list :family nil
+ (list :family 'ipv4 ;; We're not ready for IPv6 yet
:service t
- :host (or server-host 'local)
+ :host (or server-host "127.0.0.1") ;; See bug#6781
:plist '(:authenticated nil))
(list :family 'local
:service server-file
(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)
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
(insert-file-contents-literally (expand-file-name name server-auth-dir))
(or (and (looking-at "127\\.0\\.0\\.1:[0-9]+ \\([0-9]+\\)")
(assq 'comm
- (system-process-attributes
+ (process-attributes
(string-to-number (match-string 1))))
t)
:other))
(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
(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)
;; supported any more.
(assert (eq (match-end 0) (length string)))
(let ((request (substring string 0 (match-beginning 0)))
- (coding-system (and default-enable-multibyte-characters
+ (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
(setq display (pop command-line-args-left))
(if (zerop (length display)) (setq display nil)))
+ ;; -parent-id ID:
+ ;; Open X frame within window ID, via XEmbed.
+ ((and (equal "-parent-id" arg) command-line-args-left)
+ (setq parent-id (pop command-line-args-left))
+ (if (zerop (length parent-id)) (setq parent-id nil)))
+
;; -window-system: Open a new X frame.
((equal "-window-system" arg)
(setq dontkill t)
(let ((file (pop command-line-args-left)))
(if coding-system
(setq file (decode-coding-string file coding-system)))
- (setq file (command-line-normalize-file-name file))
+ (setq file (expand-file-name file dir))
(push (cons file filepos) files)
(server-log (format "New file: %s %s"
file (or filepos "")) proc))
(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))))
"Move point to the position indicated in LINE-COL.
LINE-COL should be a pair (LINE . COL)."
(when line-col
- (goto-line (car line-col))
+ (goto-char (point-min))
+ (forward-line (1- (car line-col)))
(let ((column-number (cdr line-col)))
(when (> column-number 0)
(move-to-column (1- column-number))))))
(not server-existing-buffer)))
(setq killed t)
(bury-buffer buffer)
+ ;; Prevent kill-buffer from prompting (Bug#3696).
+ (with-current-buffer buffer
+ (set-buffer-modified-p nil))
(kill-buffer buffer))
(unless killed
(if (server-temp-file-p buffer)
(progn
+ (with-current-buffer buffer
+ (set-buffer-modified-p nil))
(kill-buffer buffer)
(setq killed t))
(bury-buffer buffer)))))))