diff options
Diffstat (limited to 'elpa/org-9.5.2/ob-tangle.el')
| -rw-r--r-- | elpa/org-9.5.2/ob-tangle.el | 616 |
1 files changed, 0 insertions, 616 deletions
diff --git a/elpa/org-9.5.2/ob-tangle.el b/elpa/org-9.5.2/ob-tangle.el deleted file mode 100644 index 8ed7002..0000000 --- a/elpa/org-9.5.2/ob-tangle.el +++ /dev/null @@ -1,616 +0,0 @@ -;;; ob-tangle.el --- Extract Source Code From Org Files -*- lexical-binding: t; -*- - -;; Copyright (C) 2009-2021 Free Software Foundation, Inc. - -;; Author: Eric Schulte -;; Keywords: literate programming, reproducible research -;; Homepage: https://orgmode.org - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. - -;;; Commentary: - -;; Extract the code from source blocks out into raw source-code files. - -;;; Code: - -(require 'cl-lib) -(require 'org-src) -(require 'org-macs) -(require 'ol) - -(declare-function make-directory "files" (dir &optional parents)) -(declare-function org-at-heading-p "org" (&optional ignored)) -(declare-function org-babel-update-block-body "ob-core" (new-body)) -(declare-function org-back-to-heading "org" (&optional invisible-ok)) -(declare-function org-before-first-heading-p "org" ()) -(declare-function org-element-at-point "org-element" ()) -(declare-function org-element-type "org-element" (element)) -(declare-function org-heading-components "org" ()) -(declare-function org-in-commented-heading-p "org" (&optional no-inheritance)) -(declare-function org-in-archived-heading-p "org" (&optional no-inheritance)) -(declare-function outline-previous-heading "outline" ()) -(defvar org-id-link-to-org-use-id nil) ; Dynamically scoped - -(defcustom org-babel-tangle-lang-exts - '(("emacs-lisp" . "el") - ("elisp" . "el")) - "Alist mapping languages to their file extensions. -The key is the language name, the value is the string that should -be inserted as the extension commonly used to identify files -written in this language. If no entry is found in this list, -then the name of the language is used." - :group 'org-babel-tangle - :version "24.1" - :type '(repeat - (cons - (string "Language name") - (string "File Extension")))) - -(defcustom org-babel-tangle-use-relative-file-links t - "Use relative path names in links from tangled source back the Org file." - :group 'org-babel-tangle - :type 'boolean) - -(defcustom org-babel-post-tangle-hook nil - "Hook run in code files tangled by `org-babel-tangle'." - :group 'org-babel - :version "24.1" - :type 'hook) - -(defcustom org-babel-pre-tangle-hook '(save-buffer) - "Hook run at the beginning of `org-babel-tangle'." - :group 'org-babel - :version "24.1" - :type 'hook) - -(defcustom org-babel-tangle-body-hook nil - "Hook run over the contents of each code block body." - :group 'org-babel - :version "24.1" - :type 'hook) - -(defcustom org-babel-tangle-comment-format-beg "[[%link][%source-name]]" - "Format of inserted comments in tangled code files. -The following format strings can be used to insert special -information into the output using `org-fill-template'. -%start-line --- the line number at the start of the code block -%file --------- the file from which the code block was tangled -%link --------- Org style link to the code block -%source-name -- name of the code block - -Upon insertion the formatted comment will be commented out, and -followed by a newline. To inhibit this post-insertion processing -set the `org-babel-tangle-uncomment-comments' variable to a -non-nil value. - -Whether or not comments are inserted during tangling is -controlled by the :comments header argument." - :group 'org-babel - :version "24.1" - :type 'string) - -(defcustom org-babel-tangle-comment-format-end "%source-name ends here" - "Format of inserted comments in tangled code files. -The following format strings can be used to insert special -information into the output using `org-fill-template'. -%start-line --- the line number at the start of the code block -%file --------- the file from which the code block was tangled -%link --------- Org style link to the code block -%source-name -- name of the code block - -Upon insertion the formatted comment will be commented out, and -followed by a newline. To inhibit this post-insertion processing -set the `org-babel-tangle-uncomment-comments' variable to a -non-nil value. - -Whether or not comments are inserted during tangling is -controlled by the :comments header argument." - :group 'org-babel - :version "24.1" - :type 'string) - -(defcustom org-babel-tangle-uncomment-comments nil - "Inhibits automatic commenting and addition of trailing newline -of tangle comments. Use `org-babel-tangle-comment-format-beg' -and `org-babel-tangle-comment-format-end' to customize the format -of tangled comments." - :group 'org-babel - :type 'boolean) - -(defcustom org-babel-process-comment-text 'org-remove-indentation - "Function called to process raw Org text collected to be -inserted as comments in tangled source-code files. The function -should take a single string argument and return a string -result. The default value is `org-remove-indentation'." - :group 'org-babel - :version "24.1" - :type 'function) - -(defun org-babel-find-file-noselect-refresh (file) - "Find file ensuring that the latest changes on disk are -represented in the file." - (find-file-noselect file 'nowarn) - (with-current-buffer (get-file-buffer file) - (revert-buffer t t t))) - -(defmacro org-babel-with-temp-filebuffer (file &rest body) - "Open FILE into a temporary buffer execute BODY there like -`progn', then kill the FILE buffer returning the result of -evaluating BODY." - (declare (indent 1) (debug t)) - (let ((temp-path (make-symbol "temp-path")) - (temp-result (make-symbol "temp-result")) - (temp-file (make-symbol "temp-file")) - (visited-p (make-symbol "visited-p"))) - `(let* ((,temp-path ,file) - (,visited-p (get-file-buffer ,temp-path)) - ,temp-result ,temp-file) - (org-babel-find-file-noselect-refresh ,temp-path) - (setf ,temp-file (get-file-buffer ,temp-path)) - (with-current-buffer ,temp-file - (setf ,temp-result (progn ,@body))) - (unless ,visited-p (kill-buffer ,temp-file)) - ,temp-result))) - -;;;###autoload -(defun org-babel-tangle-file (file &optional target-file lang-re) - "Extract the bodies of source code blocks in FILE. -Source code blocks are extracted with `org-babel-tangle'. - -Optional argument TARGET-FILE can be used to specify a default -export file for all source blocks. - -Optional argument LANG-RE can be used to limit the exported -source code blocks by languages matching a regular expression. - -Return a list whose CAR is the tangled file name." - (interactive "fFile to tangle: \nP") - (let* ((visited (find-buffer-visiting file)) - (buffer (or visited (find-file-noselect file)))) - (prog1 - (with-current-buffer buffer - (org-with-wide-buffer - (mapcar #'expand-file-name - (org-babel-tangle nil target-file lang-re)))) - (unless visited (kill-buffer buffer))))) - -(defun org-babel-tangle-publish (_ filename pub-dir) - "Tangle FILENAME and place the results in PUB-DIR." - (unless (file-exists-p pub-dir) - (make-directory pub-dir t)) - (setq pub-dir (file-name-as-directory pub-dir)) - (mapc (lambda (el) (copy-file el pub-dir t)) (org-babel-tangle-file filename))) - -;;;###autoload -(defun org-babel-tangle (&optional arg target-file lang-re) - "Write code blocks to source-specific files. -Extract the bodies of all source code blocks from the current -file into their own source-specific files. -With one universal prefix argument, only tangle the block at point. -When two universal prefix arguments, only tangle blocks for the -tangle file of the block at point. -Optional argument TARGET-FILE can be used to specify a default -export file for all source blocks. Optional argument LANG-RE can -be used to limit the exported source code blocks by languages -matching a regular expression." - (interactive "P") - (run-hooks 'org-babel-pre-tangle-hook) - ;; Possibly Restrict the buffer to the current code block - (save-restriction - (save-excursion - (when (equal arg '(4)) - (let ((head (org-babel-where-is-src-block-head))) - (if head - (goto-char head) - (user-error "Point is not in a source code block")))) - (let ((block-counter 0) - (org-babel-default-header-args - (if target-file - (org-babel-merge-params org-babel-default-header-args - (list (cons :tangle target-file))) - org-babel-default-header-args)) - (tangle-file - (when (equal arg '(16)) - (or (cdr (assq :tangle (nth 2 (org-babel-get-src-block-info 'light)))) - (user-error "Point is not in a source code block")))) - path-collector) - (mapc ;; map over file-names - (lambda (by-fn) - (let ((file-name (car by-fn))) - (when file-name - (let ((lspecs (cdr by-fn)) - (fnd (file-name-directory file-name)) - modes make-dir she-banged lang) - ;; drop source-blocks to file - ;; We avoid append-to-file as it does not work with tramp. - (with-temp-buffer - (mapc - (lambda (lspec) - (let* ((block-lang (car lspec)) - (spec (cdr lspec)) - (get-spec (lambda (name) (cdr (assq name (nth 4 spec))))) - (she-bang (let ((sheb (funcall get-spec :shebang))) - (when (> (length sheb) 0) sheb))) - (tangle-mode (funcall get-spec :tangle-mode))) - (unless (string-equal block-lang lang) - (setq lang block-lang) - (let ((lang-f (org-src-get-lang-mode lang))) - (when (fboundp lang-f) (ignore-errors (funcall lang-f))))) - ;; if file contains she-bangs, then make it executable - (when she-bang - (unless tangle-mode (setq tangle-mode #o755))) - (when tangle-mode - (add-to-list 'modes tangle-mode)) - ;; Possibly create the parent directories for file. - (let ((m (funcall get-spec :mkdirp))) - (and m fnd (not (string= m "no")) - (setq make-dir t))) - ;; Handle :padlines unless first line in file - (unless (or (string= "no" (funcall get-spec :padline)) - (= (point) (point-min))) - (insert "\n")) - (when (and she-bang (not she-banged)) - (insert (concat she-bang "\n")) - (setq she-banged t)) - (org-babel-spec-to-string spec) - (setq block-counter (+ 1 block-counter)))) - lspecs) - (when make-dir - (make-directory fnd 'parents)) - ;; erase previous file - (when (file-exists-p file-name) - (delete-file file-name)) - (write-region nil nil file-name) - (mapc (lambda (mode) (set-file-modes file-name mode)) modes) - (push file-name path-collector)))))) - (if (equal arg '(4)) - (org-babel-tangle-single-block 1 t) - (org-babel-tangle-collect-blocks lang-re tangle-file))) - (message "Tangled %d code block%s from %s" block-counter - (if (= block-counter 1) "" "s") - (file-name-nondirectory - (buffer-file-name - (or (buffer-base-buffer) - (current-buffer) - (and (org-src-edit-buffer-p) - (org-src-source-buffer)))))) - ;; run `org-babel-post-tangle-hook' in all tangled files - (when org-babel-post-tangle-hook - (mapc - (lambda (file) - (org-babel-with-temp-filebuffer file - (run-hooks 'org-babel-post-tangle-hook))) - path-collector)) - path-collector)))) - -(defun org-babel-tangle-clean () - "Remove comments inserted by `org-babel-tangle'. -Call this function inside of a source-code file generated by -`org-babel-tangle' to remove all comments inserted automatically -by `org-babel-tangle'. Warning, this comment removes any lines -containing constructs which resemble Org file links or noweb -references." - (interactive) - (goto-char (point-min)) - (while (or (re-search-forward "\\[\\[file:.*\\]\\[.*\\]\\]" nil t) - (re-search-forward (org-babel-noweb-wrap) nil t)) - (delete-region (save-excursion (beginning-of-line 1) (point)) - (save-excursion (end-of-line 1) (forward-char 1) (point))))) - -(defun org-babel-spec-to-string (spec) - "Insert SPEC into the current file. - -Insert the source-code specified by SPEC into the current source -code file. This function uses `comment-region' which assumes -that the appropriate major-mode is set. SPEC has the form: - - (start-line file link source-name params body comment)" - (pcase-let* - ((`(,start ,file ,link ,source ,info ,body ,comment) spec) - (comments (cdr (assq :comments info))) - (link? (or (string= comments "both") (string= comments "link") - (string= comments "yes") (string= comments "noweb"))) - (link-data `(("start-line" . ,(number-to-string start)) - ("file" . ,file) - ("link" . ,link) - ("source-name" . ,source))) - (insert-comment (lambda (text) - (when (and comments - (not (string= comments "no")) - (org-string-nw-p text)) - (if org-babel-tangle-uncomment-comments - ;; Plain comments: no processing. - (insert text) - ;; Ensure comments are made to be - ;; comments, and add a trailing newline. - ;; Also ignore invisible characters when - ;; commenting. - (comment-region - (point) - (progn (insert (org-no-properties text)) - (point))) - (end-of-line) - (insert "\n")))))) - (when comment (funcall insert-comment comment)) - (when link? - (funcall insert-comment - (org-fill-template - org-babel-tangle-comment-format-beg link-data))) - (insert body "\n") - (when link? - (funcall insert-comment - (org-fill-template - org-babel-tangle-comment-format-end link-data))))) - -(defun org-babel-effective-tangled-filename (buffer-fn src-lang src-tfile) - "Return effective tangled filename of a source-code block. -BUFFER-FN is the name of the buffer, SRC-LANG the language of the -block and SRC-TFILE is the value of the :tangle header argument, -as computed by `org-babel-tangle-single-block'." - (let ((base-name (cond - ((string= "yes" src-tfile) - ;; Use the buffer name - (file-name-sans-extension buffer-fn)) - ((string= "no" src-tfile) nil) - ((> (length src-tfile) 0) src-tfile))) - (ext (or (cdr (assoc src-lang org-babel-tangle-lang-exts)) src-lang))) - (when base-name - ;; decide if we want to add ext to base-name - (if (and ext (string= "yes" src-tfile)) - (concat base-name "." ext) base-name)))) - -(defun org-babel-tangle-collect-blocks (&optional lang-re tangle-file) - "Collect source blocks in the current Org file. -Return an association list of language and source-code block -specifications of the form used by `org-babel-spec-to-string' -grouped by tangled file name. - -Optional argument LANG-RE can be used to limit the collected -source code blocks by languages matching a regular expression. - -Optional argument TANGLE-FILE can be used to limit the collected -code blocks by target file." - (let ((counter 0) last-heading-pos blocks) - (org-babel-map-src-blocks (buffer-file-name) - (let ((current-heading-pos - (org-with-wide-buffer - (org-with-limited-levels (outline-previous-heading))))) - (if (eq last-heading-pos current-heading-pos) (cl-incf counter) - (setq counter 1) - (setq last-heading-pos current-heading-pos))) - (unless (or (org-in-commented-heading-p) - (org-in-archived-heading-p)) - (let* ((info (org-babel-get-src-block-info 'light)) - (src-lang (nth 0 info)) - (src-tfile (cdr (assq :tangle (nth 2 info))))) - (unless (or (string= src-tfile "no") - (and tangle-file (not (equal tangle-file src-tfile))) - (and lang-re (not (string-match-p lang-re src-lang)))) - ;; Add the spec for this block to blocks under its tangled - ;; file name. - (let* ((block (org-babel-tangle-single-block counter)) - (src-tfile (cdr (assq :tangle (nth 4 block)))) - (file-name (org-babel-effective-tangled-filename - (nth 1 block) src-lang src-tfile)) - (by-fn (assoc file-name blocks))) - (if by-fn (setcdr by-fn (cons (cons src-lang block) (cdr by-fn))) - (push (cons file-name (list (cons src-lang block))) blocks))))))) - ;; Ensure blocks are in the correct order. - (mapcar (lambda (b) (cons (car b) (nreverse (cdr b)))) - (nreverse blocks)))) - -(defun org-babel-tangle-single-block (block-counter &optional only-this-block) - "Collect the tangled source for current block. -Return the list of block attributes needed by -`org-babel-tangle-collect-blocks'. When ONLY-THIS-BLOCK is -non-nil, return the full association list to be used by -`org-babel-tangle' directly." - (let* ((info (org-babel-get-src-block-info)) - (start-line - (save-restriction (widen) - (+ 1 (line-number-at-pos (point))))) - (file (buffer-file-name (buffer-base-buffer))) - (src-lang (nth 0 info)) - (params (nth 2 info)) - (extra (nth 3 info)) - (coderef (nth 6 info)) - (cref-regexp (org-src-coderef-regexp coderef)) - (link (let* ( - ;; The created link is transient. Using ID is - ;; not necessary, but could have side-effects if - ;; used. An ID property may be added to - ;; existing entries thus creatin unexpected file - ;; modifications. - (org-id-link-to-org-use-id nil) - (l (org-no-properties (org-store-link nil)))) - (and (string-match org-link-bracket-re l) - (match-string 1 l)))) - (source-name - (or (nth 4 info) - (format "%s:%d" - (or (ignore-errors (nth 4 (org-heading-components))) - "No heading") - block-counter))) - (expand-cmd (intern (concat "org-babel-expand-body:" src-lang))) - (assignments-cmd - (intern (concat "org-babel-variable-assignments:" src-lang))) - (body - ;; Run the tangle-body-hook. - (let ((body (if (org-babel-noweb-p params :tangle) - (org-babel-expand-noweb-references info) - (nth 1 info)))) - (with-temp-buffer - (insert - ;; Expand body in language specific manner. - (cond ((assq :no-expand params) body) - ((fboundp expand-cmd) (funcall expand-cmd body params)) - (t - (org-babel-expand-body:generic - body params (and (fboundp assignments-cmd) - (funcall assignments-cmd params)))))) - (when (string-match "-r" extra) - (goto-char (point-min)) - (while (re-search-forward cref-regexp nil t) - (replace-match ""))) - (run-hooks 'org-babel-tangle-body-hook) - (buffer-string)))) - (comment - (when (or (string= "both" (cdr (assq :comments params))) - (string= "org" (cdr (assq :comments params)))) - ;; From the previous heading or code-block end - (funcall - org-babel-process-comment-text - (buffer-substring - (max (condition-case nil - (save-excursion - (org-back-to-heading t) ; Sets match data - (match-end 0)) - (error (point-min))) - (save-excursion - (if (re-search-backward - org-babel-src-block-regexp nil t) - (match-end 0) - (point-min)))) - (point))))) - (result - (list start-line - (if org-babel-tangle-use-relative-file-links - (file-relative-name file) - file) - (if (and org-babel-tangle-use-relative-file-links - (string-match org-link-types-re link) - (string= (match-string 1 link) "file")) - (concat "file:" - (file-relative-name (substring link (match-end 0)) - (file-name-directory - (cdr (assq :tangle params))))) - link) - source-name - params - (if org-src-preserve-indentation - (org-trim body t) - (org-trim (org-remove-indentation body))) - comment))) - (if only-this-block - (let* ((src-tfile (cdr (assq :tangle (nth 4 result)))) - (file-name (org-babel-effective-tangled-filename - (nth 1 result) src-lang src-tfile))) - (list (cons file-name (list (cons src-lang result))))) - result))) - -(defun org-babel-tangle-comment-links (&optional info) - "Return a list of begin and end link comments for the code block at point. -INFO, when non nil, is the source block information, as returned -by `org-babel-get-src-block-info'." - (let ((link-data (pcase (or info (org-babel-get-src-block-info 'light)) - (`(,_ ,_ ,_ ,_ ,name ,start ,_) - `(("start-line" . ,(org-with-point-at start - (number-to-string - (line-number-at-pos)))) - ("file" . ,(buffer-file-name)) - ("link" . ,(let (;; The created link is transient. Using ID is - ;; not necessary, but could have side-effects if - ;; used. An ID property may be added to - ;; existing entries thus creatin unexpected file - ;; modifications. - (org-id-link-to-org-use-id nil)) - (org-no-properties (org-store-link nil)))) - ("source-name" . ,name)))))) - (list (org-fill-template org-babel-tangle-comment-format-beg link-data) - (org-fill-template org-babel-tangle-comment-format-end link-data)))) - -;; de-tangling functions -(defun org-babel-detangle (&optional source-code-file) - "Propagate changes in source file back original to Org file. -This requires that code blocks were tangled with link comments -which enable the original code blocks to be found." - (interactive) - (save-excursion - (when source-code-file (find-file source-code-file)) - (goto-char (point-min)) - (let ((counter 0) new-body end) - (while (re-search-forward org-link-bracket-re nil t) - (if (and (match-string 2) - (re-search-forward - (concat " " (regexp-quote (match-string 2)) " ends here") nil t)) - (progn (setq end (match-end 0)) - (forward-line -1) - (save-excursion - (when (setq new-body (org-babel-tangle-jump-to-org)) - (org-babel-update-block-body new-body))) - (setq counter (+ 1 counter))) - (setq end (point))) - (goto-char end)) - (prog1 counter (message "Detangled %d code blocks" counter))))) - -(defun org-babel-tangle-jump-to-org () - "Jump from a tangled code file to the related Org mode file." - (interactive) - (let ((mid (point)) - start body-start end target-buffer target-char link block-name body) - (save-window-excursion - (save-excursion - (while (and (re-search-backward org-link-bracket-re nil t) - (not ; ever wider searches until matching block comments - (and (setq start (line-beginning-position)) - (setq body-start (line-beginning-position 2)) - (setq link (match-string 0)) - (setq block-name (match-string 2)) - (save-excursion - (save-match-data - (re-search-forward - (concat " " (regexp-quote block-name) - " ends here") - nil t) - (setq end (line-beginning-position)))))))) - (unless (and start (< start mid) (< mid end)) - (error "Not in tangled code")) - (setq body (buffer-substring body-start end))) - ;; Go to the beginning of the relative block in Org file. - (org-link-open-from-string link) - (setq target-buffer (current-buffer)) - (if (string-match "[^ \t\n\r]:\\([[:digit:]]+\\)" block-name) - (let ((n (string-to-number (match-string 1 block-name)))) - (if (org-before-first-heading-p) (goto-char (point-min)) - (org-back-to-heading t)) - ;; Do not skip the first block if it begins at point min. - (cond ((or (org-at-heading-p) - (not (eq (org-element-type (org-element-at-point)) - 'src-block))) - (org-babel-next-src-block n)) - ((= n 1)) - (t (org-babel-next-src-block (1- n))))) - (org-babel-goto-named-src-block block-name)) - (goto-char (org-babel-where-is-src-block-head)) - (forward-line 1) - ;; Try to preserve location of point within the source code in - ;; tangled code file. - (let ((offset (- mid body-start))) - (when (> end (+ offset (point))) - (forward-char offset))) - (setq target-char (point))) - (org-src-switch-to-buffer target-buffer t) - (goto-char target-char) - body)) - -(provide 'ob-tangle) - -;; Local variables: -;; generated-autoload-file: "org-loaddefs.el" -;; End: - -;;; ob-tangle.el ends here |