This hurts me, but worth it. Code bits that can be loaded via reval for bootstrap, or that can be reloaded, or installed as a package.
;;; ow-min.el --- Minimal utilties for orgstrap blocks. -*- lexical-binding: t -*-
;; Author: Tom Gillespie
;; Homepage: https://github.com/tgbugs/orgstrap
;; Version: 9999
;; Package-Requires: ((emacs "24.4"))
;; Is-Version-Of: https://raw.githubusercontent.com/tgbugs/orgstrap/master/ow-min.el
;; Reval-Get-Immutable: ow-min--reval-update
;;;; License and Commentary
;; License:
;; SPDX-License-Identifier: GPL-3.0-or-later
;;; Commentary:
;; ow-min.el contains functionality needed by orgstrap blocks that are
;; primarily used by developers, such as files that implement a
;; release process where no end user interaction is expected.
;; ow-min.el is compatible with `reval-update'.
;;; Code:
<<defl-impl>>
<<run-command>>
(defalias 'run-command #'ow-run-command)
<<secure-elisp-curl>>
<<ow-utils>>
(defun ow-min--reval-update ()
"Get the immutable url for the current remote version of this file."
(reval-get-imm-github "tgbugs" "orgstrap" "ow-min.el"))
(provide 'ow-min)
;;; ow-min.el ends here
;;; ow.el --- Common functionality for Orgware files. -*- lexical-binding: t -*-
;; Author: Tom Gillespie
;; Homepage: https://github.com/tgbugs/orgstrap
;; Version: 9999
;; Package-Requires: ((emacs "27.1"))
;; Is-Version-Of: https://raw.githubusercontent.com/tgbugs/orgstrap/master/ow.el
;; Reval-Get-Immutable: ow--reval-update
;;;; License and Commentary
;; License:
;; SPDX-License-Identifier: GPL-3.0-or-later
;;; Commentary:
;; ow.el is the catch-all file that includes all the functionality
;; that you might want to use in an orgstrap block in a single place
;; including functions that are also packaged independently such as
;; the reval-* and securl-* functionality. The normal way to use it
;; is to use `reval-minimal' to obtain all the functionality, and then
;; use `reval-reload-latest' to cache a persistent copy and reload from
;; that file so that all xrefs can be resolved.
;; ow.el is compatible with `reval-update'.
;;; Code:
(unless (featurep 'reval)
<<reval-impl>>
)
(unless (featurep 'defl)
<<defl-impl>>
<<defl-extra-impl>>
)
<<run-command>>
<<secure-elisp-curl>>
<<ow-utils>>
<<&ow-unload-reload>>
<<&ow-package>>
<<ow-cli>>
<<ow-visibility>>
<<ow-usability>>
<<ow-buttons>>
<<ow-config>>
(defun ow--reval-update ()
"Get the immutable url for the current remote version of this file."
(reval-get-imm-github "tgbugs" "orgstrap" "ow.el"))
(provide 'ow)
;;; ow.el ends here
;; control initial visibility
(defun ow-narrow-to-section-0 ()
(let* ((beg (point-min))
(end (progn (goto-char beg) (org-next-visible-heading 1) (point))))
(narrow-to-region beg end)))
(defun ow-hide-section-0-blocks ()
"Hide blocks and dynamic blocks in section 0."
(save-excursion
(ow-narrow-to-section-0)
(org-hide-block-all)
(widen)))
(defun ow-old-hide-section-0-blocks ()
;; XXX deprecated this impl since better to allow exclusion than require inclusion
"Hide blocks and dynamic blocks that are used in section 0."
(let ((dblocks '("metadata" "properties" "prefixes" "setup"))
(blocks '("orgstrap-shebang")))
;; dblocks and blocks have separate namespaces
(save-excursion
(mapcar (lambda (name) (and (org-find-dblock name) (org-hide-block-toggle 'hide)))
dblocks)
;; FIXME inconsistent behavior between `org-find-dblock' and `org-babel-find-named-block'
(mapcar (lambda (name)
(let ((p (org-babel-find-named-block name)))
(and p (goto-char p) (org-hide-block-toggle 'hide))))
blocks))))
;; permanently modify visibility
(defun ow-fold-headline (&optional name)
"Set visibility property of headline with NAME or previous visible to folded."
;; https://orgmode.org/manual/Using-the-Property-API.html
(save-excursion
(if name
(goto-char (org-find-exact-headline-in-buffer name))
(org-previous-visible-heading 0))
(org-entry-put nil "visibility" "folded")
(save-buffer)))The default for org-cycle-hook is what causes the position of headings
to change when they are opened/closed. This is extremely undesirable when
using a mouse to toggle headings. https://emacs.stackexchange.com/a/31277
;; mouse behavior
(defun ow--safe-cycle (event &optional promote-to-region)
"Bind this to mouse-1 for sane clickable cycling behavior."
(interactive "e\np")
(let ((face (get-char-property (point) 'face)))
(unless (and face (listp face) (memq 'org-block face))
(unwind-protect
(progn
(remove-hook 'org-cycle-hook #'org-optimize-window-after-visibility-change t)
(org-cycle))
(add-hook 'org-cycle-hook #'org-optimize-window-after-visibility-change nil t))))
;; have to chain `mouse-set-point' otherwise double click to highlight words etc. fails
(mouse-set-point event promote-to-region))
(defun ow--set-mouse-cycle ()
"Hook fun to set mouse-cycle behavior for org buffers."
(local-unset-key [mouse-1])
(local-set-key [mouse-1] #'ow--safe-cycle))
(defun ow-enable-mouse-cycle (&optional global)
"Allow left mouse to cycle org headings.
Set GLOBAL to enable for all org buffers."
(interactive)
;; reset `org-cycle-hook' as a local variable so that
;; we can add/remove individual hooks without messing
;; with the global behavior which might some day not
;; be purely single threaded (heh)
(setq-local org-cycle-hook org-cycle-hook)
(ow--set-mouse-cycle)
(when global
(add-hook 'org-mode-hook #'ow--set-mouse-cycle)))
(defun ow-recenter-on-mouse ()
"Recenter the cursor line so that it is under the mouse."
;; after much digging using `mouse-pixel-position' together
;; with `pos-at-x-y' seems to be what we want, `mouse-position'
;; and `window-edges' are decidedly NOT the right solution
;; `pos-at-x-y' is able to call into the C code to get something
;; much closer to what is produced by an actual mouse event
;; https://emacs.stackexchange.com/questions/30852 has the wrong solution
(interactive)
(let* ((mpp (mouse-pixel-position))
(position-list (posn-at-x-y (cadr mpp)
(cddr mpp)
(selected-frame)
nil))
;;(asdf (message "%s" hrm))
(mouse-line (cdr (posn-actual-col-row position-list)))
(cursor-line (- (line-number-at-pos)
(line-number-at-pos (window-start))))
(offset (- mouse-line cursor-line)))
;;(message "ml: %s cl: %s offset: %s" mouse-line cursor-line offset)
(scroll-down offset)))In the original implementation of the familiar config each of the settings could be enabled or disabled individually, however there was pretty much never an instance where this functionality was used, so in this variant everything can only be enabled together.
(defun ow--headline-faces ()
"Set face for all headline levels to be bold and 1.2x as tall."
(mapcar (lambda (n) (set-face-attribute (intern (format "org-level-%s" n)) nil :bold t :height 1.2))
(number-sequence 1 8)))
(defun ow--tweak-whiteboard ()
"Tweak the settings for `whiteboard-theme'."
(require 'org-faces)
(set-face-attribute 'shadow nil :foreground "gray35")
(set-face-attribute 'org-meta-line nil :inherit font-lock-keyword-face)
(let ((dx (>= emacs-major-version 27)))
(apply #'set-face-attribute `(org-block-begin-line nil :foreground "black" :background "silver" ,@(when dx '(:extend t))))
(apply #'set-face-attribute `(org-block-end-line nil :foreground "black" :background "silver" ,@(when dx '(:extend t))))
(apply #'set-face-attribute `(org-block nil :background "white" ,@(when dx '(:extend t))))))
(defun ow--rainy-day ()
"Enable `rainbow-deimiters-mode' with tweaks."
(ow-use-packages (rainbow-delimiters :hook ((prog-mode) . rainbow-delimiters-mode)))
(set-face-attribute 'rainbow-delimiters-base-face nil :bold t)
(set-face-attribute 'rainbow-delimiters-unmatched-face nil :bold t :foreground "white" :background "red")
(set-face-attribute 'rainbow-delimiters-mismatched-face nil :bold t :foreground "black" :background "yellow"))
(defun ow-enable-config-familiar-1 (&optional global)
"Minimal config to achieve something more familiar for non-Emacs users.
Uses `cua-mode' with additional tweak for undo bindings.
NOTE: `undo-fu' is required for Emacs < 28."
;; Enable familiar copy/paste keybindings
(cua-mode t)
;; additional keybinds
(let ((set-key (if global #'global-set-key #'local-set-key)))
;; Ctrl s for save
(funcall set-key (kbd "C-s") #'save-buffer)
;; Ctrl f for find aka isearch
(funcall set-key (kbd "C-f") #'isearch-forward)
;; enable Cmd Shift Z for apple users Ctrl y for windows
(when (fboundp #'undo-redo)
(if (eq system-type 'darwin)
(funcall set-key (kbd "C-Z") #'undo-redo)
(funcall set-key (kbd "C-y") #'undo-redo)))
(funcall set-key (kbd "<f5>") #'ow-babel-execute-closest-src-block))
;; Move text smoothly when point is at top or bottom of buffer
(ow--setq global scroll-conservatively 101)
(ow--setq global scroll-step 1)
;; Use left mouse to cycle
(ow-enable-mouse-cycle)
;; Mouse paste at point not cursor
(setq mouse-yank-at-point t) ; set globally due to minibuffer
;; Mouse wheel behavior
(ow--setq global mouse-wheel-progressive-speed nil)
(ow--setq global mouse-wheel-scroll-amount '(3 ((shift) . hscroll)))
;; Mouse on scroll bar behavior TODO this is not quite right, but I
;; have no idea how to get emacs to stop resizing the sliders
(global-unset-key [vertical-scroll-bar mouse-1])
(global-set-key [vertical-scroll-bar down-mouse-1] 'scroll-bar-drag)
;; default shift functionality is usually not needed in ow files and
;; the message when you try to use it can be extremely confusing
(ow--setq global org-support-shift-select t)
;; Enable tab-bar-mode
(when (>= emacs-major-version 27)
(tab-bar-mode t))
;; Use the whiteboard theme
(load-theme 'whiteboard)
(ow--tweak-whiteboard)
;; Set headline faces
(ow--headline-faces))See the isearch-tool-bar-map for an example of how to do this.
(defun ow-tool-bar-image (image-name)
"Return an image specification for IMAGE-NAME."
(eval (tool-bar--image-expression image-name)))
;; run icon options gud/go.xmp mpc/play.xmp
;; stop gud/stop.xmp
(defvar ow-basic-tool-bar-map
(let ((map (make-sparse-keymap)))
(define-key map [ow-run-block]
(list 'menu-item "Run block" 'ow-run-block
:help "Run the next visible org src block"
:image '(ow-tool-bar-image "go")))
map))
;;(setq-local tool-bar-map ow-tool-bar-map);; don't export buttons
(defun ow-link-no-export (path desc format)
"Return nothing for export" ; FIXME broken ???
"")
(defun ow-button (link-name function)
"Create a new button type."
(org-link-set-parameters link-name :export #'ow-link-no-export :follow function))
(defmacro ow-defbutton (link-name &rest body)
`(ow-button ,link-name (lambda () ,@body)))
;; TODO defalias defbutton ow-defbutton
(defun ow--org-link-set-parameters (type &rest parameters)
"no-op to prevent error, install a newer version of org or emacs")
(defun ow-make-buttons ()
"Enable standard buttons." ; needed to avoid autoloading the built-in version of org-mode
(when (string< "9.3" (org-version))
;; before 9.3 the org link functionality was still in org.el
(require 'ol))
(when (string< (org-version) "9.0")
(defalias 'org-link-set-parameters #'ow--org-link-set-parameters))
;; hide headline for future startups
(org-link-set-parameters "FOLD-HEADLINE" :export #'ow-link-no-export :follow
(lambda (&optional nothing)
(ow-fold-headline)))
;; run the next #+begin_src block
(org-link-set-parameters "RUN" :export #'ow-link-no-export :follow
(lambda (&optional nothing)
(org-next-block nil)
(org-babel-execute-src-block)))
;; run the previous src block (doesn't work if there are results)
(org-link-set-parameters "RUNPREV" :export #'ow-link-no-export :follow
(lambda (&optional nothing)
(org-previous-block nil)
(org-babel-execute-src-block)))
;; run the next #+call: TODO we should be able to do this with mouse-1?
(org-link-set-parameters "RUNC" :export #'ow-link-no-export :follow
(lambda (&optional nothing)
(save-excursion
(re-search-forward "#\\+call:")
(org-ctrl-c-ctrl-c))))
;; adjust font size for the current buffer
(org-link-set-parameters "TEXT-LARGER" :export #'orsgrap--nox :follow
(lambda (&optional nothing)
(text-scale-adjust 1)
(ow-recenter-on-mouse)))
(org-link-set-parameters "TEXT-SMALLER" :export #'ow-link-no-export :follow
(lambda (&optional nothing)
(text-scale-adjust -1)
(ow-recenter-on-mouse)))
(org-link-set-parameters "TEXT-RESET" :export #'ow-link-no-export :follow
(lambda (&optional nothing)
(text-scale-adjust 0)
(ow-recenter-on-mouse))))Work around for changes to the use of org-assert-version in org 9.6.
Probably best to use ow-unload-org with a version check on org?
(defvar ow--org-reloaded nil)
(defvar ow--org-to-reload '())
(when (< emacs-major-version 26)
;; temp fix for issue in `ob-core'
(defun ow--temporary-file-directory ()
temporary-file-directory)
(defalias 'temporary-file-directory #'ow--temporary-file-directory))
(defun ow-unload-org ()
"Unload the builtin version of org used by orgstrap.
On emacs-28 the first time you call this Emacs will likely exit
will a segfault if you have enabled `native-compile' because it
tries to return into a native function that was unloaded. This
does not seem to happen on 29, and it does not happen on all
subsequent runs."
(cl-letf (((symbol-function 'org-compat-unload-function)
(lambda ()
(setq features (cl-delete-if (lambda (s) (eq s 'org-compat)) features))))
((symbol-function 'outline-mode)
(lambda () (setq-local font-lock-unfontify-region-function (lambda (b e))))))
(let ((org-features
(cl-loop
for f in features
;; XXX `org-compat' redefinitions can remove definitions that have been defined elsewhere
;; and since emacs doesn't keep track of how many times something has been defined in a
;; separate place (ie 1 + 1 = 1) it removes an alias defined and needed elsewhere
;; SUPER unforunately `org-compat' is absolutely critical for reloading `org-macs'
when (let ((sn (symbol-name f)))
(or (and (string-match "^\\(org\\|ob\\|ol\\|oc\\)-" sn)
;; ob-emacs-lisp contains `org-babel-execute:emacs-lisp' which calls this
;; function, if native-compile is enabled then calling `unload-feature'
;; on it will cause a segfault when eval tries to jump to the return value
;; and that memory has be deallocated
(or (not (featurep 'native-compile))
(not (eq f 'ob-emacs-lisp))))
(member sn '("ol" "oc" "orgstrap"))))
collect (progn '(message "unloading org feature: %s" f) (unload-feature f 'force) f))))
;font-lock-unfontify-region-function
;font-lock-unfontify-region
;org-link--description-folding-spec
(let (major-mode)
;; set `major-mode' to nil to avoid `unload--set-major-mode' from triggering
;; a reload of the buffer into `org-mode' causing an infinite loop
(unload-feature 'org))
(setq ow--org-to-reload (cons 'org-macs (cons 'org org-features))))))
(defun ow-reload-org ()
"Reload the version of org on `load-path' after unloading."
(cl-loop
for f in ow--org-to-reload
do (progn
;;(message "f: %s" f)
(condition-case nil
(require f)
(error
(format "failed to load %s" f)
nil))
;;(message "asserting version ... %s" f)
(unless (< emacs-major-version 29)
(org-assert-version))))
;; set very early in the call to `org-mode' needed when restarting `org-mode'
(setq-local font-lock-unfontify-region-function #'org-unfontify-region))(defvar ow-package-archives '(("gnu" . "https://elpa.gnu.org/packages/") ; < 26 has http
("melpa" . "https://melpa.org/packages/")
("nongnu" . "https://elpa.nongnu.org/nongnu/")))
(when (< emacs-major-version 26)
(setq gnutls-algorithm-priority "NORMAL:-VERS-TLS1.3"))
(defun ow-enable-use-package (&optional want-builtin-org populate-site force-org)
"Do all the setup needed for `use-package'.
This needs to be called with (eval-when-compile ...) to the top level prior
to any use of `use-package' otherwise it will be missing and fail"
;; package-archives is not an argument to this function to ensure that
;; there is only one place that needs to be updated if an archive location
;; changes, namely this library, updating that is easier to get right using
;; the `reval-update' machinery
(let* ((in-elisp-block
(and
(boundp 'org-babel-current-src-block-location)
org-babel-current-src-block-location))
(oeb (and (boundp 'org-export-backends)
org-export-backends))
(oerb (and (boundp 'org-export-registered-backends)
org-export-registered-backends))
(befores '())
(to-reload
(and
(not want-builtin-org)
(or in-elisp-block force-org)
(not ow--org-reloaded)
(or (featurep 'package) (require 'package))
(or ; trying to reload a non-builtin org e.g. from elpa a nightmare
(assq 'org package--builtins)
;; `package-initialize' has to have been called before this point
;; for `package--builtins' to have been set, so we have have to fail
;; over to use `locate-library' to see if we loaded the builtin org
;; FIXME at the moment this is an awful hack that only works nixen
(string-prefix-p "/usr/" (locate-library "org")))
(cl-loop
for buffer in (buffer-list) do
(with-current-buffer buffer
(when (eq major-mode 'org-mode)
(setq
befores
(cons
(cons
buffer
(with-current-buffer buffer
(buffer-local-variables)))
befores))))
return t)
(cl-letf (((symbol-function 'org-unfontify-region) (lambda (b e))))
;; if we don't bind `org-unfontify-region to be nothing emacs will segfault 139
;; when native comp is enabled because e.g. `ob-cypher' will try to call a compiled
;; function that has been unloaded at an address that is no longer valid (oops)
(ow-unload-org))))
(populate-site (or populate-site ow-site-packages))
success)
(unwind-protect
(progn
(unless to-reload
(require 'package))
(when (< emacs-major-version 26)
(setq package-archives
(cl-remove-if (lambda (p) (equal p '("gnu" . "http://elpa.gnu.org/packages/")))
package-archives))
(add-to-list 'package-archives (assoc "gnu" ow-package-archives))
(package-initialize populate-site)
(unless (package-installed-p 'gnu-elpa-keyring-update)
(let (os package-check-signature)
(setq package-check-signature nil)
(package-refresh-contents)
(package-install 'gnu-elpa-keyring-update)
(warn "You need to restart Emacs for package keyring changes to take effect.")
(setq package-check-signature os)))
(setq package--initialized nil))
(dolist (pair ow-package-archives)
(add-to-list 'package-archives pair t))
(unless package--initialized
(package-initialize populate-site))
(when populate-site
(ow-populate-site-packages (and (listp populate-site) populate-site))
(package-activate-all))
(unless (package-installed-p 'use-package)
(package-refresh-contents)
(let (font-lock-global-modes) ; insane stuff in 26
(package-install 'use-package)))
(require 'use-package)
(setq use-package-always-ensure t)
(setq success t))
(when (and to-reload (not success))
(ow-reload-org)))
(when to-reload
(unless (assq 'org package-alist)
;; prevent the byte compiler from compiling
;; the org from elpa with the old `org-macs'
(require 'org-macs)
(unless (< emacs-major-version 29)
(org-assert-version))
(unload-feature 'org-macs 'force))
(let ((ow-file (symbol-file 'ow)))
(assq-delete-all 'org package--builtins)
(assq-delete-all 'org package--builtin-versions)
(when ow-file (unload-feature 'ow)) ; need the new org-macs
(unwind-protect ; :no-require needed to prevent circular require issues
;; NOTE this does not handle the case where we don't want
;; to install elpa org if it is not already present, but
;; we do want to use it if it is
(progn (use-package org :no-require t))
(when ow-file
(when (featurep 'reval) ; `unload-feature' is brainded and unloads everything in a file
(load (symbol-file 'reval) nil t))
(load ow-file nil t))
(setq ow--org-to-reload to-reload)
(ow-reload-org)
(setq ow--org-reloaded t)
(let (enable-local-eval
org-agenda-file-menu-enabled) ; needed to prevent keymapp nil errors
;; these two are needed to prevent an eval-when-load 'ox statement from triggering
;; causing a recursive load error
(when oeb (defvar org-export-backends oeb))
(when oerb (defvar org-export-registered-backends oerb))
(cl-loop
for buffer in (buffer-list) do
(with-current-buffer buffer
(when (eq major-mode 'org-mode)
(let ((before (cdr (assoc buffer befores))))
(cl-letf (((symbol-function 'org-restart-font-lock) (lambda ())))
;; starting at org 9.7.5 have to `org-restart-font-lock' to do nothing
;; because `org-link--set-link-display' is called by `custom-initialize-reset'
;; and somehow that is called before org.el itself is loaded
(org-mode))
(let ((after (buffer-local-variables)))
(cl-loop
with a-value
for (var . b-value) in before
do (setq a-value (assq var after)) ; XXX bad complexity
unless (and a-value (equal b-value (cdr a-value)))
;; XXX WARNING there might be some cases where restoring old local variables
;; will break things if there are differences between org versions
do (set (make-local-variable var) b-value)))))))))))))
(defmacro ow-use-packages (&rest names)
"enable multiple calls to `use-package' during bootstrap
additional configuration can be provided by converting the symbol
into a list (name body ...)"
(cons
'progn
(mapcar (lambda (name)
(cond ((symbolp name) `(use-package ,name))
((listp name)
(unless (eq (car name) 'quote)
(if (memq (car name) '(if when unless))
`(,(car name) ,(cadr name) (use-package ,@(cddr name)))
`(use-package ,@name))))
((t (error "unhandled type %s" (type-of name))))))
names)))
(defvar ow-site-packages nil
"set this value before loading this file if there are known site packages")
(require 'package) ; at top level because we need access to the `package-desc-dir' which is generated by a macro
(defun ow-populate-site-packages (&optional site-packages)
"Add site packages to `package-alist' and `package-activated-list'."
(let* ((site-packages (or site-packages ow-site-packages))
(ll (or (locate-library "site-gentoo")))
(site-lisp-directory
(cond (ll (file-name-directory ll))
(t (warn "don't know site-lisp location") nil))))
;;(message ":site-lisp-directory %S :site-packages %s :osp %s" site-lisp-directory site-packages ow-site-packages)
(when site-lisp-directory
(cl-loop
for pkg in site-packages do
(let ((el (locate-library (format "%s.el" (symbol-name pkg)))))
(when el
(let ((dir (file-name-directory el))
(pkg-desc
(with-current-buffer (find-file-noselect el 'nowarn)
(prog1
(package-buffer-info)
(kill-buffer)))))
;;(message ":dir %s :el %s :site-lisp-directory %s" dir el site-lisp-directory)
(when (string-prefix-p site-lisp-directory dir)
(setf (package-desc-dir pkg-desc) dir)
(add-to-list 'package-alist (list pkg pkg-desc))
(add-to-list 'package-activated-list pkg)))))))))This is too much right now. Conditional requires and configuration
already make this approach a special happy path at best. I think that
the best compromise right now is my use-packages implementation from
the original version of orgstrap.
(defun ow-requires (&rest features)
"A list of simple requires. Conditional requires more complex."
(let ((missing (cl-loop for feature in features
unless (condition-case nil
(require feature)
(error nil))
collect feature)))
(ow-install-requires missing)
))
(defun ow-install-requires (features)
"run once to install all missing features"
(cl-loop for pair in ow-package-archives do (add-to-list 'package-archives pair t))
(package-install feature)
)
;; see this stinks, because there are other things we want to do
;; in certain circumstances I guess multiple calls to ow-requires is ok?
;; sigh
(ow-requires (if (fboundp #'undo-redo) 'simple 'undo-fu))
(unless (fboundp #'undo-redo)
(ow-requires 'undo-fu)
(defalias 'undo-redo #'undo-fu-only-undo "Backport `undo-redo'"))With orgstrap in melpa I’m going to rule that, while a fun idea, the
though of using the orgstrap block for this file to stick the
machinery in a users init.el somehow is not the best approach (to say
the least) to providing the functionality contained in this file. The
best approach is to include the following in your orgstrap block so
that it is clear what the user is in for. I’m not entirely sure how
to make it possible to make handling optional dependencies possible
… probably using a :var header option that doesn’t get hashed?
Installing missing packages dynamically is tricky. There is no good way to do it that works on every system. Having a dedicated macro that takes as arguments the names of the required packages and the required package archives seems like it would be the best way to isolate the dependencies in a single place so that users of alternative packaging systems could install them manually. It also seems like implementing detection and support for additional package managers would be easier this way. Unfortunately this seems somewhat misguided.
Package managers exist on a different time scale and in a different
space than orgstrap. Leveraging package managers to do the right thing
from orgstrap is desireable, but sometimes you just want to be able to
reuse some bootstrapping code between files. In which case you aren’t
going to publish it to an elpa, you are likely going to use
url-handler-mode to open the elisp file in a buffer, make sure the
checksum matches, and then eval it — without using securl which is
a much heavier solution for asset retrieval.
Given that I am aware of nearly a dozen ways to install and manage elisp packages, and this means that I’m only going to support packages.el (and possibly use-package) and will make sure that users can modify/disable package installation if they are using a different package manager. In theory we should also be able to detect the use of alternate package managers or use of a starter kit so that we can prompt those users that package-install will run if require fails. Maybe there is a way to create a recipe generator that will work for all of these. Without something that can interpolate between all of these, the burden on the developer is too large to be practical.
- manual
- packages.el
- use-package
- straight
- borg
- el-get
- quelpa
- cask
- ebuild
- nix
- guix
;; install `orgstrap'
(add-to-list 'package-archives '("melpa" . "https://melpa.org/packages/") t)
;; so this section is a bit trickier than anticipanted ...
(defmacro orgstrap-package (name)
()
)
(if (fboundp #'use-package)
(use-package orgstrap)
(package-install 'orgstrap))
;; TODO detect the use of quelpa/straight/borg/etc.The test that must run to ensure that a package that we need is
present is (require 'package-name).
Thus, given a list of requires (requires 'package-1 'package-2 ...)
it ought to be possible to write the following.
(defun requires (&rest package-names)
(dolist (package-name package-names)
(condition-case err
(require package-name)
;; car is file-missing it seems?
(error (orgstrap-install-package-from-require package-name)))))orgstrap-install-package-from-require encapsulates the explosion of
complexity that is the Emacs package management ecosystem. Somewhere
in there will be a function from the require name to the function that
the user wants to use to install the package. It could be a function
that wraps use-package it could be something else, like loading into
a reval registry. The default function would be to print a message to
please install that package and try again. Other prepackaged options
could be package-install, or it could be the process defined in the
orgstrap block itself. It might make sense to have a custom variable
to control the default behavior, and it could just be the name of the
package manager if we can’t figure out how to detect which one is in
use. Then the user can write their recipe and either pr back to the
source for the orgstrapped file or maybe to a central registry if they
are not using one of the standard approaches.
The full complexity solution here is to check all names individually.
As per Spec-ulation, the test that must run to determine whether a
function that we need is present is minimally (fboundp 'function-name).
For other free variables it is (boundp 'variable-name).
In theory you can run a pass over an orgstrap block to see whether all the function names that are needed are defined (the orgstrap block has to do this to itself). Technically this is a bit simpler because many of the functions are builtin and because it is possible to run the byte compiler and collect warnings. Doing full dependency tree shaking is out of scope at the moment.
Having now implemented and usedreval for a while the attraction of
being able to pin to a stable git commit is extremely valuable for
certain use cases. Thus using straight as a way to manage packages
seems reasonable. I’m not sure we want to do it by default, but it is
clear that it meets the single reproducible path criteria. Figuring
out how to lift that single path into the more generic specification
or vice versa seems consistent with the balance between reproducible
and robust.
Storing evidence and implementation of robustness is desirable, but
having good established best practices for managing the stable path is
equally important. Having orgstrap-materialize-all-dependencies or
something similar would be another way to handle this. Here is a copy
of a minimal chroot environment in which this runs. For example, base
system, Emacs, and maybe git using the gentoo docker images.
run-command provides a light wrapper around call-process to
transform external errors into elisp errors and otherwise evaluates to
the string output of the process.
Thank you semiconductor people for the idea of chain opens and comb shorts for coming up with an idea that makes it really easy to detect race conditions.
emacs -Q -batch -l ~/git/orgstrap/ow.el -eval '(ow-run-command "sh" "-c" "echo hello; sleep .5; echo there; sleep .1; echo asdf; echo sigh; echo ま; echo error >&2; echo out; sleep .1; printf asdf; sleep .1; printf asdf; sleep .1;printf \\\\x40; sleep .1; echo yay")'
emacs -Q -batch -l ~/git/orgstrap/ow.el -eval '(ow-run-command "sh" "-c" "echo err 1>&2; sleep 1; echo out")'
emacs -Q -batch -l ~/git/orgstrap/ow.el -eval '(ow-run-command "sh" "-c" "echo err 1>&2;echo out;echo err 1>&2;echo out;echo err 1>&2;echo out;echo err 1>&2;echo out;")'(require 'cl-lib)
(defvar ow-forward-subprocess-streams t "Forward streams from subprocesses.")
(defun ow--forward-stream (buffer point printcharfun)
"Use `princ' on BUFFER after POINT using PRINCHARFUN to output.
Helper function to forward stderr and stdout from subprocesses."
;; tried to add a prefix to clarify out/err distinctions but it
;; turns out that even the simplest test cases show that that is a
;; futile attempt ... thanks unix
(with-current-buffer buffer
(let ((new-point (point)))
(unless (= new-point point)
(princ (buffer-substring point new-point) printcharfun))
new-point)))
(defun ow--my-balls (process princharfun &optional no-forward)
(let* ((buffer (process-buffer process))
(point (with-current-buffer buffer (point))))
(while (accept-process-output process)
(when (and noninteractive (not no-forward))
(let (message-log-max)
(setq point (ow--forward-stream buffer point princharfun)))))
;; we don't actually want to print the junk in the buffer that
;; shows up after the process exits, unfortunately the behavior is
;; inconsistent and sometimes the junk prints and sometimes it
;; does not depending on the exact interaction between the threads
;; and the process, so we call this one last time to get everything
(ow--forward-stream buffer point princharfun)
nil))
(defun ow--accept-and-forward-process-output (process stderr-process &optional no-forward)
"Accept output from PROCESS and STDERR-PROCESS when `noninteractive' forward streams.
WARNING: does not gurantee sequencing of stdout and stderr events.
If the optional NO-FORWARD argument is non-nil do not forward.
An alternate approach might be to use `set-process-filter'."
;; https://github.com/tkf/emacs-request/issues/203
(let ((tout (make-thread (lambda () (ow--my-balls process standard-output no-forward))))
(terr (make-thread (lambda () (ow--my-balls stderr-process #'external-debugging-output no-forward)))))
;; we have to bind each process to the new threads so that they
;; can be read by each thread, in this way we can nearly get
;; behavior that matches wait for multiple objects
;; XXX WARNING: even with this behavior the ordering of events
;; IS NOT PRESERVED, see the stochastic behavior of the err-out
;; alternating chain test, clearly shows a race condition
(set-process-thread process tout)
(set-process-thread stderr-process terr)
(thread-join tout)
(thread-join terr)))
(defun ow--aafpo-<-26 (process stderr-process &optional no-forward)
"Variant of `ow--accept-and-forward-process-output' that works before Emacs 26."
(let ((stdout-buffer (process-buffer process))
(stderr-buffer (process-buffer stderr-process))
(stdout-point 1)
(stderr-point 1))
(cl-loop
for p in (list process stderr-process) do
(while (accept-process-output p)
(when (and noninteractive (not no-forward))
(let (message-log-max)
(setq stdout-point (ow--forward-stream stdout-buffer stdout-point standard-output))
(setq stderr-point (ow--forward-stream stderr-buffer stderr-point #'external-debugging-output))))))
(ow--forward-stream stdout-buffer stdout-point standard-output)
(ow--forward-stream stderr-buffer stderr-point #'external-debugging-output)))
(when (< emacs-major-version 26)
(defalias 'ow--accept-and-forward-process-output #'ow--aafpo-<-26))
(defun ow-run-command-no-thread (command &rest args)
"Run COMMAND with ARGS.
Raise an error if the return code is not zero."
;; TODO maybe implement this in terms of ow-run-command-async ?
;; usually (defalias 'run-command #'ow-run-command)
(let ((stdout-buffer (generate-new-buffer " rc stdout"))
(stderr-buffer (generate-new-buffer " rc stderr")))
(unwind-protect
(let ((process
(make-process
:name (concat "run-command: " command)
:buffer stdout-buffer
:stderr stderr-buffer
:command (cons command args))))
(while (accept-process-output process)) ; don't use mutexes kids
(let ((ex (process-exit-status process)))
(if (= 0 ex)
(with-current-buffer stdout-buffer (buffer-string))
(error "Command %s failed code: %s stdout: %S stderr: %S"
command ex
(with-current-buffer stdout-buffer (buffer-string))
(with-current-buffer stderr-buffer (buffer-string))))))
(kill-buffer stdout-buffer)
(kill-buffer stderr-buffer))))
(defun ow-run-command (command &rest args)
"Run COMMAND with ARGS.
Raise an error if the return code is not zero."
;; TODO maybe implement this in terms of ow-run-command-async ?
;; usually (defalias 'run-command #'ow-run-command)
(let ((stdout-buffer (generate-new-buffer " rc stdout"))
(stderr-buffer (generate-new-buffer " rc stderr")))
(unwind-protect
(let ((process
(make-process
:name (concat "run-command: " command)
:buffer stdout-buffer
:stderr stderr-buffer
:command (cons command args))))
(ow--accept-and-forward-process-output
process
(get-buffer-process stderr-buffer)
(not ow-forward-subprocess-streams))
(let ((ex (process-exit-status process)))
(if (= 0 ex)
(with-current-buffer stdout-buffer (buffer-string))
(error "Command %s failed code: %s stdout: %S stderr: %S"
command ex
(with-current-buffer stdout-buffer (buffer-string))
(with-current-buffer stderr-buffer (buffer-string))))))
(cl-loop ; workaround for bug#56002
for buffer in (list stdout-buffer stderr-buffer) do
(let ((p (get-buffer-process buffer)))
(when p
(set-process-query-on-exit-flag p nil))))
(kill-buffer stdout-buffer)
(kill-buffer stderr-buffer))))
(defun ow-run-command-24 (command &rest args)
"Run COMMAND with ARGS. Raise an error if the return code is not zero.
This is retained for compatibility with Emacs 24 since `make-process' was
introduced in version 25."
(with-temp-buffer
(let* ((return-code (apply #'call-process command nil (current-buffer) nil args))
(string (buffer-string)))
(if (not (= 0 return-code))
(error "Command %s failed code: %s stdout: %S" command return-code string)
string))))
(when (< emacs-major-version 25)
(defalias 'ow-run-command #'ow-run-command-24))
(defun ow--default-sentinel (process message &optional stderr-process)
"An example sentinel for async processes.
PROCESS is the process that changed status and MESSAGE is the
message related to that change. The STDERR-PROCESS is passed as
an optional argument if :stderr was set (which it always is when
using `ow-run-command-async')."
(message "%s %s %s"
message
(process-status process)
(and stderr-process (process-status stderr-process)))
(message "stdout: %S stderr: %S"
(with-current-buffer (process-buffer process) (buffer-string))
(and stderr-process (with-current-buffer (process-buffer stderr-process) (buffer-string)))))
(cl-defun ow-run-command-async (command &rest args &key sentinel &allow-other-keys)
"Run COMMAND with ARGS asynchronously.
SENTINEL is a function that has two required arguments, and MUST
ACCEPT AN ADDITIONAL OPTIONAL ARGUMENT for stderr-process. This
allows the sentinel process to be use as a normal sentinel
function as well.
Reminder that kwargs must come before rest when calling a cl-defun."
(let* ((args (or (and (memq :sentinel args)
(cl-remove-if (lambda (x) (or (not x) (eq x :sentinel)))
(plist-put args :sentinel nil)))
args))
(stdout-buffer (generate-new-buffer (concat " process-buffer-" command)))
(stderr-buffer (generate-new-buffer (concat " process-buffer-stderr" command)))
(stderr-process
(make-pipe-process
:name (concat "process-stderr-" command)
:buffer stderr-buffer))
(wrapped-sentinel
(if sentinel
(lambda (process message)
(unwind-protect
(funcall sentinel process message stderr-process)
(when (memq (process-status process) '(exit signal))
(kill-buffer stdout-buffer)
(kill-buffer stderr-buffer))))
(lambda (process message)
(when (memq (process-status process) '(exit signal))
(kill-buffer stdout-buffer)
(kill-buffer stderr-buffer)))))
(process
(make-process
:name (concat "process-" command)
:buffer stdout-buffer
:stderr stderr-process
:command (cons command args)
:sentinel wrapped-sentinel)))
process))
(cl-defun ow-run-command-async-24 (command &rest args &key sentinel &allow-other-keys)
"Run COMMAND with ARGS asynchronously. SENTINEL runs when processes change status.
Legacy implementation for Emacs < 25. Reminder that kwargs must
come before rest when calling a cl-defun."
(let* ((args (or (and (memq :sentinel args)
(cl-remove-if (lambda (x) (or (not x) (eq x :sentinel)))
(plist-put args :sentinel nil)))
args))
(process (apply #'start-process
(format "process-%s" command)
(generate-new-buffer
(format " process-buffer-%s" command))
command
args)))
(when sentinel
(set-process-sentinel process sentinel))
process))
(when (< emacs-major-version 25)
(defalias 'ow-run-command-async #'ow-run-command-async-24))
(defun ow-call-process (command &rest args)
"`call-process' and do not wait, fork it an let it be freeeee!"
(apply #'call-process command nil 0 nil args))
(defun ow-find-file-new-process (file)
"`find-file' in a separate Emacs process.
`user-emacs-directory' and `user-init-file' are passed
to the new process if they are non-nil, otherwise default
values are provided."
(apply
#'ow-call-process
`(,(expand-file-name (invocation-name) (invocation-directory))
,@(when user-emacs-directory
`("-eval" "(setq user-emacs-directory (pop argv))" ,user-emacs-directory))
,@(if user-init-file
`("-eval" "(progn (setq user-init-file (pop argv)) (load user-init-file))" ,user-init-file)
'("-q"))
"-visit" ,file)));; ow-cli
(require 'cl-lib)
(defun ow-string-to-number (string &optional base)
"vanilla `string-to-number' has a degenerate case with \"0\""
(let ((maybe-zero (string-to-number string base)))
(if (= maybe-zero 0)
(if (string= maybe-zero "0")
0
(error "%S is not a number!" string))
maybe-zero)))
(defun ow-keyword-name (keyword)
"Get the `symbol-name' of KEYWORD without the leading colon."
(unless (keywordp keyword)
(error "%s is not a keyword! %s" keyword (type-of keyword)))
(substring (symbol-name keyword) 1))
(defun ow-cli--norm-arg (arg)
(let ((int (ignore-errors (ow--string-to-number arg))))
(if int int arg)))
(defun ow-cli--process-bind-keyword (bind-keyword)
"Processes BIND-KEYWORD into let-binding elements `cl-case' elements and alist elements.
Bind keyword lists may take the following forms.
(:flag) ; legacy support before we added the internal binding clause
((:flag)) ; same as (:flag)
((:flag) flag-internal)
(:option default)
((:option default))
((:option default) option-internal)
(subcmd)
(subcmd subcmd-internal)"
(unless (listp bind-keyword)
(error "%s not a list! %s" bind-keyword (type-of bind-keyword)))
(let* ((kw-or-element? (car bind-keyword))
(bind? (if (symbolp kw-or-element?) nil (cdr bind-keyword)))
(element (if (symbolp kw-or-element?) bind-keyword kw-or-element?))
(_ (unless (listp element)
(error "%s not a list! %s" element (type-of element))))
(kw (car element))
(sl (and (keywordp kw) (ow-keyword-name kw)))
(subcmd? (not (keywordp kw)))
(assign? (and (not subcmd?) (cdr element)))
(real-assign (if bind? (car bind?) (if subcmd? kw (intern sl))))
(default (if assign? (car assign?) assign?)) ; FIXME
(p (if assign?
`(progn (setf ,real-assign (ow-cli--norm-arg (cadr args)))
;; equivalent of bash shift shift
(setf args (cddr args)))
`(progn (setf ,real-assign t)
;; equivalent of bash shift
(setf args (cdr args))))))
(list `(,real-assign ,default) ; default
`(,(if subcmd? kw (intern (format "--%s" sl))) ,p) ; case
`(cons ',real-assign ,real-assign))))
(defmacro ow-cli-parse-args (&rest keywords)
"(parse-args (:port port) (:pid pid) (:flag))
XXX This is a legacy function.
NOTE if the default value if a kwarg is nil rather than
empty i.e. (:asdf nil) vs (:asdf) the form with nil will
not fail but will be nil unless some value is provided
AND it will eat the next kwarg this is probably a misdesign"
`(ow-cli-gen ,keywords parsed))
(defmacro ow-cli-gen (bind-keywords &rest body) ; (ref:cli-gen)
"All the machinery needed for simple cli specification.
BIND-KEYWORDS follow a reverse let pattern because if the name to
bind is not specified then it is the `ow-keyword-name' of the keyword
used to specify the command line option.
For example
((:option default)) -> --option value -> (let ((option \"value\")) )
((:option default) option-internal) -> --option value -> (let ((option-internal \"value\")) )"
;; FIXME ambiguity between (:option bind-to-name) and ((:option) bind-to-name)
(declare (indent 2) (indent 1))
(cl-destructuring-bind (defaults cases returns)
(apply #'cl-mapcar #'list ; `cl-mapcar' required for this to work
(mapcar #'ow-cli--process-bind-keyword bind-keywords))
`(let ((args (cdr command-line-args-left))
,@defaults)
(cl-do ()
((null args) nil)
(cl-case (intern (car args))
,@cases
(otherwise (progn (message "unhandled: %s" (car args))
(setf args (cdr args))))))
(let (cases returns (parsed (list ,@returns)))
,@body))))
(defun ow-cli-opt (opt)
"If OPT is in `argv' return the index of OPT in `argv'.
If you need to set variables from `argv' early in load, (e.g.
before a call to `reval' so you can set the cache location) then
you need some absolutely minimal argv parsing machinery.
Thus, this function is not particularly useful in a library because
its primary use case is to check for and set `user-emacs-directory'
if it is passed on the command line. It is kept here for reference
so that it can be pasted into a file that needs to able to set
`user-emacs-directory' before `reval' or `ow-cli-gen' are present."
(let ((index (cl-position opt argv :test #'string=)))
(and index (elt argv (1+ index)))))
<<orthauth-minimal>>~ow-cli-gen~ takes a generative approach to parsing command line
options which I usually dislike and discourage because it puts the
specification of the interface at the wrong place and the --help
string can easily get out of sync and must be actively kept in
sync. This should thus only be used for quick and dirty work that is
not indented for external consumption or reuse. For more complex cli
needs including any that are expected to be user facing I suggest
reusing the internal machinery from docopt.el since it makes the
specification of the interface the interface!
emacs -q \
--eval "(setq command-line-args-left nil)" \
-- --option value --flag --other other(ow-cli-gen
(((:repo "~/git/apinatomy-models") apinat-model-repo)
((:converter "apinat-converter") apinat-converter-path)
((:model-id nil))
((:secrets oa-secrets) oa-secrets)
((:debug) apinat-converter-debug)
)
parsed)
(let ((command-line-args-left '("--" "--option" "value" "--flag" "--other" "other")))
(ow-cli-gen
((:option nil)
((:option-2 'lol))
((:flag) flag-internal)
((:other "default") other-internal))
parsed))
;; TODO do we want to be able to do this? or at this point do we docopt and go home?
;; yes, yes we do want this
(let ((command-line-args-left '("--" "subcommand" "--option" "value" "--flag" "--other" "other" "rest-1")))
(ow-cli-gen
((:option nil)
((:option-2 'lol))
((:flag) flag-internal)
((:other "default") other-internal)
;; (subcommand (subsubcommand-1) (subsubcommand-2)) ; this is too much work to parse
;; it is easier to make it possible to accept subcommands and then deal with valid
;; combinations in the body (separation of concerns is weird for macros)
(unique-subcommand)
(subcommand sc-internal)
(subsubcommand-1 ssc-1-int)
(subsubcommand-2 ssc-2-int))
parsed))
;; orthauth-minimal
(defvar oa-secrets nil "path to orthauth secrets.sxpr file")
(defun oa--resolve-path (plist elements)
"recursively `cl-getf' in order keywords from ELEMENTS in nested plists inside PLIST"
(if elements
(oa--resolve-path (cl-getf plist (car elements)) (cdr elements))
plist))
(defun oa--read (path)
"read the first sexpression in the file at PATH"
(with-temp-buffer
(insert-file-contents path)
(read (buffer-string))))
(defun oa-path (&rest elements)
"Retrieve value at nested path defined by keywords provided in ELEMENTS in `oa-secrets'"
(let ((plist (oa--read oa-secrets)))
(oa--resolve-path plist elements)))As a point of curiosity, it is possible to implement this using curl and sha256sum in a way that is quite a bit faster. However, the complexity of the code needed to implement it in a way that is portable makes it significantly harder to understand and audit.
(defvar securl-default-cypher 'sha256) ; remember kids, always publish the cypher with the checksum
(defun securl-path-checksum (path &optional cypher)
"Compute checksum for PATH under CYPHER.
Not as fast as using sha256sum, but requires no dependencies 1.4s vs .25s for ~60mb"
(let ((cypher (or cypher securl-default-cypher)))
(with-temp-buffer
(insert-file-contents-literally path)
(secure-hash cypher (current-buffer)))))
(defun securl (cypher checksum url path)
"Securely fetch URL to PATH only if it matches CHECKSUM under CYPHER.
Files that do not match the checksum are quarantined."
;; unless the file exists or the checksum matches fetch and check
(unless (and (file-exists-p path)
(let ((existing-checksum (securl-path-checksum path cypher)))
(or (string= checksum existing-checksum)
;; (not (message "checksum mismatch:\n%S\n%S" checksum existing-checksum))
(not (rename-file path
(make-temp-file (concat path "._existing_failure_."))
t)))))
(let ((path-temp (make-temp-file (concat path "._fetching_."))))
(url-copy-file url path-temp t)
(let ((new-checksum (securl-path-checksum path-temp cypher)))
(if (string= checksum new-checksum)
(rename-file path-temp path)
(let ((path-failure (make-temp-file (concat path "._checksum_failure_."))))
(rename-file path-temp path-failure t)
(error "checksum FAILED for path! %s" path-failure))))))
;; return nil in all cases the calling scope has the path and
;; whatever is at that path must have passed the current checksum
nil)TODO there are a bunch of different pathological cases that I have already worked out but for which there are no explicit existing tests. The checksum of a non-existent file could be anything re all my mountain bikes go 66mph. The table below enumerates the most common cases, but cases such as rex no conflate 404, 500, and connection errors among others.
| lex | lsum | rex | rsum | act | test? |
|---|---|---|---|---|---|
| yes | yes | ? | ? | done | |
| yes | bad | yes | ok | l -> existing-bad, r -> l | |
| no | ? | yes | ok | r -> l | |
| no | ? | no | ? | r no file error | |
| no | ? | yes | bad | r -> bad, r bad file error |
(securl 'sha256
'aada229afa36ac1f3e9f26e1ec7c0c09214d75563adb62aa0fac2f1ae58496fe
"https://raw.githubusercontent.com/tgbugs/orgstrap/417b87304da27397/packages.el"
"packages-test-fetch.el")Random stuff that doesn’t fit elsewhere.
(defmacro ow--setq (global &rest body)
`(if ,global
(setq ,@body)
(setq-local ,@body)))
(defun ow-url-head-ok (url)
"Check if URL is up and OK using HTTP HEAD.
All errors are silenced."
(let ((url-request-method "HEAD"))
(condition-case nil
(with-current-buffer (url-retrieve-synchronously url)
;;(buffer-substring (point-min) url-http-end-of-headers)
(goto-char 0)
(re-search-forward "^HTTP.+OK$"))
(error nil))))
(defun ow--results-silent (fun &rest args)
"Whoever named the original version of this has a strange sense of humor."
;; so :results silent, which is what org babel calls between vars
;; set automatically is completely broken when one block calls another
;; there likely needs to be an internal gensymed value that babel blocks
;; can pass to eachother so that a malicious user cannot actually slience
;; values, along with an option to still print, but until then we have this
(let ((result (car args))
(result-params (cadr args)))
(if (member "silent" result-params)
result
(apply fun args))))
(defun ow-babel-execute-src-block (block-name &optional universal-argument error-on-fail)
"Use to confirm running a chain of dependent blocks starting with BLOCK-NAME.
This retains single confirmation at the entry point for the block.
If ERROR-ON-FAIL is non-nil then an error will be raised by overriding
`org-babel-eval-error-notify' via cl-letf."
;; TODO consider a header arg for a variant of this in org babel proper
(interactive "P")
(let ((org-confirm-babel-evaluate (lambda (_l _b) nil))) ;; FIXME TODO set messages buffer size to nil
(save-excursion
(when (org-babel-find-named-block block-name)
;; goto won't raise an error which results in the block where
;; `ow-confirm-once' is being used being called an infinite
;; number of times and blowing the stack
(org-babel-goto-named-src-block block-name)
(unwind-protect
(progn
;; FIXME optionally raise errors on failure here !?
(advice-add #'org-babel-insert-result :around #'ow--results-silent)
(if error-on-fail
(cl-letf
(((symbol-function 'org-babel-eval-error-notify)
(lambda (exit-code stderr)
(error "Babel evaluation of %S failed with %s%s%s"
block-name
exit-code
(if stderr "\n" "")
(if stderr stderr "")))))
(org-babel-execute-src-block))
(org-babel-execute-src-block)))
(advice-remove #'org-babel-insert-result #'ow--results-silent))))))
(defalias 'ow-babel-exec #'ow-babel-execute-src-block)
(define-obsolete-function-alias
'ow-babel-eval #'ow-babel-execute-src-block "29.1"
"Support for orgstrap blocks that have not updated.
Better to use `ow-babel-exec' alias to match terminology.")
(defun ow-babel-execute-closest-src-block (&optional universal-argument)
"Execute the block that is closest to the cursor line.
If `org-element-at-point' is a src-block run that block.
Distance is `count-lines' between `point' and the end of the
previous block and `point' and the beginning of the next block.
If the distance is equal run the next block."
(interactive "P")
;; FIXME also whether one of the blocks is visible
;; FIXME also whether we cross a heading ...
(let ((elem (save-excursion
(forward-char) ; issues with line after block counting as block
(org-element-at-point))))
(if (eq (org-element-type elem) 'src-block)
(save-excursion
(goto-char (cl-getf (nth 1 elem) :begin))
(org-babel-execute-src-block))
(let ((here (point))
(prev-beg-end
(save-excursion
(condition-case nil
(progn
(org-babel-previous-src-block)
(let ((e (nth 1 (org-element-at-point))))
(cons (cl-getf e :begin)
(cl-getf e :end))))
(user-error nil))))
(next-beg
(save-excursion
(condition-case nil
(progn
(org-babel-next-src-block)
(point))
(user-error nil)))))
(let ((dist-prev (and prev-beg-end (count-lines (1- (cdr prev-beg-end)) here)))
(dist-next (and next-beg (count-lines here (1- next-beg)))))
(if (or dist-prev dist-next)
(save-excursion
(goto-char
(cond
((and dist-prev dist-next)
(if (>= dist-prev dist-next)
next-beg ; next gets priority if line dist is equal
(car prev-beg-end)))
(dist-next next-beg)
(dist-prev (car prev-beg-end))))
(message "%s" (point))
(org-babel-execute-src-block))
(user-error "Could not find any source blocks to run.")))))))Not quite a sandbox yet, but at least a clean slate.
I think two side by side impls are probably better for this rather than replaying the insanity that is ./get-emacs.org
Today we learn about the WAT that is <<. Apparently the way to
prevent variables from being interpreted in the heredoc is to SINGLE
QUOTE THE LIMIT STRING SPECIFICATION !?!?!?!?! WAT.
https://stackoverflow.com/a/2954835. See also
https://stackoverflow.com/a/23930212.
#read -r -d '' OW_INIT << 'EOF'
#<<&orgware-cli-init>>
#EOF
read -r -d '' OW_ELISP << 'EOF'
<<&orgware-cli-elisp>>
EOF
# FIXME @ needs to be split for -Q -q and --no-init-file and --quick
# everything else goes before the --
# FIXME -Q seems that it will prevent persistence of save local variable values?
# using mktemp is inefficient, but it is the simplest way to
# get emacs to do something other than normal without using -Q or -q
# and since -l won't accept a file descriptor <(echo 'asdf')
#__el_path="$(mktemp -t orgware-init-XXXXXX.el)"
#echo "${OW_INIT}" > "${__el_path}"
#echo ${__el_path}
#read
#-l "${__el_path}" \
emacs -q \
--eval "${OW_ELISP}" \
-- $@
#CODE=$?
#rm "${__el_path}"
#exit $CODEIronically the approach that I ditched in favor of orgstrap which
involved invoking emacs twice to tangle the files that were then
passed to emacs via -l when it was invoked the second time was
actually on to something >_<.
(setq user-emacs-directory (expand-file-name "~/.orgware.d/"))
(let ((args (member "--" command-line-args)))
(if (member "-q" args) ; FIXME yeah, the old bad version actually has it right >_<
(delete "-q" args) ; should propagate since "--" is car ?
(setq user-init-file (expand-file-name "~/.orgware.d/init.el"))))
; TODO probably add a custom.el file to avoid the usual init.el files
<<&ow-package>>put ow package in the init so that that way it will have a location on the file system in the event someone needs to resolve the function xref
(progn
<<&orgware-cli-init>>
(ow-enable-use-package)
(when (and user-init-file (file-exists-p user-init-file))
(load user-init-file))
(use-package orgstrap)
(orgstrap-mode 1))old bad, or … maybe not bad, emacs really really doesn’t want you to be able to run it with an alternate configuration file and then have another config
(let* ((args (member "--" command-line-args))
;; FIXME or will terminate early before removing all of them
;; I think there is a verions of or that hits all?
(no-init
(mapcar
;; FIXME ugh this is so obvously broken
(lambda (flag)
(when (member flag args)
;; XXX this is kind of dangerous, except that we know that "--" is always the car
(setq args (delete flag command-line-args))))
'("-q" "--no-init-file" "-Q" "--quick"))))
(message "%S" no-init)
;;`normal-top-level' ; oh dear
;;(setq user-emacs-directory (expand-file-name "~/.orgware.d/"))
(unless no-init
(setq user-init-file (expand-file-name "~/.orgware.d/init.el")))
<<&ow-package>>
(ow-enable-use-package)
(use-package orgstrap)
(orgstrap-mode 1))There is a question of whether to default to the users init.el by running without -q, but it seems like it would be wiser to tell people to just use -l ~/.emacs.d/init.el and/or to load a potentially non-existent init-orgware.el config file or something like that?
It is critical that known safe hashes be stored in a way that is persistent to prevent prompt fatigue.
(defun ow---pre-tangle ()
(org-babel-lob-ingest "./defl.org") ; chicken meet egg
;; ensure that reval has been ingested so we can tangle the reval-impl block
(org-babel-lob-ingest "./reval.org"))
(add-hook 'org-babel-pre-tangle-hook #'ow---pre-tangle nil t)
;; TODO need a way to hook for C-c C-v C-v because org-src-mode-hook fires too late
(defun ow---strip-empty-lines ()
;; NOTE don't use `replace-regexp' it is marked as interacitve only
;; for a reason, the byte compiler would probably catch the issue
(save-excursion
(goto-char (point-min))
(while (re-search-forward "^ +$" nil t)
(replace-match ""))))
;; FIXME this is a hack to deal with the fact that noweb expansion
;; adds whitespace at the start of empty lines and there is no obvious
;; way to fix that right now note that the hook runs in the buffer
;; where the expanded body is being prepared before buffer-string is
;; called so it is perfect for this use case, note that the hook has
;; to be set globally
(add-hook 'org-babel-tangle-body-hook #'ow---strip-empty-lines)