doomemacs/core/autoload/debug.el

;;; core/autoload/debug.el -*- lexical-binding: t; -*-

;;
;;; Doom's debug mode

;;;###autoload
(defvar doom-debug-variables
  '(debug-on-error
    doom-debug-p
    garbage-collection-messages
    gcmh-verbose
    init-file-debug
    jka-compr-verbose
    url-debug
    use-package-verbose
    (message-log-max . 16384))
  "A list of variable to toggle on `doom-debug-mode'.

Each entry can be a variable symbol or a cons cell whose CAR is the variable
symbol and CDR is the value to set it to when `doom-debug-mode' is activated.")

(defvar doom--debug-vars-old-values nil)
(defvar doom--debug-vars-undefined nil)

(defun doom--watch-debug-vars-h (&rest _)
  (when-let (bound-vars (cl-remove-if-not #'boundp doom--debug-vars-undefined))
    (doom-log "New variables available: %s" bound-vars)
    (let ((message-log-max nil))
      (doom-debug-mode -1)
      (doom-debug-mode +1))))

;;;###autoload
(define-minor-mode doom-debug-mode
  "Toggle `debug-on-error' and `doom-debug-p' for verbose logging."
  :init-value nil
  :global t
  (let ((enabled doom-debug-mode))
    (setq doom--debug-vars-undefined nil)
    (dolist (var doom-debug-variables)
      (cond ((listp var)
             (cl-destructuring-bind (var . val) var
               (if (not (boundp var))
                   (add-to-list 'doom--debug-vars-undefined var)
                 (set-default
                  var (if (not enabled)
                          (alist-get var doom--debug-vars-old-values)
                        (setf (alist-get var doom--debug-vars-old-values)
                              (symbol-value var))
                        val)))))
            ((if (boundp var)
                 (set-default var enabled)
               (add-to-list 'doom--debug-vars-undefined var)))))
    (when (called-interactively-p 'any)
      (when (fboundp 'explain-pause-mode)
        (explain-pause-mode (if enabled +1 -1))))
    ;; Watch for changes in `doom-debug-variables', or when packages load (and
    ;; potentially define one of `doom-debug-variables'), in case some of them
    ;; aren't defined when `doom-debug-mode' is first loaded.
    (cond (enabled
           (add-variable-watcher 'doom-debug-variables #'doom--watch-debug-vars-h)
           (add-hook 'after-load-functions #'doom--watch-debug-vars-h))
          (t
           (remove-variable-watcher 'doom-debug-variables #'doom--watch-debug-vars-h)
           (remove-hook 'after-load-functions #'doom--watch-debug-vars-h)))
    (message "Debug mode %s" (if enabled "on" "off"))))


;;
;;; Hooks

;;;###autoload
(defun doom-run-all-startup-hooks-h ()
  "Run all startup Emacs hooks. Meant to be executed after starting Emacs with
-q or -Q, for example:

  emacs -Q -l init.el -f doom-run-all-startup-hooks-h"
  (setq after-init-time (current-time))
  (let ((inhibit-startup-hooks nil))
    (mapc (lambda (hook)
            (run-hook-wrapped hook #'doom-try-run-hook))
          '(after-init-hook
            delayed-warnings-hook
            emacs-startup-hook
            tty-setup-hook
            window-setup-hook))))


;;
;;; Helpers

(defsubst doom--collect-forms-in (file form)
  (when (file-readable-p file)
    (let (forms)
      (with-temp-buffer
        (insert-file-contents file)
        (let (emacs-lisp-mode) (emacs-lisp-mode))
        (while (re-search-forward (format "(%s " (regexp-quote form)) nil t)
          (let ((ppss (syntax-ppss)))
            (unless (or (nth 4 ppss)
                        (nth 3 ppss))
              (save-excursion
                (goto-char (match-beginning 0))
                (push (sexp-at-point) forms)))))
        (nreverse forms)))))

;;;###autoload
(defun doom-info ()
  "Returns diagnostic information about the current Emacs session in markdown,
ready to be pasted in a bug report on github."
  (require 'vc-git)
  (require 'core-packages)
  (let ((default-directory doom-emacs-dir))
    (letf! ((defun sh (&rest args) (cdr (apply #'doom-call-process args)))
            (defun cat (file &optional limit)
              (with-temp-buffer
                (insert-file-contents file nil 0 limit)
                (buffer-string)))
            (defun abbrev-path (path)
              (replace-regexp-in-string
               (regexp-opt (list (user-login-name)) 'words) "$USER"
               (abbreviate-file-name path)))
            (defun symlink-path (file)
              (format "%s%s" (abbrev-path file)
                      (if (file-symlink-p file)
                          (concat " -> " (file-truename file))
                        ""))))
      `((system
         (info   . ,(cons (doom-system-distro-version) (sh "uname" "-msr")))
         (shell  . ,(abbrev-path shell-file-name))
         (path   . ,(mapcar #'abbrev-path exec-path)))
        (emacs
         (dir       . ,(symlink-path doom-emacs-dir))
         (version   . ,(delq nil (list emacs-version emacs-repository-version (format-time-string "%b %d, %Y" emacs-build-time))))
         (buildopts . ,system-configuration-options)
         (features  . ,system-configuration-features)
         (traits
          . ,(delq
              nil (list (cond ((not doom-interactive-p) 'batch)
                              ((display-graphic-p) 'gui)
                              ('tty))
                        (if (daemonp) 'daemon)
                        (if (and (require 'server)
                                 (server-running-p))
                            'server-running)
                        (if (boundp 'chemacs-profiles-path)
                            'chemacs)
                        (if (file-exists-p doom-env-file)
                            'envvar-file)
                        (if (featurep 'exec-path-from-shell)
                            'exec-path-from-shell)
                        (if (file-symlink-p user-emacs-directory)
                            'symlinked-emacsdir)
                        (if (file-symlink-p doom-private-dir)
                            'symlinked-doomdir)
                        (if (doom-files-in `(,@doom-modules-dirs
                                             ,doom-core-dir
                                             ,doom-private-dir)
                                           :type 'files :match "\\.elc$")
                            'byte-compiled-config)))))
        (doom
         (dir     . ,(symlink-path doom-private-dir))
         (version . ,(list doom-version (sh "git" "log" "-1" "--format=%D %h %ci")))
         ,@(when doom-interactive-p
             `((font  . ,(bound-and-true-p doom-font))
               (theme . ,(bound-and-true-p doom-theme))))
         (modules
          ,@(or (cl-loop with cat = nil
                         for key being the hash-keys of doom-modules
                         if (or (not cat)
                                (not (eq cat (car key))))
                         do (setq cat (car key))
                         and collect cat
                         collect
                         (let* ((flags (doom-module-get cat (cdr key) :flags))
                                (path  (doom-module-get cat (cdr key) :path))
                                (module (append (cond ((null path)
                                                       (list '&nopath))
                                                      ((file-in-directory-p path doom-private-dir)
                                                       (list '&user)))
                                                (if flags
                                                    `(,(cdr key) ,@flags)
                                                  (list (cdr key))))))
                           (if (= (length module) 1)
                               (car module)
                             module)))
                '("n/a")))
         (packages
          ,@(or (condition-case e
                    (mapcar
                     #'cdr (doom--collect-forms-in
                            (doom-path doom-private-dir "packages.el")
                            "package!"))
                  (error (format "<%S>" e)))
                '("n/a")))
         (unpin
          ,@(or (condition-case e
                    (mapcan #'identity
                            (mapcar
                             #'cdr (doom--collect-forms-in
                                    (doom-path doom-private-dir "packages.el")
                                    "unpin!")))
                  (error (format "<%S>" e)))
                '("n/a")))
         (elpa
          ,@(or (condition-case e
                    (progn
                      (package-initialize)
                      (cl-loop for (name . _) in package-alist
                               collect (format "%s" name)))
                  (error (format "<%S>" e)))
                '("n/a"))))))))


;;
;;; Commands

;;;###autoload
(defun doom/version ()
  "Display the current version of Doom & Emacs, including the current Doom
branch and commit."
  (interactive)
  (let ((default-directory doom-core-dir))
    (print! "Doom v%s (%s)"
            doom-version
            (or (cdr (doom-call-process "git" "log" "-1" "--format=%D %h %ci"))
                "n/a"))))

;;;###autoload
(defun doom/info (&optional raw)
  "Collects some debug information about your Emacs session, formats it and
copies it to your clipboard, ready to be pasted into bug reports!"
  (interactive "P")
  (let ((buffer (get-buffer-create "*doom info*"))
        (info (doom-info)))
    (with-current-buffer buffer
      (erase-buffer)
      (if raw
          (progn
            (save-excursion
              (pp info (current-buffer)))
            (dolist (sym '(modules packages))
              (when (re-search-forward (format "^ *\\((%s\\)" sym) nil t)
                (goto-char (match-beginning 1))
                (cl-destructuring-bind (beg . end)
                    (bounds-of-thing-at-point 'sexp)
                  (let ((sexp (prin1-to-string (sexp-at-point))))
                    (delete-region beg end)
                    (insert sexp))))))
        (insert "```\n")
        (dolist (group info)
          (insert! "%-8s%-10s %s\n"
                   ((upcase (symbol-name (car group)))
                    (caadr group)
                    (cdadr group)))
          (dolist (spec (cddr group))
            (insert! (indent 8 "%-10s %s\n")
                     ((car spec) (cdr spec)))))
        (insert "```\n"))
      (if (not doom-interactive-p)
          (print! (buffer-string))
        (pop-to-buffer buffer)
        (kill-new (buffer-string))
        (print! (green "Copied your doom info to clipboard"))))))

;;;###autoload
(defun doom/am-i-secure ()
  "Test to see if your root certificates are securely configured in emacs.
Some items are not supported by the `nsm.el' module."
  (declare (interactive-only t))
  (interactive)
  (unless (string-match-p "\\_<GNUTLS\\_>" system-configuration-features)
    (warn "gnutls support isn't built into Emacs, there may be problems"))
  (if-let* ((bad-hosts
             (cl-loop for bad
                      in '("https://expired.badssl.com/"
                           "https://wrong.host.badssl.com/"
                           "https://self-signed.badssl.com/"
                           "https://untrusted-root.badssl.com/"
                           ;; "https://revoked.badssl.com/"
                           ;; "https://pinning-test.badssl.com/"
                           "https://sha1-intermediate.badssl.com/"
                           "https://rc4-md5.badssl.com/"
                           "https://rc4.badssl.com/"
                           "https://3des.badssl.com/"
                           "https://null.badssl.com/"
                           "https://sha1-intermediate.badssl.com/"
                           ;; "https://client-cert-missing.badssl.com/"
                           "https://dh480.badssl.com/"
                           "https://dh512.badssl.com/"
                           "https://dh-small-subgroup.badssl.com/"
                           "https://dh-composite.badssl.com/"
                           "https://invalid-expected-sct.badssl.com/"
                           ;; "https://no-sct.badssl.com/"
                           ;; "https://mixed-script.badssl.com/"
                           ;; "https://very.badssl.com/"
                           "https://subdomain.preloaded-hsts.badssl.com/"
                           "https://superfish.badssl.com/"
                           "https://edellroot.badssl.com/"
                           "https://dsdtestprovider.badssl.com/"
                           "https://preact-cli.badssl.com/"
                           "https://webpack-dev-server.badssl.com/"
                           "https://captive-portal.badssl.com/"
                           "https://mitm-software.badssl.com/"
                           "https://sha1-2016.badssl.com/"
                           "https://sha1-2017.badssl.com/")
                      if (condition-case _e
                             (url-retrieve-synchronously bad)
                           (error nil))
                      collect bad)))
      (error "tls seems to be misconfigured (it got %s)."
             bad-hosts)
    (url-retrieve "https://badssl.com"
                  (lambda (status)
                    (if (or (not status) (plist-member status :error))
                        (warn "Something went wrong.\n\n%s" (pp-to-string status))
                      (message "Your trust roots are set up properly.\n\n%s" (pp-to-string status))
                      t)))))


;;
;;; Vanilla sandbox

(defun doom--run-sandbox (&optional mode)
  (interactive)
  (let ((contents (buffer-string))
        (file (make-temp-file "doom-sandbox-")))
    (require 'package)
    (with-temp-file file
      (prin1 `(progn
                (setq before-init-time (current-time)
                      after-init-time nil
                      noninteractive nil
                      user-init-file ,file
                      process-environment ',doom--initial-process-environment
                      exec-path ',doom--initial-exec-path
                      doom-debug-p t
                      init-file-debug t
                      doom--initial-load-path load-path
                      load-path ',load-path
                      package--init-file-ensured t
                      package-user-dir ,package-user-dir
                      package-archives ',package-archives
                      user-emacs-directory ,doom-emacs-dir
                      comp-deferred-compilation nil
                      comp-eln-load-path ',(bound-and-true-p comp-eln-load-path)
                      comp-async-env-modifier-form ',(bound-and-true-p comp-async-env-modifier-form)
                      comp-deferred-compilation-black-list ',(bound-and-true-p comp-deferred-compilation-black-list))
                (with-eval-after-load 'undo-tree
                  ;; HACK `undo-tree' throws errors because `buffer-undo-tree'
                  ;;      isn't correctly initialized
                  (setq-default buffer-undo-tree (make-undo-tree)))
                (ignore-errors
                  (delete-directory ,(expand-file-name "auto-save-list" doom-emacs-dir) 'parents)))
             (current-buffer))
      (prin1 `(unwind-protect
                  (defun --run-- () ,(read (concat "(progn\n" contents "\n)")))
                (delete-file ,file))
             (current-buffer))
      (prin1 (pcase mode
               (`vanilla-doom+ ; Doom core + modules - private config
                `(progn
                   (load-file ,(expand-file-name "core.el" doom-core-dir))
                   (setq doom-modules-dirs (list doom-modules-dir))
                   (let ((doom-init-modules-p t))
                     (doom-initialize)
                     (doom-initialize-core-modules))
                   (setq doom-modules ',doom-modules)
                   (maphash (lambda (key plist)
                              (doom-module-put
                               (car key) (cdr key)
                               :path (doom-module-locate-path (car key) (cdr key))))
                            doom-modules)
                   (--run--)
                   (maphash (doom-module-loader doom-module-init-file) doom-modules)
                   (maphash (doom-module-loader doom-module-config-file) doom-modules)
                   (run-hook-wrapped 'doom-init-modules-hook #'doom-try-run-hook)))
               (`vanilla-doom  ; only Doom core
                `(progn
                   (load-file ,(expand-file-name "core.el" doom-core-dir))
                   (let ((doom-init-modules-p t))
                     (doom-initialize)
                     (doom-initialize-core-modules))
                   (--run--)))
               (`vanilla       ; nothing loaded
                `(progn
                   (package-initialize)
                   (--run--))))
             (current-buffer))
      ;; Redo all startup initialization, like running startup hooks and loading
      ;; init files.
      (prin1 `(progn
                (fset 'doom-try-run-hook #',(symbol-function #'doom-try-run-hook))
                (fset 'doom-run-all-startup-hooks-h #',(symbol-function #'doom-run-all-startup-hooks-h))
                (doom-run-all-startup-hooks-h))
             (current-buffer)))
    (let ((args (if (eq mode 'doom)
                    (list "-l" file)
                  (list "-Q" "-l" file))))
      (require 'restart-emacs)
      (condition-case e
          (cond ((display-graphic-p)
                 (if (memq system-type '(windows-nt ms-dos))
                     (restart-emacs--start-gui-on-windows args)
                   (restart-emacs--start-gui-using-sh args)))
                ((memq system-type '(windows-nt ms-dos))
                 (user-error "Cannot start another Emacs from Windows shell."))
                ((suspend-emacs
                  (format "%s %s -nw; fg"
                          (shell-quote-argument (restart-emacs--get-emacs-binary))
                          (mapconcat #'shell-quote-argument args " ")))))
        (error
         (delete-file file)
         (signal (car e) (cdr e)))))))

(fset 'doom--run-vanilla-emacs (cmd! (doom--run-sandbox 'vanilla)))
(fset 'doom--run-vanilla-doom  (cmd! (doom--run-sandbox 'vanilla-doom)))
(fset 'doom--run-vanilla-doom+ (cmd! (doom--run-sandbox 'vanilla-doom+)))
(fset 'doom--run-full-doom     (cmd! (doom--run-sandbox 'doom)))

(defvar doom-sandbox-emacs-lisp-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map (kbd "C-c C-c") #'doom--run-vanilla-emacs)
    (define-key map (kbd "C-c C-d") #'doom--run-vanilla-doom)
    (define-key map (kbd "C-c C-p") #'doom--run-vanilla-doom+)
    (define-key map (kbd "C-c C-f") #'doom--run-full-doom)
    (define-key map (kbd "C-c C-k") #'kill-current-buffer)
    map))

(define-derived-mode doom-sandbox-emacs-lisp-mode emacs-lisp-mode "Sandbox Elisp"
  "TODO")

;;;###autoload
(defun doom/sandbox ()
  "Open the Emacs Lisp sandbox.

This is a test bed for running Emacs Lisp in another instance of Emacs with
varying amounts of Doom loaded, including:

  a) vanilla Emacs (nothing loaded),
  b) vanilla Doom (only Doom core),
  c) Doom + modules - your private config or
  c) Doom + modules + your private config (a complete Doom session)

This is done without sacrificing access to installed packages. Use the sandbox
to reproduce bugs and determine if Doom is to blame."
  (interactive)
  (let* ((buffer-name "*doom:sandbox*")
         (exists (get-buffer buffer-name))
         (buf (get-buffer-create buffer-name)))
    (with-current-buffer buf
      (doom-sandbox-emacs-lisp-mode)
      (setq-local default-directory doom-emacs-dir)
      (unless (buffer-live-p exists)
        (insert-file-contents (doom-glob doom-core-dir "templates/VANILLA_SANDBOX"))
        (let ((contents (substitute-command-keys (buffer-string))))
          (erase-buffer)
          (insert contents "\n")))
      (goto-char (point-max)))
    (pop-to-buffer buf)))


;;
;;; Reporting bugs

;;;###autoload
(defun doom/report-bug ()
  "Open a markdown buffer destinated to populate the New Issue page on Doom
Emacs' issue tracker.

If called when a backtrace buffer is present, it and the output of `doom-info'
will be automatically appended to the result."
  (interactive)
  (browse-url "https://github.com/hlissner/doom-emacs/issues/new/choose"))

;;;###autoload
(defun doom/copy-buffer-contents (buffer-name)
  "Copy the contents of BUFFER-NAME to your clipboard."
  (interactive
   (list (if current-prefix-arg
             (completing-read "Select buffer: " (mapcar #'buffer-name (buffer-list)))
           (buffer-name (current-buffer)))))
  (let ((buffer (get-buffer buffer-name)))
    (unless (buffer-live-p buffer)
      (user-error "Buffer isn't live"))
    (kill-new
     (with-current-buffer buffer
       (substring-no-properties (buffer-string))))
    (message "Contents of %S were copied to the clipboard" buffer-name)))


;;
;;; Profiling

(defvar doom--profiler nil)
;;;###autoload
(defun doom/toggle-profiler ()
  "Toggle the Emacs profiler. Run it again to see the profiling report."
  (interactive)
  (if (not doom--profiler)
      (profiler-start 'cpu+mem)
    (profiler-report)
    (profiler-stop))
  (setq doom--profiler (not doom--profiler)))