Now on revision 113486. ------------------------------------------------------------ revno: 113486 committer: Stefan Monnier branch nick: trunk timestamp: Mon 2013-07-22 00:06:21 -0400 message: * lisp/url/url-http.el (status): Remove, unused. (success): Remove var. (url-http-handle-authentication): Return the value that `success' should take instead of setting `success' directly. Don't set `status' since it's not used. (url-http-parse-headers): Avoid unneeded setq. Move the `setq success'. (url-http): Use pcase. (url-http-file-exists-p): Simplify. diff: === modified file 'lisp/url/ChangeLog' --- lisp/url/ChangeLog 2013-06-26 16:54:48 +0000 +++ lisp/url/ChangeLog 2013-07-22 04:06:21 +0000 @@ -1,3 +1,15 @@ +2013-07-22 Stefan Monnier + + * url-http.el (status): Remove, unused. + (success): Remove var. + (url-http-handle-authentication): Return the value that `success' + should take instead of setting `success' directly. Don't set `status' + since it's not used. + (url-http-parse-headers): Avoid unneeded setq. + Move the `setq success'. + (url-http): Use pcase. + (url-http-file-exists-p): Simplify. + 2013-06-26 Lars Magne Ingebrigtsen * url-cookie.el: Implement a command and mode for displaying and === modified file 'lisp/url/url-http.el' --- lisp/url/url-http.el 2013-02-16 02:05:32 +0000 +++ lisp/url/url-http.el 2013-07-22 04:06:21 +0000 @@ -375,9 +375,6 @@ (replace-match "")) (- end url-http-end-of-headers))) -(defvar status) -(defvar success) - (defun url-http-handle-authentication (proxy) (url-http-debug "Handling %s authentication" (if proxy "proxy" "normal")) (let ((auths (or (nreverse @@ -404,9 +401,9 @@ (url-strip-leading-spaces this-auth))) (let* ((this-type - (if (string-match "[ \t]" this-auth) - (downcase (substring this-auth 0 (match-beginning 0))) - (downcase this-auth))) + (downcase (if (string-match "[ \t]" this-auth) + (substring this-auth 0 (match-beginning 0)) + this-auth))) (registered (url-auth-registered this-type)) (this-strength (cddr registered))) (when (and registered (> this-strength strength)) @@ -421,20 +418,26 @@ (insert "

Sorry, but I do not know how to handle " type " authentication. If you'd like to write it," " send it to " url-bug-address ".

") - (setq status t)) + ;; We used to set a `status' var (declared "special") but I can't + ;; find the corresponding let-binding, so it's probably an error. + ;; FIXME: Maybe it was supposed to set `success', i.e. to return t? + ;; (setq status t) + nil) ;; Not success yet. + (let* ((args (url-parse-args (subst-char-in-string ?, ?\; auth))) (auth (url-get-authentication auth-url (cdr-safe (assoc "realm" args)) type t args))) (if (not auth) - (setq success t) + t ;Success. (push (cons (if proxy "Proxy-Authorization" "Authorization") auth) url-http-extra-headers) (let ((url-request-method url-http-method) (url-request-data url-http-data) (url-request-extra-headers url-http-extra-headers)) (url-retrieve-internal url url-callback-function - url-callback-arguments))))))) + url-callback-arguments)) + nil))))) ;; Not success yet. (defun url-http-parse-response () "Parse just the response code." @@ -498,12 +501,11 @@ (when (and connection (string= (downcase connection) "close")) (delete-process url-http-process))))) - (let ((buffer (current-buffer)) - (class nil) - (success nil) - ;; other status symbols: jewelry and luxury cars - (status-symbol (cadr (assq url-http-response-status url-http-codes)))) - (setq class (/ url-http-response-status 100)) + (let* ((buffer (current-buffer)) + (class (/ url-http-response-status 100)) + (success nil) + ;; other status symbols: jewelry and luxury cars + (status-symbol (cadr (assq url-http-response-status url-http-codes)))) (url-http-debug "Parsed HTTP headers: class=%d status=%d" class url-http-response-status) (when (url-use-cookies url-http-target-url) @@ -536,15 +538,14 @@ (pcase status-symbol ((or `no-content `reset-content) ;; No new data, just stay at the same document - (url-mark-buffer-as-dead buffer) - (setq success t)) + (url-mark-buffer-as-dead buffer)) (_ ;; Generic success for all others. Store in the cache, and ;; mark it as successful. (widen) (if (and url-automatic-caching (equal url-http-method "GET")) - (url-store-in-cache buffer)) - (setq success t)))) + (url-store-in-cache buffer)))) + (setq success t)) (3 ; Redirection ;; 300 Multiple choices ;; 301 Moved permanently @@ -684,106 +685,107 @@ ;; 422 Unprocessable Entity (Added by DAV) ;; 423 Locked ;; 424 Failed Dependency - (pcase status-symbol - (`unauthorized ; 401 - ;; The request requires user authentication. The response - ;; MUST include a WWW-Authenticate header field containing a - ;; challenge applicable to the requested resource. The - ;; client MAY repeat the request with a suitable - ;; Authorization header field. - (url-http-handle-authentication nil)) - (`payment-required ; 402 - ;; This code is reserved for future use - (url-mark-buffer-as-dead buffer) - (error "Somebody wants you to give them money")) - (`forbidden ; 403 - ;; The server understood the request, but is refusing to - ;; fulfill it. Authorization will not help and the request - ;; SHOULD NOT be repeated. - (setq success t)) - (`not-found ; 404 - ;; Not found - (setq success t)) - (`method-not-allowed ; 405 - ;; The method specified in the Request-Line is not allowed - ;; for the resource identified by the Request-URI. The - ;; response MUST include an Allow header containing a list of - ;; valid methods for the requested resource. - (setq success t)) - (`not-acceptable ; 406 - ;; The resource identified by the request is only capable of - ;; generating response entities which have content - ;; characteristics not acceptable according to the accept - ;; headers sent in the request. - (setq success t)) - (`proxy-authentication-required ; 407 - ;; This code is similar to 401 (Unauthorized), but indicates - ;; that the client must first authenticate itself with the - ;; proxy. The proxy MUST return a Proxy-Authenticate header - ;; field containing a challenge applicable to the proxy for - ;; the requested resource. - (url-http-handle-authentication t)) - (`request-timeout ; 408 - ;; The client did not produce a request within the time that - ;; the server was prepared to wait. The client MAY repeat - ;; the request without modifications at any later time. - (setq success t)) - (`conflict ; 409 - ;; The request could not be completed due to a conflict with - ;; the current state of the resource. This code is only - ;; allowed in situations where it is expected that the user - ;; might be able to resolve the conflict and resubmit the - ;; request. The response body SHOULD include enough - ;; information for the user to recognize the source of the - ;; conflict. - (setq success t)) - (`gone ; 410 - ;; The requested resource is no longer available at the - ;; server and no forwarding address is known. - (setq success t)) - (`length-required ; 411 - ;; The server refuses to accept the request without a defined - ;; Content-Length. The client MAY repeat the request if it - ;; adds a valid Content-Length header field containing the - ;; length of the message-body in the request message. - ;; - ;; NOTE - this will never happen because - ;; `url-http-create-request' automatically calculates the - ;; content-length. - (setq success t)) - (`precondition-failed ; 412 - ;; The precondition given in one or more of the - ;; request-header fields evaluated to false when it was - ;; tested on the server. - (setq success t)) - ((or `request-entity-too-large `request-uri-too-large) ; 413 414 - ;; The server is refusing to process a request because the - ;; request entity|URI is larger than the server is willing or - ;; able to process. - (setq success t)) - (`unsupported-media-type ; 415 - ;; The server is refusing to service the request because the - ;; entity of the request is in a format not supported by the - ;; requested resource for the requested method. - (setq success t)) - (`requested-range-not-satisfiable ; 416 - ;; A server SHOULD return a response with this status code if - ;; a request included a Range request-header field, and none - ;; of the range-specifier values in this field overlap the - ;; current extent of the selected resource, and the request - ;; did not include an If-Range request-header field. - (setq success t)) - (`expectation-failed ; 417 - ;; The expectation given in an Expect request-header field - ;; could not be met by this server, or, if the server is a - ;; proxy, the server has unambiguous evidence that the - ;; request could not be met by the next-hop server. - (setq success t)) - (_ - ;; The request could not be understood by the server due to - ;; malformed syntax. The client SHOULD NOT repeat the - ;; request without modifications. - (setq success t))) + (setq success + (pcase status-symbol + (`unauthorized ; 401 + ;; The request requires user authentication. The response + ;; MUST include a WWW-Authenticate header field containing a + ;; challenge applicable to the requested resource. The + ;; client MAY repeat the request with a suitable + ;; Authorization header field. + (url-http-handle-authentication nil)) + (`payment-required ; 402 + ;; This code is reserved for future use + (url-mark-buffer-as-dead buffer) + (error "Somebody wants you to give them money")) + (`forbidden ; 403 + ;; The server understood the request, but is refusing to + ;; fulfill it. Authorization will not help and the request + ;; SHOULD NOT be repeated. + t) + (`not-found ; 404 + ;; Not found + t) + (`method-not-allowed ; 405 + ;; The method specified in the Request-Line is not allowed + ;; for the resource identified by the Request-URI. The + ;; response MUST include an Allow header containing a list of + ;; valid methods for the requested resource. + t) + (`not-acceptable ; 406 + ;; The resource identified by the request is only capable of + ;; generating response entities which have content + ;; characteristics not acceptable according to the accept + ;; headers sent in the request. + t) + (`proxy-authentication-required ; 407 + ;; This code is similar to 401 (Unauthorized), but indicates + ;; that the client must first authenticate itself with the + ;; proxy. The proxy MUST return a Proxy-Authenticate header + ;; field containing a challenge applicable to the proxy for + ;; the requested resource. + (url-http-handle-authentication t)) + (`request-timeout ; 408 + ;; The client did not produce a request within the time that + ;; the server was prepared to wait. The client MAY repeat + ;; the request without modifications at any later time. + t) + (`conflict ; 409 + ;; The request could not be completed due to a conflict with + ;; the current state of the resource. This code is only + ;; allowed in situations where it is expected that the user + ;; might be able to resolve the conflict and resubmit the + ;; request. The response body SHOULD include enough + ;; information for the user to recognize the source of the + ;; conflict. + t) + (`gone ; 410 + ;; The requested resource is no longer available at the + ;; server and no forwarding address is known. + t) + (`length-required ; 411 + ;; The server refuses to accept the request without a defined + ;; Content-Length. The client MAY repeat the request if it + ;; adds a valid Content-Length header field containing the + ;; length of the message-body in the request message. + ;; + ;; NOTE - this will never happen because + ;; `url-http-create-request' automatically calculates the + ;; content-length. + t) + (`precondition-failed ; 412 + ;; The precondition given in one or more of the + ;; request-header fields evaluated to false when it was + ;; tested on the server. + t) + ((or `request-entity-too-large `request-uri-too-large) ; 413 414 + ;; The server is refusing to process a request because the + ;; request entity|URI is larger than the server is willing or + ;; able to process. + t) + (`unsupported-media-type ; 415 + ;; The server is refusing to service the request because the + ;; entity of the request is in a format not supported by the + ;; requested resource for the requested method. + t) + (`requested-range-not-satisfiable ; 416 + ;; A server SHOULD return a response with this status code if + ;; a request included a Range request-header field, and none + ;; of the range-specifier values in this field overlap the + ;; current extent of the selected resource, and the request + ;; did not include an If-Range request-header field. + t) + (`expectation-failed ; 417 + ;; The expectation given in an Expect request-header field + ;; could not be met by this server, or, if the server is a + ;; proxy, the server has unambiguous evidence that the + ;; request could not be met by the next-hop server. + t) + (_ + ;; The request could not be understood by the server due to + ;; malformed syntax. The client SHOULD NOT repeat the + ;; request without modifications. + t))) ;; Tell the callback that an error occurred, and what the ;; status code was. (when success @@ -1222,18 +1224,17 @@ (set-process-buffer connection buffer) (set-process-filter connection 'url-http-generic-filter) - (let ((status (process-status connection))) - (cond - ((eq status 'connect) - ;; Asynchronous connection - (set-process-sentinel connection 'url-http-async-sentinel)) - ((eq status 'failed) - ;; Asynchronous connection failed - (error "Could not create connection to %s:%d" host port)) - (t - (set-process-sentinel connection - 'url-http-end-of-document-sentinel) - (process-send-string connection (url-http-create-request))))))) + (pcase (process-status connection) + (`connect + ;; Asynchronous connection + (set-process-sentinel connection 'url-http-async-sentinel)) + (`failed + ;; Asynchronous connection failed + (error "Could not create connection to %s:%d" host port)) + (_ + (set-process-sentinel connection + 'url-http-end-of-document-sentinel) + (process-send-string connection (url-http-create-request)))))) buffer)) (defun url-http-async-sentinel (proc why) @@ -1302,17 +1303,14 @@ (url-retrieve-synchronously url))) (defun url-http-file-exists-p (url) - (let ((status nil) - (exists nil) - (buffer (url-http-head url))) - (if (not buffer) - (setq exists nil) - (setq status (url-http-symbol-value-in-buffer 'url-http-response-status - buffer 500) - exists (and (integerp status) - (>= status 200) (< status 300))) - (kill-buffer buffer)) - exists)) + (let ((buffer (url-http-head url))) + (when buffer + (let ((status (url-http-symbol-value-in-buffer 'url-http-response-status + buffer 500))) + (prog1 + (and (integerp status) + (>= status 200) (< status 300)) + (kill-buffer buffer)))))) (defalias 'url-http-file-readable-p 'url-http-file-exists-p) ------------------------------------------------------------ revno: 113485 committer: Juanma Barranquero branch nick: trunk timestamp: Mon 2013-07-22 03:25:47 +0200 message: lisp/desktop.el: Require 'cl-lib. (desktop-before-saving-frames-functions): New hook. (desktop--process-minibuffer-frames): Set desktop-mini parameter only for frames being saved. Rename from desktop--save-minibuffer-frames. (desktop-save-frames): Run hook desktop-before-saving-frames-functions. Do not save frames with non-nil `desktop-dont-save' parameter. Filter out deleted frames. (desktop--find-frame): Use cl-find-if. (desktop--select-frame): Use cl-(first|second|third) to access values of desktop-mini. (desktop--make-frame): Use cl-delete-if. (desktop--sort-states): Fix sorting of minibuffer-owning frames. (desktop-restore-frames): Use cl-(first|second|third) to access values of desktop-mini. Look for visible frame at the end, not while restoring frames. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2013-07-22 01:04:10 +0000 +++ lisp/ChangeLog 2013-07-22 01:25:47 +0000 @@ -1,5 +1,21 @@ 2013-07-22 Juanma Barranquero + * desktop.el: Require 'cl-lib. + (desktop-before-saving-frames-functions): New hook. + (desktop--process-minibuffer-frames): Set desktop-mini parameter only + for frames being saved. Rename from desktop--save-minibuffer-frames. + (desktop-save-frames): Run hook desktop-before-saving-frames-functions. + Do not save frames with non-nil `desktop-dont-save' parameter. Filter + out deleted frames. + (desktop--find-frame): Use cl-find-if. + (desktop--select-frame): Use cl-(first|second|third) to access values + of desktop-mini. + (desktop--make-frame): Use cl-delete-if. + (desktop--sort-states): Fix sorting of minibuffer-owning frames. + (desktop-restore-frames): Use cl-(first|second|third) to access values + of desktop-mini. Look for visible frame at the end, not while + restoring frames. + * dired-x.el (dired-mark-unmarked-files, dired-virtual) (dired-guess-default, dired-mark-sexp, dired-filename-at-point): Use string-match-p, looking-at-p (bug#14927). === modified file 'lisp/desktop.el' --- lisp/desktop.el 2013-07-21 17:45:12 +0000 +++ lisp/desktop.el 2013-07-22 01:25:47 +0000 @@ -133,6 +133,8 @@ ;;; Code: +(require 'cl-lib) + (defvar desktop-file-version "206" "Version number of desktop file format. Written into the desktop file and used at desktop read to provide @@ -395,6 +397,13 @@ :group 'desktop :version "24.4") +(defcustom desktop-before-saving-frames-functions nil + "Abnormal hook run before saving frames. +Functions in this hook are called with one argument, a live frame." + :type 'hook + :group 'desktop + :version "24.4") + (defcustom desktop-file-name-format 'absolute "Format in which desktop file names should be saved. Possible values are: @@ -1052,42 +1061,55 @@ (push desktop--target-display filtered)))) filtered)) -(defun desktop--save-minibuffer-frames () +(defun desktop--process-minibuffer-frames (frames) ;; Adds a desktop-mini parameter to frames ;; desktop-mini is a list (MINIBUFFER NUMBER DEFAULT?) where ;; MINIBUFFER t if the frame (including minibuffer-only) owns a minibuffer ;; NUMBER if MINIBUFFER = t, an ID for the frame; if nil, the ID of ;; the frame containing the minibuffer used by this frame ;; DEFAULT? if t, this frame is the value of default-minibuffer-frame - ;; FIXME: What happens with multi-terminal sessions? - (let ((frames (frame-list)) - (count 0)) + (let ((count 0)) ;; Reset desktop-mini for all frames - (dolist (frame frames) + (dolist (frame (frame-list)) (set-frame-parameter frame 'desktop-mini nil)) ;; Number all frames with its own minibuffer (dolist (frame (minibuffer-frame-list)) (set-frame-parameter frame 'desktop-mini (list t - (setq count (1+ count)) + (cl-incf count) (eq frame default-minibuffer-frame)))) ;; Now link minibufferless frames with their minibuffer frames (dolist (frame frames) (unless (frame-parameter frame 'desktop-mini) - (let* ((mb-frame (window-frame (minibuffer-window frame))) - (this (cadr (frame-parameter mb-frame 'desktop-mini)))) - (set-frame-parameter frame 'desktop-mini (list nil this nil))))))) + (let ((mb-frame (window-frame (minibuffer-window frame)))) + ;; Frames whose minibuffer frame has been filtered out will have + ;; desktop-mini = nil, so desktop-restore-frames will restore them + ;; according to their minibuffer parameter. Set up desktop-mini + ;; for the rest. + (when (memq mb-frame frames) + (set-frame-parameter frame 'desktop-mini + (list nil + (cl-second (frame-parameter mb-frame 'desktop-mini)) + nil)))))))) (defun desktop-save-frames () - "Save frame state in `desktop-saved-frame-states'." + "Save frame state in `desktop-saved-frame-states'. +Runs the hook `desktop-before-saving-frames-functions'. +Frames with a non-nil `desktop-dont-save' parameter are not saved." (setq desktop-saved-frame-states (and desktop-restore-frames - (progn - (desktop--save-minibuffer-frames) + (let ((frames (cl-delete-if + (lambda (frame) + (run-hook-with-args 'desktop-before-saving-frames-functions frame) + (frame-parameter frame 'desktop-dont-save)) + (frame-list)))) + ;; In case some frame was deleted by a hook function + (setq frames (cl-delete-if-not #'frame-live-p frames)) + (desktop--process-minibuffer-frames frames) (mapcar (lambda (frame) (cons (desktop--filter-frame-parms (frame-parameters frame) t) (window-state-get (frame-root-window frame) t))) - (frame-list)))))) + frames))))) ;;;###autoload (defun desktop-save (dirname &optional release auto-save) @@ -1200,13 +1222,11 @@ return the first one for which (PREDICATE frame ARGS) returns t. If PREDICATE is nil, it is always satisfied. Internal use only. This is an auxiliary function for `desktop--select-frame'." - (catch :found - (dolist (frame desktop--reuse-list) - (when (and (equal (frame-parameter frame 'display) display) - (or (null predicate) - (apply predicate frame args))) - (throw :found frame))) - nil)) + (cl-find-if (lambda (frame) + (and (equal (frame-parameter frame 'display) display) + (or (null predicate) + (apply predicate frame args)))) + desktop--reuse-list)) (defun desktop--select-frame (display frame-cfg) "Look for an existing frame to reuse. @@ -1241,13 +1261,13 @@ (lambda (f n) (let ((m (frame-parameter f 'desktop-mini))) (and m - (null (car m)) - (= (cadr m) n) - (equal (cadr (frame-parameter - (window-frame (minibuffer-window f)) - 'desktop-mini)) + (null (cl-first m)) + (= (cl-second m) n) + (equal (cl-second (frame-parameter + (window-frame (minibuffer-window f)) + 'desktop-mini)) n)))) - display (cadr mini)))) + display (cl-second mini)))) (;; Default to just finding a frame in the same display. t (setq frame (desktop--find-frame nil display)))) @@ -1282,8 +1302,9 @@ (let ((width (and (eq fullscreen 'fullheight) (cdr (assq 'width filtered-cfg)))) (height (and (eq fullscreen 'fullwidth) (cdr (assq 'height filtered-cfg)))) (visible (assq 'visibility filtered-cfg))) - (dolist (parameter '(visibility fullscreen width height)) - (setq filtered-cfg (assq-delete-all parameter filtered-cfg))) + (setq filtered-cfg (cl-delete-if (lambda (p) + (memq p '(visibility fullscreen width height))) + filtered-cfg)) (when width (setq filtered-cfg (append `((user-size . t) (width . ,width)) filtered-cfg))) @@ -1312,11 +1333,12 @@ ;; minibufferless frames, ascending ID (let ((dm1 (cdr (assq 'desktop-mini (car state1)))) (dm2 (cdr (assq 'desktop-mini (car state2))))) - (cond ((nth 2 dm1) t) - ((nth 2 dm2) nil) - ((null (car dm2)) t) - ((null (car dm1)) nil) - (t (< (cadr dm1) (cadr dm2)))))) + (cond ((cl-third dm1) t) + ((cl-third dm2) nil) + ((eq (cl-first dm1) (cl-first dm2)) + (< (cl-second dm1) (cl-second dm2))) + (t + (cl-first dm1))))) (defun desktop-restoring-frames-p () "True if calling `desktop-restore-frames' will actually restore frames." @@ -1328,7 +1350,6 @@ being set (usually, by reading it from the desktop)." (when (desktop-restoring-frames-p) (let* ((frame-mb-map nil) ;; Alist of frames with their own minibuffer - (visible nil) (delete-saved (eq desktop-restore-in-current-display 'delete)) (forcing (not (desktop-restore-in-original-display-p))) (target (and forcing (cons 'display (frame-parameter nil 'display))))) @@ -1369,15 +1390,15 @@ (cond ((null d-mini)) ;; No desktop-mini. Process as normal frame. (to-tty) ;; Ignore minibuffer stuff and process as normal frame. - ((car d-mini) ;; Frame has its own minibuffer (or it is minibuffer-only). - (setq num (cadr d-mini)) + ((cl-first d-mini) ;; Frame has minibuffer (or it is minibuffer-only). + (setq num (cl-second d-mini)) (when (eq (cdr (assq 'minibuffer frame-cfg)) 'only) (setq frame-cfg (append '((tool-bar-lines . 0) (menu-bar-lines . 0)) frame-cfg)))) (t ;; Frame depends on other frame's minibuffer window. - (let ((mb-frame (cdr (assq (cadr d-mini) frame-mb-map)))) + (let ((mb-frame (cdr (assq (cl-second d-mini) frame-mb-map)))) (unless (frame-live-p mb-frame) - (error "Minibuffer frame %s not found" (cadr d-mini))) + (error "Minibuffer frame %s not found" (cl-second d-mini))) (let ((mb-param (assq 'minibuffer frame-cfg)) (mb-window (minibuffer-window mb-frame))) (unless (and (window-live-p mb-window) @@ -1390,12 +1411,9 @@ ;; restore the window config. (setq frame (desktop--make-frame frame-cfg window-cfg)) ;; Set default-minibuffer if required. - (when (nth 2 d-mini) (setq default-minibuffer-frame frame)) + (when (cl-third d-mini) (setq default-minibuffer-frame frame)) ;; Store frame/NUM to assign to minibufferless frames. - (when num (push (cons num frame) frame-mb-map)) - ;; Try to locate at least one visible frame. - (when (and (not visible) (frame-visible-p frame)) - (setq visible frame)))) + (when num (push (cons num frame) frame-mb-map)))) (error (delay-warning 'desktop (error-message-string err) :error)))) @@ -1405,12 +1423,13 @@ (ignore-errors (delete-frame frame)))) (setq desktop--reuse-list nil) ;; Make sure there's at least one visible frame, and select it. - (unless (or visible (daemonp)) - (setq visible (if (frame-live-p default-minibuffer-frame) - default-minibuffer-frame - (car (frame-list)))) - (make-frame-visible visible) - (select-frame-set-input-focus visible))))) + (unless (or (daemonp) + (cl-find-if #'frame-visible-p (frame-list))) + (let ((visible (if (frame-live-p default-minibuffer-frame) + default-minibuffer-frame + (car (frame-list))))) + (make-frame-visible visible) + (select-frame-set-input-focus visible)))))) ;;;###autoload (defun desktop-read (&optional dirname) ------------------------------------------------------------ revno: 113484 fixes bug: http://debbugs.gnu.org/14927 committer: Juanma Barranquero branch nick: trunk timestamp: Mon 2013-07-22 03:04:10 +0200 message: lisp/dired-x.el: Fix bug#14927. (dired-mark-unmarked-files, dired-virtual, dired-guess-default) (dired-mark-sexp, dired-filename-at-point): Use string-match-p, looking-at-p. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2013-07-21 17:45:12 +0000 +++ lisp/ChangeLog 2013-07-22 01:04:10 +0000 @@ -1,3 +1,9 @@ +2013-07-22 Juanma Barranquero + + * dired-x.el (dired-mark-unmarked-files, dired-virtual) + (dired-guess-default, dired-mark-sexp, dired-filename-at-point): + Use string-match-p, looking-at-p (bug#14927). + 2013-07-21 Juanma Barranquero * desktop.el (desktop-saved-frame-states): === modified file 'lisp/dired-x.el' --- lisp/dired-x.el 2013-06-21 12:24:37 +0000 +++ lisp/dired-x.el 2013-07-22 01:04:10 +0000 @@ -563,10 +563,10 @@ (dired-mark-if (and ;; not already marked - (looking-at " ") + (looking-at-p " ") ;; uninteresting (let ((fn (dired-get-filename localp t))) - (and fn (string-match regexp fn)))) + (and fn (string-match-p regexp fn)))) msg))) @@ -610,7 +610,7 @@ (interactive (list (read-string "Virtual Dired directory: " (dired-virtual-guess-dir)))) (goto-char (point-min)) - (or (looking-at " ") + (or (looking-at-p " ") ;; if not already indented, do it now: (indent-region (point-min) (point-max) 2)) (or dirname (setq dirname default-directory)) @@ -627,7 +627,7 @@ ;; If raw ls listing (not a saved old dired buffer), give it a ;; decent subdir headerline: (goto-char (point-min)) - (or (looking-at dired-subdir-regexp) + (or (looking-at-p dired-subdir-regexp) (insert " " (directory-file-name (file-name-directory default-directory)) ":\n")) @@ -1089,13 +1089,13 @@ (setq elt (car alist) regexp (car elt) alist (cdr alist)) - (if (string-match regexp file) + (if (string-match-p regexp file) (setq cmds (cdr elt) alist nil))) ;; If more than one file, see if all of FILES match regular expression. (while (and flist - (string-match regexp (car flist))) + (string-match-p regexp (car flist))) (setq flist (cdr flist))) ;; If flist is still non-nil, then do not guess since this means that not @@ -1500,7 +1500,7 @@ (or (dired-move-to-end-of-filename t) (point))) - sym (if (looking-at " -> ") + sym (if (looking-at-p " -> ") (buffer-substring (progn (forward-char 4) (point)) (line-end-position)) "")) @@ -1564,12 +1564,12 @@ (save-excursion ;; First see if just past a filename. (or (eobp) ; why? - (when (looking-at "[] \t\n[{}()]") ; whitespace or some parens + (when (looking-at-p "[] \t\n[{}()]") ; whitespace or some parens (skip-chars-backward " \n\t\r({[]})") (or (bobp) (backward-char 1)))) (let ((filename-chars "-.[:alnum:]_/:$+@") start prefix) - (if (looking-at (format "[%s]" filename-chars)) + (if (looking-at-p (format "[%s]" filename-chars)) (progn (skip-chars-backward filename-chars) (setq start (point) @@ -1577,11 +1577,11 @@ ;; This is something to do with ange-ftp filenames. ;; It convert foo@bar to /foo@bar. ;; But when does the former occur in dired buffers? - (and (string-match + (and (string-match-p "^\\w+@" (buffer-substring start (line-end-position))) "/")) - (if (string-match "[/~]" (char-to-string (preceding-char))) + (if (string-match-p "[/~]" (char-to-string (preceding-char))) (setq start (1- start))) (skip-chars-forward filename-chars)) (error "No file found around point!")) ------------------------------------------------------------ revno: 113483 committer: Juanma Barranquero branch nick: trunk timestamp: Sun 2013-07-21 19:45:12 +0200 message: lisp/desktop.el: Make some frame-restoring functions public. (desktop-saved-frame-states): Rename from desktop--saved-states; all users changed. (desktop-save-frames): Rename from desktop--save-frames. Do not save state to desktop file. (desktop-save): Save desktop-saved-frame-states to desktop file and reset to nil. (desktop-restoring-frames-p): New function. (desktop-restore-frames): Use it. Rename from desktop--restore-frames. (desktop-read): Use desktop-restoring-frames-p. Do not try to fix buffer-lists when restoring frames. Suggested by Martin Rudalics. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2013-07-21 02:53:19 +0000 +++ lisp/ChangeLog 2013-07-21 17:45:12 +0000 @@ -1,5 +1,16 @@ 2013-07-21 Juanma Barranquero + * desktop.el (desktop-saved-frame-states): + Rename from desktop--saved-states; all users changed. + (desktop-save-frames): Rename from desktop--save-frames. + Do not save state to desktop file. + (desktop-save): Save desktop-saved-frame-states to desktop file + and reset to nil. + (desktop-restoring-frames-p): New function. + (desktop-restore-frames): Use it. Rename from desktop--restore-frames. + (desktop-read): Use desktop-restoring-frames-p. Do not try to fix + buffer-lists when restoring frames. Suggested by Martin Rudalics. + * desktop.el: Correctly restore iconified frames. (desktop--filter-iconified-position): New function. (desktop-filter-parameters-alist): Add entries for `top' and `left'. === modified file 'lisp/desktop.el' --- lisp/desktop.el 2013-07-21 04:22:33 +0000 +++ lisp/desktop.el 2013-07-21 17:45:12 +0000 @@ -578,8 +578,9 @@ "Checksum of the last auto-saved contents of the desktop file. Used to avoid writing contents unchanged between auto-saves.") -(defvar desktop--saved-states nil - "Saved window/frame state. Internal use only.") +(defvar desktop-saved-frame-states nil + "Saved state of all frames. +Only valid during frame saving & restoring; intended for internal use.") ;; ---------------------------------------------------------------------------- ;; Desktop file conflict detection @@ -1077,20 +1078,16 @@ (this (cadr (frame-parameter mb-frame 'desktop-mini)))) (set-frame-parameter frame 'desktop-mini (list nil this nil))))))) -(defun desktop--save-frames () - "Save window/frame state, as a global variable. -Intended to be called from `desktop-save'. -Internal use only." - (setq desktop--saved-states +(defun desktop-save-frames () + "Save frame state in `desktop-saved-frame-states'." + (setq desktop-saved-frame-states (and desktop-restore-frames (progn (desktop--save-minibuffer-frames) (mapcar (lambda (frame) (cons (desktop--filter-frame-parms (frame-parameters frame) t) (window-state-get (frame-root-window frame) t))) - (frame-list))))) - (unless (memq 'desktop--saved-states desktop-globals-to-save) - (desktop-outvar 'desktop--saved-states))) + (frame-list)))))) ;;;###autoload (defun desktop-save (dirname &optional release auto-save) @@ -1132,8 +1129,11 @@ (insert "\n;; Global section:\n") ;; Called here because we save the window/frame state as a global ;; variable for compatibility with previous Emacsen. - (desktop--save-frames) + (desktop-save-frames) + (unless (memq 'desktop-saved-frame-states desktop-globals-to-save) + (desktop-outvar 'desktop-saved-frame-states)) (mapc (function desktop-outvar) desktop-globals-to-save) + (setq desktop-saved-frame-states nil) ; after saving desktop-globals-to-save (when (memq 'kill-ring desktop-globals-to-save) (insert "(setq kill-ring-yank-pointer (nthcdr " @@ -1318,10 +1318,15 @@ ((null (car dm1)) nil) (t (< (cadr dm1) (cadr dm2)))))) -(defun desktop--restore-frames () +(defun desktop-restoring-frames-p () + "True if calling `desktop-restore-frames' will actually restore frames." + (and desktop-restore-frames desktop-saved-frame-states)) + +(defun desktop-restore-frames () "Restore window/frame configuration. -Internal use only." - (when (and desktop-restore-frames desktop--saved-states) +This function depends on the value of `desktop-saved-frame-states' +being set (usually, by reading it from the desktop)." + (when (desktop-restoring-frames-p) (let* ((frame-mb-map nil) ;; Alist of frames with their own minibuffer (visible nil) (delete-saved (eq desktop-restore-in-current-display 'delete)) @@ -1330,12 +1335,13 @@ ;; Sorting saved states allows us to easily restore minibuffer-owning frames ;; before minibufferless ones. - (setq desktop--saved-states (sort desktop--saved-states #'desktop--sort-states)) + (setq desktop-saved-frame-states (sort desktop-saved-frame-states + #'desktop--sort-states)) ;; Potentially all existing frames are reusable. Later we will decide which ones ;; to reuse, and how to deal with any leftover. (setq desktop--reuse-list (frame-list)) - (dolist (state desktop--saved-states) + (dolist (state desktop-saved-frame-states) (condition-case err (let* ((frame-cfg (car state)) (window-cfg (cdr state)) @@ -1465,16 +1471,17 @@ (file-error (message "Couldn't record use of desktop file") (sit-for 1)))) - ;; `desktop-create-buffer' puts buffers at end of the buffer list. - ;; We want buffers existing prior to evaluating the desktop (and - ;; not reused) to be placed at the end of the buffer list, so we - ;; move them here. - (mapc 'bury-buffer - (nreverse (cdr (memq desktop-first-buffer (nreverse (buffer-list)))))) - (switch-to-buffer (car (buffer-list))) + (unless (desktop-restoring-frames-p) + ;; `desktop-create-buffer' puts buffers at end of the buffer list. + ;; We want buffers existing prior to evaluating the desktop (and + ;; not reused) to be placed at the end of the buffer list, so we + ;; move them here. + (mapc 'bury-buffer + (nreverse (cdr (memq desktop-first-buffer (nreverse (buffer-list)))))) + (switch-to-buffer (car (buffer-list)))) (run-hooks 'desktop-delay-hook) (setq desktop-delay-hook nil) - (desktop--restore-frames) + (desktop-restore-frames) (run-hooks 'desktop-after-read-hook) (message "Desktop: %d buffer%s restored%s%s." desktop-buffer-ok-count @@ -1486,18 +1493,19 @@ (format ", %d to restore lazily" (length desktop-buffer-args-list)) "")) - ;; Bury the *Messages* buffer to not reshow it when burying - ;; the buffer we switched to above. - (when (buffer-live-p (get-buffer "*Messages*")) - (bury-buffer "*Messages*")) - ;; Clear all windows' previous and next buffers, these have - ;; been corrupted by the `switch-to-buffer' calls in - ;; `desktop-restore-file-buffer' (bug#11556). This is a - ;; brute force fix and should be replaced by a more subtle - ;; strategy eventually. - (walk-window-tree (lambda (window) - (set-window-prev-buffers window nil) - (set-window-next-buffers window nil))) + (unless (desktop-restoring-frames-p) + ;; Bury the *Messages* buffer to not reshow it when burying + ;; the buffer we switched to above. + (when (buffer-live-p (get-buffer "*Messages*")) + (bury-buffer "*Messages*")) + ;; Clear all windows' previous and next buffers, these have + ;; been corrupted by the `switch-to-buffer' calls in + ;; `desktop-restore-file-buffer' (bug#11556). This is a + ;; brute force fix and should be replaced by a more subtle + ;; strategy eventually. + (walk-window-tree (lambda (window) + (set-window-prev-buffers window nil) + (set-window-next-buffers window nil)))) t)) ;; No desktop file found. (desktop-clear) ------------------------------------------------------------ revno: 113482 committer: Paul Eggert branch nick: trunk timestamp: Sun 2013-07-21 08:56:55 -0700 message: * alloc.c (make_save_ptr_ptr): Define this function. It was inadvertently omitted. It's needed only if HAVE_MENUS && ! (USE_X_TOOLKIT || USE_GTK). diff: === modified file 'src/ChangeLog' --- src/ChangeLog 2013-07-21 11:47:07 +0000 +++ src/ChangeLog 2013-07-21 15:56:55 +0000 @@ -1,3 +1,9 @@ +2013-07-21 Paul Eggert + + * alloc.c (make_save_ptr_ptr): Define this function. + It was inadvertently omitted. It's needed only if + HAVE_MENUS && ! (USE_X_TOOLKIT || USE_GTK). + 2013-07-21 Jan Djärv * nsterm.m (sendEvent:): Skip mouse moved if no dialog and no Emacs === modified file 'src/alloc.c' --- src/alloc.c 2013-07-19 17:54:26 +0000 +++ src/alloc.c 2013-07-21 15:56:55 +0000 @@ -3394,6 +3394,19 @@ return val; } +#if defined HAVE_MENUS && ! (defined USE_X_TOOLKIT || defined USE_GTK) +Lisp_Object +make_save_ptr_ptr (void *a, void *b) +{ + Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value); + struct Lisp_Save_Value *p = XSAVE_VALUE (val); + p->save_type = SAVE_TYPE_PTR_PTR; + p->data[0].pointer = a; + p->data[1].pointer = b; + return val; +} +#endif + Lisp_Object make_save_funcptr_ptr_obj (void (*a) (void), void *b, Lisp_Object c) { ------------------------------------------------------------ revno: 113481 fixes bug: http://debbugs.gnu.org/14895 committer: Jan D. branch nick: trunk timestamp: Sun 2013-07-21 13:47:07 +0200 message: * nsterm.m (sendEvent:): Skip mouse moved if no dialog and no Emacs frame have focus. diff: === modified file 'src/ChangeLog' --- src/ChangeLog 2013-07-21 06:53:47 +0000 +++ src/ChangeLog 2013-07-21 11:47:07 +0000 @@ -1,3 +1,8 @@ +2013-07-21 Jan Djärv + + * nsterm.m (sendEvent:): Skip mouse moved if no dialog and no Emacs + frame have focus (Bug#14895). + 2013-07-21 Paul Eggert Avoid vfork-related deadlock more cleanly. === modified file 'src/nsterm.m' --- src/nsterm.m 2013-07-19 01:24:35 +0000 +++ src/nsterm.m 2013-07-21 11:47:07 +0000 @@ -4416,6 +4416,7 @@ { int type = [theEvent type]; NSWindow *window = [theEvent window]; + /* NSTRACE (sendEvent); */ /*fprintf (stderr, "received event of type %d\t%d\n", type);*/ @@ -4469,6 +4470,23 @@ } } + +#ifdef NS_IMPL_COCOA + /* If no dialog and none of our frames have focus and it is a move, skip it. + It is a mouse move in an auxillary menu, i.e. on the top right on OSX, + such as Wifi, sound, date or similar. + This prevents "spooky" highlightning in the frame under the menu. */ + if (type == NSMouseMoved && [NSApp modalWindow] == nil) + { + struct ns_display_info *di; + BOOL has_focus = NO; + for (di = x_display_list; ! has_focus && di; di = di->next) + has_focus = di->x_focus_frame != 0; + if (! has_focus) + return; + } +#endif + [super sendEvent: theEvent]; } ------------------------------------------------------------ revno: 113480 committer: Glenn Morris branch nick: trunk timestamp: Sun 2013-07-21 06:19:07 -0400 message: Auto-commit of generated files. diff: === modified file 'autogen/configure' --- autogen/configure 2013-07-13 10:17:35 +0000 +++ autogen/configure 2013-07-21 10:19:07 +0000 @@ -16442,7 +16442,7 @@ $as_echo "#define PTY_ITERATION int i; for (i = 0; i < 1; i++)" >>confdefs.h - $as_echo "#define PTY_TTY_NAME_SPRINTF { char *ptyname = 0; sigset_t blocked; sigemptyset (&blocked); sigaddset (&blocked, SIGCHLD); pthread_sigmask (SIG_BLOCK, &blocked, 0); if (grantpt (fd) != -1 && unlockpt (fd) != -1) ptyname = ptsname(fd); pthread_sigmask (SIG_UNBLOCK, &blocked, 0); if (!ptyname) { emacs_close (fd); return -1; } snprintf (pty_name, sizeof pty_name, \"%s\", ptyname); }" >>confdefs.h + $as_echo "#define PTY_TTY_NAME_SPRINTF { char *ptyname = 0; sigset_t blocked; sigemptyset (&blocked); sigaddset (&blocked, SIGCHLD); pthread_sigmask (SIG_BLOCK, &blocked, 0); if (grantpt (fd) != -1 && unlockpt (fd) != -1) ptyname = ptsname(fd); pthread_sigmask (SIG_UNBLOCK, &blocked, 0); if (!ptyname) { emacs_close (fd); return -1; } snprintf (pty_name, PTY_NAME_SIZE, \"%s\", ptyname); }" >>confdefs.h if test "x$ac_cv_func_posix_openpt" = xyes; then $as_echo "#define PTY_OPEN fd = posix_openpt (O_RDWR | O_CLOEXEC | O_NOCTTY)" >>confdefs.h @@ -16487,12 +16487,12 @@ ;; sol2* ) - $as_echo "#define PTY_TTY_NAME_SPRINTF { char *ptsname (int), *ptyname; int grantpt_result; sigset_t blocked; sigemptyset (&blocked); sigaddset (&blocked, SIGCHLD); pthread_sigmask (SIG_BLOCK, &blocked, 0); grantpt_result = grantpt (fd); pthread_sigmask (SIG_UNBLOCK, &blocked, 0); if (grantpt_result == -1 || unlockpt (fd) == -1 || !(ptyname = ptsname (fd))) { emacs_close (fd); return -1; } snprintf (pty_name, sizeof pty_name, \"%s\", ptyname); }" >>confdefs.h + $as_echo "#define PTY_TTY_NAME_SPRINTF { char *ptsname (int), *ptyname; int grantpt_result; sigset_t blocked; sigemptyset (&blocked); sigaddset (&blocked, SIGCHLD); pthread_sigmask (SIG_BLOCK, &blocked, 0); grantpt_result = grantpt (fd); pthread_sigmask (SIG_UNBLOCK, &blocked, 0); if (grantpt_result == -1 || unlockpt (fd) == -1 || !(ptyname = ptsname (fd))) { emacs_close (fd); return -1; } snprintf (pty_name, PTY_NAME_SIZE, \"%s\", ptyname); }" >>confdefs.h ;; unixware ) - $as_echo "#define PTY_TTY_NAME_SPRINTF { char *ptsname (int), *ptyname; int grantpt_result; sigset_t blocked; sigemptyset (&blocked); sigaddset (&blocked, SIGCHLD); pthread_sigmask (SIG_BLOCK, &blocked, 0); grantpt_result = grantpt (fd); pthread_sigmask (SIG_UNBLOCK, &blocked, 0); if (grantpt_result == -1) fatal(\"could not grant slave pty\"); if (unlockpt(fd) == -1) fatal(\"could not unlock slave pty\"); if (!(ptyname = ptsname(fd))) fatal (\"could not enable slave pty\"); snprintf (pty_name, sizeof pty_name, \"%s\", ptyname); }" >>confdefs.h + $as_echo "#define PTY_TTY_NAME_SPRINTF { char *ptsname (int), *ptyname; int grantpt_result; sigset_t blocked; sigemptyset (&blocked); sigaddset (&blocked, SIGCHLD); pthread_sigmask (SIG_BLOCK, &blocked, 0); grantpt_result = grantpt (fd); pthread_sigmask (SIG_UNBLOCK, &blocked, 0); if (grantpt_result == -1) fatal(\"could not grant slave pty\"); if (unlockpt(fd) == -1) fatal(\"could not unlock slave pty\"); if (!(ptyname = ptsname(fd))) fatal (\"could not enable slave pty\"); snprintf (pty_name, PTY_NAME_SIZE, \"%s\", ptyname); }" >>confdefs.h ;; esac ------------------------------------------------------------ revno: 113479 committer: Paul Eggert branch nick: trunk timestamp: Sat 2013-07-20 23:53:47 -0700 message: Avoid vfork-related deadlock more cleanly. * callproc.c (child_setup): When the child's exec fails, output the program name, as that's more useful. Use O_NONBLOCK to avoid deadlock. * process.c (create_process_1): Remove; no longer needed. (create_process): Remove timer hack; no longer needed, now that the child avoids deadlock. diff: === modified file 'src/ChangeLog' --- src/ChangeLog 2013-07-21 02:53:19 +0000 +++ src/ChangeLog 2013-07-21 06:53:47 +0000 @@ -1,3 +1,13 @@ +2013-07-21 Paul Eggert + + Avoid vfork-related deadlock more cleanly. + * callproc.c (child_setup): When the child's exec fails, output + the program name, as that's more useful. Use O_NONBLOCK to avoid + deadlock. + * process.c (create_process_1): Remove; no longer needed. + (create_process): Remove timer hack; no longer needed, now that + the child avoids deadlock. + 2013-07-20 Glenn Morris * image.c (Fimage_flush): Fix doc typo. === modified file 'src/callproc.c' --- src/callproc.c 2013-07-17 04:37:27 +0000 +++ src/callproc.c 2013-07-21 06:53:47 +0000 @@ -1193,6 +1193,7 @@ { char **env; char *pwd_var; + int exec_errno; #ifdef WINDOWSNT int cpid; HANDLE handles[3]; @@ -1368,13 +1369,16 @@ tcsetpgrp (0, pid); execve (new_argv[0], new_argv, env); - - /* Don't output the program name here, as it can be arbitrarily long, - and a long write from a vforked child to its parent can cause a - deadlock. */ - emacs_perror ("child process"); - - _exit (errno == ENOENT ? EXIT_ENOENT : EXIT_CANNOT_INVOKE); + exec_errno = errno; + + /* Avoid deadlock if the child's perror writes to a full pipe; the + pipe's reader is the parent, but with vfork the parent can't + run until the child exits. Truncate the diagnostic instead. */ + fcntl (STDERR_FILENO, F_SETFL, O_NONBLOCK); + + errno = exec_errno; + emacs_perror (new_argv[0]); + _exit (exec_errno == ENOENT ? EXIT_ENOENT : EXIT_CANNOT_INVOKE); #else /* MSDOS */ pid = run_msdos_command (new_argv, pwd_var + 4, in, out, err, env); === modified file 'src/process.c' --- src/process.c 2013-07-20 15:33:00 +0000 +++ src/process.c 2013-07-21 06:53:47 +0000 @@ -1599,12 +1599,6 @@ remove_process (proc); } -static void -create_process_1 (struct atimer *timer) -{ - /* Nothing to do. */ -} - static void create_process (Lisp_Object process, char **new_argv, Lisp_Object current_dir) @@ -1841,14 +1835,13 @@ unblock_child_signal (); unblock_input (); + if (forkin >= 0) + emacs_close (forkin); + if (forkin != forkout && forkout >= 0) + emacs_close (forkout); + if (pid < 0) - { - if (forkin >= 0) - emacs_close (forkin); - if (forkin != forkout && forkout >= 0) - emacs_close (forkout); - report_file_errno ("Doing vfork", Qnil, vfork_errno); - } + report_file_errno ("Doing vfork", Qnil, vfork_errno); else { /* vfork succeeded. */ @@ -1857,26 +1850,6 @@ register_child (pid, inchannel); #endif /* WINDOWSNT */ - /* If the subfork execv fails, and it exits, - this close hangs. I don't know why. - So have an interrupt jar it loose. */ - { - struct atimer *timer; - EMACS_TIME offset = make_emacs_time (1, 0); - - stop_polling (); - timer = start_atimer (ATIMER_RELATIVE, offset, create_process_1, 0); - - if (forkin >= 0) - emacs_close (forkin); - - cancel_atimer (timer); - start_polling (); - } - - if (forkin != forkout && forkout >= 0) - emacs_close (forkout); - pset_tty_name (XPROCESS (process), lisp_pty_name); #ifndef WINDOWSNT