;; URL: https://github.com/skeeto/emacs-http-server
-;; Package-Version: 20230821.1458
-;; Package-Revision: 347c30494d3b
-;; Package-Requires: ((cl-lib "0.3"))
+;; Package-Version: 20260623.1110
+;; Package-Revision: ceb208f96601
+;; Package-Requires: ((emacs "29.1") (compat "31"))
+;; Keywords: network, comm
;;; Commentary:
-;; Use `httpd-start' to start the web server. Files are served from
+;; Use `httpd-start' to start the web server. Files are served from
;; `httpd-root' on port `httpd-port' using `httpd-ip-family' at host
-;; `httpd-host'. While the root can be changed at any time, the server
+;; `httpd-host'. While the root can be changed at any time, the server
;; needs to be restarted in order for a port change to take effect.
;; Everything is performed by servlets, including serving
-;; files. Servlets are enabled by setting `httpd-servlets' to true
-;; (default). Servlets are four-parameter functions that begin with
+;; files. Servlets are enabled by setting `httpd-servlets' to true
+;; (default). Servlets are four-parameter functions that begin with
;; "httpd/" where the trailing component specifies the initial path on
-;; the server. For example, the function `httpd/hello-world' will be
+;; the server. For example, the function `httpd/hello-world' will be
;; called for the request "/hello-world" and "/hello-world/foo".
;; The default servlet `httpd/' is the one that serves files from
;; `httpd-root' and can be turned off through redefinition or setting
-;; `httpd-serve-files' to nil. It is used even when `httpd-servlets'
+;; `httpd-serve-files' to nil. It is used even when `httpd-servlets'
;; is nil.
;; The four parameters for a servlet are process, URI path, GET/POST
;; arguments (alist), and the full request object (header
-;; alist). These are ordered by general importance so that some can be
-;; ignored. Two macros are provided to help with writing servlets.
+;; alist). These are ordered by general importance so that some can be
+;; ignored. Two macros are provided to help with writing servlets.
-;; * `with-httpd-buffer' -- Creates a temporary buffer that is
+;; * `httpd-with-buffer' -- Creates a temporary buffer that is
;; automatically served to the client at the end of the body.
;; Additionally, `standard-output' is set to this output
-;; buffer. For example, this servlet says hello,
+;; buffer. For example, this servlet says hello,
;; (defun httpd/hello-world (proc path &rest args)
-;; (with-httpd-buffer proc "text/plain"
+;; (httpd-with-buffer proc "text/plain"
;; (insert "hello, " (file-name-nondirectory path))))
;; This servlet be viewed at http://localhost:8080/hello-world/Emacs
-;; * `defservlet' -- Similar to the above macro but totally hides the
-;; process object from the servlet itself. The above servlet can be
+;; * `httpd-servlet' -- Similar to the above macro but totally hides the
+;; process object from the servlet itself. The above servlet can be
;; re-written identically like so,
-;; (defservlet hello-world text/plain (path)
+;; (httpd-servlet hello-world text/plain (path)
;; (insert "hello, " (file-name-nondirectory path)))
-;; Note that `defservlet' automatically sets `httpd-current-proc'. See
-;; below.
+;; Note that `httpd-servlet' automatically sets `httpd-current-proc'.
+;; See below.
;; The "function parameters" part can be left empty or contain up to
;; three parameters corresponding to the final three servlet
-;; parameters. For example, a servlet that shows *scratch* and doesn't
+;; parameters. For example, a servlet that shows *scratch* and doesn't
;; need parameters,
-;; (defservlet scratch text/plain ()
+;; (httpd-servlet scratch text/plain ()
;; (insert-buffer-substring (get-buffer-create "*scratch*")))
-;; A higher level macro `defservlet*' wraps this lower-level
-;; `defservlet' macro, automatically binding variables to components
-;; of the request. For example, this binds parts of the request path
-;; and one query parameter. Request components not provided by the
+;; A higher level macro `httpd-servlet*' wraps this lower-level
+;; `httpd-servlet' macro, automatically binding variables to components
+;; of the request. For example, this binds parts of the request path
+;; and one query parameter. Request components not provided by the
;; client are bound to nil.
-;; (defservlet* packages/:package/:version text/plain (verbose)
+;; (httpd-servlet* packages/:package/:version text/plain (verbose)
;; (insert (format "%s\n%s\n" package version))
;; (princ (get-description package version))
;; (when verbose
@@ -84,118 +86,85 @@
;; * `httpd-redirect' -- redirect the browser to another url
;; * `httpd-send-header' -- send custom headers
;; * `httpd-error' -- report an error to the client
-;; * `httpd-log' -- log an object to *httpd*
+;; * `httpd-log' -- log an object to the `httpd-log-buffer'
;; Some of these functions require a process object, which isn't
-;; passed to `defservlet' servlets. Use t in place of the process
+;; passed to `httpd-servlet' servlets. Use t in place of the process
;; argument to use `httpd-current-proc' (like `standard-output').
;; If you just need to serve static from some location under some
-;; route on the server, use `httpd-def-file-servlet'. It expands into
-;; a `defservlet' that serves files.
-
-;;; History:
-
-;; Version 1.5.1: improvements
-;; * Add `httpd-running-p'
-;; * Properly handle "Connection: close" and HTTP/1.0
-;; Version 1.5.0: improvements
-;; * Drastically improved performance for large requests
-;; * More HTTP status codes
-;; Version 1.4.6: fixes
-;; * Added httpd-serve-directory
-;; * Fix some encoding issues
-;; Version 1.4.5: fixes
-;; * Update to cl-lib from cl
-;; Version 1.4.4: features
-;; * Common Lisp &key-like defservlet* argument support
-;; * Fix up some defservlet* usage warnings.
-;; Version 1.4.3: features
-;; * Add `httpd-discard-buffer'
-;; * Add `httpd-def-file-servlet'
-;; * Be more careful about not sending extra headers
-;; Version 1.4.2: features, fixes
-;; * `defservlet*' macro
-;; Version 1.4.1: small bug fixes, one feature
-;; * All mime-type parameters now accept string designators
-;; * Documentation update
-;; Version 1.4.0: features, API change, and fixes
-;; * Removed httpd-send-buffer; httpd-send-header now does this implicitly
-;; * httpd-send-header now accepts keywords instead
-;; * Fix httpd-clean-path in Windows
-;; * Fix a content-length bug
-;; * defservlet fontification
-;; Version 1.3.1: features and fixes
-;; * Set `standard-output' in `with-httpd-buffer'
-;; Version 1.3.0: security fix
-;; * Fix path expansion security issue
-;; * Fix coding system (don't default)
-;; Version 1.2.4: fixes
-;; * Handle large POSTs
-;; * Fix date strings
+;; route on the server, use `httpd-file-servlet'. It expands into
+;; a `httpd-servlet' that serves files.
;;; Code:
+(eval-when-compile (require 'subr-x))
(require 'cl-lib)
(require 'pp)
(require 'url-util)
+(require 'compat)
(defgroup simple-httpd nil
"A simple web server."
- :group 'comm)
+ :link '(url-link :tag "Website" "https://github.com/skeeto/emacs-http-server")
+ :link '(emacs-library-link :tag "Library Source" "simple-httpd.el")
+ :group 'network
+ :group 'comm
+ :group 'web
+ :prefix "httpd-")
(defcustom httpd-ip-family 'ipv4
"Web server IP family used by `make-network-process'."
- :group 'simple-httpd
:type 'symbol)
(defcustom httpd-host nil
"Web server host name used by `make-network-process'."
- :group 'simple-httpd
:type '(choice (const nil) (const local) string))
(defcustom httpd-port 8080
"Web server port."
- :group 'simple-httpd
- :type 'integer)
+ :type 'natnum)
(defcustom httpd-root "~/public_html"
"Web server file root."
- :group 'simple-httpd
- :type 'directory)
+ :type '(choice (const nil) directory))
(defcustom httpd-serve-files t
"Enable serving files from `httpd-root'."
- :group 'simple-httpd
:type 'boolean)
(defcustom httpd-listings t
"If true, serve directory listings."
- :group 'simple-httpd
:type 'boolean)
(defcustom httpd-servlets t
"Enable servlets."
- :group 'simple-httpd
:type 'boolean)
+(defcustom httpd-log-buffer "*httpd*"
+ "Buffer for log messages.
+Set to nil to disable logging."
+ :type '(choice (const nil) string))
+
(defcustom httpd-show-backtrace-when-error nil
"If true, show backtrace on error page."
- :group 'simple-httpd
:type 'boolean)
(defcustom httpd-start-hook nil
"Hook to run when the server has started."
- :group 'simple-httpd
:type 'hook)
(defcustom httpd-stop-hook nil
"Hook to run when the server has stopped."
- :group 'simple-httpd
:type 'hook)
-(defvar httpd-server-name (format "simple-httpd (Emacs %s)" emacs-version)
- "String to use in the Server header.")
+(defcustom httpd-filter-functions nil
+ "Functions called with request as argument, should return modified request."
+ :type 'hook)
+
+(defcustom httpd-server-name (format "simple-httpd (Emacs %s)" emacs-version)
+ "String to use in the Server header."
+ :type '(choice (const nil) string))
(defvar httpd-mime-types
'(("png" . "image/png")
@@ -204,18 +173,20 @@
("jpeg" . "image/jpeg")
("tif" . "image/tif")
("tiff" . "image/tiff")
+ ("webp" . "image/webp")
("ico" . "image/x-icon")
("svg" . "image/svg+xml")
- ("css" . "text/css; charset=utf-8")
- ("htm" . "text/html; charset=utf-8")
- ("html" . "text/html; charset=utf-8")
- ("xml" . "text/xml; charset=utf-8")
- ("rss" . "text/xml; charset=utf-8")
- ("atom" . "text/xml; charset=utf-8")
- ("txt" . "text/plain; charset=utf-8")
- ("el" . "text/plain; charset=utf-8")
- ("js" . "text/javascript; charset=utf-8")
- ("md" . "text/x-markdown; charset=utf-8")
+ ("css" . "text/css")
+ ("htm" . "text/html")
+ ("html" . "text/html")
+ ("xml" . "text/xml")
+ ("rss" . "text/xml")
+ ("atom" . "text/xml")
+ ("txt" . "text/plain")
+ ("el" . "text/plain")
+ ("js" . "text/javascript")
+ ("md" . "text/markdown")
+ ("org" . "text/org")
("gz" . "application/octet-stream")
("ps" . "application/postscript")
("eps" . "application/postscript")
@@ -308,266 +279,364 @@
"HTTP status codes.")
(defvar httpd-html
- '((403 . "
-
-403 Forbidden
-
-Forbidden
-The requested URL is forbidden.
-%s
-")
- (404 . "
-
-404 Not Found
-
-Not Found
+ '((404 . "
+%2$s %3$s
+%2$s %3$s
The requested URL was not found on this server.
-%s
-")
- (500 . "
-
-500 Internal Error
-
-500 Internal Error
-Internal error when handling this request.
-%s
+%1$s
")
+ (t . "
+%2$s %3$s
+%2$s %3$s
+An error occurred.
+%1$s
"))
"HTML for various errors.")
+(defvar httpd--server nil
+ "Server process.")
+
+(defvar httpd--clients nil
+ "Client processes.")
+
;; User interface
;;;###autoload
(defun httpd-start ()
- "Start the web server process. If the server is already
-running, this will restart the server. There is only one server
-instance per Emacs instance."
+ "Start the web server process.
+If the server is already running, this will restart the server. There
+is only one server instance per Emacs instance."
(interactive)
(httpd-stop)
- (httpd-log `(start ,(current-time-string)))
- (make-network-process
- :name "httpd"
- :service httpd-port
- :server t
- :host httpd-host
- :family httpd-ip-family
- :filter 'httpd--filter
- :coding 'binary
- :log 'httpd--log)
+ (httpd-log `(start ,(httpd-date-string)))
+ (setq httpd--server
+ (make-network-process
+ :name "httpd"
+ :service httpd-port
+ :server t
+ :host httpd-host
+ :family httpd-ip-family
+ :filter #'httpd--filter
+ :coding 'binary
+ :log #'httpd--accept))
(run-hooks 'httpd-start-hook))
;;;###autoload
(defun httpd-stop ()
"Stop the web server if it is currently running, otherwise do nothing."
(interactive)
- (when (process-status "httpd")
- (delete-process "httpd")
- (httpd-log `(stop ,(current-time-string)))
+ (when (httpd-running-p)
+ (mapc #'delete-process httpd--clients)
+ (delete-process httpd--server)
+ (setq httpd--server nil
+ httpd--clients nil)
+ (httpd-log `(stop ,(httpd-date-string)))
(run-hooks 'httpd-stop-hook)))
;;;###autoload
(defun httpd-running-p ()
"Return non-nil if the simple-httpd server is running."
- (not (null (process-status "httpd"))))
+ (process-live-p httpd--server))
;;;###autoload
-(defun httpd-serve-directory (directory)
- "Start the web server with given `directory' as `httpd-root'."
+(defun httpd-serve-directory (&optional directory)
+ "Start the web server with given DIRECTORY as `httpd-root'.
+If DIRECTORY is nil use the current `default-directory'."
(interactive "DServe directory: \n")
- (setf httpd-root directory)
+ (setq httpd-root (or directory default-directory))
(httpd-start)
(message "Started simple-httpd on %s:%d, serving: %s"
(cl-case httpd-host
- ((nil) "0.0.0.0")
- ((local) "localhost")
- (otherwise httpd-host)) httpd-port directory))
+ ((nil local) "localhost")
+ (otherwise httpd-host))
+ httpd-port directory))
(defun httpd-batch-start ()
"Never returns, holding the server open indefinitely for batch mode.
-Logs are redirected to stdout. To use, invoke Emacs like this:
-emacs -Q -batch -l simple-httpd.elc -f httpd-batch-start"
- (if (not noninteractive)
- (error "Only use `httpd-batch-start' in batch mode!")
- (httpd-start)
- (defalias 'httpd-log 'pp)
- (while t (sleep-for 60))))
+Logs are redirected to stdout. To use, invoke Emacs like this:
+ \"emacs -Q -batch -l simple-httpd.elc -f httpd-batch-start\""
+ (unless noninteractive
+ (error "Only use `httpd-batch-start' in batch mode"))
+ (httpd-start)
+ (fset #'httpd-log #'pp)
+ (while t (sleep-for 60)))
;; Utility
(defun httpd-date-string (&optional date)
- "Return an HTTP date string (RFC 1123)."
- (format-time-string "%a, %e %b %Y %T GMT" date t))
+ "Return DATE as HTTP date string (RFC 1123)."
+ (format-time-string "%a, %d %b %Y %T GMT" date t))
(defun httpd-etag (file)
"Compute the ETag for FILE."
(concat "\"" (substring (sha1 (prin1-to-string (file-attributes file))) -16)
"\""))
-(defun httpd--stringify (designator)
- "Turn a string designator into a string."
- (let ((string (format "%s" designator)))
- (if (keywordp designator)
- (substring string 1)
- string)))
+(defun httpd--stringify (obj)
+ "Turn OBJ into a string, e.g., symbols, keywords or strings."
+ (cond
+ ((stringp obj) obj)
+ ((keywordp obj) (substring (symbol-name obj) 1))
+ ((symbolp obj) (symbol-name obj))
+ (t (format "%s" obj))))
;; Networking code
(defun httpd--connection-close-p (request)
- "Return non-nil if the client requested \"connection: close\"."
- (or (equal '("close") (cdr (assoc "Connection" request)))
- (equal '("HTTP/1.0") (cddr (assoc "GET" request)))))
+ "Return non-nil if the REQUEST has \"connection: close\"."
+ (let ((conn (cadr (assoc "Connection" request))))
+ (or (and (stringp conn) (string-equal-ignore-case conn "close"))
+ (equal "HTTP/1.0" (caddar request)))))
+
+(defun httpd--parse-content-args (request)
+ "Parse arguments in content string of REQUEST."
+ (when-let* ((content-type (cadr (assoc "Content-Type" request)))
+ ((string-prefix-p "application/x-www-form-urlencoded"
+ content-type)))
+ (httpd-parse-args (cadr (assoc "Content" request)))))
+
+(defun httpd--handle-request (proc request)
+ "Handle REQUEST from client PROC."
+ (condition-case err
+ (let* ((_ (run-hook-wrapped
+ 'httpd-filter-functions
+ (lambda (fun)
+ (setq request (funcall fun request))
+ nil)))
+ (uri (cadar request))
+ (parsed-uri (httpd-parse-uri (concat uri)))
+ (uri-path (car parsed-uri))
+ (uri-query (nconc (cadr parsed-uri)
+ (httpd--parse-content-args request)))
+ (servlet (httpd-get-servlet uri-path)))
+ (httpd-log `(request
+ (date ,(httpd-date-string))
+ (address ,(car (process-contact proc)))
+ (path ,uri-path)
+ (query ,uri-query)
+ (servlet ,servlet)
+ (headers . ,request)))
+ (process-put proc :request-active request)
+ (funcall servlet proc uri-path uri-query request))
+ (error
+ (httpd--error-safe proc 500 err))))
+
+(defun httpd--content-string (len)
+ "Return request content of length LEN if it is fully transmitted.
+Return nil if transmission is incomplete."
+ (if (> len 0)
+ (when (>= (buffer-size) len)
+ (prog1 (buffer-substring (point-min) (setq len (+ (point-min) len)))
+ (delete-region (point-min) len)))
+ ""))
+
+(defun httpd--content-length (request)
+ "Return content length of REQUEST."
+ (let* ((te (cadr (assoc "Transfer-Encoding" request)))
+ (len (cadr (assoc "Content-Length" request))))
+ (when (and (or (not te) (string-equal-ignore-case te "identity"))
+ (or (not len) (string-match-p "\\`[0-9]+\\'" len)))
+ (if len (string-to-number len) 0))))
(defun httpd--filter (proc chunk)
- "Runs each time client makes a request."
+ "Process called each time client makes a request.
+PROC is the client process and CHUNK is part of the request as string."
(with-current-buffer (process-get proc :request-buffer)
(goto-char (point-max))
(insert chunk)
- (let ((request (process-get proc :request)))
- (unless request
- (when (setf request (httpd-parse))
- (delete-region (point-min) (point))
- (process-put proc :request request)))
- (when request
- (let ((content-length (cadr (assoc "Content-Length" request))))
- (when (or (null content-length)
- (= (buffer-size) (string-to-number content-length)))
- (let* ((content (buffer-string))
- (uri (cl-cadar request))
- (parsed-uri (httpd-parse-uri (concat uri)))
- (uri-path (httpd-unhex (nth 0 parsed-uri)))
- (uri-query (append (nth 1 parsed-uri)
- (httpd-parse-args content)))
- (servlet (httpd-get-servlet uri-path)))
- (erase-buffer)
- (process-put proc :request nil)
- (setf request (nreverse (cons (list "Content" content)
- (nreverse request))))
- (httpd-log `(request (date ,(httpd-date-string))
- (address ,(car (process-contact proc)))
- (get ,uri-path)
- ,(cons 'headers request)))
- (if (null servlet)
- (httpd--error-safe proc 404)
- (condition-case error-case
- (funcall servlet proc uri-path uri-query request)
- (error (httpd--error-safe proc 500 error-case))))
- (when (httpd--connection-close-p request)
- (process-send-eof proc)))))))))
+ (let ((continue t) (request nil))
+ (while continue
+ (setq continue nil
+ request (process-get proc :request-pending))
+ (when (and (not request) (setq request (httpd-parse)))
+ (process-put proc :request-pending request)
+ (delete-region (point-min) (point)))
+ (cond
+ (request
+ (if-let* ((len (httpd--content-length request)))
+ (when-let* ((content (httpd--content-string len)))
+ (process-put proc :request-pending nil)
+ (httpd--push-request proc (nconc request `(("Content" ,content))))
+ (setq continue t))
+ (httpd--push-request proc `(("GET" "/error?status=411" "HTTP/1.1")
+ ("Connection" "close")))))
+ ((looking-at-p "[^\r\n]*[\r\n]")
+ (httpd--push-request proc '(("GET" "/error?status=400" "HTTP/1.1")
+ ("Connection" "close"))))))))
+ (httpd--pop-request proc))
-(defun httpd--log (server proc message)
- "Runs each time a new client connects."
- (with-current-buffer (generate-new-buffer " *httpd-client*")
- (process-put proc :request-buffer (current-buffer)))
+(defun httpd--push-request (proc request)
+ "Push REQUEST to client PROC queue."
+ (cl-callf (lambda (q) (nconc q (list request)))
+ (process-get proc :request-queue)))
+
+(defun httpd--pop-request (proc)
+ "Pop request from client PROC queue and handle it."
+ (when-let* (((not (process-get proc :request-active)))
+ (request (pop (process-get proc :request-queue))))
+ (run-at-time 0 nil #'httpd--handle-request proc request)))
+
+(defun httpd--accept (_server proc _message)
+ "Runs each time a new client PROC connects to the server."
+ (push proc httpd--clients)
+ (process-put proc :request-buffer (generate-new-buffer " *httpd-client*" t))
(set-process-sentinel proc #'httpd--sentinel)
- (httpd-log (list 'connection (car (process-contact proc)))))
+ (httpd-log `(connection ,(car (process-contact proc)))))
(defun httpd--sentinel (proc message)
- "Runs when a client closes the connection."
- (unless (string-match-p "^open " message)
- (let ((buffer (process-get proc :request-buffer)))
- (when buffer
- (kill-buffer buffer)))))
+ "Runs when a client PROC closes the connection.
+MESSAGE describes the state change."
+ (unless (string-prefix-p "open " message)
+ (httpd-log `(close ,(car (process-contact proc))))
+ (cl-callf2 delq proc httpd--clients)
+ (when-let* ((buffer (process-get proc :request-buffer)))
+ (kill-buffer buffer))))
;; Logging
+(defun httpd--log (item)
+ "Pretty print ITEM to the log."
+ (with-current-buffer (get-buffer-create httpd-log-buffer)
+ (setq buffer-read-only t
+ truncate-lines t)
+ (with-silent-modifications
+ (let* ((win (get-buffer-window))
+ (follow (and win (= (window-point win) (point-max)))))
+ (save-excursion
+ (goto-char (point-max))
+ (pp item (current-buffer)))
+ (when follow
+ (set-window-point win (point-max)))))))
+
(defun httpd-log (item)
- "Pretty print a lisp object to the log."
- (with-current-buffer (get-buffer-create "*httpd*")
- (setf buffer-read-only nil)
- (let ((follow (= (point) (point-max))))
- (save-excursion
- (goto-char (point-max))
- (pp item (current-buffer)))
- (if follow (goto-char (point-max))))
- (setf truncate-lines t
- buffer-read-only t)
- (set-buffer-modified-p nil)))
+ "Pretty print ITEM to the log.
+If `httpd-log-buffer' is nil, ITEM may not be evaluated."
+ (declare (compiler-macro
+ (lambda (_)
+ `(when httpd-log-buffer
+ (httpd--log ,item)))))
+ (when httpd-log-buffer
+ (httpd--log item)))
;; Servlets
(defvar httpd-current-proc nil
"The process object currently in use.")
-(defvar httpd--header-sent nil
+(defvar-local httpd--header-sent nil
"Buffer-local variable indicating if the header has been sent.")
-(make-variable-buffer-local 'httpd--header-sent)
-(defun httpd-resolve-proc (proc)
- "Return the correct process to use. This handles `httpd-current-proc'."
+(defsubst httpd--resolve-proc (proc)
+ "Return the correct process to use.
+Return `httpd-current-proc' if PROC is t."
(if (eq t proc) httpd-current-proc proc))
-(defmacro with-httpd-buffer (proc mime &rest body)
- "Create a temporary buffer, set it as the current buffer, and,
-at the end of body, automatically serve it to an HTTP client with
-an HTTP header indicating the specified MIME type. Additionally,
-`standard-output' is set to this output buffer and
-`httpd-current-proc' is set to PROC."
+(defmacro httpd--ensure-buffer (&rest body)
+ "Ensure that BODY is executed in a temporary httpd buffer.
+Reuse the current buffer if it is a temporary httpd buffer."
+ (declare (indent 0) (debug t))
+ (cl-with-gensyms (temp)
+ `(let (,temp)
+ (with-current-buffer
+ (if (eq major-mode 'httpd-buffer)
+ (current-buffer)
+ (setq ,temp (generate-new-buffer " *httpd-temp*" t)))
+ (unwind-protect
+ (progn
+ (setq major-mode 'httpd-buffer)
+ ,@body)
+ (when (buffer-live-p ,temp)
+ (kill-buffer ,temp)))))))
+
+(defmacro httpd-with-buffer (proc mime &rest body)
+ "Create temporary buffer and serve it to the client.
+Create a temporary buffer, set it as the current buffer, and, at the end
+of body, automatically serve it to an HTTP client with an HTTP header
+indicating the specified MIME type. Additionally, `standard-output' is
+set to this output buffer and `httpd-current-proc' is set to PROC."
(declare (indent defun))
- (let ((proc-sym (make-symbol "--proc--")))
- `(let ((,proc-sym ,proc))
- (with-temp-buffer
- (setf major-mode 'httpd-buffer)
- (let ((standard-output (current-buffer))
- (httpd-current-proc ,proc-sym))
- ,@body)
- (unless httpd--header-sent
- (httpd-send-header ,proc-sym ,mime 200))))))
+ (cl-once-only (proc)
+ `(httpd--ensure-buffer
+ (let ((standard-output (current-buffer))
+ (httpd-current-proc ,proc))
+ ,@body)
+ (unless httpd--header-sent
+ (httpd-send-header ,proc ,mime 200)))))
(defun httpd-discard-buffer ()
- "Don't respond using current server buffer (`with-httpd-buffer').
-Returns a process for future response."
- (when (eq major-mode 'httpd-buffer) (setf httpd--header-sent t))
+ "Don't respond using current server buffer (`httpd-with-buffer').
+Returns a process for future response.
+
+ (httpd-servlet slow text/plain ()
+ (let ((proc (httpd-discard-buffer)))
+ (run-at-time 1 0
+ (lambda ()
+ (ignore-errors
+ (httpd-with-buffer proc \"text/plain\"
+ (insert \"Slow response\")))))))"
+ (when (eq major-mode 'httpd-buffer) (setq httpd--header-sent t))
httpd-current-proc)
-(defmacro defservlet (name mime path-query-request &rest body)
- "Defines a simple httpd servelet. The servlet runs in a
-temporary buffer which is automatically served to the client
-along with a header.
+(defmacro httpd-servlet (name mime path-query-request &rest body)
+ "Defines a simple httpd servlet.
+
+NAME is the servlet name as symbol.
+MIME the mime-type as symbol.
+PATH-QUERY-REQUEST is the argument list.
+BODY is the function body.
+
+The servlet runs in a temporary buffer which is automatically served to
+the client along with a header.
A servlet that serves the contents of *scratch*,
- (defservlet scratch text/plain ()
+ (httpd-servlet scratch text/plain ()
(insert-buffer-substring (get-buffer-create \"*scratch*\")))
A servlet that says hello,
- (defservlet hello-world text/plain (path)
+ (httpd-servlet hello-world text/plain (path)
(insert \"hello, \" (file-name-nondirectory path))))"
(declare (indent defun))
- (let ((proc-sym (make-symbol "proc"))
- (fname (intern (concat "httpd/" (symbol-name name)))))
- `(defun ,fname (,proc-sym ,@path-query-request &rest ,(cl-gensym))
- (with-httpd-buffer ,proc-sym ,(httpd--stringify mime)
- ,@body))))
+ (cl-with-gensyms (proc-sym rest-sym)
+ (let ((fname (intern (concat "httpd/" (symbol-name name)))))
+ `(defun ,fname (,proc-sym ,@path-query-request &rest ,rest-sym)
+ (httpd-with-buffer ,proc-sym ,(httpd--stringify mime)
+ ,@body)))))
(defun httpd-parse-endpoint (symbol)
- "Parse an endpoint definition template for use with `defservlet*'."
+ "Parse an endpoint template SYMBOL for use with `httpd-servlet*'."
(cl-loop for item in (split-string (symbol-name symbol) "/")
for n upfrom 0
when (and (> (length item) 0) (eql (aref item 0) ?:))
collect (cons (intern (substring item 1)) n) into vars
else collect item into path
- finally
- (cl-return
- (cl-values (intern (mapconcat #'identity path "/")) vars))))
+ finally return
+ (cl-values (intern (string-join path "/")) vars)))
(defvar httpd-path nil
- "Anaphoric variable for `defservlet*'.")
+ "Dynamic variable bound by `httpd-servlet*'.")
(defvar httpd-query nil
- "Anaphoric variable for `defservlet*'.")
+ "Dynamic variable bound by `httpd-servlet*'.")
(defvar httpd-request nil
- "Anaphoric variable for `defservlet*'.")
+ "Dynamic variable bound by `httpd-servlet*'.")
(defvar httpd-split-path nil
- "Anaphoric variable for `defservlet*'.")
+ "Dynamic variable bound by `httpd-servlet*'.")
-(defmacro defservlet* (endpoint mime args &rest body)
- "Like `defservlet', but automatically bind variables/arguments
-to the request. Trailing components of the ENDPOINT can be bound
-by prefixing these components with a colon, acting like a template.
+(defmacro httpd-servlet* (endpoint mime args &rest body)
+ "Like `httpd-servlet', but bind variables/arguments to the request.
- (defservlet* packages/:package/:version text/plain (verbose)
+ENDPOINT is the path as symbol.
+MIME the mime-type as symbol.
+ARGS is the argument list.
+BODY is the function body.
+
+Trailing components of the ENDPOINT can be bound by prefixing these
+components with a colon, acting like a template.
+
+ (httpd-servlet* packages/:package/:version text/plain (verbose)
(insert (format \"%s\\n%s\\n\" package version))
(princ (get-description package version))
(when verbose
@@ -578,93 +647,80 @@ When accessed from this URL,
http://example.com/packages/foobar/1.0?verbose=1
the variables package, version, and verbose will be bound to the
-associated components of the URL. Components not provided are
-bound to nil. The query arguments can use the Common Lisp &key
+associated components of the URL. Components not provided are
+bound to nil. The query arguments can use the Common Lisp &key
form (variable default provided-p).
- (defservlet* greeting/:name text/plain ((greeting \"hi\" greeting-p))
+ (httpd-servlet* greeting/:name text/plain ((greeting \"hi\" greeting-p))
(princ (format \"%s, %s (provided: %s)\" greeting name greeting-p)))
-The original path, query, and request can be accessed by the
-anaphoric special variables `httpd-path', `httpd-query', and
-`httpd-request'."
+The original path, query, and request can be accessed by the dynamically
+bound variables `httpd-path', `httpd-query', and `httpd-request'."
(declare (indent defun))
- (let ((path-lexical (cl-gensym))
- (query-lexical (cl-gensym))
- (request-lexical (cl-gensym)))
+ (cl-with-gensyms (path-lexical query-lexical request-lexical)
(cl-multiple-value-bind (path vars) (httpd-parse-endpoint endpoint)
- `(defservlet ,path ,mime (,path-lexical ,query-lexical ,request-lexical)
+ `(httpd-servlet ,path ,mime (,path-lexical ,query-lexical ,request-lexical)
(let ((httpd-path ,path-lexical)
(httpd-query ,query-lexical)
(httpd-request ,request-lexical)
(httpd-split-path (split-string
(substring ,path-lexical 1) "/")))
(let ,(cl-loop for (var . pos) in vars
- for extract =
- `(httpd-unhex (nth ,pos httpd-split-path))
+ for extract = `(nth ,pos httpd-split-path)
collect (list var extract))
(let ,(cl-loop for arg in args
for has-default = (listp arg)
for has-default-p = (and has-default
(= 3 (length arg)))
for arg-name = (symbol-name
- (if has-default (cl-first arg) arg))
+ (if has-default (car arg) arg))
when has-default collect
- (list (cl-first arg)
+ (list (car arg)
`(let ((value (assoc ,arg-name httpd-query)))
(if value
- (cl-second value)
- ,(cl-second arg))))
+ (cadr value)
+ ,(cadr arg))))
else collect
- (list arg `(cl-second
+ (list arg `(cadr
(assoc ,arg-name httpd-query)))
when has-default-p collect
- (list (cl-third arg)
+ (list (caddr arg)
`(not (null (assoc ,arg-name httpd-query)))))
,@body)))))))
-(font-lock-add-keywords
- 'emacs-lisp-mode
- '(("(\\<\\(defservlet\\*?\\)\\> +\\([^ ()]+\\) +\\([^ ()]+\\)"
- (1 'font-lock-keyword-face)
- (2 'font-lock-function-name-face)
- (3 'font-lock-type-face))))
-
-(defmacro httpd-def-file-servlet (name root)
+(defmacro httpd-file-servlet (name root)
"Defines a servlet that serves files from ROOT under the route NAME.
- (httpd-def-file-servlet my/www \"/var/www/\")
+ (httpd-file-servlet my/www \"/var/www/\")
Automatically handles redirects and uses `httpd-serve-root' to
actually serve up files."
(let* ((short-root (directory-file-name (symbol-name name)))
(path-root (concat short-root "/"))
(chop (length path-root)))
- `(defservlet ,name nil (uri-path query request)
- (setf httpd--header-sent t) ; Don't actually use this temp buffer
+ `(httpd-servlet ,name nil (uri-path query request)
(if (= (length uri-path) ,chop)
(httpd-redirect t ,path-root)
- (let ((path (substring uri-path ,chop)))
- (httpd-serve-root t ,root path request))))))
+ (httpd-serve-root t ,root (substring uri-path ,chop) request)))))
;; Request parsing
-(defun httpd--normalize-header (header)
- "Destructively capitalize the components of HEADER."
- (mapconcat #'capitalize (split-string header "-") "-"))
+(defsubst httpd--normalize-header (header)
+ "Capitalize the components of HEADER."
+ (replace-regexp-in-string "[^-]+" #'capitalize header t))
(defun httpd-parse ()
"Parse HTTP header in current buffer into association list.
-Leaves the point at the start of the request content. Returns nil
+Leaves the point at the start of the request content. Returns nil
if it failed to parse a complete HTTP header."
(goto-char (point-min))
- (when (looking-at "\\([^ ]+\\) +\\([^ ]+\\) +\\([^\r]+\\)\r\n")
+ (when (looking-at "\\([^ \r\n]+\\) +\\([^ \r\n]+\\) +\\([^\r\n]+\\)\r\n")
(let ((method (match-string 1))
(path (decode-coding-string (match-string 2) 'iso-8859-1))
(version (match-string 3))
- (headers ()))
+ (headers nil))
(goto-char (match-end 0))
- (while (looking-at "\\([-!#-'*+.0-9A-Z^_`a-z|~]+\\): *\\([^\r]+\\)\r\n")
+ (while (looking-at "\\([-!#-'*+.0-9A-Z^_`a-z|~]+\\): *\\([^\r\n]+\\)\r\n")
(goto-char (match-end 0))
(let ((name (match-string 1))
(value (match-string 2)))
@@ -674,47 +730,59 @@ if it failed to parse a complete HTTP header."
(goto-char (match-end 0))
(cons (list method path version) (nreverse headers))))))
-(defun httpd-unhex (str)
- "Fully decode the URL encoding in STR (including +'s)."
- (when str
- (let ((nonplussed (replace-regexp-in-string (regexp-quote "+") " " str)))
- (decode-coding-string (url-unhex-string nonplussed t) 'utf-8))))
+(defsubst httpd-unhex (str)
+ "Fully decode the URL encoding in STR."
+ (decode-coding-string (url-unhex-string str t) 'utf-8))
-(defun httpd-parse-args (argstr)
- "Parse a string containing URL encoded arguments."
- (unless (zerop (length argstr))
- (mapcar (lambda (str)
- (mapcar 'httpd-unhex (split-string str "=")))
- (split-string argstr "&"))))
+(defsubst httpd-unhex-plus (str)
+ "Fully decode URL/form encoding in STR, treating `+' as space."
+ (httpd-unhex (string-replace "+" " " str)))
+
+(defun httpd-parse-args (str)
+ "Parse STR containing URL/form encoded arguments."
+ (unless (equal str "")
+ (mapcar
+ (lambda (s)
+ (if-let* ((i (string-search "=" s)))
+ (list (httpd-unhex-plus (substring s 0 i))
+ (httpd-unhex-plus (substring s (1+ i))))
+ (list (httpd-unhex-plus s))))
+ (split-string str "&" t))))
(defun httpd-parse-uri (uri)
"Split a URI into its components.
The first element of the return value is the script path, the
second element is an alist of variable/value pairs, and the third
element is the fragment."
- (let ((p1 (string-match (regexp-quote "?") uri))
- (p2 (string-match (regexp-quote "#") uri))
- retval)
- (push (if p2 (httpd-unhex (substring uri (1+ p2)))) retval)
- (push (if p1 (httpd-parse-args (substring uri (1+ p1) p2))) retval)
- (push (substring uri 0 (or p1 p2)) retval)))
+ (let ((q (string-search "?" uri))
+ (h (string-search "#" uri)))
+ (when (and q h (> q h))
+ (setq q nil))
+ (list (httpd-unhex (substring uri 0 (or q h)))
+ (and q (httpd-parse-args (substring uri (1+ q) h)))
+ (and h (httpd-unhex (substring uri (1+ h)))))))
+
+(defconst httpd--html-entities
+ '((?& . "&")
+ (?' . "'")
+ (?\" . """)
+ (?< . "<")
+ (?> . ">"))
+ "Alist of HTML entities escaped by `httpd-escape-html-buffer'.")
(defun httpd-escape-html-buffer ()
"Escape current buffer contents to be safe for inserting into HTML."
(goto-char (point-min))
- (while (search-forward-regexp "[<>&]" nil t)
+ (while (re-search-forward "[<>&'\"]" nil t)
(replace-match
- (cl-case (aref (match-string 0) 0)
- (?< "<")
- (?> ">")
- (?& "&")))))
+ (alist-get (char-after (match-beginning 0)) httpd--html-entities))))
-(defun httpd-escape-html (string)
- "Escape STRING so that it's safe to insert into an HTML document."
- (with-temp-buffer
- (insert string)
- (httpd-escape-html-buffer)
- (buffer-string)))
+(defun httpd-escape-html (str)
+ "Escape STR so that it's safe to insert into an HTML document."
+ (replace-regexp-in-string
+ "[<>&'\"]"
+ (lambda (c) (alist-get (aref c 0) httpd--html-entities))
+ str))
;; Path handling
@@ -728,35 +796,35 @@ element is the fragment."
(defun httpd-clean-path (path)
"Clean dangerous .. from PATH and remove the leading slash."
- (let* ((sep (if (member system-type '(windows-nt ms-dos)) "[/\\]" "/"))
- (split (delete ".." (split-string path sep)))
- (unsplit (mapconcat 'identity (delete "" split) "/")))
- (concat "./" unsplit)))
+ (let ((sep (if (memq system-type '(windows-nt ms-dos)) "[/\\]" "/")))
+ (concat "./" (string-join (delete ".." (split-string path sep t)) "/"))))
(defun httpd-gen-path (path &optional root)
- "Translate GET to secure path in ROOT (`httpd-root')."
- (let ((clean (expand-file-name (httpd-clean-path path) (or root httpd-root))))
+ "Generate secure path in ROOT from request PATH."
+ (let ((clean (expand-file-name (httpd-clean-path path) root)))
(if (file-directory-p clean)
(let* ((dir (file-name-as-directory clean))
- (indexes (cl-mapcar (apply-partially 'concat dir) httpd-indexes))
- (existing (cl-remove-if-not 'file-exists-p indexes)))
+ (indexes (mapcar (apply-partially #'concat dir) httpd-indexes))
+ (existing (cl-remove-if-not #'file-exists-p indexes)))
(or (car existing) dir))
clean)))
(defun httpd-get-servlet (uri-path)
"Determine the servlet to be executed for URI-PATH."
- (if (not httpd-servlets)
- 'httpd/
- (cl-labels ((cat (x)
- (concat "httpd/" (mapconcat 'identity (reverse x) "/"))))
- (let ((parts (cdr (split-string (directory-file-name uri-path) "/"))))
- (or
- (cl-find-if 'fboundp (mapcar 'intern-soft
- (cl-maplist #'cat (reverse parts))))
- 'httpd/)))))
+ (or
+ (and httpd-servlets
+ (cl-find-if
+ #'fboundp
+ (cl-maplist
+ (lambda (x)
+ (intern-soft (string-join (cons "httpd" (reverse x)) "/")))
+ (nreverse (cdr (split-string (directory-file-name uri-path) "/"))))))
+ 'httpd/))
(defun httpd-serve-root (proc root uri-path &optional request)
- "Securely serve a file from ROOT from under PATH."
+ "Securely serve a file from ROOT.
+PROC is the client process, URI-PATH the request path and REQUEST the
+request header as alist."
(let* ((path (httpd-gen-path uri-path root))
(status (httpd-status path)))
(cond
@@ -765,140 +833,164 @@ element is the fragment."
(t (httpd-send-file proc path request)))))
(defun httpd/ (proc uri-path query request)
- "Default root servlet which serves files when httpd-serve-files is T."
- (if (and httpd-serve-files httpd-root)
- (httpd-serve-root proc httpd-root uri-path request)
- (httpd-error proc 403)))
+ "Default root servlet which serves files when `httpd-serve-files' is t.
+PROC is the client process, URI-PATH the request path, QUERY the query
+arguments and REQUEST the request header as alist."
+ (cond
+ ((equal uri-path "/error")
+ (let ((status (string-to-number (or (cadr (assoc "status" query)) ""))))
+ (unless (and (assq status httpd-status-codes) (>= status 400))
+ (setq status 400))
+ (httpd-error proc status)))
+ ((and httpd-serve-files httpd-root)
+ (httpd-serve-root proc httpd-root uri-path request))
+ ((httpd-error proc 403))))
(defun httpd-get-mime (ext)
- "Fetch MIME type given the file extention."
+ "Fetch MIME type given the file extension EXT."
(or (and ext (cdr (assoc (downcase ext) httpd-mime-types)))
"application/octet-stream"))
;; Data sending functions
(defun httpd-send-header (proc mime status &rest header-keys)
- "Send an HTTP header with given MIME type and STATUS, followed
-by the current buffer. If PROC is T use the `httpd-current-proc'
-as the process.
+ "Send an HTTP header followed by the current buffer.
+MIME is the mime type and STATUS the HTTP status code. If PROC is t use
+the `httpd-current-proc' as the process.
Extra headers can be sent by supplying them like keywords, i.e.
(httpd-send-header t \"text/plain\" 200 :X-Powered-By \"simple-httpd\")"
- (let ((status-str (cdr (assq status httpd-status-codes)))
- (headers `(("Server" . ,httpd-server-name)
- ("Date" . ,(httpd-date-string))
- ("Connection" . "keep-alive")
- ("Content-Type" . ,(httpd--stringify mime))
- ("Content-Length" . ,(httpd--buffer-size)))))
- (unless httpd--header-sent
- (setf httpd--header-sent t)
- (with-temp-buffer
- (insert (format "HTTP/1.1 %d %s\r\n" status status-str))
- (cl-loop for (header value) on header-keys by #'cddr
- for header-name = (substring (symbol-name header) 1)
- for value-name = (format "%s" value)
- collect (cons header-name value-name) into extras
- finally (setf headers (nconc headers extras)))
- (dolist (header headers)
- (insert (format "%s: %s\r\n" (car header) (cdr header))))
- (insert "\r\n")
- (process-send-region (httpd-resolve-proc proc)
- (point-min) (point-max)))
- (process-send-region (httpd-resolve-proc proc)
- (point-min) (point-max)))))
+ (when httpd--header-sent
+ (error "Header already sent"))
+ (setq httpd--header-sent t)
+ (let* ((proc (httpd--resolve-proc proc))
+ (request (or (process-get proc :request-active)
+ (error "No active request")))
+ (status-str (alist-get status httpd-status-codes))
+ (mime-str (httpd--stringify mime))
+ (mime-str (if (and (string-prefix-p "text/" mime-str)
+ (not (string-search "charset=" mime-str)))
+ (concat mime-str "; charset=utf-8")
+ mime-str))
+ (close (httpd--connection-close-p request))
+ (headers `(("Date" . ,(httpd-date-string))
+ ("Content-Type" . ,mime-str)
+ ("Content-Length" . ,(httpd--buffer-size))
+ ("Connection" . ,(if close "close" "keep-alive"))
+ ,@(and httpd-server-name `(("Server" . ,httpd-server-name)))))
+ (header-list `(,(format "%s %d %s\r\n" (caddar request) status status-str)
+ ,@(cl-loop for (header . value) in headers collect
+ (format "%s: %s\r\n" header value))
+ ,@(cl-loop for (header value) on header-keys by #'cddr collect
+ (format "%s: %s\r\n" (httpd--stringify header) value))
+ "\r\n")))
+ (process-put proc :request-active nil)
+ (process-send-string proc (apply #'concat header-list))
+ (unless (or (= (point-min) (point-max)) (equal "HEAD" (caar request)))
+ (process-send-region proc (point-min) (point-max)))
+ (if close
+ (delete-process proc)
+ (httpd--pop-request proc))))
(defun httpd-redirect (proc path &optional code)
- "Redirect the client to PATH (default 301). If PROC is T use
-the `httpd-current-proc' as the process."
- (httpd-log (list 'redirect path))
- (httpd-discard-buffer)
- (with-temp-buffer
+ "Redirect the client to PATH (default 301).
+If PROC is t use the `httpd-current-proc' as the process."
+ (httpd-log `(redirect ,path))
+ (httpd--ensure-buffer
(httpd-send-header proc "text/plain" (or code 301) :Location path)))
(defun httpd-send-file (proc path &optional req)
- "Serve file to the given client. If PROC is T use the
-`httpd-current-proc' as the process."
- (httpd-discard-buffer)
- (let ((req-etag (cadr (assoc "If-None-Match" req)))
- (etag (httpd-etag path))
- (mtime (httpd-date-string (nth 4 (file-attributes path)))))
- (if (equal req-etag etag)
- (with-temp-buffer
- (httpd-log `(file ,path not-modified))
- (httpd-send-header proc "text/plain" 304))
- (httpd-log `(file ,path))
- (with-temp-buffer
- (set-buffer-multibyte nil)
- (insert-file-contents-literally path)
- (httpd-send-header proc (httpd-get-mime (file-name-extension path))
- 200 :Last-Modified mtime :ETag etag)))))
+ "Serve file at PATH to the given client PROC.
+REQ is the request. If PROC is t use the `httpd-current-proc' as the
+process."
+ (httpd--ensure-buffer
+ (let ((etag (httpd-etag path)))
+ (if (not (equal (cadr (assoc "If-None-Match" req)) etag))
+ (let ((mime (httpd-get-mime (file-name-extension path)))
+ (mtime (httpd-date-string
+ (file-attribute-modification-time
+ (file-attributes path)))))
+ (httpd-log `(file ,path))
+ (set-buffer-multibyte nil)
+ (insert-file-contents-literally path)
+ (httpd-send-header proc mime 200
+ :ETag etag :Last-Modified mtime))
+ (httpd-log `(file ,path not-modified))
+ (httpd-send-header proc "text/plain" 304)))))
(defun httpd-send-directory (proc path uri-path)
- "Serve a file listing to the client. If PROC is T use the
-`httpd-current-proc' as the process."
- (httpd-discard-buffer)
- (let ((title (concat "Directory listing for "
- (url-insert-entities-in-string uri-path))))
- (if (equal "/" (substring uri-path -1))
- (with-temp-buffer
+ "Serve a file listing to the client.
+PROC is the client process, PATH the directory PATH, URI-PATH the
+request path and REQUEST the request header as alist. If PROC is t use
+the `httpd-current-proc' as the process."
+ (if (string-suffix-p "/" uri-path)
+ (let ((title (concat "Directory listing for "
+ (httpd-escape-html uri-path))))
+ (httpd--ensure-buffer
(httpd-log `(directory ,path))
- (insert "\n")
- (insert "\n" title "\n")
- (insert "\n" title "
\n
\n")
+ (insert "\n"
+ "\n" title "\n"
+ "\n" title "
\n
\n")
(dolist (file (directory-files path))
(unless (eq ?. (aref file 0))
(let* ((full (expand-file-name file path))
(tail (if (file-directory-p full) "/" ""))
- (f (url-insert-entities-in-string file))
+ (f (httpd-escape-html file))
(l (url-hexify-string file)))
(insert (format "- %s%s
\n"
l tail f tail)))))
(insert "
\n
\n\n")
- (httpd-send-header proc "text/html; charset=utf-8" 200))
- (httpd-redirect proc (concat uri-path "/")))))
+ (httpd-send-header proc "text/html" 200)))
+ (httpd-redirect proc (concat uri-path "/"))))
-(defun httpd--buffer-size (&optional buffer)
- "Get the buffer size in bytes."
- (let ((orig enable-multibyte-characters)
- (size 0))
- (with-current-buffer (or buffer (current-buffer))
- (set-buffer-multibyte nil)
- (setf size (buffer-size))
- (if orig (set-buffer-multibyte orig)))
- size))
+(defun httpd--buffer-size ()
+ "Get size of current buffer in bytes."
+ (let ((orig enable-multibyte-characters))
+ (set-buffer-multibyte nil)
+ (prog1 (buffer-size)
+ (when orig (set-buffer-multibyte orig)))))
(defun httpd-error (proc status &optional info)
- "Send an error page appropriate for STATUS to the client,
-optionally inserting object INFO into page. If PROC is T use the
+ "Send an error page appropriate for STATUS to the client.
+The INFO object is optionally inserted into page. If PROC is t use the
`httpd-current-proc' as the process."
- (httpd-discard-buffer)
(httpd-log `(error ,status ,info))
- (with-temp-buffer
- (let ((html (or (cdr (assq status httpd-html)) ""))
- (contents
- (if (not info)
- ""
- (with-temp-buffer
- (let ((standard-output (current-buffer)))
- (insert "error: ")
- (princ info)
- (insert "\n")
- (when httpd-show-backtrace-when-error
- (insert "backtrace: ")
- (princ (backtrace))
- (insert "\n"))
- (httpd-escape-html-buffer)
- (buffer-string))))))
- (insert (format html contents)))
+ (httpd--ensure-buffer
+ (let ((contents
+ (if (or info httpd-show-backtrace-when-error)
+ (with-temp-buffer
+ (let ((standard-output (current-buffer)))
+ (when info
+ (insert "error: ")
+ (princ info)
+ (insert ?\n))
+ (when httpd-show-backtrace-when-error
+ (insert "backtrace:\n")
+ (backtrace)
+ (insert ?\n))
+ (httpd-escape-html-buffer)
+ (buffer-string)))
+ "")))
+ (insert (format
+ (or (alist-get status httpd-html)
+ (alist-get t httpd-html))
+ contents status
+ (alist-get status httpd-status-codes)) ?\n))
(httpd-send-header proc "text/html" status)))
(defun httpd--error-safe (&rest args)
- "Call httpd-error and report failures to *httpd*."
- (condition-case error-case
+ "Call `httpd-error' with ARGS and log failures."
+ (condition-case err
(apply #'httpd-error args)
- (error (httpd-log `(hard-error ,error-case)))))
+ (error (httpd-log `(hard-error ,err)))))
+
+;; Old names. Not deprecated to avoid churn.
+(defalias 'defservlet #'httpd-servlet)
+(defalias 'defservlet* #'httpd-servlet*)
+(defalias 'httpd-def-file-servlet #'httpd-file-servlet)
+(defalias 'with-httpd-buffer #'httpd-with-buffer)
+(defalias 'httpd-resolve-proc #'httpd--resolve-proc)
(provide 'simple-httpd)
-
;;; simple-httpd.el ends here
diff --git a/lisp/spacemacs-theme/spacemacs-theme-pkg.el b/lisp/spacemacs-theme/spacemacs-theme-pkg.el
index ee8acf27..ed0e8fb5 100644
--- a/lisp/spacemacs-theme/spacemacs-theme-pkg.el
+++ b/lisp/spacemacs-theme/spacemacs-theme-pkg.el
@@ -1,8 +1,8 @@
;; -*- no-byte-compile: t; lexical-binding: nil -*-
-(define-package "spacemacs-theme" "20251221.1656"
+(define-package "spacemacs-theme" "20260523.1256"
"Color theme with a dark and light versions."
()
:url "https://github.com/nashamri/spacemacs-theme"
- :commit "5635d6bbc76e6f06b99fa5dac6e6fd6675459ca6"
- :revdesc "5635d6bbc76e"
+ :commit "cbd290dfde96f53a7b41730c7840850a8a7b8a02"
+ :revdesc "cbd290dfde96"
:keywords '("color" "theme"))
diff --git a/lisp/spacemacs-theme/spacemacs-theme.el b/lisp/spacemacs-theme/spacemacs-theme.el
index 2d95aceb..1f8f83b6 100644
--- a/lisp/spacemacs-theme/spacemacs-theme.el
+++ b/lisp/spacemacs-theme/spacemacs-theme.el
@@ -5,8 +5,8 @@
;; Author: Nasser Alshammari
;; URL:
;;
-;; Package-Version: 20251221.1656
-;; Package-Revision: 5635d6bbc76e
+;; Package-Version: 20260523.1256
+;; Package-Revision: cbd290dfde96
;; Keywords: color, theme
;; Package-Requires: ((emacs "24"))
@@ -725,6 +725,13 @@ to `auto', tags may not be properly aligned. "
`(lsp-ui-doc-background ((,class (:background ,bg2))))
`(lsp-ui-doc-header ((,class (:foreground ,head1 :background ,head1-bg))))
`(lsp-ui-sideline-code-action ((,class (:foreground ,comp))))
+ `(lsp-ui-peek-header ((,class (:foreground ,bg1 :background ,base))))
+ `(lsp-ui-peek-peek ((,class (:background ,bg2))))
+ `(lsp-ui-peek-list ((,class (:background ,bg2))))
+ `(lsp-ui-peek-highlight ((,class (:background ,highlight))))
+ `(lsp-ui-peek-line-number ((,class (:foreground ,base))))
+ `(lsp-ui-peek-selection ((,class (:background ,bg3))))
+ `(lsp-ui-peek-filename ((,class (:foreground ,base))))
;;;;; magit
`(magit-blame-culprit ((,class :background ,yellow-bg :foreground ,yellow)))
@@ -1068,6 +1075,13 @@ to `auto', tags may not be properly aligned. "
`(web-mode-type-face ((,class (:inherit ,font-lock-type-face))))
`(web-mode-warning-face ((,class (:inherit ,font-lock-warning-face))))
+;;;;; wgrep
+ `(wgrep-face ((,class (:foreground ,green))))
+ `(wgrep-delete-face ((,class (:foreground ,red))))
+ `(wgrep-reject-face ((,class (:foreground ,red))))
+ `(wgrep-file-face ((,class (:foreground ,green))))
+ `(wgrep-done-face ((,class (:foreground ,blue))))
+
;;;;; which-key
`(which-key-command-description-face ((,class (:foreground ,base))))
`(which-key-group-description-face ((,class (:foreground ,keyword))))
diff --git a/lisp/tablist/tablist-pkg.el b/lisp/tablist/tablist-pkg.el
index 9ea7ff06..7593e162 100644
--- a/lisp/tablist/tablist-pkg.el
+++ b/lisp/tablist/tablist-pkg.el
@@ -1,10 +1,10 @@
;; -*- no-byte-compile: t; lexical-binding: nil -*-
-(define-package "tablist" "20231019.1126"
+(define-package "tablist" "20260623.1855"
"Extended tabulated-list-mode."
- '((emacs "24.3"))
+ '((emacs "25.1"))
:url "https://github.com/emacsorphanage/tablist"
- :commit "fcd37147121fabdf003a70279cf86fbe08cfac6f"
- :revdesc "fcd37147121f"
+ :commit "01f065e387ffe6b7a41f180f257cd12551c7a9c2"
+ :revdesc "01f065e387ff"
:keywords '("extensions" "lisp")
:authors '(("Andreas Politz" . "politza@fh-trier.de"))
:maintainers '(("Andreas Politz" . "politza@fh-trier.de")))
diff --git a/lisp/tablist/tablist.el b/lisp/tablist/tablist.el
index d2f9ae80..a6f88ad1 100644
--- a/lisp/tablist/tablist.el
+++ b/lisp/tablist/tablist.el
@@ -5,9 +5,9 @@
;; Author: Andreas Politz
;; Keywords: extensions, lisp
;; Package: tablist
-;; Package-Version: 20231019.1126
-;; Package-Revision: fcd37147121f
-;; Package-Requires: ((emacs "24.3"))
+;; Package-Version: 20260623.1855
+;; Package-Revision: 01f065e387ff
+;; Package-Requires: ((emacs "25.1"))
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
@@ -315,13 +315,12 @@ as argument for the function `completion-in-region'.")
(cond
((not disable)
(set (make-local-variable 'mode-line-misc-info)
- (append
- (list
- (list 'tablist-current-filter
- '(:eval (format " [%s]"
- (if tablist-filter-suspended
- "suspended"
- "filtered")))))))
+ (cons '(tablist-current-filter
+ (:eval (format " [%s]"
+ (if tablist-filter-suspended
+ "suspended"
+ "filtered"))))
+ cleaned-misc))
(add-hook 'post-command-hook
'tablist-selection-changed-handler nil t)
(add-hook 'tablist-selection-changed-functions
@@ -437,18 +436,18 @@ a face on."
(tabulated-list-put-tag
(string tablist-marker-char))
(put-text-property
- (point-at-bol)
- (1+ (point-at-bol))
+ (line-beginning-position)
+ (1+ (line-beginning-position))
'face tablist-marker-face)
(let ((columns (tablist-column-offsets)))
(dolist (c (tablist-major-columns))
(when (and (>= c 0)
(< c (length columns)))
- (let ((beg (+ (point-at-bol)
+ (let ((beg (+ (line-beginning-position)
(nth c columns)))
(end (if (= c (1- (length columns)))
- (point-at-eol)
- (+ (point-at-bol)
+ (line-end-position)
+ (+ (line-beginning-position)
(nth (1+ c) columns)))))
(cond
((and tablist-marked-face
@@ -841,7 +840,7 @@ STATE is a return value of `tablist-get-mark-state'."
(forward-char))
;; before any columns
(when (< current 0)
- (goto-char (+ (point-at-bol) (if (> n 0)
+ (goto-char (+ (line-beginning-position) (if (> n 0)
(car columns)
(car (last columns)))))
(setq n (* (cl-signum n) (1- (abs n)))))
@@ -1011,11 +1010,11 @@ Optional REVERT-P means, revert the display afterwards."
(unless n (setq n (tablist-current-column)))
(tablist-assert-column-editable n)
(let* ((offsets (append (tablist-column-offsets)
- (list (- (point-at-eol)
- (point-at-bol)))))
- (beg (+ (point-at-bol)
+ (list (- (line-end-position)
+ (line-beginning-position)))))
+ (beg (+ (line-beginning-position)
(nth n offsets)))
- (end (+ (point-at-bol)
+ (end (+ (line-beginning-position)
(nth (1+ n) offsets)))
(entry (tabulated-list-get-entry beg))
(inhibit-read-only t)
@@ -1027,9 +1026,9 @@ Optional REVERT-P means, revert the display afterwards."
(goto-char beg)
(delete-region beg end)
(add-text-properties
- (point-at-bol) (point-at-eol)
+ (line-beginning-position) (line-end-position)
'(read-only t field t))
- (unless (= beg (point-at-bol))
+ (unless (= beg (line-beginning-position))
(put-text-property (1- beg) beg 'rear-nonsticky t))
(save-excursion
;; Keep one read-only space at the end for keeping text
@@ -1039,7 +1038,7 @@ Optional REVERT-P means, revert the display afterwards."
(concat
(tablist-nth-entry n entry)
(propertize " "
- 'display `(space :align-to ,(- end (point-at-bol)))))
+ 'display `(space :align-to ,(- end (line-beginning-position)))))
'field nil
'front-sticky '(tablist-edit)
'rear-nonsticky '(read-only field)
@@ -1086,7 +1085,7 @@ Optional REVERT-P means, revert the display afterwards."
(tablist-edit-column-minor-mode -1)
(remove-overlays beg end 'tablist-edit t)
(put-text-property beg end 'tablist-edit nil)
- (delete-region (point-at-bol) (1+ (point-at-eol)))
+ (delete-region (line-beginning-position) (1+ (line-end-position)))
(save-excursion
(tabulated-list-print-entry id entry))
(forward-char (nth column (tablist-column-offsets))))))
@@ -1518,7 +1517,8 @@ FILTER defaults to `tablist-current-filter'."
(tablist-filter-negate filter))))
(force-mode-line-update))
-(defadvice tabulated-list-print (after tabulated-list activate)
+(define-advice tabulated-list-print
+ (:after (&rest _) tablist-reapply-filter)
"Reapply the filter."
(when (or tablist-minor-mode
(derived-mode-p 'tablist-mode))
@@ -1864,8 +1864,8 @@ visibility."
(beginning-of-line)
(let ((inhibit-read-only t))
(add-text-properties
- (point-at-bol)
- (1+ (point-at-eol))
+ (line-beginning-position)
+ (1+ (line-end-position))
`(invisible ,flag)))))
(defun tablist-filter-hide-entry (&optional pos)
diff --git a/lisp/transient/transient-pkg.el b/lisp/transient/transient-pkg.el
index c8c841ff..e24d0efa 100644
--- a/lisp/transient/transient-pkg.el
+++ b/lisp/transient/transient-pkg.el
@@ -1,13 +1,14 @@
;; -*- no-byte-compile: t; lexical-binding: nil -*-
-(define-package "transient" "20260401.2145"
+(define-package "transient" "20260617.1137"
"Transient commands."
'((emacs "28.1")
- (compat "30.1")
- (cond-let "0.2")
+ (compat "31.0")
+ (cond-let "1.1")
+ (llama "1.0")
(seq "2.24"))
:url "https://github.com/magit/transient"
- :commit "8b14203107950d6eba0e17d14867e05547725219"
- :revdesc "8b1420310795"
+ :commit "9d103f338fb9fd4506a0f1651c483209ab838f49"
+ :revdesc "9d103f338fb9"
:keywords '("extensions")
:authors '(("Jonas Bernoulli" . "emacs.transient@jonas.bernoulli.dev"))
:maintainers '(("Jonas Bernoulli" . "emacs.transient@jonas.bernoulli.dev")))
diff --git a/lisp/transient/transient.el b/lisp/transient/transient.el
index 58410add..a98370d5 100644
--- a/lisp/transient/transient.el
+++ b/lisp/transient/transient.el
@@ -6,12 +6,13 @@
;; Homepage: https://github.com/magit/transient
;; Keywords: extensions
-;; Package-Version: 20260401.2145
-;; Package-Revision: 8b1420310795
+;; Package-Version: 20260617.1137
+;; Package-Revision: 9d103f338fb9
;; Package-Requires: (
;; (emacs "28.1")
-;; (compat "30.1")
-;; (cond-let "0.2")
+;; (compat "31.0")
+;; (cond-let "1.1")
+;; (llama "1.0")
;; (seq "2.24"))
;; SPDX-License-Identifier: GPL-3.0-or-later
@@ -45,7 +46,7 @@
;;; Code:
-(defconst transient-version "0.12.0")
+(defconst transient-version "0.13.4")
(require 'cl-lib)
(require 'compat)
@@ -53,6 +54,7 @@
(require 'eieio)
(require 'edmacro)
(require 'format-spec)
+(require 'llama)
(require 'pcase)
(require 'pp)
@@ -101,19 +103,6 @@ similar defect.") :emergency))
(defvar Man-notify-method)
(defvar pp-default-function) ; since Emacs 29.1
-(static-if (< emacs-major-version 30)
- (progn
- (defun internal--build-binding@backport-e680827e814 (fn binding prev-var)
- "Backport not warning about `_' not being left unused.
-Backport fix for https://debbugs.gnu.org/cgi/bugreport.cgi?bug=69108,
-from Emacs commit e680827e814e155cf79175d87ff7c6ee3a08b69a."
- (let ((binding (funcall fn binding prev-var)))
- (if (eq (car binding) '_)
- (cons (make-symbol "s") (cdr binding))
- binding)))
- (advice-add 'internal--build-binding :around
- #'internal--build-binding@backport-e680827e814)))
-
(define-obsolete-variable-alias
'transient-show-popup
'transient-show-menu
@@ -136,9 +125,12 @@ from Emacs commit e680827e814e155cf79175d87ff7c6ee3a08b69a."
,(macroexp-progn body))
((debug error)
(transient--emergency-exit ,id)
- (static-if (fboundp 'error-type-p) ; since Emacs 31.1
- (signal err)
- (signal (car err) (cdr err))))))
+ (static-if (version< emacs-version "31.0.50")
+ (signal (car err) (cdr err))
+ (condition-case nil
+ (signal err)
+ (wrong-number-of-arguments
+ (signal (car err) (cdr err))))))))
(defun transient--exit-and-debug (&rest args)
(transient--emergency-exit :debugger)
@@ -871,7 +863,8 @@ See also option `transient-highlight-mismatched-keys'."
(defun transient--pp-to-file (value file)
(when (or value (file-exists-p file))
(make-directory (file-name-directory file) t)
- (setq value (cl-sort (copy-sequence value) #'string< :key #'car))
+ (setq value (compat-call sort (copy-sequence value)
+ :lessp #'string< :key #'car))
(with-temp-file file
(let ((print-level nil)
(print-length nil)
@@ -906,11 +899,12 @@ should not change it manually.")
(defun transient-save-history ()
(setq transient-history
- (cl-sort (mapcar (pcase-lambda (`(,key . ,val))
- (cons key (seq-take (delete-dups val)
- transient-history-limit)))
- transient-history)
- #'string< :key #'car))
+ (compat-call sort
+ (mapcar (pcase-lambda (`(,key . ,val))
+ (cons key (take transient-history-limit
+ (delete-dups val))))
+ transient-history)
+ :lessp #'string< :key #'car))
(transient--pp-to-file transient-history transient-history-file))
(defun transient-maybe-save-history ()
@@ -1250,7 +1244,7 @@ to the setup function:
(,(or class 'transient-prefix) :command ',name ,@slots))
(transient--set-layout
',name
- (list ,@(mapcan (lambda (s) (transient--parse-child name s)) groups))))))
+ (list ,@(mapcan (##transient--parse-child name %) groups))))))
(put 'transient-define-prefix 'autoload-macro 'expand)
(defmacro transient-define-group (name &rest groups)
@@ -1264,7 +1258,7 @@ form as for `transient-define-prefix'."
(indent defun))
`(transient--set-layout
',name
- (list ,@(mapcan (lambda (s) (transient--parse-child name s)) groups))))
+ (list ,@(mapcan (##transient--parse-child name %) groups))))
(defmacro transient-define-suffix (name arglist &rest args)
"Define NAME as a transient suffix command.
@@ -1503,7 +1497,7 @@ commands are aliases for."
('transient-column)))
(and args (cons 'list args))
(cons 'list
- (mapcan (lambda (s) (transient--parse-child prefix s)) spec)))))
+ (mapcan (##transient--parse-child prefix %) spec)))))
(defun transient--parse-suffix (prefix spec)
(let (class args)
@@ -1540,8 +1534,8 @@ commands are aliases for."
(sym (intern
(format
"transient:%s:%s:%d" prefix
- (replace-regexp-in-string (plist-get args :key) " " "")
- (prog1 gensym-counter (cl-incf gensym-counter))))))
+ (string-replace (plist-get args :key) " " "")
+ (prog1 gensym-counter (incf gensym-counter))))))
(use :command
`(prog1 ',sym
(put ',sym 'interactive-only t)
@@ -1666,7 +1660,12 @@ symbol property.")
(transient--set-layout
prefix
(named-let upgrade ((spec layout))
- (cond ((vectorp spec)
+ (cond ((and (vectorp spec)
+ (length= spec 3))
+ ;; This format is used by emoji.el from Emacs <= 29.4.
+ (pcase-let ((`[,class ,args ,children] spec))
+ (vector class args (mapcar #'upgrade children))))
+ ((vectorp spec)
(pcase-let ((`[,level ,class ,args ,children] spec))
(when level
(setq args (plist-put args :level level)))
@@ -1812,9 +1811,9 @@ layout of PREFIX."
(let* ((siblings (aref parent 2))
(pos (cl-position group siblings)))
(aset parent 2
- (nconc (seq-take siblings pos)
+ (nconc (take pos siblings)
(transient--get-children group)
- (seq-drop siblings (1+ pos))))))))
+ (drop (1+ pos) siblings)))))))
;;;###autoload
(defun transient-remove-suffix (prefix loc)
@@ -2171,7 +2170,7 @@ probably use this instead:
(defun transient--suffix-prototype (command)
(or (get command 'transient--suffix)
- (seq-some (lambda (cmd) (get cmd 'transient--suffix))
+ (seq-some (##get % 'transient--suffix)
(function-alias-p command))))
;;; Keymaps
@@ -2508,14 +2507,12 @@ of the corresponding object."
(pcase this-command
('transient-update
(setq transient--showp t)
- (let ((keys (listify-key-sequence (this-single-command-raw-keys))))
- (setq unread-command-events (mapcar (lambda (key) (cons t key)) keys))
+ (let ((keys (listify-key-sequence (this-single-command-keys))))
+ (setq unread-command-events (mapcar (##cons t %) keys))
keys))
('transient-quit-seq
(setq unread-command-events
- (butlast (listify-key-sequence
- (this-single-command-raw-keys))
- 2))
+ (butlast (listify-key-sequence (this-single-command-keys)) 2))
(butlast transient--redisplay-key))
(_ nil)))
(let ((topmap (make-sparse-keymap))
@@ -2642,7 +2639,7 @@ value. Otherwise return CHILDREN as is.")
(defun transient--init-suffixes (name)
(let ((levels (alist-get name transient-levels)))
- (mapcan (lambda (c) (transient--init-child levels c nil))
+ (mapcan (##transient--init-child levels % nil)
(append (transient--get-children name)
(and (not transient--editp)
(transient--get-children
@@ -2661,7 +2658,7 @@ value. Otherwise return CHILDREN as is.")
(defun transient--init-child (levels spec parent)
(cl-etypecase spec
- (symbol (mapcan (lambda (c) (transient--init-child levels c parent))
+ (symbol (mapcan (##transient--init-child levels % parent)
(transient--get-children spec)))
(vector (transient--init-group levels spec parent))
(list (transient--init-suffix levels spec parent))
@@ -2677,7 +2674,7 @@ value. Otherwise return CHILDREN as is.")
(_(prog1 t
(when (transient--inapt-suffix-p obj)
(oset obj inapt t))))
- (suffixes (mapcan (lambda (c) (transient--init-child levels c obj))
+ (suffixes (mapcan (##transient--init-child levels % obj)
(transient-setup-children obj children))))
(progn
(oset obj suffixes suffixes)
@@ -3638,8 +3635,7 @@ transient is active."
(cond
(interactivep
(setq transient--helpp t))
- ((lookup-key transient--transient-map
- (this-single-command-raw-keys))
+ ((lookup-key transient--transient-map (this-single-command-keys))
(setq transient--helpp nil)
(with-demoted-errors "transient-help: %S"
(transient--display-help #'transient-show-help
@@ -3680,7 +3676,7 @@ For example:
(and transient--editp
(setq command prefix)))
(list command
- (let ((keys (this-single-command-raw-keys)))
+ (let ((keys (this-single-command-keys)))
(and (lookup-key transient--transient-map keys)
(progn
(transient--show)
@@ -3701,8 +3697,7 @@ For example:
(setq akey t))
(t
(oset (transient-suffix-object command) level level)
- (when (cdr (cl-remove-if-not (lambda (obj)
- (eq (oref obj command) command))
+ (when (cdr (cl-remove-if-not (##eq (oref % command) command)
transient--suffixes))
(setq akey (cons command (this-command-keys))))))
(setf (alist-get akey alist) level)
@@ -3833,7 +3828,7 @@ such as when suggesting a new feature or reporting an issue."
:description "Echo arguments"
:key "x"
(interactive (list (transient-args transient-current-command)))
- (if (seq-every-p #'stringp arguments)
+ (if (all #'stringp arguments)
(message "%s: %s" (key-description (this-command-keys))
(mapconcat (lambda (arg)
(propertize (if (string-match-p " " arg)
@@ -3910,8 +3905,8 @@ Call `transient-default-value' but because that is a noop for
(string-match regexp v)
(match-string 1 v)))))
(if multi-value
- (delq nil (mapcar match value))
- (cl-some match value)))))))
+ (seq-filter match value)
+ (seq-some match value)))))))
(cl-defmethod transient-init-value ((obj transient-switch))
"Extract OBJ's value from the value of the prefix object."
@@ -4112,19 +4107,19 @@ stand-alone command."
(when (fboundp 'org-read-date)
(org-read-date 'with-time nil nil prompt default-time)))
-(static-if (fboundp 'string-edit) ; since Emacs 29.1
- (defun transient-read-string-from-buffer (prompt value _)
- "Switch to a new buffer to edit STRING in a recursive edit.
+(static-when (fboundp 'string-edit) ; since Emacs 29.1
+ (defun transient-read-string-from-buffer (prompt value _)
+ "Switch to a new buffer to edit STRING in a recursive edit.
Like `read-string-from-buffer' but accept an additional argument as
provided by `transient-infix-read' (but ignore it). Only available
when using Emacs 29.1 or greater."
- (string-edit prompt (or value "")
- (lambda (edited)
- (setq value edited)
- (exit-recursive-edit))
- :abort-callback #'exit-recursive-edit)
- (recursive-edit)
- value))
+ (string-edit prompt (or value "")
+ (lambda (edited)
+ (setq value edited)
+ (exit-recursive-edit))
+ :abort-callback #'exit-recursive-edit)
+ (recursive-edit)
+ value))
;;;; Prompt
@@ -4419,7 +4414,7 @@ does nothing." nil)
(pcase-exhaustive (oref obj multi-value)
('nil (concat arg value))
((or 't 'rest) (cons arg value))
- ('repeat (mapcar (lambda (v) (concat arg v)) value))))))
+ ('repeat (mapcar (##concat arg %) value))))))
(cl-defmethod transient-infix-value ((_ transient-variable))
"Return nil, which means \"no value\".
@@ -4446,9 +4441,8 @@ Append \"=\ to ARG to indicate that it is an option."
[match (let ((case-fold-search nil)
(re (format "\\`%s\\(?:=\\(.+\\)\\)?\\'"
(substring arg 0 -1))))
- (cl-find-if (lambda (a)
- (and (stringp a)
- (string-match re a)))
+ (cl-find-if (##and (stringp %)
+ (string-match re %))
args))]
(match-string 1 match)))))
@@ -4458,9 +4452,10 @@ Append \"=\ to ARG to indicate that it is an option."
(when-let* ((_ transient--stack)
(command (oref obj command))
(suffix-obj (transient-suffix-object command))
- (_(memq (if (slot-boundp suffix-obj 'transient)
- (oref suffix-obj transient)
- (oref transient-current-prefix transient-suffix))
+ (_(memq (cond ((slot-boundp suffix-obj 'transient)
+ (oref suffix-obj transient))
+ (transient-current-prefix
+ (oref transient-current-prefix transient-suffix)))
(list t 'recurse #'transient--do-recurse))))
(oset obj return t)))
@@ -4691,27 +4686,25 @@ have a history of their own.")
"%s- [%s] %s"
(key-description (this-command-keys))
(oref transient--prefix command)
- (mapconcat
- #'identity
- (sort
- (mapcan
- (lambda (suffix)
- (let ((key (kbd (oref suffix key))))
- ;; Don't list any common commands.
- (and (not (memq (oref suffix command)
- `(,(lookup-key transient-map key)
- ,(lookup-key transient-sticky-map key)
- ;; From transient-common-commands:
- transient-set
- transient-save
- transient-history-prev
- transient-history-next
- transient-quit-one
- transient-toggle-common
- transient-set-level)))
- (list (propertize (oref suffix key) 'face 'transient-key)))))
- transient--suffixes)
- #'string<)
+ (string-join
+ (sort (seq-keep
+ (lambda (suffix)
+ (let ((key (kbd (oref suffix key))))
+ ;; Don't list any common commands.
+ (and (not (memq (oref suffix command)
+ `(,(lookup-key transient-map key)
+ ,(lookup-key transient-sticky-map key)
+ ;; From transient-common-commands:
+ transient-set
+ transient-save
+ transient-history-prev
+ transient-history-next
+ transient-quit-one
+ transient-toggle-common
+ transient-set-level)))
+ (propertize (oref suffix key) 'face 'transient-key))))
+ transient--suffixes)
+ #'string<)
(propertize "|" 'face 'transient-delimiter)))))
(defun transient--insert-menu (setup)
@@ -4938,14 +4931,14 @@ as a button."
(let ((len (length transient--redisplay-key))
(seq (cl-coerce (edmacro-parse-keys key t) 'list)))
(cond
- ((member (seq-take seq len)
+ ((member (take len seq)
(list transient--redisplay-key
(thread-last transient--redisplay-key
(cl-substitute ?- 'kp-subtract)
(cl-substitute ?= 'kp-equal)
(cl-substitute ?+ 'kp-add))))
- (let ((pre (key-description (vconcat (seq-take seq len))))
- (suf (key-description (vconcat (seq-drop seq len)))))
+ (let ((pre (key-description (vconcat (take len seq))))
+ (suf (key-description (vconcat (drop len seq)))))
(setq pre (string-replace "RET" "C-m" pre))
(setq pre (string-replace "TAB" "C-i" pre))
(setq suf (string-replace "RET" "C-m" suf))
@@ -5181,8 +5174,8 @@ apply the face `transient-unreachable' to the complete string."
(defun transient--key-unreachable-p (obj)
(and transient--redisplay-key
(let ((key (oref obj key)))
- (not (or (equal (seq-take (cl-coerce (edmacro-parse-keys key t) 'list)
- (length transient--redisplay-key))
+ (not (or (equal (take (length transient--redisplay-key)
+ (cl-coerce (edmacro-parse-keys key t) 'list))
transient--redisplay-key)
(transient--lookup-key transient-sticky-map (kbd key)))))))
@@ -5202,26 +5195,32 @@ apply the face `transient-unreachable' to the complete string."
(length (oref suffix key))))
(oref group suffixes))))))
-(defun transient--pixel-width (string)
- (save-window-excursion
+(static-if (fboundp 'string-pixel-width) ; since Emacs 29.1
+ (progn ; See https://github.com/magit/magit/issues/5557.
+ (defalias 'transient--string-pixel-width #'string-pixel-width))
+ ;; c22b735f0c6 and 61c254cafc9 cannot be backported. Some later
+ ;; commits could be ported, but users should instead update Emacs.
+ (defun transient--string-pixel-width (string)
(with-temp-buffer
(insert string)
- (set-window-dedicated-p nil nil)
- (set-window-buffer nil (current-buffer))
- (car (window-text-pixel-size
- nil (line-beginning-position) (point))))))
+ (save-window-excursion
+ (set-window-dedicated-p nil nil)
+ (set-window-buffer nil (current-buffer))
+ (car (window-text-pixel-size
+ nil (line-beginning-position) (point)))))))
(defun transient--column-stops (columns)
(let* ((var-pitch (or transient-align-variable-pitch
(oref transient--prefix variable-pitch)))
- (char-width (and var-pitch (transient--pixel-width " "))))
+ (char-width (and var-pitch (transient--string-pixel-width " "))))
(transient--seq-reductions-from
(apply-partially #'+ (* 2 (if var-pitch char-width 1)))
(transient--mapn
(lambda (cells min)
(apply #'max
(if min (if var-pitch (* min char-width) min) 0)
- (mapcar (if var-pitch #'transient--pixel-width #'length) cells)))
+ (mapcar (if var-pitch #'transient--string-pixel-width #'length)
+ cells)))
columns
(oref transient--prefix column-widths))
0)))
@@ -5632,14 +5631,16 @@ search instead."
lisp-imenu-generic-expression :test #'equal)
(defun transient--suspend-text-conversion-style ()
- (static-if (boundp 'overriding-text-conversion-style) ; since Emacs 30.1
- (when text-conversion-style
- (letrec ((suspended overriding-text-conversion-style)
- (fn (lambda ()
- (setq overriding-text-conversion-style nil)
- (remove-hook 'transient-exit-hook fn))))
- (setq overriding-text-conversion-style suspended)
- (add-hook 'transient-exit-hook fn)))))
+ (when (and (bound-and-true-p text-conversion-style)
+ (bound-and-true-p overriding-text-conversion-style)
+ ;; Somehow the above does not silence the compiler.
+ (boundp 'overriding-text-conversion-style))
+ (letrec ((suspended overriding-text-conversion-style)
+ (fn (lambda ()
+ (setq overriding-text-conversion-style nil)
+ (remove-hook 'transient-exit-hook fn))))
+ (setq overriding-text-conversion-style suspended)
+ (add-hook 'transient-exit-hook fn))))
(declare-function which-key-mode "ext:which-key" (&optional arg))
@@ -5700,7 +5701,7 @@ Like `cl-mapcar' but while that stops when the shortest list
is exhausted, continue until the longest list is, using nil
as stand-in for elements of exhausted lists."
(let (result)
- (while (catch 'more (mapc (lambda (l) (and l (throw 'more t))) lists) nil)
+ (while (catch 'more (mapc (##and % (throw 'more t)) lists) nil)
(push (apply function (mapcar #'car-safe lists)) result)
(setq lists (mapcar #'cdr lists)))
(nreverse result)))
@@ -5792,11 +5793,16 @@ as stand-in for elements of exhausted lists."
;; (cond . 0)
;; (interactive . 0))
;; read-symbol-shorthands: (
-;; ("and$" . "cond-let--and$")
-;; ("and-let" . "cond-let--and-let")
-;; ("if-let" . "cond-let--if-let")
-;; ("when$" . "cond-let--when$")
-;; ("when-let" . "cond-let--when-let")
-;; ("while-let" . "cond-let--while-let"))
+;; ("and$" . "cond-let--and$")
+;; ("thread$" . "cond-let--thread$")
+;; ("when$" . "cond-let--when$")
+;; ("and-let*" . "cond-let--and-let*")
+;; ("and-let" . "cond-let--and-let")
+;; ("if-let*" . "cond-let--if-let*")
+;; ("if-let" . "cond-let--if-let")
+;; ("when-let*" . "cond-let--when-let*")
+;; ("when-let" . "cond-let--when-let")
+;; ("while-let*" . "cond-let--while-let*")
+;; ("while-let" . "cond-let--while-let"))
;; End:
;;; transient.el ends here
diff --git a/lisp/transient/transient.info b/lisp/transient/transient.info
index a563c4cc..717ed96b 100644
--- a/lisp/transient/transient.info
+++ b/lisp/transient/transient.info
@@ -32,7 +32,7 @@ used to implement similar menus in other packages.
resource to get over that hurdle is Psionic K's interactive tutorial,
available at .
-This manual is for Transient version 0.12.0.
+This manual is for Transient version 0.13.4.
Copyright (C) 2018-2026 Free Software Foundation, Inc.
diff --git a/lisp/update-autoloads.el b/lisp/update-autoloads.el
index 17e90ba6..b0830fb0 100644
--- a/lisp/update-autoloads.el
+++ b/lisp/update-autoloads.el
@@ -63,6 +63,7 @@
;; (package-generate-autoloads "org" (concat config-dir "lisp/org")) ;; already org-loaddefs.el
(package-generate-autoloads "org-appear" (concat config-dir "lisp/org-appear"))
(package-generate-autoloads "org-contrib" (concat config-dir "lisp/org-contrib"))
+ (package-generate-autoloads "org-wc" (concat config-dir "lisp/org-wc"))
(package-generate-autoloads "ox-pandoc" (concat config-dir "lisp/ox-pandoc"))
(package-generate-autoloads "ox-rst" (concat config-dir "lisp/ox-rst"))
(package-generate-autoloads "rainbow-mode" (concat config-dir "lisp/rainbow-mode"))
diff --git a/lisp/vterm/CMakeLists.txt b/lisp/vterm/CMakeLists.txt
index 4917264c..65aa4e37 100644
--- a/lisp/vterm/CMakeLists.txt
+++ b/lisp/vterm/CMakeLists.txt
@@ -51,6 +51,10 @@ if (USE_SYSTEM_LIBVTERM)
if (${VTermSBClearExists} EQUAL "0")
add_definitions(-DVTermSBClearNotExists)
endif()
+ execute_process(COMMAND grep -c "vterm_screen_enable_reflow" "${LIBVTERM_INCLUDE_DIR}/vterm.h" OUTPUT_VARIABLE VTermScreenEnableReflowExists)
+ if (${VTermScreenEnableReflowExists} EQUAL "0")
+ add_definitions(-DVTermScreenEnableReflowNotExists)
+ endif()
else()
message(STATUS "System libvterm not found: libvterm will be downloaded and compiled as part of the build process")
endif()
diff --git a/lisp/vterm/vterm-module.c b/lisp/vterm/vterm-module.c
index 72ed7e90..f781c95e 100644
--- a/lisp/vterm/vterm-module.c
+++ b/lisp/vterm/vterm-module.c
@@ -28,6 +28,9 @@ void free_lineinfo(LineInfo *line) {
}
static int term_sb_push(int cols, const VTermScreenCell *cells, void *data) {
Term *term = (Term *)data;
+ bool pushed_by_height_decr =
+ term->height_resize < 0 &&
+ term->sb_pending_by_height_decr < -term->height_resize;
if (!term->sb_size) {
return 0;
@@ -69,8 +72,9 @@ static int term_sb_push(int cols, const VTermScreenCell *cells, void *data) {
sbrow->info = term->lines[0];
memmove(term->lines, term->lines + 1,
sizeof(term->lines[0]) * (term->lines_len - 1));
- if (term->resizing) {
- /* pushed by window height decr */
+ if (pushed_by_height_decr) {
+ /* Only shrink line metadata for rows lost to a height decrease.
+ Reflow can also push lines during width changes. */
if (term->lines[term->lines_len - 1] != NULL) {
/* do not need free here ,it is reused ,we just need set null */
term->lines[term->lines_len - 1] = NULL;
@@ -97,8 +101,7 @@ static int term_sb_push(int cols, const VTermScreenCell *cells, void *data) {
if (term->sb_pending < term->sb_size) {
term->sb_pending++;
/* when window height decreased */
- if (term->height_resize < 0 &&
- term->sb_pending_by_height_decr < -term->height_resize) {
+ if (pushed_by_height_decr) {
term->sb_pending_by_height_decr++;
}
}
@@ -114,6 +117,9 @@ static int term_sb_push(int cols, const VTermScreenCell *cells, void *data) {
/// @param data Term
static int term_sb_pop(int cols, VTermScreenCell *cells, void *data) {
Term *term = (Term *)data;
+ bool popped_by_height_incr =
+ term->height_resize > 0 &&
+ term->lines_len < term->height + term->height_resize;
if (!term->sb_current) {
return 0;
@@ -142,14 +148,23 @@ static int term_sb_pop(int cols, VTermScreenCell *cells, void *data) {
cells[col].width = 1;
}
- LineInfo **lines = malloc(sizeof(LineInfo *) * (term->lines_len + 1));
-
- memmove(lines + 1, term->lines, sizeof(term->lines[0]) * term->lines_len);
- lines[0] = sbrow->info;
+ if (popped_by_height_incr) {
+ LineInfo **lines = malloc(sizeof(LineInfo *) * (term->lines_len + 1));
+ memmove(lines + 1, term->lines, sizeof(term->lines[0]) * term->lines_len);
+ lines[0] = sbrow->info;
+ term->lines_len += 1;
+ free(term->lines);
+ term->lines = lines;
+ } else if (term->lines_len > 0) {
+ LineInfo *lastline = term->lines[term->lines_len - 1];
+ memmove(term->lines + 1, term->lines,
+ sizeof(term->lines[0]) * (term->lines_len - 1));
+ term->lines[0] = sbrow->info;
+ free_lineinfo(lastline);
+ } else {
+ free_lineinfo(sbrow->info);
+ }
free(sbrow);
- term->lines_len += 1;
- free(term->lines);
- term->lines = lines;
return 1;
}
@@ -421,8 +436,9 @@ static int term_resize(int rows, int cols, void *user_data) {
term->invalid_start = 0;
term->invalid_end = rows;
- /* if rows=term->lines_len, that means term_sb_pop already resize term->lines
- */
+ /* term_sb_pop grows term->lines only for rows gained by height increases.
+ * Reflow can also pop lines during width changes, but those pops keep the
+ * metadata length stable. */
/* if rowslines_len, term_sb_push would resize term->lines there */
/* we only need to take care of rows>term->height */
@@ -456,7 +472,6 @@ static int term_resize(int rows, int cols, void *user_data) {
term->height = rows;
invalidate_terminal(term, -1, -1);
- term->resizing = false;
return 1;
}
@@ -1253,6 +1268,9 @@ emacs_value Fvterm_new(emacs_env *env, ptrdiff_t nargs, emacs_value args[],
vterm_screen_set_callbacks(term->vts, &vterm_screen_callbacks, term);
vterm_screen_set_damage_merge(term->vts, VTERM_DAMAGE_SCROLL);
vterm_screen_enable_altscreen(term->vts, true);
+#ifndef VTermScreenEnableReflowNotExists
+ vterm_screen_enable_reflow(term->vts, true);
+#endif
term->sb_size = MIN(SB_MAX, sb_size);
term->sb_current = 0;
term->sb_pending = 0;
@@ -1275,7 +1293,6 @@ emacs_value Fvterm_new(emacs_env *env, ptrdiff_t nargs, emacs_value args[],
}
term->linenum = term->height;
term->linenum_added = 0;
- term->resizing = false;
term->pty_fd = -1;
@@ -1373,7 +1390,6 @@ emacs_value Fvterm_set_size(emacs_env *env, ptrdiff_t nargs, emacs_value args[],
term->linenum_added = rows - term->height - term->sb_current;
}
}
- term->resizing = true;
vterm_set_size(term->vt, rows, cols);
vterm_screen_flush_damage(term->vts);
diff --git a/lisp/vterm/vterm-module.h b/lisp/vterm/vterm-module.h
index ebf36249..f387ae64 100644
--- a/lisp/vterm/vterm-module.h
+++ b/lisp/vterm/vterm-module.h
@@ -113,7 +113,6 @@ typedef struct Term {
int width, height;
int height_resize;
- bool resizing;
bool disable_bold_font;
bool disable_underline;
bool disable_inverse_video;
diff --git a/lisp/vterm/vterm-pkg.el b/lisp/vterm/vterm-pkg.el
index 8e5f2d11..3703c9b4 100644
--- a/lisp/vterm/vterm-pkg.el
+++ b/lisp/vterm/vterm-pkg.el
@@ -1,10 +1,10 @@
;; -*- no-byte-compile: t; lexical-binding: nil -*-
-(define-package "vterm" "20251119.1653"
+(define-package "vterm" "20260626.1906"
"Fully-featured terminal emulator."
'((emacs "25.1"))
:url "https://github.com/akermu/emacs-libvterm"
- :commit "a01a2894a1c1e81a39527835a9169e35b7ec5dec"
- :revdesc "a01a2894a1c1"
+ :commit "9495966d9124ac32c307aee5c0aeb4a06be37519"
+ :revdesc "9495966d9124"
:keywords '("terminals")
:authors '(("Lukas Fürmetz" . "fuermetz@mailbox.org"))
:maintainers '(("Lukas Fürmetz" . "fuermetz@mailbox.org")))
diff --git a/lisp/vterm/vterm.el b/lisp/vterm/vterm.el
index d6e4e779..2bf6348c 100644
--- a/lisp/vterm/vterm.el
+++ b/lisp/vterm/vterm.el
@@ -3,8 +3,8 @@
;; Copyright (C) 2017-2020 by Lukas Fürmetz & Contributors
;;
;; Author: Lukas Fürmetz
-;; Package-Version: 20251119.1653
-;; Package-Revision: a01a2894a1c1
+;; Package-Version: 20260626.1906
+;; Package-Revision: 9495966d9124
;; URL: https://github.com/akermu/emacs-libvterm
;; Keywords: terminals
;; Package-Requires: ((emacs "25.1"))
@@ -844,7 +844,10 @@ Exceptions are defined by `vterm-keymap-exceptions'."
;; Support to compilation-shell-minor-mode
;; Is this necessary? See vterm--compilation-setup
(setq next-error-function 'vterm-next-error-function)
- (setq-local bookmark-make-record-function 'vterm--bookmark-make-record))
+ (setq-local bookmark-make-record-function 'vterm--bookmark-make-record)
+
+ ;; Support to display directory in buffer listings.
+ (setq list-buffers-directory (expand-file-name default-directory)))
(defun vterm--tramp-get-shell (method)
"Get the shell for a remote location as specified in `vterm-tramp-shells'.
@@ -1244,12 +1247,9 @@ Argument ARG is passed to `yank'"
But when clicking to the unused area below the last prompt,
move the cursor to the prompt area."
(interactive "e\np")
- (let ((pt (mouse-set-point event promote-to-region)))
- (if (= (count-words pt (point-max)) 0)
- (vterm-reset-cursor-point)
- pt))
- ;; Otherwise it selects text for every other click
- (keyboard-quit))
+ (if (> (count-words (posn-point (event-end event)) (point-max)) 0)
+ (mouse-set-point event promote-to-region)
+ (vterm-reset-cursor-point)))
(defun vterm-send-string (string &optional paste-p)
"Send the string STRING to vterm.
@@ -1703,7 +1703,9 @@ If N is negative backward-line from end of buffer."
(defun vterm--set-directory (path)
"Set `default-directory' to PATH."
(let ((dir (vterm--get-directory path)))
- (when dir (setq default-directory dir))))
+ (when dir
+ (setq default-directory dir)
+ (setq list-buffers-directory dir))))
(defun vterm--get-directory (path)
"Get normalized directory to PATH."
@@ -1719,7 +1721,10 @@ If N is negative backward-line from end of buffer."
(progn
(when (file-directory-p dir)
(setq directory (file-name-as-directory dir))))
- (setq directory (file-name-as-directory (concat "/-:" path))))))
+ (let ((method (if (tramp-tramp-file-p default-directory)
+ (tramp-file-name-method (tramp-dissect-file-name default-directory))
+ tramp-default-method-marker)))
+ (setq directory (file-name-as-directory (concat tramp-prefix-format method tramp-postfix-method-format path)))))))
(when (file-directory-p path)
(setq directory (file-name-as-directory path))))
directory)))
diff --git a/lisp/web-mode/web-mode-pkg.el b/lisp/web-mode/web-mode-pkg.el
index 60c677be..b220acdf 100644
--- a/lisp/web-mode/web-mode-pkg.el
+++ b/lisp/web-mode/web-mode-pkg.el
@@ -1,9 +1,9 @@
;; -*- no-byte-compile: t; lexical-binding: nil -*-
-(define-package "web-mode" "20260331.1441"
+(define-package "web-mode" "20260623.932"
"Major mode for editing web templates."
'((emacs "24.3.1"))
:url "https://web-mode.org"
- :commit "e93b3fb89fd6345a5ff59795bed712abd486200a"
- :revdesc "e93b3fb89fd6"
+ :commit "aeee2d4c82a791ff69657c1413873bf9265544df"
+ :revdesc "aeee2d4c82a7"
:keywords '("languages")
:maintainers '(("François-Xavier Bois" . "fxbois@gmail.com")))
diff --git a/lisp/web-mode/web-mode.el b/lisp/web-mode/web-mode.el
index e9465c39..a42955f4 100644
--- a/lisp/web-mode/web-mode.el
+++ b/lisp/web-mode/web-mode.el
@@ -1,9 +1,9 @@
;;; web-mode.el --- major mode for editing web templates -*- coding: utf-8; lexical-binding: t; -*-
-;; Copyright 2011-2025 François-Xavier Bois
+;; Copyright 2011-2026 François-Xavier Bois
-;; Package-Version: 20260331.1441
-;; Package-Revision: e93b3fb89fd6
+;; Package-Version: 20260623.932
+;; Package-Revision: aeee2d4c82a7
;; Author: François-Xavier Bois
;; Maintainer: François-Xavier Bois
;; Package-Requires: ((emacs "24.3.1"))
@@ -24,7 +24,7 @@
;;---- CONSTS ------------------------------------------------------------------
-(defconst web-mode-version "17.3.22"
+(defconst web-mode-version "17.3.24"
"Web Mode version.")
;;---- GROUPS ------------------------------------------------------------------
@@ -9591,7 +9591,7 @@ Also return non-nil if it is the command `self-insert-command' is remapped to."
((and is-js (member ?\, chars))
(when debug (message "I400(%S) part-args" pos))
(cond
- ((not (web-mode-part-args-beginning pos reg-beg))
+ ((not (web-mode-javascript-args-beginning pos reg-beg)) ;; #1337
;;(message "ici")
)
((cdr (assoc "lineup-args" web-mode-indentation-params))
diff --git a/lisp/with-editor/with-editor-pkg.el b/lisp/with-editor/with-editor-pkg.el
index 977b5f53..29e1b5c2 100644
--- a/lisp/with-editor/with-editor-pkg.el
+++ b/lisp/with-editor/with-editor-pkg.el
@@ -1,11 +1,13 @@
;; -*- no-byte-compile: t; lexical-binding: nil -*-
-(define-package "with-editor" "20260301.1317"
+(define-package "with-editor" "20260625.855"
"Use the Emacsclient as $EDITOR."
- '((emacs "26.1")
- (compat "30.1"))
+ '((emacs "28.1")
+ (compat "31.0")
+ (cond-let "1.1")
+ (llama "1.0"))
:url "https://github.com/magit/with-editor"
- :commit "64211dcb815f2533ac3d2a7e56ff36ae804d8338"
- :revdesc "64211dcb815f"
+ :commit "36c34610b6b700b4d1f39ccabd2b8b8c9642292d"
+ :revdesc "36c34610b6b7"
:keywords '("processes" "terminals")
:authors '(("Jonas Bernoulli" . "emacs.with-editor@jonas.bernoulli.dev"))
:maintainers '(("Jonas Bernoulli" . "emacs.with-editor@jonas.bernoulli.dev")))
diff --git a/lisp/with-editor/with-editor.el b/lisp/with-editor/with-editor.el
index 519296cd..e1da9838 100644
--- a/lisp/with-editor/with-editor.el
+++ b/lisp/with-editor/with-editor.el
@@ -6,9 +6,13 @@
;; Homepage: https://github.com/magit/with-editor
;; Keywords: processes terminals
-;; Package-Version: 20260301.1317
-;; Package-Revision: 64211dcb815f
-;; Package-Requires: ((emacs "26.1") (compat "30.1"))
+;; Package-Version: 20260625.855
+;; Package-Revision: 36c34610b6b7
+;; Package-Requires: (
+;; (emacs "28.1")
+;; (compat "31.0")
+;; (cond-let "1.1")
+;; (llama "1.0"))
;; SPDX-License-Identifier: GPL-3.0-or-later
@@ -80,6 +84,8 @@
(require 'cl-lib)
(require 'compat)
+(require 'cond-let)
+(require 'llama)
(require 'server)
(require 'shell)
(eval-when-compile (require 'subr-x))
@@ -125,14 +131,14 @@ please see https://github.com/magit/magit/wiki/Emacsclient."))))
((bound-and-true-p emacsclient-program-name))
("emacsclient"))
path
- (mapcan (lambda (v) (cl-mapcar (lambda (e) (concat v e)) exec-suffixes))
+ (mapcan (lambda (suffix) (mapcar (##concat suffix %) exec-suffixes))
(nconc (and (boundp 'debian-emacs-flavor)
(list (format ".%s" debian-emacs-flavor)))
- (cl-mapcon (lambda (v)
- (setq v (string-join (reverse v) "."))
- (list v
- (concat "-" v)
- (concat ".emacs" v)))
+ (cl-mapcon (lambda (ver)
+ (setq ver (string-join (reverse ver) "."))
+ (list ver
+ (concat "-" ver)
+ (concat ".emacs" ver)))
(reverse version-lst))
(cons "" with-editor-emacsclient-program-suffixes)))
(lambda (exec)
@@ -383,7 +389,7 @@ And some tools that do not handle $EDITOR properly also break."
(dolist (client clients)
(message "client %S" client)
(ignore-errors
- (server-send-string client "-error Canceled by user"))
+ (server-send-string client "-error Canceled by user\n"))
(delete-process client))
(when (buffer-live-p buf)
(kill-buffer buf)))
@@ -546,12 +552,14 @@ at run-time.
process-environment))
;; As last resort fallback to the sleeping editor.
(push (concat "ALTERNATE_EDITOR=" with-editor-sleeping-editor)
- process-environment)))
+ process-environment)
+ ;; Work around bug in server.el of Emacs < 31.1. #139
+ (when (member (getenv "TERM") '(nil ""))
+ (setenv "TERM" "dumb"))))
(defun with-editor-server-window ()
(or (and buffer-file-name
- (cdr (cl-find-if (lambda (cons)
- (string-match-p (car cons) buffer-file-name))
+ (cdr (cl-find-if (##string-match-p (car %) buffer-file-name)
with-editor-server-window-alist)))
server-window))
@@ -732,8 +740,7 @@ OPEN \\([^ ]+?\\)\
Files matching a regexp in `with-editor-file-name-history-exclude'
are prevented from being added to that list."
(pcase-dolist (`(,file . ,_) files)
- (when (cl-find-if (lambda (regexp)
- (string-match-p regexp file))
+ (when (cl-find-if (##string-match-p % file)
with-editor-file-name-history-exclude)
(setq file-name-history
(delete (abbreviate-file-name file) file-name-history)))))
@@ -775,11 +782,11 @@ This works in `shell-mode', `term-mode', `eshell-mode' and
(process-environment process-environment))
(with-editor--setup)
(while (accept-process-output vterm--process 1 nil t))
- (when-let ((v (getenv envvar)))
- (vterm-send-string (format " export %s=%S" envvar v))
+ (when$ (getenv envvar)
+ (vterm-send-string (format " export %s=%S" envvar $))
(vterm-send-return))
- (when-let ((v (getenv "EMACS_SERVER_FILE")))
- (vterm-send-string (format " export EMACS_SERVER_FILE=%S" v))
+ (when$ (getenv "EMACS_SERVER_FILE")
+ (vterm-send-string (format " export EMACS_SERVER_FILE=%S" $))
(vterm-send-return))
(vterm-send-string " clear")
(vterm-send-return))
@@ -915,14 +922,13 @@ Also take care of that for `with-editor-[async-]shell-command'."
(funcall fn command output-buffer error-buffer)
(with-editor (funcall fn command output-buffer error-buffer)))
;; The comint filter was overridden with our filter. Use both.
- (and-let* ((process (get-buffer-process
- (or output-buffer
- (get-buffer "*Async Shell Command*")))))
+ (and-let ((process (get-buffer-process
+ (or output-buffer
+ (get-buffer "*Async Shell Command*")))))
(prog1 process
- (set-process-filter process
- (lambda (proc str)
- (comint-output-filter proc str)
- (with-editor-process-filter proc str t))))))
+ (add-function :after (process-filter process)
+ (lambda (proc str)
+ (with-editor-process-filter proc str t))))))
((funcall fn command output-buffer error-buffer)))))
;;; _
@@ -995,5 +1001,19 @@ See info node `(with-editor)Debugging' for instructions."
;; byte-compile-warnings: (not docstrings-control-chars)
;; indent-tabs-mode: nil
;; lisp-indent-local-overrides: ((cond . 0) (interactive . 0))
+;; read-symbol-shorthands: (
+;; ("and$" . "cond-let--and$")
+;; ("thread$" . "cond-let--thread$")
+;; ("when$" . "cond-let--when$")
+;; ("and-let*" . "cond-let--and-let*")
+;; ("and-let" . "cond-let--and-let")
+;; ("if-let*" . "cond-let--if-let*")
+;; ("if-let" . "cond-let--if-let")
+;; ("when-let*" . "cond-let--when-let*")
+;; ("when-let" . "cond-let--when-let")
+;; ("while-let*" . "cond-let--while-let*")
+;; ("while-let" . "cond-let--while-let")
+;; ("match-string" . "match-string")
+;; ("match-str" . "match-string-no-properties"))
;; End:
;;; with-editor.el ends here
diff --git a/lisp/with-editor/with-editor.info b/lisp/with-editor/with-editor.info
index a95ab4ec..963a14b3 100644
--- a/lisp/with-editor/with-editor.info
+++ b/lisp/with-editor/with-editor.info
@@ -40,7 +40,7 @@ library is made available as a separate package. It also defines some
additional functionality which makes it useful even for end-users, who
don't use Magit or another package which uses it internally.
-This manual is for With-Editor version 3.4.9.
+This manual is for With-Editor version 3.5.1.
Copyright (C) 2015-2026 Jonas Bernoulli
diff --git a/lisp/yasnippet/doc/faq.org b/lisp/yasnippet/doc/faq.org
new file mode 100644
index 00000000..6cff4d88
--- /dev/null
+++ b/lisp/yasnippet/doc/faq.org
@@ -0,0 +1,87 @@
+#+SETUPFILE: org-setup.inc
+
+#+TITLE: Frequently Asked Questions
+
+- *Note*: In addition to the questions and answers presented here,
+ you might also with to visit the list of [[https://github.com/joaotavora/yasnippet/issues?q=label%3Asupport][solved support issues]] in
+ the Github issue tracker. It might be more up-to-date than this
+ list.
+
+* Why are my snippet abbrev keys triggering when I don't want them too?
+Expansion of abbrev keys is controlled by [[sym:yas-key-syntaxes][=yas-key-syntaxes=]]. Try
+removing entries which correspond to the abbrev key character syntax.
+For example, if you have a snippet with abbrev key "bar", that you
+don't want to trigger when point follows the text =foo_bar=, remove
+the ="w"= entry (since "bar" has only word syntax characters).
+
+* Why aren't my snippet abbrev keys triggering when I want them too?
+See previous question, but in reverse.
+
+* Why is there an extra newline?
+
+If there is a newline at the end of a snippet definition file,
+YASnippet will add a newline when expanding that snippet. When editing
+or saving a snippet file, please be careful not to accidentally add a
+terminal newline.
+
+Note that some editors will automatically add a newline for you. In
+Emacs, if you set =require-final-newline= to =t=, it will add the
+final newline automatically.
+
+* Why doesn't TAB navigation work with flyspell
+
+This is [[https://debbugs.gnu.org/26672][Emacs Bug#26672]], so you should upgrade to version 25.3 or
+better. Otherwise, a workaround is to inhibit flyspell overlays while
+the snippet is active:
+
+#+BEGIN_SRC emacs-lisp
+ (add-hook 'flyspell-incorrect-hook
+ #'(lambda (&rest _)
+ (and yas-active-field-overlay
+ (overlay-buffer yas-active-field-overlay))))
+#+END_SRC
+
+* How do I use alternative keys, i.e. not TAB?
+
+Edit the keymaps [[sym:yas-minor-mode-map][=yas-minor-mode-map=]] and [[sym:yas-keymap][=yas-keymap=]] as you would
+any other keymap, but use [[sym:yas-filtered-definition][=yas-filtered-definition=]] on the definition
+if you want to respect [[sym:yas-keymap-disable-hook][=yas-keymap-disable-hook=]]:
+
+#+begin_src emacs-lisp :exports code
+ (define-key yas-minor-mode-map (kbd "") nil)
+ (define-key yas-minor-mode-map (kbd "TAB") nil)
+ (define-key yas-minor-mode-map (kbd "") yas-maybe-expand)
+
+ ;;keys for navigation
+ (define-key yas-keymap [(tab)] nil)
+ (define-key yas-keymap (kbd "TAB") nil)
+ (define-key yas-keymap [(shift tab)] nil)
+ (define-key yas-keymap [backtab] nil)
+ (define-key yas-keymap (kbd "")
+ (yas-filtered-definition 'yas-next-field-or-maybe-expand))
+ (define-key yas-keymap (kbd "")
+ (yas-filtered-definition 'yas-prev-field))
+#+end_src
+
+* How do I define an abbrev key containing characters not supported by the filesystem?
+
+- *Note*: This question applies if you're still defining snippets
+ whose key /is/ the filename. This is behavior still provided by
+ version 0.6 for backward compatibilty, but is somewhat
+ deprecated...
+
+For example, you want to define a snippet by the key =<= which is not a
+valid character for filename on Windows. This means you can't use the
+filename as a trigger key in this case.
+
+You should rather use the =# key:= directive to specify the key of the
+defined snippet explicitly and name your snippet with an arbitrary valid
+filename, =lt.YASnippet= for example, using =<= for the =# key:=
+directive:
+
+#+BEGIN_SRC snippet
+ # key: <
+ # name: <...>
+ # --
+ <${1:div}>$0
+#+END_SRC
diff --git a/lisp/yasnippet/doc/index.org b/lisp/yasnippet/doc/index.org
new file mode 100644
index 00000000..c5e0be32
--- /dev/null
+++ b/lisp/yasnippet/doc/index.org
@@ -0,0 +1,47 @@
+#+SETUPFILE: org-setup.inc
+#+TITLE: Yet another snippet extension
+
+The YASnippet documentation has been split into separate parts:
+
+0. [[https://github.com/joaotavora/yasnippet/blob/master/README.mdown][README]]
+
+ Contains an introduction, installation instructions and other important
+ notes.
+
+1. [[file:snippet-organization.org][Organizing Snippets]]
+
+ Describes ways to organize your snippets in the hard disk.
+
+2. [[file:snippet-expansion.org][Expanding Snippets]]
+
+ Describes how YASnippet chooses snippets for expansion at point.
+
+ Maybe, you'll want some snippets to be expanded in a particular mode,
+ or only under certain conditions, or be prompted using =ido=, etc...
+
+3. [[file:snippet-development.org][Writing Snippets]]
+
+ Describes the YASnippet definition syntax, which is very close (but
+ not equivalent) to Textmate's. Includes a section about converting
+ TextMate snippets.
+
+4. [[file:snippet-menu.org][The YASnippet menu]]
+
+ Explains how to use the YASnippet menu to explore, learn and modify
+ snippets.
+
+5. [[file:faq.org][Frequently asked questions]]
+
+ Answers to frequently asked questions.
+
+6. [[file:snippet-reference.org][YASnippet Symbol Reference]]
+
+ An automatically generated listing of all YASnippet commands,
+ (customization) variables, and functions.
+
+
+# Local Variables:
+# mode: org
+# fill-column: 80
+# coding: utf-8
+# End:
diff --git a/lisp/yasnippet/doc/snippet-development.org b/lisp/yasnippet/doc/snippet-development.org
new file mode 100644
index 00000000..806f82e5
--- /dev/null
+++ b/lisp/yasnippet/doc/snippet-development.org
@@ -0,0 +1,474 @@
+#+SETUPFILE: org-setup.inc
+
+#+TITLE: Writing snippets
+
+* Snippet development
+
+** Quickly finding snippets
+
+There are some ways you can quickly find a snippet file or create a new one:
+
+- =M-x yas-new-snippet=, key binding: =C-c & C-n=
+
+ Creates a new buffer with a template for making a new snippet. The
+ buffer is in =snippet-mode= (see [[snippet-mode][below]]). When you are done editing
+ the new snippet, use [[yas-load-snippet-buffer-and-close][=C-c C-c=]] to save it.
+
+- =M-x yas-visit-snippet-file=, key binding: =C-c & C-v=
+
+ Prompts you for possible snippet expansions like
+ [[sym:yas-insert-snippet][=yas-insert-snippet=]], but instead of expanding it, takes you directly
+ to the snippet definition's file, if it exists.
+
+Once you find this file it will be set to =snippet-mode= (see [[snippet-mode][ahead]])
+and you can start editing your snippet.
+
+** Using the =snippet-mode= major mode <>
+
+There is a major mode =snippet-mode= to edit snippets. You can set the
+buffer to this mode with =M-x snippet-mode=. It provides reasonably
+useful syntax highlighting.
+
+Three commands are defined in this mode:
+
+- =M-x yas-load-snippet-buffer=, key binding: =C-c C-l=
+
+ Prompts for a snippet table (with a default based on snippet's
+ major mode) and loads the snippet currently being edited.
+
+- =M-x yas-load-snippet-buffer-and-close=, key binding: =C-c C-c=
+ <>
+
+ Like =yas-load-snippet-buffer=, but also saves the snippet and
+ calls =quit-window=. The destination is decided based on the
+ chosen snippet table and snippet collection directly (defaulting to
+ the first directory in =yas-snippet-dirs= (see [[file:snippet-organization.org][Organizing Snippets]]
+ for more detail on how snippets are organized).
+
+- =M-x yas-tryout-snippet=, key binding: =C-c C-t=
+
+ When editing a snippet, this opens a new empty buffer, sets it to
+ the appropriate major mode and inserts the snippet there, so you
+ can see what it looks like.
+
+There are also /snippets for writing snippets/: =vars=, =$f= and =$m=
+:-).
+
+* File content
+
+A file defining a snippet generally contains the template to be
+expanded.
+
+Optionally, if the file contains a line of =# --=, the lines above it
+count as comments, some of which can be /directives/ (or meta data).
+Snippet directives look like =# property: value= and tweak certain
+snippet properties described below. If no =# --= is found, the whole
+file is considered the snippet template.
+
+Here's a typical example:
+
+#+BEGIN_SRC snippet
+ # contributor: pluskid
+ # name: __...__
+ # --
+ __${init}__
+#+END_SRC
+
+Here's a list of currently supported directives:
+
+** =# key:= snippet abbrev
+
+This is the probably the most important directive, it's the
+abbreviation you type to expand a snippet just before hitting the key
+that runs [[sym:yas-expand][=yas-expand=]]. If you don't specify this,
+the snippet will not be expandable through the trigger mechanism.
+
+** =# name:= snippet name
+
+This is a one-line description of the snippet. It will be displayed in
+the menu. It's a good idea to select a descriptive name for a snippet --
+especially distinguishable among similar snippets.
+
+If you omit this name, it will default to the file name the snippet
+was loaded from.
+
+** =# condition:= snippet condition
+
+This is a piece of Emacs Lisp code. If a snippet has a condition, then
+it will only be expanded when the condition code evaluate to some
+non-nil value.
+
+See also [[sym:yas-buffer-local-condition][=yas-buffer-local-condition=]] in
+[[./snippet-expansion.org][Expanding snippets]]
+
+** =# group:= snippet menu grouping
+
+When expanding/visiting snippets from the menu-bar menu, snippets for a
+given mode can be grouped into sub-menus. This is useful if one has too
+many snippets for a mode which will make the menu too long.
+
+The =# group:= property only affect menu construction (See
+[[./snippet-menu.org][the YASnippet menu]]) and the same effect can be
+achieved by grouping snippets into sub-directories and using the
+=.yas-make-groups= special file (for this see
+[[./snippet-organization.org][Organizing Snippets]]
+
+Refer to the bundled snippets for =ruby-mode= for examples of the
+=# group:= directive. Group can also be nested, e.g.
+=control structure.loops= indicates that the snippet is under the =loops=
+group which is under the =control structure= group.
+
+** =# expand-env:= expand environment
+
+This is another piece of Emacs Lisp code in the form of a =let= /varlist
+form/, i.e. a list of lists assigning values to variables. It can be
+used to override variable values while the snippet is being expanded.
+
+Interesting variables to override are [[sym:yas-wrap-around-region][=yas-wrap-around-region=]] and
+[[sym:yas-indent-line][=yas-indent-line=]] (see [[./snippet-expansion.org][Expanding Snippets]]).
+
+As an example, you might normally have [[sym:yas-indent-line][=yas-indent-line=]] set to '=auto=
+and [[sym:yas-wrap-around-region][=yas-wrap-around-region=]] set to =t=, but for this particularly
+brilliant piece of ASCII art these values would mess up your hard work.
+You can then use:
+
+#+BEGIN_SRC snippet
+ # name: ASCII home
+ # expand-env: ((yas-indent-line 'fixed) (yas-wrap-around-region 'nil))
+ # --
+ welcome to my
+ X humble
+ / \ home,
+ / \ $0
+ / \
+ /-------\
+ | |
+ | +-+ |
+ | | | |
+ +--+-+--+
+#+END_SRC
+
+** =# binding:= direct keybinding
+
+You can use this directive to expand a snippet directly from a normal
+Emacs keybinding. The keybinding will be registered in the Emacs keymap
+named after the major mode the snippet is active for.
+
+Additionally a variable [[sym:yas-prefix][=yas-prefix=]] is set to the prefix argument
+you normally use for a command. This allows for small variations on the
+same snippet, for example in this =html-mode= snippet.
+
+#+BEGIN_SRC snippet
+ # name: ...
+ # binding: C-c C-c C-m
+ # --
+ `(when yas-prefix "\n")`$0`(when yas-prefix "\n")`
+#+END_SRC
+
+This binding will be recorded in the keymap =html-mode-map=. To expand a
+paragraph tag newlines, just press =C-u C-c C-c C-m=. Omitting the =C-u=
+will expand the paragraph tag without newlines.
+
+** =# type:= =snippet= or =command=
+
+If the =type= directive is set to =command=, the body of the snippet
+is interpreted as Lisp code to be evaluated when the snippet is
+triggered.
+
+If it's =snippet= (the default when there is no =type= directive), the
+snippet body will be parsed according to the [[Template Syntax]],
+described below.
+
+** =# uuid:= unique identifier
+
+This provides to a way to identify a snippet, independent of its name.
+Loading a second snippet file with the same uuid would replace the
+previous snippet.
+
+** =# contributor:= snippet author
+
+This is optional and has no effect whatsoever on snippet functionality,
+but it looks nice.
+
+* Template Syntax
+
+The syntax of the snippet template is simple but powerful, very similar
+to TextMate's.
+
+** Plain Text
+
+Arbitrary text can be included as the content of a template. They are
+usually interpreted as plain text, except =$= and =`=. You need to
+use =\= to escape them: =\$= and =\`=. The =\= itself may also needed to be
+escaped as =\\= sometimes.
+
+** Embedded Emacs Lisp code
+
+Emacs Lisp code can be embedded inside the template, written inside
+back-quotes (=`=). The Lisp forms are evaluated when the snippet is
+being expanded. The evaluation is done in the same buffer as the
+snippet being expanded.
+
+Here's an example for =c-mode= to calculate the header file guard
+dynamically:
+
+#+BEGIN_SRC snippet
+ #ifndef ${1:_`(upcase (file-name-nondirectory (file-name-sans-extension (buffer-file-name))))`_H_}
+ #define $1
+
+ $0
+
+ #endif /* $1 */
+#+END_SRC
+
+From version 0.6, snippet expansions are run with some special
+Emacs Lisp variables bound. One of these is [[sym:yas-selected-text][=yas-selected-text=]]. You can
+therefore define a snippet like:
+
+#+BEGIN_SRC snippet
+ for ($1;$2;$3) {
+ `yas-selected-text`$0
+ }
+#+END_SRC
+
+to "wrap" the selected region inside your recently inserted snippet.
+Alternatively, you can also customize the variable
+[[sym:yas-wrap-around-region][=yas-wrap-around-region=]] to =t= which will do this automatically.
+
+*** Note: backquote expressions should not modify the buffer
+
+Please note that the Lisp forms in backquotes should *not* modify the
+buffer, doing so will trigger a warning. For example, instead of
+doing
+
+#+BEGIN_SRC snippet
+ Timestamp: `(insert (current-time-string))`
+#+END_SRC
+
+do this:
+#+BEGIN_SRC snippet
+ Timestamp: `(current-time-string)`
+#+END_SRC
+
+The warning may be suppressed with the following code in your init file:
+#+BEGIN_SRC emacs-lisp
+ (add-to-list 'warning-suppress-types '(yasnippet backquote-change))
+#+END_SRC
+
+
+** Tab stop fields
+
+Tab stops are fields that you can navigate back and forth by =TAB= and
+=S-TAB=. They are written by =$= followed with a number. =$0= has the
+special meaning of the /exit point/ of a snippet. That is the last place
+to go when you've traveled all the fields. Here's a typical example:
+
+#+BEGIN_SRC snippet
+
+ $0
+
+#+END_SRC
+** Placeholder fields
+
+Tab stops can have default values -- a.k.a placeholders. The syntax is
+like this:
+
+#+BEGIN_SRC snippet
+ ${N:default value}
+#+END_SRC
+
+They act as the default value for a tab stop. But when you first
+type at a tab stop, the default value will be replaced by your typing.
+The number can be omitted if you don't want to create [[mirrors-fields][mirrors]] or
+[[mirror-transformations][transformations]] for this field.
+
+** Mirrors <>
+
+We refer to tab stops with placeholders as a /field/. A field can
+have mirrors. *All* mirrors get updated whenever you update any field
+text. Here's an example:
+
+#+BEGIN_SRC snippet
+ \begin{${1:enumerate}}
+ $0
+ \end{$1}
+#+END_SRC
+
+When you type "document" at =${1:enumerate}=, the word "document" will
+also be inserted at =\end{$1}=. The best explanation is to see the
+screencast([[http://www.youtube.com/watch?v=vOj7btx3ATg][YouTube]] or [[http://yasnippet.googlecode.com/files/yasnippet.avi][avi video]]).
+
+The tab stops with the same number to the field act as its mirrors. If
+none of the tab stops have an initial value, the first one is selected as
+the field and the others are its mirrors.
+
+** Mirrors with transformations <>
+
+If the value of an =${n:=-construct starts with and contains =$(=,
+then it is interpreted as a mirror for field =n= with a
+transformation. The mirror's text content is calculated according to
+this transformation, which is Emacs Lisp code that gets evaluated in
+an environment where the variable [[sym:yas-text][=yas-text=]] is bound to the text
+content (string) contained in the field =n=. Here's an example for
+Objective-C:
+
+#+BEGIN_SRC snippet
+ - (${1:id})${2:foo}
+ {
+ return $2;
+ }
+
+ - (void)set${2:$(capitalize yas-text)}:($1)aValue
+ {
+ [$2 autorelease];
+ $2 = [aValue retain];
+ }
+ $0
+#+END_SRC
+
+Look at =${2:$(capitalize yas-text)}=, it is a mirror with
+transformation instead of a field. The actual field is at the first
+line: =${2:foo}=. When you type text in =${2:foo}=, the transformation
+will be evaluated and the result will be placed there as the
+transformed text. So in this example, if you type "baz" in the field,
+the transformed text will be "Baz". This example is also available in
+the screencast.
+
+Another example is for =rst-mode=. In reStructuredText, the document
+title can be some text surrounded by "===" below and above. The "==="
+should be at least as long as the text. So
+
+#+BEGIN_SRC rst
+ =====
+ Title
+ =====
+#+END_SRC
+
+is a valid title but
+
+#+BEGIN_SRC rst
+ ===
+ Title
+ ===
+#+END_SRC
+
+is not. Here's an snippet for rst title:
+
+#+BEGIN_SRC snippet
+ ${1:$(make-string (string-width yas-text) ?\=)}
+ ${1:Title}
+ ${1:$(make-string (string-width yas-text) ?\=)}
+
+ $0
+#+END_SRC
+
+Note that a mirror with a transform is not restricted to the text of
+the field it is mirroring. By making use of [[sym:yas-field-value][=yas-field-value=]], a
+mirror can look at any of the snippet's field (as mentioned above, all
+mirrors are updated when any field is updated). Here is an example
+which shows a "live" result of calling format:
+
+#+BEGIN_SRC snippet
+(format "${1:formatted %s}" "${2:value}")
+=> "${1:$(ignore-errors (format (yas-field-value 1) (yas-field-value 2)))}"
+#+END_SRC
+
+To keep the example simple, it uses =ignore-errors= to suppress errors
+due to incomplete format codes.
+
+** Fields with transformations
+
+From version 0.6 on, you can also have Lisp transformation inside
+fields. These work mostly like mirror transformations. However, they
+are evaluated when you first enter the field, after each change you
+make to the field and also just before you exit the field.
+
+The syntax is also a tiny bit different, so that the parser can
+distinguish between fields and mirrors. In the following example
+
+: #define "${1:mydefine$(upcase yas-text)}"
+
+=mydefine= gets automatically upcased to =MYDEFINE= once you enter the
+field. As you type text, it gets filtered through the transformation
+every time.
+
+Note that to tell this kind of expression from a mirror with a
+transformation, YASnippet needs extra text between the =:= and the
+transformation's =$=. If you don't want this extra-text, you can use two
+=$='s instead.
+
+: #define "${1:$$(upcase yas-text)}"
+
+Please note that as soon as a transformation takes place, it changes the
+value of the field and sets it its internal modification state to
+=true=. As a consequence, the auto-deletion behaviour of normal fields
+does not take place. This is by design.
+
+** Choosing fields value from a list and other tricks
+
+As mentioned, the field transformation is invoked just after you enter
+the field, and with some useful variables bound, notably
+[[sym:yas-modified-p][=yas-modified-p=]] and [[sym:yas-moving-away-p][=yas-moving-away-p=]]. Because of this feature you
+can place a transformation in the primary field that lets you select
+default values for it.
+
+For example, the [[sym:yas-choose-value][=yas-completing-read=]] function is version of
+=completing-read= which checks these variables. For example, asking
+the user for the initial value of a field:
+
+#+BEGIN_SRC snippet
+
+ $0
+
+#+END_SRC
+
+See the definition of [[sym:yas-choose-value][=yas-completing-read=]] to see how it was written
+using the two variables. If you're really lazy :) and can't spare a
+tab keypress, you can automatically move to the next field (or exit)
+after choosing the value with [[sym:yas-auto-next][=yas-auto-next=]]. The snippet above
+becomes:
+
+#+BEGIN_SRC snippet
+
+ $0
+
+#+END_SRC
+
+Here's another use, for =LaTeX-mode=, which calls reftex-label just as you
+enter snippet field 2. This one makes use of [[sym:yas-modified-p][=yas-modified-p=]] directly.
+
+#+BEGIN_SRC snippet
+ \section{${1:"Titel der Tour"}}%
+ \index{$1}%
+ \label{{2:"waiting for reftex-label call..."$(unless yas-modified-p (reftex-label nil 'dont-insert))}}%
+#+END_SRC
+
+The function [[sym:yas-verify-value][=yas-verify-value=]] has another neat trick, and makes use
+of [[sym:yas-moving-away-p][=yas-moving-away-p=]]. Try it and see! Also, check out this [[http://groups.google.com/group/smart-snippet/browse_thread/thread/282a90a118e1b662][thread]]
+
+** Nested placeholder fields
+
+From version 0.6 on, you can also have nested placeholders of the type:
+
+#+BEGIN_SRC snippet
+ $0
+#+END_SRC
+
+This allows you to choose if you want to give this =div= an =id=
+attribute. If you tab forward after expanding, it will let you change
+"some\_id" to whatever you like. Alternatively, you can just press =C-d=
+(which executes [[sym:yas-skip-and-clear-or-delete-char][=yas-skip-and-clear-or-delete-char=]]) and go straight to
+the exit marker.
+
+By the way, =C-d= will only clear the field if you cursor is at the
+beginning of the field /and/ it hasn't been changed yet. Otherwise, it
+performs the normal Emacs =delete-char= command.
+
+** Indentation markers
+
+If [[sym:yas-indent-line][=yas-indent-line=]] is *not* set to '=auto=, it's still possible to
+indent specific lines by adding an indentation marker, =$>=, somewhere
+on the line.
diff --git a/lisp/yasnippet/doc/snippet-expansion.org b/lisp/yasnippet/doc/snippet-expansion.org
new file mode 100644
index 00000000..2ff0e458
--- /dev/null
+++ b/lisp/yasnippet/doc/snippet-expansion.org
@@ -0,0 +1,284 @@
+#+SETUPFILE: org-setup.inc
+
+#+TITLE: Expanding snippets
+
+ This section describes how YASnippet chooses snippets for expansion at point.
+
+ Maybe, you'll want some snippets to be expanded in a particular
+ mode, or only under certain conditions, or be prompted using
+
+* Triggering expansion
+
+ You can use YASnippet to expand snippets in different ways:
+
+ - When [[sym:yas-minor-mode][=yas-minor-mode=]] is active:
+ - Type the snippet's *trigger key* then calling [[sym:yas-expand][=yas-expand=]]
+ (bound to =TAB= by default).
+
+ - Use the snippet's *keybinding*.
+
+ - By expanding directly from the "YASnippet" menu in the menu-bar
+
+ - Using hippie-expand
+
+ - Call [[sym:yas-insert-snippet][=yas-insert-snippet=]] (use =M-x yas-insert-snippet= or its
+ keybinding =C-c & C-s=).
+
+ - Use m2m's excellent auto-complete
+ TODO: example for this
+
+ - Expanding from emacs-lisp code
+
+** Trigger key
+
+[[sym:yas-expand][=yas-expand=]] tries to expand a /snippet abbrev/ (also known as
+/snippet key/) before point. YASnippet also provides a /conditional
+binding/ for this command: the variable [[sym:yas-expand][=yas-maybe-expand=]] contains a
+special value which, when bound in a keymap, tells Emacs to call
+[[sym:yas-expand][=yas-expand=]] if and only if there is a snippet abbrev before point.
+If there is no snippet to expand, Emacs will behave as if [[sym:yas-expand][=yas-expand=]]
+is unbound and so will run whatever command is bound to that key
+normally.
+
+When [[sym:yas-minor-mode][=yas-minor-mode=]] is enabled, it binds [[sym:yas-maybe-expand][=yas-maybe-expand=]] to =TAB=
+and == by default, however, you can freely remove those bindings:
+
+#+begin_src emacs-lisp :exports code
+ (define-key yas-minor-mode-map (kbd "") nil)
+ (define-key yas-minor-mode-map (kbd "TAB") nil)
+#+end_src
+
+And set your own:
+
+#+begin_src emacs-lisp :exports code
+ ;; Bind `SPC' to `yas-expand' when snippet expansion available (it
+ ;; will still call `self-insert-command' otherwise).
+ (define-key yas-minor-mode-map (kbd "SPC") yas-maybe-expand)
+ ;; Bind `C-c y' to `yas-expand' ONLY.
+ (define-key yas-minor-mode-map (kbd "C-c y") #'yas-expand)
+#+end_src
+
+
+To enable the YASnippet minor mode in all buffers globally use the
+command [[sym:yas-global-mode][=yas-global-mode=]]. This will enable a modeline indicator,
+=yas=:
+
+[[./images/minor-mode-indicator.png]]
+
+When you use [[sym:yas-global-mode][=yas-global-mode=]] you can also selectively disable
+YASnippet in some buffers by calling [[sym:yas-minor-mode][=yas-minor-mode=]] with a negative
+argument in the buffer's mode hook.
+
+*** Fallback behaviour
+
+YASnippet used to support a more complicated way of sharing
+keybindings before [[sym:yas-expand][=yas-maybe-expand=]] was added. This is now
+obsolete.
+
+** Insert at point
+
+The command [[sym:yas-insert-snippet][=yas-insert-snippet=]] lets you insert snippets at point
+/for your current major mode/. It prompts you for the snippet key
+first, and then for a snippet template if more than one template
+exists for the same key.
+
+The list presented contains the snippets that can be inserted at point,
+according to the condition system. If you want to see all applicable
+snippets for the major mode, prefix this command with =C-u=.
+
+The prompting methods used are again controlled by
+[[sym:yas-prompt-functions][=yas-prompt-functions=]].
+
+*** Inserting region or register contents into snippet
+
+It's often useful to inject already written text in the middle of a
+snippet. The variable [[sym:yas-wrap-around-region][=yas-wrap-around-region=]] when to t substitute
+the region contents into the =$0= placeholder of a snippet expanded by
+[[sym:yas-insert-snippet][=yas-insert-snippet=]]. Setting it to a character value (e.g. =?0=)
+will insert the contents of corresponding register.
+
+Older (versions 0.9.1 and below) of Yasnippet, supported a setting of
+=cua= that is equivalent to =?0= but only worked with =cua-mode=
+turned on. This setting is still supported for backwards
+compatibility, but is now entirely equivalent to =?0=.
+
+** Snippet keybinding
+
+See the section of the =# binding:= directive in
+[[./snippet-development.org][Writing Snippets]].
+
+** Expanding from the menu
+
+See [[./snippet-menu.org][the YASnippet Menu]].
+
+** Expanding with =hippie-expand=
+
+To integrate with =hippie-expand=, just put
+[[sym:yas-hippie-try-expand][=yas-hippie-try-expand=]] in
+=hippie-expand-try-functions-list=. This probably makes more sense
+when placed at the top of the list, but it can be put anywhere you
+prefer.
+
+** Expanding from emacs-lisp code
+
+Sometimes you might want to expand a snippet directly from your own
+elisp code. You should call [[sym:yas-expand-snippet][=yas-expand-snippet=]] instead of
+[[sym:yas-expand][=yas-expand=]] in this case. [[sym:yas-expand-snippet][=yas-expand-snippet=]] takes a string in
+snippet template syntax, if you want to expand an existing snippet you
+can use [[sym:yas-lookup-snippet][=yas-lookup-snippet=]] to find its contents by name.
+
+As with expanding from the menubar, the condition system and multiple
+candidates doesn't affect expansion (the condition system does affect
+[[sym:yas-lookup-snippet][=yas-lookup-snippet=]] though). In fact, expanding from the YASnippet
+menu has the same effect of evaluating the follow code:
+
+#+BEGIN_SRC emacs-lisp
+ (yas-expand-snippet template)
+#+END_SRC
+
+See the internal documentation on [[sym:yas-expand-snippet][=yas-expand-snippet=]] and
+[[sym:yas-lookup-snippet][=yas-lookup-snippet=]] for more information.
+
+* Controlling expansion
+
+** Eligible snippets<>
+
+YASnippet does quite a bit of filtering to find out which snippets are
+eligible for expanding at the current cursor position.
+
+In particular, the following things matter:
+
+- Currently loaded snippets tables
+
+ These are loaded from a directory hierarchy in your file system. See
+ [[./snippet-organization.org][Organizing Snippets]]. They are named
+ after major modes like =html-mode=, =ruby-mode=, etc...
+
+- Major mode of the current buffer
+
+ If the currrent major mode matches one of the loaded snippet tables,
+ then all that table's snippets are considered for expansion. Use
+ =M-x describe-variable RET major-mode RET= to find out which major
+ mode you are in currently.
+
+- Parent tables
+
+ Snippet tables defined as the parent of some other eligible table
+ are also considered. This works recursively, i.e., parents of
+ parents of eligible tables are also considered. As a special case,
+ if a mode doesn't have a parent, then =fundamental-mode= is
+ considered to be its parent.
+
+- Buffer-local list of extra modes
+
+ Use [[sym:yas-activate-extra-mode][=yas-activate-extra-mode=]] to
+ consider snippet tables whose name does not correspond to a major
+ mode. Typically, you call this from a minor mode hook, for example:
+
+#+BEGIN_SRC emacs-lisp
+ ;; When entering rinari-minor-mode, consider also the snippets in the
+ ;; snippet table "rails-mode"
+ (add-hook 'rinari-minor-mode-hook
+ #'(lambda ()
+ (yas-activate-extra-mode 'rails-mode)))
+#+END_SRC
+
+- Buffer-local [[sym:yas-buffer-local-condition][=yas-buffer-local-condition=]] variable
+
+ This variable provides finer grained control over what snippets can
+ be expanded in the current buffer. For example, the constant
+ [[sym:yas-not-string-or-comment-condition][=yas-not-string-or-comment-condition=]] has a value that disables
+ snippet expansion inside comments or string literals. See [[condition-system][the
+ condition system]] for more info.
+
+** The condition system <>
+
+Consider this scenario: you are an old Emacs hacker. You like the
+abbrev-way and bind [[sym:yas-expand][=yas-expand=]] to =SPC=. However, you don't want
+=if= to be expanded as a snippet when you are typing in a comment
+block or a string (e.g. in =python-mode=).
+
+If you use the =# condition := directive (see [[./snippet-development.org][Writing Snippets]]) you
+could just specify the condition for =if= to be =(not
+(python-syntax-comment-or-string-p))=. But how about =while=, =for=,
+etc? Writing the same condition for all the snippets is just boring.
+So you can instead set [[sym:yas-buffer-local-condition][=yas-buffer-local-condition=]] to =(not
+(python-syntax-comment-or-string-p))= in =python-mode-hook=.
+
+Then, what if you really want some particular snippet to expand even
+inside a comment? Set [[sym:yas-buffer-local-condition][=yas-buffer-local-condition=]] like this
+
+#+BEGIN_SRC emacs-lisp
+ (add-hook 'python-mode-hook
+ (lambda ()
+ (setq yas-buffer-local-condition
+ (lambda ()
+ (if (python-syntax-comment-or-string-p)
+ '(require-snippet-condition . force-in-comment)
+ t)))))
+#+END_SRC
+
+... and for a snippet that you want to expand in comments, specify a
+condition which evaluates to the symbol =force-in-comment=. Then it
+can be expanded as you expected, while other snippets like =if= still
+can't expanded in comments.
+
+For the full set of possible conditions, see the documentation for
+[[sym:yas-buffer-local-condition][=yas-buffer-local-condition=]].
+
+** Multiples snippet with the same key
+
+The rules outlined [[eligible-snippets][above]] can return more than
+one snippet to be expanded at point.
+
+When there are multiple candidates, YASnippet will let you select one.
+The UI for selecting multiple candidate can be customized through
+[[sym:yas-prompt-functions][=yas-prompt-functions=]] , which defines your preferred methods of being
+prompted for snippets.
+
+You can customize it with
+=M-x customize-variable RET yas-prompt-functions RET=. Alternatively you
+can put in your emacs-file:
+
+#+BEGIN_SRC emacs-lisp
+ (setq yas-prompt-functions '(yas-x-prompt yas-dropdown-prompt))
+#+END_SRC
+
+Currently there are some alternatives solution with YASnippet.
+
+*** Use the X window system
+
+[[./images/x-menu.png]]
+
+The function [[sym:yas-x-prompt][=yas-x-prompt=]] can be used to show a popup menu for you to
+select. This menu will be part of you native window system widget, which
+means:
+
+- It usually looks beautiful. E.g. when you compile Emacs with gtk
+ support, this menu will be rendered with your gtk theme.
+- Your window system may or may not allow to you use =C-n=, =C-p= to
+ navigate this menu.
+- This function can't be used when in a terminal.
+
+*** Minibuffer prompting
+
+[[./images/ido-menu.png]]
+
+You can use functions [[sym:yas-completing-prompt][=yas-completing-prompt=]] for the classic emacs
+completion method or [[sym:yas-ido-prompt][=yas-ido-prompt=]] for a much nicer looking method.
+The best way is to try it. This works in a terminal.
+
+*** Use =dropdown-menu.el=
+
+[[./images/dropdown-menu.png]]
+
+The function [[sym:yas-dropdown-prompt][=yas-dropdown-prompt=]] can also be placed in the
+[[sym:yas-prompt-functions][=yas-prompt-functions=]] list.
+
+This works in both window system and terminal and is customizable, you
+can use =C-n=, =C-p= to navigate, =q= to quit and even press =6= as a
+shortcut to select the 6th candidate.
+
+*** Roll your own
+
+See the documentation on variable [[sym:yas-prompt-functions][=yas-prompt-functions=]]
diff --git a/lisp/yasnippet/doc/snippet-menu.org b/lisp/yasnippet/doc/snippet-menu.org
new file mode 100644
index 00000000..fee3a196
--- /dev/null
+++ b/lisp/yasnippet/doc/snippet-menu.org
@@ -0,0 +1,68 @@
+#+SETUPFILE: org-setup.inc
+
+#+TITLE: YASnippet menu
+
+When [[sym:yas-minor-mode][=yas-minor-mode=]] is active, YASnippet will setup a menu just after
+the "Buffers" menu in the menubar.
+
+In this menu, you can find
+
+- The currently loaded snippet definitions, organized by major mode,
+ and optional grouping.
+
+- A rundown of the most common commands, (followed by their
+ keybindings) including commands to load directories and reload all
+ snippet definitions.
+
+- A series of submenus for customizing and exploring YASnippet
+ behavior.
+
+[[./images/menu-1.png]]
+
+* Loading snippets from menu
+
+Invoking "Load snippets..." from the menu invokes [[sym:yas-load-directory][=yas-load-directory=]]
+and prompts you for a snippet directory hierarchy to load.
+
+Also useful is the "Reload everything" item to invoke [[sym:yas-reload-all][=yas-reload-all=]]
+which uncondionally reloads all the snippets directories defined in
+[[sym:yas-snippet-dirs][=yas-snippet-dirs=]] and rebuilds the menus.
+
+* Snippet menu behavior
+
+YASnippet will list in this section all the loaded snippet definitions
+organized by snippet table name.
+
+You can use this section to explore currently loaded snippets. If you
+click on one of them, the default behavior is to expand it,
+unconditionally, inside the current buffer.
+
+You can however, customize variable [[sym:yas-visit-from-menu][=yas-visit-from-menu=]] to be =t=
+which will take you to the snippet definition file when you select it
+from the menu.
+
+If you want the menu show only snippet tables whose name corresponds to
+a "real" major mode. You do this by setting [[sym:yas-use-menu][=yas-use-menu=]] to
+'=real-modes=.
+
+Finally, to have the menu show only the tables for the currently active
+mode, set [[sym:yas-use-menu][=yas-use-menu=]] to =abbreviate=.
+
+These customizations can also be found in the menu itself, under the
+"Snippet menu behavior" submenu.
+
+* Controlling indenting
+
+The "Indenting" submenu contains options to control the values of
+[[sym:yas-indent-line][=yas-indent-line=]] and [[sym:yas-also-auto-indent-first-line][=yas-also-auto-indent-first-line=]]. See
+[[./snippet-development.org][Writing snippets]].
+
+* Prompting method
+
+The "Prompting method" submenu contains options to control the value of
+[[sym:yas-prompt-functions][=yas-prompt-functions=]]. See [[./snippet-expansion.org][Expanding snippets]].
+
+* Misc
+
+The "Misc" submenu contains options to control the values of more
+variables.
diff --git a/lisp/yasnippet/doc/snippet-organization.org b/lisp/yasnippet/doc/snippet-organization.org
new file mode 100644
index 00000000..6b8feef9
--- /dev/null
+++ b/lisp/yasnippet/doc/snippet-organization.org
@@ -0,0 +1,132 @@
+#+SETUPFILE: org-setup.inc
+
+#+TITLE: Organizing snippets
+
+* Basic structure
+
+ Snippet collections can be stored in plain text files. They are
+ arranged by sub-directories naming *snippet tables*. These mostly
+ name Emacs major mode names.
+
+ #+begin_example
+ .
+ |-- c-mode
+ | `-- printf
+ |-- java-mode
+ | `-- println
+ `-- text-mode
+ |-- email
+ `-- time
+ #+end_example
+
+ The collections are loaded into *snippet tables* which the
+ triggering mechanism (see [[file:snippet-expansion.org][Expanding Snippets]]) looks up and
+ (hopefully) causes the right snippet to be expanded for you.
+
+* Setting up =yas-snippet-dirs=
+
+ The emacs variable [[sym:yas-snippet-dirs][=yas-snippet-dirs=]] tells YASnippet
+ which collections to consider. It's used when you activate
+ [[sym:yas-global-mode][=yas-global-mode=]] or call
+ [[sym:yas-reload-all][=yas-reload-all=]] interactively.
+
+ The default considers:
+
+ - a personal collection that lives in =~/.emacs.d/snippets=
+ - the bundled collection, taken as a relative path to =yasnippet.el= location
+
+ When you come across other snippet collections, do the following to try them
+ out:
+
+ #+begin_src emacs-lisp :exports code
+ ;; Develop in ~/emacs.d/mysnippets, but also
+ ;; try out snippets in ~/Downloads/interesting-snippets
+ (setq yas-snippet-dirs '("~/emacs.d/mysnippets"
+ "~/Downloads/interesting-snippets"))
+
+ ;; OR, keeping YASnippet defaults try out ~/Downloads/interesting-snippets
+ (setq yas-snippet-dirs (append yas-snippet-dirs
+ '("~/Downloads/interesting-snippets")))
+ #+end_src
+
+ Collections appearing earlier in the list override snippets with same names
+ appearing in collections later in the list. [[sym:yas-new-snippet][=yas-new-snippet=]] always stores
+ snippets in the first collection.
+
+* The =.yas-parents= file
+
+ It's very useful to have certain modes share snippets between
+ themselves. To do this, choose a mode subdirectory and place a
+ =.yas-parents= containing a whitespace-separated list of other mode
+ names. When you reload those modes become parents of the original
+ mode.
+
+ #+begin_example
+ .
+ |-- c-mode
+ | |-- .yas-parents # contains "cc-mode text-mode"
+ | `-- printf
+ |-- cc-mode
+ | |-- for
+ | `-- while
+ |-- java-mode
+ | |-- .yas-parents # contains "cc-mode text-mode"
+ | `-- println
+ `-- text-mode
+ |-- email
+ `-- time
+ #+end_example
+
+
+* TODO The =.yas-make-groups= file
+
+ If you place an empty plain text file =.yas-make-groups= inside one
+ of the mode directories, the names of these sub-directories are
+ considered groups of snippets and [[file:snippet-menu.org][the menu]] is organized much more
+ cleanly:
+
+ [[./images/menu-groups.png]]
+
+ Another way to achieve this is to place a =# group:= directive
+ inside the snippet definition. See [[./snippet-development.org][Writing Snippets]].
+
+ #+begin_example
+ $ tree ruby-mode/
+ ruby-mode/
+ |-- .yas-make-groups
+ |-- collections
+ | |-- each
+ | `-- ...
+ |-- control structure
+ | |-- forin
+ | `-- ...
+ |-- definitions
+ | `-- ...
+ `-- general
+ `-- ...
+ #+end_example
+
+ Yet another way to create a nice snippet menu is to write into
+ =.yas-make-groups= a menu definition. TODO
+
+* The =.yas-setup.el= file
+
+ If there is file named =.yas-setup.el= in a mode's snippet
+ subdirectory, it is loaded along with the snippets. Utility
+ functions used by the snippets can be put here.
+
+* The =.yas-compiled-snippet.el= file
+
+ You may compile a top-level snippet directory with the
+ =yas-compile-directory= function, which will create a
+ =.yas-compiled-snippets.el= file under each mode subdirectory,
+ which contains definitions for all snippets in the subdirectory.
+ Compilation helps improve loading time.
+
+ Alternatively, you may compile all directories in the list
+ =yas-snippet-dirs= with the =yas-recompile-all= function.
+
+* The =.yas-skip= file
+
+ A =.yas-skip= file in a mode's snippet subdirectory tells YASnippet
+ not to load snippets from there.
diff --git a/lisp/yasnippet/doc/snippet-reference.org b/lisp/yasnippet/doc/snippet-reference.org
new file mode 100644
index 00000000..a38fca5a
--- /dev/null
+++ b/lisp/yasnippet/doc/snippet-reference.org
@@ -0,0 +1,12 @@
+#+SETUPFILE: org-setup.inc
+
+#+TITLE: Reference
+
+#+BEGIN_SRC emacs-lisp :exports results :results value raw
+(yas--document-symbols 1 `("Interactive functions" . ,#'interactive-form)
+ `("Customization variables" . ,#'(lambda (sym)
+ (and (boundp sym)
+ (get sym 'standard-value))))
+ `("Useful functions" . ,#'fboundp)
+ `("Useful variables" . ,#'boundp))
+#+END_SRC
diff --git a/lisp/yasnippet/yasnippet-debug.el b/lisp/yasnippet/yasnippet-debug.el
new file mode 100644
index 00000000..6fd3e3f6
--- /dev/null
+++ b/lisp/yasnippet/yasnippet-debug.el
@@ -0,0 +1,354 @@
+;;; yasnippet-debug.el --- debug functions for yasnippet -*- lexical-binding: t -*-
+
+;; Copyright (C) 2010-2025 Free Software Foundation, Inc.
+
+;; Author: João Távora
+;; Keywords: emulations, convenience
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see .
+
+;;; Commentary:
+
+;; Some debug functions. When loaded from the command line, provides
+;; quick way to test out snippets in a fresh Emacs instance.
+;;
+;; emacs -Q -l yasnippet-debug [-v[v]]
+;; [-M:] [-M.] [-S:[]]
+;; [-- ...]
+;;
+;; See the source in `yas-debug-process-command-line' for meaning of
+;; args.
+;;
+;;; Code:
+
+(defconst yas--loaddir
+ (file-name-directory (or load-file-name buffer-file-name))
+ "Directory that yasnippet was loaded from.")
+
+(require 'yasnippet (if (boundp 'yas--loaddir)
+ ;; Don't require '-L ' when debugging.
+ (expand-file-name "yasnippet" yas--loaddir)))
+(require 'cl-lib)
+(require 'color nil t)
+(require 'edebug)
+(eval-when-compile
+ (require 'subr-x nil t)
+ (cond ((fboundp 'when-let*) nil) ; Introduced in 26.
+ ((fboundp 'when-let) ; Introduced in 25.1,
+ (defalias 'when-let* 'when-let)) ; deprecated in 26.
+ (t (defmacro when-let* (key-vals &rest body)
+ (declare (indent 1) (debug ((symbolp form) body)))
+ (let ((key-val (pop key-vals)))
+ (if key-val
+ `(let ((,(car key-val) ,(cadr key-val)))
+ (if ,(car key-val)
+ (when-let* ,key-vals
+ ,@body)))
+ `(progn ,@body)))))))
+
+(defvar yas-debug-live-indicators
+ (make-hash-table :test #'eq))
+
+(defun yas-debug-live-colors ()
+ (let ((colors ()))
+ (maphash (lambda (_k v) (push (nth 1 (car v)) colors)) yas-debug-live-indicators)
+ colors))
+
+(defvar yas-debug-recently-live-indicators)
+
+(defun yas-debug-get-live-indicator (location)
+ (require 'color)
+ (when (boundp 'yas-debug-recently-live-indicators)
+ (push location yas-debug-recently-live-indicators))
+ (let (beg end)
+ (if (markerp location)
+ (setq beg (setq end (marker-position location)))
+ (setq beg (yas-debug-ov-fom-start location)
+ end (yas-debug-ov-fom-end location)))
+ (or (when-let* ((color-ov (gethash location yas-debug-live-indicators)))
+ (if (and beg end) (move-overlay (cdr color-ov) beg end)
+ (delete-overlay (cdr color-ov)))
+ color-ov)
+ (let* ((live-colors (yas-debug-live-colors))
+ (color
+ (cl-loop with best-color = nil with max-dist = -1
+ for color = (format "#%06X" (random #x1000000))
+ for comp = (if (fboundp 'color-complement)
+ (apply #'color-rgb-to-hex (color-complement color))
+ color)
+ if (< (color-distance color (face-foreground 'default))
+ (color-distance comp (face-foreground 'default)))
+ do (setq color comp)
+ for dist = (cl-loop for c in live-colors
+ minimize (color-distance c color))
+ if (or (not live-colors) (> dist max-dist))
+ do (setq best-color color) (setq max-dist dist)
+ repeat (if live-colors 100 1)
+ finally return `(:background ,best-color)))
+ (ov (make-overlay beg end)))
+ (if (markerp location)
+ (overlay-put ov 'before-string (propertize "↓" 'face color))
+ (overlay-put ov 'before-string (propertize "↘" 'face color))
+ (overlay-put ov 'after-string (propertize "↙" 'face color)))
+ (puthash location (cons color ov) yas-debug-live-indicators)))))
+
+(defun yas-debug-live-marker (marker)
+ (let* ((color-ov (yas-debug-get-live-indicator marker))
+ (color (car color-ov))
+ (ov (cdr color-ov))
+ (decorator (overlay-get ov 'before-string))
+ (str (format "at %d" (+ marker))))
+ (if (markerp marker)
+ (propertize str
+ 'cursor-sensor-functions
+ `(,(lambda (_window _oldpos dir)
+ (overlay-put
+ ov 'before-string
+ (propertize decorator
+ 'face (if (eq dir 'entered)
+ 'mode-line-highlight color)))))
+ 'face color)
+ str)))
+
+(defun yas-debug-ov-fom-start (ovfom)
+ (cond ((overlayp ovfom) (overlay-start ovfom))
+ ((integerp ovfom) ovfom)
+ (t (yas--fom-start ovfom))))
+(defun yas-debug-ov-fom-end (ovfom)
+ (cond ((overlayp ovfom) (overlay-end ovfom))
+ ((integerp ovfom) ovfom)
+ (t (yas--fom-end ovfom))))
+
+(defun yas-debug-live-range (range)
+ (let* ((color-ov (yas-debug-get-live-indicator range))
+ (color (car color-ov))
+ (ov (cdr color-ov))
+ (decorator-beg (overlay-get ov 'before-string))
+ (decorator-end (overlay-get ov 'after-string))
+ (beg (yas-debug-ov-fom-start range))
+ (end (yas-debug-ov-fom-end range)))
+ (if (and beg end (or (overlayp range)
+ (and (not (integerp beg))
+ (not (integerp end)))))
+ (propertize (format "from %d to %d" (+ beg) (+ end))
+ 'cursor-sensor-functions
+ `(,(lambda (_window _oldpos dir)
+ (let ((face (if (eq dir 'entered)
+ 'mode-line-highlight color)))
+ (overlay-put ov 'before-string
+ (propertize decorator-beg 'face face))
+ (overlay-put ov 'after-string
+ (propertize decorator-end 'face face)))))
+ 'face color)
+ "")))
+
+(defmacro yas-debug-with-tracebuf (outbuf &rest body)
+ (declare (indent 1) (debug (sexp body)))
+ (let ((tracebuf-var (make-symbol "tracebuf")))
+ `(let ((,tracebuf-var (or ,outbuf (get-buffer-create "*YASnippet trace*"))))
+ (unless (eq ,tracebuf-var (current-buffer))
+ (cl-flet ((printf (fmt &rest args)
+ (with-current-buffer ,tracebuf-var
+ (insert (apply #'format fmt args)))))
+ (unless ,outbuf
+ (with-current-buffer ,tracebuf-var
+ (erase-buffer)
+ (when (fboundp 'cursor-sensor-mode)
+ (cursor-sensor-mode +1))
+ (setq truncate-lines t)))
+ (setq ,outbuf ,tracebuf-var)
+ (save-restriction
+ (widen)
+ ,@body))))))
+
+
+(defun yas-debug-snippet (snippet &optional outbuf)
+ (yas-debug-with-tracebuf outbuf
+ (when-let* ((overlay (yas--snippet-control-overlay snippet)))
+ (printf "\tsid: %d control overlay %s\n"
+ (yas--snippet-id snippet)
+ (yas-debug-live-range overlay)))
+ (when-let* ((active-field (yas--snippet-active-field snippet)))
+ (unless (consp (yas--field-start active-field))
+ (printf "\tactive field: #%d %s %s covering \"%s\"\n"
+ (or (yas--field-number active-field) -1)
+ (if (yas--field-modified-p active-field) "**" "--")
+ (yas-debug-live-range active-field)
+ (buffer-substring-no-properties (yas--field-start active-field) (yas--field-end active-field)))))
+ (when-let* ((exit (yas--snippet-exit snippet)))
+ (printf "\tsnippet-exit: %s next: %s\n"
+ (yas-debug-live-marker (yas--exit-marker exit))
+ (yas--exit-next exit)))
+ (dolist (field (yas--snippet-fields snippet))
+ (unless (consp (yas--field-start field))
+ (printf "\tfield: %d %s %s covering \"%s\" next: %s%s\n"
+ (or (yas--field-number field) -1)
+ (if (yas--field-modified-p field) "**" "--")
+ (yas-debug-live-range field)
+ (buffer-substring-no-properties (yas--field-start field) (yas--field-end field))
+ (yas--debug-format-fom-concise (yas--field-next field))
+ (if (yas--field-parent-field field)
+ (format " parent: %s"
+ (yas--debug-format-fom-concise
+ (yas--field-parent-field field)))
+ "")))
+ (dolist (mirror (yas--field-mirrors field))
+ (unless (consp (yas--mirror-start mirror))
+ (printf "\t\tmirror: %s covering \"%s\" next: %s\n"
+ (yas-debug-live-range mirror)
+ (buffer-substring-no-properties (yas--mirror-start mirror) (yas--mirror-end mirror))
+ (yas--debug-format-fom-concise (yas--mirror-next mirror))))))))
+
+(defvar yas-debug-target-buffer nil)
+(defvar yas-debug-target-snippets nil nil)
+(make-variable-buffer-local 'yas-debug-target-snippets)
+
+(defvar yas-debug-undo nil)
+
+(defun yas-toggle-debug-undo (value)
+ (interactive (list (not yas-debug-undo)))
+ (setq yas-debug-undo value)
+ (yas--message 3 "debug undo %sabled" (if yas-debug-undo "en" "dis")))
+
+(defun yas-debug--target-snippet (snippet)
+ (add-to-list 'yas-debug-target-snippets snippet))
+
+(defun yas-debug--untarget-snippet (snippet)
+ (setq yas-debug-target-snippets
+ (remq snippet yas-debug-target-snippets))
+ (maphash (lambda (_k color-ov)
+ (delete-overlay (cdr color-ov)))
+ yas-debug-live-indicators)
+ (clrhash yas-debug-live-indicators))
+
+(defun yas-debug-snippets (&optional outbuf hook)
+ "Print debug information on active snippets to buffer OUTBUF.
+If OUTBUF is nil, use a buffer named \"*YASsnippet trace*\".
+If HOOK is non-nil, install `yas-debug-snippets' in
+`post-command-hook' to update the information on every command
+after this one. If it is `snippet-navigation' then install hook
+buffer-locally, otherwise install it globally. If HOOK is
+`edebug-create', also instrument the function
+`yas--snippet-parse-create' with `edebug' and show its source."
+ (interactive (list nil t))
+ (condition-case err
+ (yas-debug-with-tracebuf outbuf
+ (unless (buffer-live-p yas-debug-target-buffer)
+ (setq yas-debug-target-buffer nil))
+ (with-current-buffer (or yas-debug-target-buffer (current-buffer))
+ (when yas-debug-target-snippets
+ (setq yas-debug-target-snippets
+ (cl-delete-if-not #'yas--snippet-p yas-debug-target-snippets)))
+ (let ((yas-debug-recently-live-indicators nil))
+ (printf "(length yas--snippets-snippets) => %d\n"
+ (length yas--active-snippets))
+ (dolist (snippet (or yas-debug-target-snippets
+ (yas-active-snippets)))
+ (printf "snippet %d\n" (yas--snippet-id snippet))
+ (yas-debug-snippet snippet outbuf))
+ (maphash (lambda (loc color-ov)
+ (unless (memq loc yas-debug-recently-live-indicators)
+ (delete-overlay (cdr color-ov))
+ (remhash loc yas-debug-live-indicators)))
+ yas-debug-live-indicators))
+ (when (and yas-debug-undo (listp buffer-undo-list))
+ (printf "Undo list has %s elements:\n" (length buffer-undo-list))
+ (cl-loop for undo-elem in buffer-undo-list
+ do (printf "%S\n" undo-elem))))
+ (when hook
+ (setq yas-debug-target-buffer (current-buffer))
+ (advice-add 'yas--snippet-parse-create :before #'yas-debug--target-snippet)
+ (advice-add 'yas--commit-snippet :after #'yas-debug--untarget-snippet)
+ (add-hook 'post-command-hook #'yas-debug-snippets
+ nil (eq hook 'snippet-navigation))
+ ;; Window management is slapped together, it does what I
+ ;; want when the caller has a single window open. Good
+ ;; enough for now.
+ (when (eq hook 'edebug-create)
+ (edebug-instrument-function 'yas--snippet-parse-create)
+ (let ((buf-point (find-function-noselect 'yas--snippet-parse-create)))
+ (with-current-buffer (car buf-point)
+ (goto-char (cdr buf-point)))))
+ outbuf))
+ ((debug error) (signal (car err) (cdr err)))))
+
+(defun yas-debug-snippet-create ()
+ (yas-debug-snippets nil 'create))
+
+(defun yas--debug-format-fom-concise (fom)
+ (when fom
+ (cond ((yas--field-p fom)
+ (format "field %s from %d to %d"
+ (yas--field-number fom)
+ (+ (yas--field-start fom))
+ (+ (yas--field-end fom))))
+ ((yas--mirror-p fom)
+ (format "mirror from %d to %d"
+ (+ (yas--mirror-start fom))
+ (+ (yas--mirror-end fom))))
+ (t
+ (format "snippet exit at %d"
+ (+ (yas--fom-start fom)))))))
+
+(defun yas-debug-process-command-line (&optional options)
+ "Implement command line processing."
+ (setq yas-verbosity 99)
+ (setq yas-triggers-in-field t)
+ (setq debug-on-error t)
+ (let* ((snippet-mode 'fundamental-mode)
+ (snippet-key nil))
+ (unless options
+ (setq options (cl-loop for opt = (pop command-line-args-left)
+ while (and opt (not (equal opt "--"))
+ (string-prefix-p "-" opt))
+ collect opt)))
+ (when-let* ((mode (cl-member "-M:" options :test #'string-prefix-p)))
+ (setq snippet-mode (intern (concat (substring (car mode) 3) "-mode"))))
+ (when-let* ((mode (cl-member "-M." options :test #'string-prefix-p)))
+ (setq snippet-mode
+ (cdr (cl-assoc (substring (car mode) 2) auto-mode-alist
+ :test (lambda (ext regexp) (string-match-p regexp ext))))))
+ (switch-to-buffer (get-buffer-create "*yas test*"))
+ (funcall snippet-mode)
+ (when-let* ((snippet-file (cl-member "-S:" options :test #'string-prefix-p)))
+ (setq snippet-file (substring (car snippet-file) 3))
+ (if (file-exists-p snippet-file)
+ (with-temp-buffer
+ (insert-file-contents snippet-file)
+ (let ((snippet-deflist (yas--parse-template snippet-file)))
+ (yas-define-snippets snippet-mode (list snippet-deflist))
+ (setq snippet-key (car snippet-deflist))))
+ (yas-reload-all)
+ (let ((template (yas--lookup-snippet-1 snippet-file snippet-mode)))
+ (if template
+ (setq snippet-key (yas--template-key template))
+ (error "No such snippet `%s'" snippet-file)))))
+ (display-buffer (find-file-noselect
+ (expand-file-name "yasnippet.el" yas--loaddir)))
+ (when-let* ((verbosity (car (or (member "-v" options) (member "-vv" options)))))
+ (set-window-buffer
+ (split-window) (yas-debug-snippets
+ nil (if (equal verbosity "-vv") 'edebug-create t))))
+ (yas-minor-mode +1)
+ (when snippet-key (insert snippet-key))))
+
+(when command-line-args-left
+ (yas-debug-process-command-line))
+
+(provide 'yasnippet-debug)
+;; Local Variables:
+;; indent-tabs-mode: nil
+;; autoload-compute-prefixes: nil
+;; End:
+;;; yasnippet-debug.el ends here
diff --git a/lisp/yasnippet/yasnippet-pkg.el b/lisp/yasnippet/yasnippet-pkg.el
index 3cefaed7..621873b8 100644
--- a/lisp/yasnippet/yasnippet-pkg.el
+++ b/lisp/yasnippet/yasnippet-pkg.el
@@ -7,4 +7,7 @@
:commit "dd570a6b22364212fff9769cbf4376bdbd7a63c5"
:revdesc "dd570a6b2236"
:keywords '("convenience" "emulation")
+ :authors '(("pluskid" . "pluskid@gmail.com")
+ ("João Távora" . "joaotavora@gmail.com")
+ ("Noam Postavsky" . "npostavs@gmail.com"))
:maintainers '(("Noam Postavsky" . "npostavs@gmail.com")))