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-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-hide-section-0-blocks ()
"Hide blocks and dynamic blocks that are used in section 0."
(let ((dblocks '("metadata" "properties" "prefixes"))
(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))))
;; 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))))(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 ()
"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
(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)
(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))
(unless (package-installed-p 'use-package)
(package-refresh-contents)
(package-install 'use-package))
(require 'use-package)
(setq use-package-always-ensure t))
(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)))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.
(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))))
(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-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))
;; 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)"
(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 (keywordp kw-or-element?) nil (cdr bind-keyword)))
(element (if (keywordp 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 (ow-keyword-name kw))
(assign? (cdr element))
(real-assign (if bind? (car bind?) (intern (ow-keyword-name kw))))
(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
`(,(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))))
<<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))
;; 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-eval (block-name &optional universal-argument)
"Use to confirm running a chain of dependent blocks starting with BLOCK-NAME.
This retains single confirmation at the entry point for the block."
;; 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)
(org-babel-execute-src-block))
(advice-remove #'org-babel-insert-result #'ow--results-silent))))))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)