[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[nongnu] elpa/org-contrib 3dd9841522 1/4: Delete files
|
From: |
ELPA Syncer |
|
Subject: |
[nongnu] elpa/org-contrib 3dd9841522 1/4: Delete files |
|
Date: |
Sun, 5 Jun 2022 02:58:49 -0400 (EDT) |
branch: elpa/org-contrib
commit 3dd98415225823f21fb7e12f272c0f199ac7407f
Author: Bastien Guerry <bzg@gnu.org>
Commit: Bastien Guerry <bzg@gnu.org>
Delete files
These files were to be removed from the next release.
---
lisp/ob-arduino.el | 117 ----
lisp/ob-clojure-literate.el | 306 ---------
lisp/ob-mathematica.el | 95 ---
lisp/ob-php.el | 73 ---
lisp/ob-redis.el | 59 --
lisp/ob-sclang.el | 93 ---
lisp/ob-smiles.el | 71 --
lisp/ob-stan.el | 86 ---
lisp/ol-notmuch.el | 155 -----
lisp/org-attach-embedded-images.el | 132 ----
lisp/org-contacts.el | 1244 ------------------------------------
lisp/org-link-edit.el | 392 ------------
lisp/org-mac-link.el | 1074 -------------------------------
lisp/org-notify.el | 407 ------------
lisp/org-passwords.el | 385 -----------
lisp/org-velocity.el | 823 ------------------------
lisp/ox-rss.el | 421 ------------
17 files changed, 5933 deletions(-)
diff --git a/lisp/ob-arduino.el b/lisp/ob-arduino.el
deleted file mode 100644
index 76054e85fb..0000000000
--- a/lisp/ob-arduino.el
+++ /dev/null
@@ -1,117 +0,0 @@
-;;; ob-arduino.el --- Org-mode Babel support for Arduino
-;;
-;; Authors: stardiviner <numbchild@gmail.com>
-;; Package-Requires: ((emacs "24.4") (org "24.1"))
-;; Package-Version: 1.0
-;; Keywords: arduino org babel
-;; homepage:
https://github.com/stardiviner/arduino-mode/blob/master/ob-arduino.el
-;;
-;; This file is not 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:
-;;
-;; Like the following src block, press =[C-c C-c]= to upload to Arduino board.
-;;
-;; #+begin_src arduino
-;; // the setup function runs once when you press reset or power the board
-;; void setup() {
-;; // initialize digital pin LED_BUILTIN as an output.
-;; pinMode(LED_BUILTIN, OUTPUT);
-;; }
-;;
-;; // the loop function runs over and over again forever
-;; void loop() {
-;; digitalWrite(LED_BUILTIN, HIGH); // turn the LED on (HIGH is the
voltage level)
-;; delay(100); // wait for 0.1 second
-;; digitalWrite(LED_BUILTIN, LOW); // turn the LED off by making the
voltage LOW
-;; delay(100); // wait for 0.1 second
-;; }
-;; #+end_src
-;;
-;;; Code:
-
-(require 'org)
-(require 'ob)
-(require 'arduino-mode nil t)
-
-(defgroup ob-arduino nil
- "org-mode blocks for Arduino."
- :group 'org)
-
-(defcustom ob-arduino:program "arduino"
- "Default Arduino program name."
- :group 'ob-arduino
- :type 'string)
-
-(defcustom ob-arduino:port "/dev/ttyACM0"
- "Default Arduino port."
- :group 'ob-arduino
- :type 'string)
-
-(defcustom ob-arduino:board "arduino:avr:uno"
- "Default Arduino board."
- :group 'ob-arduino
- :type 'string)
-
-
-(defvar org-babel-default-header-args:sclang nil)
-
-;;;###autoload
-(defun org-babel-execute:arduino (body params)
- "org-babel arduino hook."
- (let* ((port (cdr (assoc :port params)))
- (board (cdr (assoc :board params)))
- (cmd (mapconcat 'identity (list
- ob-arduino:program "--upload"
- (if port (concat "--port " port))
- (if board (concat "--board " board))
- ) " "))
- (code (org-babel-expand-body:generic body params))
- (src-file (org-babel-temp-file "ob-arduino-" ".ino")))
- ;; delete all `ob-arduino' temp files, otherwise arduino will compile all
- ;; ob-arduino temp files, and report error.
- (mapc
- (lambda (f)
- (unless (file-directory-p f)
- (delete-file (expand-file-name f org-babel-temporary-directory))))
- (directory-files
- (file-name-directory (org-babel-temp-file "ob-arduino-" ".ino"))
- nil ".ino"))
- ;; specify file for arduino command.
- (with-temp-file src-file
- (insert code))
- (org-babel-eval
- (concat ob-arduino:program
- " " "--upload"
- " " (if port (concat "--port " port))
- " " (if board (concat "--board " board))
- " " src-file)
- "" ; pass empty string "" as `BODY' to
`org-babel--shell-command-on-region'
- ;; to fix command `arduino' don't accept string issue.
- )
- ))
-
-
-;;;###autoload
-(eval-after-load 'org
- '(add-to-list 'org-src-lang-modes '("arduino" . arduino)))
-
-
-
-
-(provide 'ob-arduino)
-
-;;; ob-arduino.el ends here
diff --git a/lisp/ob-clojure-literate.el b/lisp/ob-clojure-literate.el
deleted file mode 100644
index 39e4f394f1..0000000000
--- a/lisp/ob-clojure-literate.el
+++ /dev/null
@@ -1,306 +0,0 @@
-;;; ob-clojure-literate.el --- Clojure's Org-mode Literate Programming
-
-;; Authors: stardiviner <numbchild@gmail.com>
-;; Package-Requires: ((emacs "24.4") (org "9") (cider "0.16.0") (dash
"2.12.0"))
-;; Package-Version: 1.1
-;; Keywords: tools
-;; homepage: https://github.com/stardiviner/ob-clojure-literate
-
-;; This file is not 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:
-;;
-;; Auto setup ob-clojure-literate scaffold and jack-in Clojure project.
-;;
-;; Usage:
-;;
-;; [M-x ob-clojure-literate-mode] to toggle this minor mode.
-
-;;; Code:
-
-(require 'ob-clojure)
-(require 'cider nil t)
-
-(defgroup ob-clojure-literate nil
- "Clojure's Org-mode Literate Programming."
- :prefix "ob-clojure-literate-"
- :group 'ob-babel)
-
-;;;###autoload
-(defcustom ob-clojure-literate-auto-jackin-p nil
- "Auto jack in ob-clojure project.
-Don't auto jack in by default for not rude."
- :type 'boolean
- :group 'ob-clojure-literate)
-
-(defcustom ob-clojure-literate-project-location nil
- "The location for `ob-clojure-literate' scaffold project.
-If it is nil, then `cider-jack-in' will jack-in outside of Clojure project.
-If it is a directory, `ob-clojure-literate' will try to create Clojure project
automatically."
- :type 'string
- :group 'ob-clojure-literate)
-
-(defvar ob-clojure-literate-session nil)
-(defvar ob-clojure-literate-original-ns nil)
-(defvar ob-clojure-literate-session-ns nil)
-(defvar ob-clojure-literate-cider-connections nil)
-
-(defcustom ob-clojure-literate-default-session "*cider-repl localhost*"
- "The default session name for `ob-clojure-literate'."
- :type 'string
- :group 'ob-clojure-literate)
-
-(defun ob-clojure-literate-any-connection-p ()
- "Return t if have any CIDER connection."
- (and
- ;; handle the case `cider-jack-in' is not finished creating connection, but
`ob-clojure-literate-mode' is enabled.
- (not (null (cider-connections)))
- (not (null ob-clojure-literate-session)) ; before mode enabled, it is nil.
- (not (string-empty-p ob-clojure-literate-session)) ; after disable, it is
"".
- ))
-
-(defun ob-clojure-literate-get-session-list ()
- "Return a list of available started CIDER REPL sessions list."
- (mapcar #'buffer-name
- ;; for multiple connections case.
- ;; get global value instead of buffer local.
- (default-value 'cider-connections)))
-
-;;; Do not allow "ob-clojure" project session name.
-(defun ob-clojure-literate-set-session ()
- "Set session name for buffer local."
- ;; if default session is the only one in connections list.
- (if (and (= (length (ob-clojure-literate-get-session-list)) 1)
- (member ob-clojure-literate-default-session
(ob-clojure-literate-get-session-list)))
- (setq-local ob-clojure-literate-session
ob-clojure-literate-default-session)
- ;; if have any connections, choose one from them.
- (if (ob-clojure-literate-any-connection-p)
- (setq-local ob-clojure-literate-session
- (completing-read "Choose ob-clojure-literate :session : "
- (ob-clojure-literate-get-session-list)))
- ;; if none, set to default session name to fix `ob-clojure-literate-mode'
- ;; is enabled before `cider-jack-in' generated connections.
- (setq-local ob-clojure-literate-session
- ob-clojure-literate-default-session))))
-
-;;;###autoload
-(defun ob-clojure-literate-specify-session ()
- "Specify ob-clojure header argument :session with value selected from a list
of available sessions."
- (interactive)
- (let ((lang (nth 0 (org-babel-get-src-block-info))))
- (if (and (string= lang "clojure") ; only in clojure src block.
- (car (seq-filter ; only when :session is not specified yet.
- (lambda (header-argument)
- (if (eq (car header-argument) :session)
- (not (null (cdr header-argument)))))
- (nth 2 (org-babel-get-src-block-info)))))
- (org-babel-insert-header-arg
- "session"
- (format "\"%s\""
- (completing-read
- "Choose :session for ob-clojure-literate: "
- (ob-clojure-literate-get-session-list))))
- (message "This function only used in `clojure' src block.")))
- )
-
-;;; Auto start CIDER REPL session in a complete Leiningen project environment
for Org-mode Babel to jack-in.
-;;;###autoload
-(defun ob-clojure-literate-auto-jackin ()
- "Auto setup ob-clojure-literate scaffold and jack-in Clojure project."
- (interactive)
- (cond
- ;; jack-in outside of Clojure project.
- ((null ob-clojure-literate-project-location)
- (if (member (get-buffer "*cider-repl localhost*") cider-connections)
- (message "CIDER default session already launched.")
- (cider-jack-in nil)))
- ((not (null ob-clojure-literate-project-location))
- (unless (file-directory-p (expand-file-name
ob-clojure-literate-project-location))
- (make-directory ob-clojure-literate-project-location t)
- (let ((default-directory ob-clojure-literate-project-location))
- (shell-command "lein new ob-clojure")))
- (unless (or
- (and (cider-connected-p)
- (if (not (null ob-clojure-literate-session))
- (seq-contains cider-connections (get-buffer
ob-clojure-literate-session))))
- cider-connections
- (ob-clojure-literate-any-connection-p))
- ;; return back to original file.
- (if (not (and (= (length (ob-clojure-literate-get-session-list)) 1)
- (member ob-clojure-literate-default-session
(ob-clojure-literate-get-session-list))))
- (save-window-excursion
- (find-file (expand-file-name (concat
ob-clojure-literate-project-location "ob-clojure/src/ob_clojure/core.clj")))
- (with-current-buffer "core.clj"
- (cider-jack-in))))))))
-
-(defun ob-clojure-literate-set-local-cider-connections (toggle?)
- "Set buffer local `cider-connections' for `ob-clojure-literate-mode'
`TOGGLE?'."
- (if toggle?
- (progn
- (setq ob-clojure-literate-cider-connections cider-connections)
- (unless (local-variable-if-set-p 'cider-connections)
- (make-local-variable 'cider-connections))
- (setq-local cider-connections ob-clojure-literate-cider-connections))
- ;; store/restore emptied CIDER connections by `ob-clojure-literate-enable'.
- (kill-local-variable 'cider-connections) ; kill local variable so that I
can get the original global variable value.
- ;; Empty all CIDER connections to avoid `cider-current-connection' return
any connection.
- ;; FIXME: when try to enable, `cider-connections' is local and nil.
- ;; (if (and (= (length (ob-clojure-literate-get-session-list)) 1)
- ;; (member ob-clojure-literate-default-session
(ob-clojure-literate-get-session-list))))
- ;; (unless (local-variable-if-set-p 'cider-connections)
- ;; (make-local-variable 'cider-connections))
- ;; (setq-local cider-connections '())
- ))
-
-(defun ob-clojure-literate-set-ns (body params)
- "Fix the issue that `cider-current-ns' try to invoke `clojure-find-ns' to
extract ns from buffer."
- ;; TODO: Is it possible to find ns in `body'?
- (when (ob-clojure-literate-any-connection-p)
- (setq ob-clojure-literate-original-ns (cider-current-ns))
- (with-current-buffer ob-clojure-literate-session
- (setq ob-clojure-literate-session-ns cider-buffer-ns))
- (setq-local cider-buffer-ns (or (cdr (assq :ns params))
- ob-clojure-literate-session-ns)))
- (message (format "ob-clojure-literate: current CIDER ns is [%s]."
cider-buffer-ns)))
-
-(defun ob-clojure-literate-set-local-session (toggle?)
- "Set buffer local `org-babel-default-header-args:clojure' for
`ob-clojure-literate-mode' `TOGGLE?'."
- (if toggle?
- (progn
- ;; set local default session for ob-clojure.
- (setq ob-clojure-literate-session (ob-clojure-literate-set-session))
- (unless (local-variable-if-set-p
'org-babel-default-header-args:clojure)
- (make-local-variable 'org-babel-default-header-args:clojure))
- (add-to-list 'org-babel-default-header-args:clojure
- `(:session . ,ob-clojure-literate-session))
- )
- ;; remove :session from buffer local default header arguments list.
- (unless (local-variable-if-set-p 'org-babel-default-header-args:clojure)
- (make-local-variable 'org-babel-default-header-args:clojure))
- (setq org-babel-default-header-args:clojure
- (delq t
- (mapcar
- (lambda (cons) (if (eq (car cons) :session) t cons))
- org-babel-default-header-args:clojure)))))
-
-
-;;; Support header arguments :results graphics :file "image.png" by inject
Clojure code.
-(defun ob-clojure-literate-inject-code (args)
- "Inject Clojure code into `BODY' in `ARGS'.
-It is used to change Clojure currently working directory in a FAKE way.
-And generate inline graphics image file link result.
-Use header argument like this:
-
-:results graphics :file \"incanter-plot.png\"
-
-Then you need to assign image variable to this :file value like:
-(def incanter-plot (histogram (sample-normal 1000)))
-
-*NOTE*: Currently only support Incanter's `save' function.
-"
- (let* ((body (nth 0 args))
- (params (nth 1 args))
- (dir (cdr (assq :dir params)))
- (default-directory (and (buffer-file-name) (file-name-directory
(buffer-file-name))))
- (directory (and dir (file-name-as-directory (expand-file-name dir))))
- (result-type (cdr (assq :results params)))
- (file (cdr (assq :file params)))
- (file-name (and file (file-name-base file)))
- ;; TODO: future support `:graphics-file' to avoid collision.
- (graphics-result (member "graphics" (cdr (assq :result-params
params))))
- ;; (graphics-file (cdr (assq :graphics-file params)))
- ;; (graphics-name (file-name-base graphics-file))
- (prepend-to-body (lambda (code)
- (setq body (concat code "\n" body))))
- (append-to-body (lambda (code)
- (setq body (concat body "\n" code "\n"))))
- )
- (when directory
- (unless (file-directory-p (expand-file-name directory))
- (warn (format "Target directory %s does not exist, please create it."
dir))))
- (when file
- (funcall append-to-body
- (format "(save %s \"%s\")" file-name (concat directory file)))
- )
- (list body params) ; return modified argument list
- ))
-
-;;; support :results graphics :dir "data/image" :file "incanter-plot.png"
-(defun ob-clojure-literate-support-graphics-result (result)
- "Support :results graphics :dir \"data/images\" :file \"incanter-plot.png\"
-reset `RESULT' to `nil'."
- (let* ((params (nth 2 info))
- (graphics-result (member "graphics" (cdr (assq :result-params
params)))))
- (if graphics-result
- (setq result nil))
- result))
-
-
-(defvar ob-clojure-literate-mode-map
- (let ((map (make-sparse-keymap)))
- map)
- "Keymap for `ob-clojure-literate-mode'.")
-
-(define-key org-babel-map (kbd "M-s") 'ob-clojure-literate-specify-session)
-(define-key org-babel-map (kbd "M-j") 'ob-clojure-literate-auto-jackin)
-;; (define-key org-babel-map (kbd "M-e") 'cider-eval-last-sexp)
-;; (define-key org-babel-map (kbd "M-d") 'cider-doc)
-
-;;;###autoload
-(defun ob-clojure-literate-enable ()
- "Enable Org-mode buffer locally for `ob-clojure-literate'."
- (when (and (not (null cider-connections)) ; only enable
`ob-clojure-literate-mode' when has CIDER connections.
- (equal major-mode 'org-mode)) ; `ob-clojure-literate-mode' only
works in `org-mode'.
- (ob-clojure-literate-set-local-cider-connections ob-clojure-literate-mode)
- (ob-clojure-literate-set-local-session ob-clojure-literate-mode)
- (advice-add 'org-babel-execute:clojure :before
#'ob-clojure-literate-set-ns)
- (advice-add 'org-babel-expand-body:clojure :filter-args
#'ob-clojure-literate-inject-code)
- (advice-add 'org-babel-execute:clojure :filter-return
#'ob-clojure-literate-support-graphics-result)
- (message "ob-clojure-literate minor mode enabled.")))
-
-;;;###autoload
-(defun ob-clojure-literate-disable ()
- "Disable Org-mode buffer locally for `ob-clojure-literate'."
- (advice-remove 'org-babel-execute:clojure #'ob-clojure-literate-set-ns)
- (advice-remove 'org-babel-expand-body:clojure
#'ob-clojure-literate-inject-code)
- (advice-remove 'org-babel-execute:clojure
#'ob-clojure-literate-support-graphics-result)
- (setq-local cider-buffer-ns ob-clojure-literate-original-ns)
- (ob-clojure-literate-set-local-cider-connections ob-clojure-literate-mode)
- (ob-clojure-literate-set-local-session ob-clojure-literate-mode)
- (message "ob-clojure-literate minor mode disabled."))
-
-;;;###autoload
-(if ob-clojure-literate-auto-jackin-p (ob-clojure-literate-auto-jackin))
-
-;;;###autoload
-(define-minor-mode ob-clojure-literate-mode
- "A minor mode to toggle `ob-clojure-literate'."
- :require 'ob-clojure-literate
- :init-value nil
- :lighter " clj-lp"
- :group 'ob-clojure-literate
- :keymap ob-clojure-literate-mode-map
- :global nil
- (if ob-clojure-literate-mode
- (ob-clojure-literate-enable)
- (ob-clojure-literate-disable))
- )
-
-
-
-(provide 'ob-clojure-literate)
-
-;;; ob-clojure-literate.el ends here
diff --git a/lisp/ob-mathematica.el b/lisp/ob-mathematica.el
deleted file mode 100644
index 2b703da698..0000000000
--- a/lisp/ob-mathematica.el
+++ /dev/null
@@ -1,95 +0,0 @@
-;;; ob-mathematica.el --- org-babel functions for Mathematica evaluation
-
-;; Copyright (C) 2014, 2021 Yi Wang
-
-;; Authors: Yi Wang
-;; Keywords: literate programming, reproducible research
-;; Homepage: https://github.com/tririver/ob-mathematica/
-
-;; This file is not 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/>.
-
-;; Org-Babel support for evaluating Mathematica source code.
-
-;;; Code:
-(require 'ob)
-(require 'ob-ref)
-(require 'ob-comint)
-(require 'ob-eval)
-
-(declare-function org-trim "org" (s &optional keep-lead))
-
-;; Optionally require mma.el for font lock, etc
-(require 'mma nil 'noerror)
-(add-to-list 'org-src-lang-modes '("mathematica" . "mma"))
-
-(defvar org-babel-tangle-lang-exts)
-(add-to-list 'org-babel-tangle-lang-exts '("mathematica" . "m"))
-
-(defvar org-babel-default-header-args:mathematica '())
-
-(defvar org-babel-mathematica-command "MathematicaScript -script"
- "Name of the command for executing Mathematica code.")
-
-(defvar org-babel-mathematica-command-alt "math -noprompt"
- "Name of the command for executing Mathematica code.")
-
-(defun org-babel-expand-body:mathematica (body params)
- "Expand BODY according to PARAMS, return the expanded body."
- (let ((vars (org-babel--get-vars params)))
- (concat
- (mapconcat ;; define any variables
- (lambda (pair)
- (format "%s=%s;"
- (car pair)
- (org-babel-mathematica-var-to-mathematica (cdr pair))))
- vars "\n") "\nPrint[\n" body "\n]\n")))
-
-(defun org-babel-execute:mathematica (body params)
- "Execute a block of Mathematica code with org-babel. This function is
-called by `org-babel-execute-src-block'"
- (let* ((result-params (cdr (assq :result-params params)))
- (full-body (org-babel-expand-body:mathematica body params))
- (tmp-script-file (org-babel-temp-file "mathematica-"))
- (cmd org-babel-mathematica-command))
- ;; actually execute the source-code block
- (with-temp-file tmp-script-file (insert full-body))
- ;; (with-temp-file "/tmp/dbg" (insert full-body))
- ((lambda (raw)
- (if (or (member "code" result-params)
- (member "pp" result-params)
- (and (member "output" result-params)
- (not (member "table" result-params))))
- raw
- (org-babel-script-escape (org-trim raw))))
- (org-babel-eval (concat cmd " " tmp-script-file) ""))))
-
-(defun org-babel-prep-session:mathematica (session params)
- "This function does nothing so far"
- (error "Currently no support for sessions"))
-
-(defun org-babel-prep-session:mathematica (session body params)
- "This function does nothing so far"
- (error "Currently no support for sessions"))
-
-(defun org-babel-mathematica-var-to-mathematica (var)
- "Convert an elisp value to a Mathematica variable.
-Convert an elisp value, VAR, into a string of Mathematica source code
-specifying a variable of the same value."
- (if (listp var)
- (concat "{" (mapconcat #'org-babel-mathematica-var-to-mathematica var ",
") "}")
- (format "%S" var)))
-
-(provide 'ob-mathematica)
diff --git a/lisp/ob-php.el b/lisp/ob-php.el
deleted file mode 100644
index 9b0b990e22..0000000000
--- a/lisp/ob-php.el
+++ /dev/null
@@ -1,73 +0,0 @@
-;;; ob-php.el --- Execute PHP within org-mode blocks
-;; Copyright 2016, 2021 stardiviner
-
-;; Author: stardiviner <numbchild@gmail.com>
-;; Maintainer: stardiviner <numbchild@gmail.com>
-;; Homepage: https://github.com/stardiviner/ob-php
-;; Keywords: org babel php
-;; Homepage: https://github.com/stardiviner/ob-php
-;; Created: 04th May 2016
-;; Version: 0.0.1
-;; Package-Requires: ((org "8"))
-
-;; This file is not 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:
-;;
-;; Execute PHP within org-mode blocks.
-
-;;; Code:
-(require 'org)
-(require 'ob)
-
-(defgroup ob-php nil
- "org-mode blocks for PHP."
- :group 'org)
-
-(defcustom org-babel-php-command "php"
- "The command to execute babel body code."
- :group 'ob-php
- :type 'string)
-
-(defcustom org-babel-php-command-options nil
- "The php command options to use when execute code."
- :group 'ob-php
- :type 'string)
-
-(defcustom ob-php:inf-php-buffer "*php*"
- "Default PHP inferior buffer."
- :group 'ob-php
- :type 'string)
-
-;;;###autoload
-(defun org-babel-execute:php (body params)
- "Orgmode Babel PHP evaluate function for `BODY' with `PARAMS'."
- (let* ((cmd (concat org-babel-php-command " " org-babel-php-command-options))
- (body (concat "<?php\n" body "\n?>")))
- (org-babel-eval cmd body)))
-
-;;;###autoload
-(eval-after-load 'org
- '(add-to-list 'org-src-lang-modes '("php" . php)))
-
-(defvar org-babel-default-header-args:php '())
-
-(add-to-list 'org-babel-default-header-args:php
- '(:results . "output"))
-
-(provide 'ob-php)
-
-;;; ob-php.el ends here
diff --git a/lisp/ob-redis.el b/lisp/ob-redis.el
deleted file mode 100644
index 204f5d40dd..0000000000
--- a/lisp/ob-redis.el
+++ /dev/null
@@ -1,59 +0,0 @@
-;;; ob-redis.el --- Execute Redis queries within org-mode blocks
-;; Copyright 2016-2021 stardiviner
-
-;; Author: stardiviner <numbchild@gmail.com>
-;; Maintainer: stardiviner <numbchild@gmail.com>
-;; Keywords: org babel redis
-;; Homepage: https://github.com/stardiviner/ob-redis
-;; Created: 28th Feb 2016
-;; Version: 0.0.1
-;; Package-Requires: ((org "8"))
-
-;; This file is not 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:
-;;
-;; Execute Redis queries within org-mode blocks.
-
-;;; Code:
-(require 'org)
-(require 'ob)
-
-(defgroup ob-redis nil
- "org-mode blocks for Redis."
- :group 'org)
-
-(defcustom ob-redis:default-db "127.0.0.1:6379"
- "Default Redis database."
- :group 'ob-redis
- :type 'string)
-
-;;;###autoload
-(defun org-babel-execute:redis (body params)
- "org-babel redis hook."
- (let* ((db (or (cdr (assoc :db params))
- ob-redis:default-db))
- (cmd (mapconcat 'identity (list "redis-cli") " ")))
- (org-babel-eval cmd body)
- ))
-
-;;;###autoload
-(eval-after-load 'org
- '(add-to-list 'org-src-lang-modes '("redis" . redis)))
-
-(provide 'ob-redis)
-
-;;; ob-redis.el ends here
diff --git a/lisp/ob-sclang.el b/lisp/ob-sclang.el
deleted file mode 100644
index 861ef37dbf..0000000000
--- a/lisp/ob-sclang.el
+++ /dev/null
@@ -1,93 +0,0 @@
-;;; ob-sclang.el --- SCLang support for Org-mode Babel
-;;; -*- coding: utf-8 -*-
-
-;; Copyright (C) 2017-2021 Free Software Foundation, Inc.
-
-;; Authors: stardiviner <numbchild@gmail.com>
-;; Homepage: https://github.com/stardiviner/ob-sclang
-;; Package-Version: 0.1
-;; Keywords: babel sclang
-
-;; This file is not 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:
-
-;; `ob-sclang' requires `sclang' from SuperCollider.
-;; Usually SuperCollider dependencies for Emacs are at
/usr/share/emacs/site-lisp/SuperCollider/
-;; You can install SuperCollider following this article:
-;; https://github.com/supercollider/supercollider#building-the-source-code
-
-;; Usage:
-
-;; Support to evaluate sclang Org-mode src block with function
`sclang-eval-string'.
-
-;; For example:
-
-;; #+BEGIN_SRC sclang :results none
-;; "Hello World".postln;
-;; #+END_SRC
-;;
-;; *NOTE* Temporary output to org-babel result output is not supported.
-;; Because `sclang-eval-string' will send output to Sclang Post Buffer.
-;; And command line `sclang' execute will not automatically stop after
finished execution.
-;;
-;; #+BEGIN_SRC sclang :results none
-;; // modulate a sine frequency and a noise amplitude with another sine
-;; // whose frequency depends on the horizontal mouse pointer position
-;; {
-;; var x = SinOsc.ar(MouseX.kr(1, 100));
-;; SinOsc.ar(300 * x + 800, 0, 0.1)
-;; +
-;; PinkNoise.ar(0.1 * x + 0.1)
-;; }.play;
-;; #+END_SRC
-
-
-;;; Code:
-;;;
----------------------------------------------------------------------------
-(require 'org)
-(require 'ob)
-
-(require 'sclang nil t)
-
-(defgroup ob-sclang nil
- "org-mode blocks for SuperCollider SCLang."
- :group 'org)
-
-;;;###autoload
-(defun org-babel-execute:sclang (body params)
- "Org-mode Babel sclang hook for evaluate `BODY' with `PARAMS'."
- (unless (or (equal (buffer-name) sclang-post-buffer)
- (sclang-get-process))
- (sclang-start))
- (sclang-eval-string body t))
-
-(defvar org-babel-default-header-args:sclang nil)
-
-(setq org-babel-default-header-args:sclang
- '((:session . "*SCLang:Workspace*")
- ;; TODO: temporary can't find way to let sclang output to stdout for
org-babel.
- (:output . "none")))
-
-(eval-after-load 'org
- '(progn
- (add-to-list 'org-src-lang-modes '("sclang" . sclang))))
-
-;;;
----------------------------------------------------------------------------
-
-(provide 'ob-sclang)
-
-;;; ob-sclang.el ends here
diff --git a/lisp/ob-smiles.el b/lisp/ob-smiles.el
deleted file mode 100644
index 1e61a00bd4..0000000000
--- a/lisp/ob-smiles.el
+++ /dev/null
@@ -1,71 +0,0 @@
-;;; ob-smiles.el --- Org-mode Babel support for SMILES
-
-;; Author: John Kitchin <jkitchin@andrew.cmu.edu>
-;; Maintainer: stardiviner <numbchild@gmail.com>
-;; Homepage: https://github.com/stardiviner/ob-smiles
-;; Keywords: org babel SMILES
-;; Version: 0.0.1
-;; Package-Requires: ((smiles-mode "0.0.1") (org "8"))
-
-;; This file is not 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:
-
-;;; I copy code from:
-;;;
https://kitchingroup.cheme.cmu.edu/blog/2016/03/26/A-molecule-link-for-org-mode
-
-;;; Code:
-
-(require 'ob)
-(require 'org-element)
-
-;; Org-mode Babel
-(defun org-babel-execute:smiles (body params)
- "Execute SMILES babel `BODY' with `PARAMS'."
- (shell-command-to-string
- (format "obabel -:\"%s\" -osvg 2> /dev/null" body)))
-
-;; Org-mode link
-(defun molecule-jump (name)
- "Jump to molecule `NAME' definition."
- (org-mark-ring-push)
- (org-link-open-from-string (format "[[%s]]" name)))
-
-(defun molecule-export (path desc backend)
- "Export molecule to HTML format on `PATH' with `DESC' and `BACKEND'."
- (let ((name (save-window-excursion
- (molecule-jump path)
- (org-element-property :name (org-element-context)))))
- (cond
- ((eq 'html backend)
- (format "<a href=\"#%s\">%s</a>" name name)))))
-
-(org-link-set-parameters
- "molecule"
- :follow 'molecule-jump
- :export 'molecule-export)
-
-;; org-mode element
-(org-element-map (org-element-parse-buffer)
- 'src-block
- (lambda (src)
- (when (string= "smiles" (org-element-property :language src))
- (org-element-property :name src))))
-
-
-(provide 'ob-smiles)
-
-;;; ob-smiles.el ends here
diff --git a/lisp/ob-stan.el b/lisp/ob-stan.el
deleted file mode 100644
index 398cceccef..0000000000
--- a/lisp/ob-stan.el
+++ /dev/null
@@ -1,86 +0,0 @@
-;;; ob-stan.el --- Babel Functions for Stan -*- lexical-binding: t;
-*-
-
-;; Copyright (C) 2015-2021 Free Software Foundation, Inc.
-
-;; Author: Kyle Meyer
-;; Keywords: literate programming, reproducible research
-;; Homepage: https://git.kyleam.com/ob-stan
-
-;; This file is not 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:
-
-;; Org-Babel support for evaluating Stan [1] source code.
-;;
-;; Evaluating a Stan block can produce two different results.
-;;
-;; 1) Dump the source code contents to a file.
-;;
-;; This file can then be used as a variable in other blocks, which
-;; allows interfaces like RStan to use the model.
-;;
-;; 2) Compile the contents to a model file.
-;;
-;; This provides access to the CmdStan interface. To use this, set
-;; `org-babel-stan-cmdstan-directory' and provide a :file argument
-;; that does not end in ".stan".
-;;
-;; For more information and usage examples, visit
-;; https://orgmode.org/worg/org-contrib/babel/languages/ob-doc-stan.html
-;;
-;; [1] https://mc-stan.org/
-
-;;; Code:
-(require 'ob)
-(require 'org-compat)
-
-(defcustom org-babel-stan-cmdstan-directory nil
- "CmdStan source directory.
-Call \"make\" from this directory to compile the Stan block.
-When nil, executing Stan blocks dumps the content to a file."
- :group 'org-babel
- :type '(choice
- (directory :tag "Compilation directory")
- (const :tag "Dump to a file" nil)))
-
-(defvar org-babel-default-header-args:stan
- '((:results . "file")))
-
-(defun org-babel-execute:stan (body params)
- "Generate Stan file from BODY according to PARAMS.
-A :file header argument must be given. If
-`org-babel-stan-cmdstan-directory' is non-nil and the file name
-does not have a \".stan\" extension, save an intermediate
-\".stan\" file and compile the block to the named file.
-Otherwise, write the Stan code directly to the named file."
- (let ((file (expand-file-name
- (or (cdr (assq :file params))
- (user-error "Set :file argument to execute Stan blocks")))))
- (if (or (not org-babel-stan-cmdstan-directory)
- (string-match-p "\\.stan\\'" file))
- (with-temp-file file (insert body))
- (with-temp-file (concat file ".stan") (insert body))
- (let ((default-directory org-babel-stan-cmdstan-directory))
- (call-process-shell-command (concat "make " file))))
- nil)) ; Signal that output has been written to file.
-
-(defun org-babel-prep-session:stan (_session _params)
- "Return an error because Stan does not support sessions."
- (user-error "Stan does not support sessions"))
-
-(provide 'ob-stan)
-
-;;; ob-stan.el ends here
diff --git a/lisp/ol-notmuch.el b/lisp/ol-notmuch.el
deleted file mode 100644
index 7d959727ca..0000000000
--- a/lisp/ol-notmuch.el
+++ /dev/null
@@ -1,155 +0,0 @@
-;;; ol-notmuch.el --- Links to notmuch messages
-
-;; Copyright (C) 2010-2014, 2021 Matthieu Lemerre
-
-;; Author: Matthieu Lemerre <racin@free.fr>
-;; Maintainer: Jonas Bernoulli <jonas@bernoul.li>
-;; Keywords: outlines, hypermedia, calendar, wp
-;; Homepage: https://git.sr.ht/~tarsius/ol-notmuch
-
-;; This file is not part of GNU Emacs.
-
-;; This file 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, or (at your option)
-;; any later version.
-
-;; This file 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:
-
-;; This file implements links to notmuch messages and "searches". A
-;; search is a query to be performed by notmuch; it is the equivalent
-;; to folders in other mail clients. Similarly, mails are referred to
-;; by a query, so both a link can refer to several mails.
-
-;; Links have one the following form
-;; notmuch:<search terms>
-;; notmuch-search:<search terms>.
-
-;; The first form open the queries in notmuch-show mode, whereas the
-;; second link open it in notmuch-search mode. Note that queries are
-;; performed at the time the link is opened, and the result may be
-;; different from when the link was stored.
-
-;;; Code:
-
-(require 'ol)
-
-;; customisable notmuch open functions
-(defcustom org-notmuch-open-function
- 'org-notmuch-follow-link
- "Function used to follow notmuch links.
-
-Should accept a notmuch search string as the sole argument."
- :group 'org-notmuch
- :version "24.4"
- :package-version '(Org . "8.0")
- :type 'function)
-
-(defcustom org-notmuch-search-open-function
- 'org-notmuch-search-follow-link
- "Function used to follow notmuch-search links.
-Should accept a notmuch search string as the sole argument."
- :group 'org-notmuch
- :version "24.4"
- :package-version '(Org . "8.0")
- :type 'function)
-
-(make-obsolete-variable 'org-notmuch-search-open-function nil "9.3")
-
-
-
-;; Install the link type
-(org-link-set-parameters "notmuch"
- :follow #'org-notmuch-open
- :store #'org-notmuch-store-link)
-
-(defun org-notmuch-store-link ()
- "Store a link to a notmuch search or message."
- (when (memq major-mode '(notmuch-show-mode notmuch-tree-mode))
- (let* ((message-id (notmuch-show-get-message-id t))
- (subject (notmuch-show-get-subject))
- (to (notmuch-show-get-to))
- (from (notmuch-show-get-from))
- (date (org-trim (notmuch-show-get-date)))
- desc link)
- (org-link-store-props :type "notmuch" :from from :to to :date date
- :subject subject :message-id message-id)
- (setq desc (org-link-email-description))
- (setq link (concat "notmuch:id:" message-id))
- (org-link-add-props :link link :description desc)
- link)))
-
-(defun org-notmuch-open (path _)
- "Follow a notmuch message link specified by PATH."
- (funcall org-notmuch-open-function path))
-
-(defun org-notmuch-follow-link (search)
- "Follow a notmuch link to SEARCH.
-
-Can link to more than one message, if so all matching messages are shown."
- (require 'notmuch)
- (notmuch-show search))
-
-
-
-(org-link-set-parameters "notmuch-search"
- :follow #'org-notmuch-search-open
- :store #'org-notmuch-search-store-link)
-
-(defun org-notmuch-search-store-link ()
- "Store a link to a notmuch search or message."
- (when (eq major-mode 'notmuch-search-mode)
- (let ((link (concat "notmuch-search:" notmuch-search-query-string))
- (desc (concat "Notmuch search: " notmuch-search-query-string)))
- (org-link-store-props :type "notmuch-search"
- :link link
- :description desc)
- link)))
-
-(defun org-notmuch-search-open (path _)
- "Follow a notmuch message link specified by PATH."
- (message "%s" path)
- (org-notmuch-search-follow-link path))
-
-(defun org-notmuch-search-follow-link (search)
- "Follow a notmuch link by displaying SEARCH in notmuch-search mode."
- (require 'notmuch)
- (notmuch-search search))
-
-
-
-(org-link-set-parameters "notmuch-tree"
- :follow #'org-notmuch-tree-open
- :store #'org-notmuch-tree-store-link)
-
-(defun org-notmuch-tree-store-link ()
- "Store a link to a notmuch search or message."
- (when (eq major-mode 'notmuch-tree-mode)
- (let ((link (concat "notmuch-tree:" (notmuch-tree-get-query)))
- (desc (concat "Notmuch tree: " (notmuch-tree-get-query))))
- (org-link-store-props :type "notmuch-tree"
- :link link
- :description desc)
- link)))
-
-(defun org-notmuch-tree-open (path _)
- "Follow a notmuch message link specified by PATH."
- (message "%s" path)
- (org-notmuch-tree-follow-link path))
-
-(defun org-notmuch-tree-follow-link (search)
- "Follow a notmuch link by displaying SEARCH in notmuch-tree mode."
- (require 'notmuch)
- (notmuch-tree search))
-
-(provide 'ol-notmuch)
-
-;;; ol-notmuch.el ends here
diff --git a/lisp/org-attach-embedded-images.el
b/lisp/org-attach-embedded-images.el
deleted file mode 100644
index 5beb37abba..0000000000
--- a/lisp/org-attach-embedded-images.el
+++ /dev/null
@@ -1,132 +0,0 @@
-;;; org-attach-embedded-images.el --- Transmute images to attachments
-;;
-;; Copyright 2018-2021 Free Software Foundation, Inc.
-;;
-;; Author: Marco Wahl
-;; Homepage: https://gitlab.com/marcowahl/org-attach-embedded-imagse
-;; Version: 0.1
-;; Keywords: org, media
-;;
-;; This file is not part of GNU Emacs.
-;;
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 3, or (at your option)
-;; any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; There are occasions when images are displayed in a subtree which
-;; are not org attachments. For example if you copy and paste a part
-;; of a web page (containing images) from eww to an org subtree.
-
-;; This module provides command `org-attach-embedded-images-in-subtree'
-;; to save such images as attachments and insert org links to them.
-
-;; Install:
-
-;; To use this module insert it to `org-modules'. The insert can be
-;; performed via {M-x customize-variable RET org-modules RET} followed
-;; by insertion of `org-attach-embedded-images' to the external
-;; modules section.
-
-;; Alternatively you can add the line
-
-;; (require 'org-attach-embedded-images)
-
-;; to your emacs configuration.
-
-;; Use
-
-;; M-x org-attach-embedded-images-in-subtree
-
-;; in a subtree with embedded images. The images get attached and can
-;; later be reviewed.
-
-;; Note: Possibly
-
-;; M-x org-toggle-inline-images
-
-;; is needed to see the images in the Org mode window.
-
-
-;; Code:
-
-(require 'org)
-(require 'org-attach)
-
-
-;; Auxiliary functions
-
-(defun org-attach-embedded-images--next-property-display-data (position limit)
- "Return position of the next property-display location with image data.
-Return nil if there is no next display property.
-POSITION and LIMIT as in `next-single-property-change'."
- (let ((pos (next-single-property-change position 'display nil limit)))
- (while (and (< pos limit)
- (let ((display-prop
- (plist-get (text-properties-at pos) 'display)))
- (or (not display-prop)
- (not (plist-get (cdr display-prop) :data)))))
- (setq pos (next-single-property-change pos 'display nil limit)))
- pos))
-
-(defun org-attach-embedded-images--attach-with-sha1-name (data)
- "Save the image given as DATA as org attachment with its sha1 as name.
-Return the filename."
- (let* ((extension (symbol-name (image-type-from-data data)))
- (basename (concat (sha1 data) "." extension))
- (dir (org-attach-dir t))
- (filename (concat dir "/" basename)))
- (unless (file-exists-p filename)
- (with-temp-file filename
- (setq buffer-file-coding-system 'binary)
- (set-buffer-multibyte nil)
- (insert data)))
- (org-attach-sync)
- basename))
-
-
-;; Command
-
-;;;###autoload
-(defun org-attach-embedded-images-in-subtree ()
- "Save the displayed images as attachments and insert links to them."
- (interactive)
- (when (org-before-first-heading-p)
- (user-error "Before first heading. Nothing has been attached."))
- (save-excursion
- (org-attach-dir t)
- (let ((beg (progn (org-back-to-heading) (point)))
- (end (progn (org-end-of-subtree) (point)))
- names)
- ;; pass 1
- (goto-char beg)
- (while (< (goto-char
(org-attach-embedded-images--next-property-display-data (point) end)) end)
- (let ((data (plist-get (cdr (plist-get (text-properties-at (point))
'display)) :data)))
- (assert data)
- (push (org-attach-embedded-images--attach-with-sha1-name data)
- names)))
- ;; pass 2
- (setq names (nreverse names))
- (goto-char beg)
- (while names
- (goto-char (org-attach-embedded-images--next-property-display-data
(point) end))
- (while (get-text-property (point) 'display)
- (goto-char (next-property-change (point) nil end)))
- (skip-chars-forward "]")
- (insert (concat "\n[[attachment:" (pop names) "]]"))))))
-
-
-(provide 'org-attach-embedded-images)
-
-
-;;; org-attach-embedded-images.el ends here
diff --git a/lisp/org-contacts.el b/lisp/org-contacts.el
deleted file mode 100644
index 82e8f3a420..0000000000
--- a/lisp/org-contacts.el
+++ /dev/null
@@ -1,1244 +0,0 @@
-;;; org-contacts.el --- Contacts management
-
-;; Copyright (C) 2010-2014, 2021 Julien Danjou <julien@danjou.info>
-
-;; Author: Julien Danjou <julien@danjou.info>
-;; Maintainer: stardiviner <numbchild@gmail.com>
-;; Keywords: outlines, hypermedia, calendar
-;; Homepage: https://repo.or.cz/org-contacts.git
-;;
-;; This file is not part of GNU Emacs.
-;;
-;; This program is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;;; Commentary:
-
-;; This file contains the code for managing your contacts into Org-mode.
-
-;; To enter new contacts, you can use `org-capture' and a minimal template
just like
-;; this:
-
-;; ("c" "Contacts" entry (file "~/Org/contacts.org")
-;; "* %(org-contacts-template-name)
-;; :PROPERTIES:
-;; :EMAIL: %(org-contacts-template-email)
-;; :END:")))
-;;
-;; You can also use a complex template, for example:
-;;
-;; ("c" "Contacts" entry (file "~/Org/contacts.org")
-;; "* %(org-contacts-template-name)
-;; :PROPERTIES:
-;; :EMAIL: %(org-contacts-template-email)
-;; :PHONE:
-;; :ALIAS:
-;; :NICKNAME:
-;; :IGNORE:
-;; :ICON:
-;; :NOTE:
-;; :ADDRESS:
-;; :BIRTHDAY:
-;; :END:")))
-
-;;;; Usage:
-
-;;; How to search?
-;;;
-;;; You can use `org-sparse-tree' [C-c / p] to filter based on a
-;;; specific property. Or other matcher on `org-sparse-tree'.
-
-;;; Code:
-
-(require 'cl-lib)
-(require 'org)
-(require 'gnus-util)
-(require 'gnus-art)
-(require 'mail-utils)
-(require 'org-agenda)
-(require 'org-capture)
-(require 'ol)
-
-(defgroup org-contacts nil
- "Options about contacts management."
- :group 'org)
-
-(defcustom org-contacts-files nil
- "List of Org files to use as contacts source.
-When set to nil, all your Org files will be used."
- :type '(repeat file)
- :group 'org-contacts)
-
-(defcustom org-contacts-email-property "EMAIL"
- "Name of the property for contact email address."
- :type 'string
- :group 'org-contacts)
-
-(defcustom org-contacts-tel-property "PHONE"
- "Name of the property for contact phone number."
- :type 'string
- :group 'org-contacts)
-
-(defcustom org-contacts-address-property "ADDRESS"
- "Name of the property for contact address."
- :type 'string
- :group 'org-contacts)
-
-(defcustom org-contacts-birthday-property "BIRTHDAY"
- "Name of the property for contact birthday date."
- :type 'string
- :group 'org-contacts)
-
-(defcustom org-contacts-note-property "NOTE"
- "Name of the property for contact note."
- :type 'string
- :group 'org-contacts)
-
-(defcustom org-contacts-alias-property "ALIAS"
- "Name of the property for contact name alias."
- :type 'string
- :group 'org-contacts)
-
-(defcustom org-contacts-ignore-property "IGNORE"
- "Name of the property, which values will be ignored when
-completing or exporting to vcard."
- :type 'string
- :group 'org-contacts)
-
-
-(defcustom org-contacts-birthday-format "Birthday: %l (%Y)"
- "Format of the anniversary agenda entry.
-The following replacements are available:
-
- %h - Heading name
- %l - Link to the heading
- %y - Number of year
- %Y - Number of year (ordinal)"
- :type 'string
- :group 'org-contacts)
-
-(defcustom org-contacts-last-read-mail-property "LAST_READ_MAIL"
- "Name of the property for contact last read email link storage."
- :type 'string
- :group 'org-contacts)
-
-(defcustom org-contacts-icon-property "ICON"
- "Name of the property for contact icon."
- :type 'string
- :group 'org-contacts)
-
-(defcustom org-contacts-nickname-property "NICKNAME"
- "Name of the property for IRC nickname match."
- :type 'string
- :group 'org-contacts)
-
-(defcustom org-contacts-icon-size 32
- "Size of the contacts icons."
- :type 'string
- :group 'org-contacts)
-
-(defcustom org-contacts-icon-use-gravatar (fboundp 'gravatar-retrieve)
- "Whether use Gravatar to fetch contact icons."
- :type 'boolean
- :group 'org-contacts)
-
-(defcustom org-contacts-completion-ignore-case t
- "Ignore case when completing contacts."
- :type 'boolean
- :group 'org-contacts)
-
-(defcustom org-contacts-group-prefix "+"
- "Group prefix."
- :type 'string
- :group 'org-contacts)
-
-(defcustom org-contacts-tags-props-prefix "#"
- "Tags and properties prefix."
- :type 'string
- :group 'org-contacts)
-
-(defcustom org-contacts-matcher
- (mapconcat #'identity
- (mapcar (lambda (x) (concat x "<>\"\""))
- (list org-contacts-email-property
- org-contacts-alias-property
- org-contacts-tel-property
- org-contacts-address-property
- org-contacts-birthday-property))
- "|")
- "Matching rule for finding heading that are contacts.
-This can be a tag name, or a property check."
- :type 'string
- :group 'org-contacts)
-
-(defcustom org-contacts-email-link-description-format "%s (%d)"
- "Format used to store links to email.
-This overrides `org-email-link-description-format' if set."
- :group 'org-contacts
- :type 'string)
-
-(defcustom org-contacts-vcard-file "contacts.vcf"
- "Default file for vcard export."
- :group 'org-contacts
- :type 'file)
-
-(defcustom org-contacts-enable-completion t
- "Enable or not the completion in `message-mode' with `org-contacts'."
- :group 'org-contacts
- :type 'boolean)
-
-(defcustom org-contacts-complete-functions
- '(org-contacts-complete-group org-contacts-complete-tags-props
org-contacts-complete-name)
- "List of functions used to complete contacts in `message-mode'."
- :group 'org-contacts
- :type 'hook)
-
-;; Decalre external functions and variables
-(declare-function org-reverse-string "org")
-(declare-function diary-ordinal-suffix "ext:diary-lib")
-(declare-function wl-summary-message-number "ext:wl-summary")
-(declare-function wl-address-header-extract-address "ext:wl-address")
-(declare-function wl-address-header-extract-realname "ext:wl-address")
-(declare-function erc-buffer-list "ext:erc")
-(declare-function erc-get-channel-user-list "ext:erc")
-(declare-function google-maps-static-show "ext:google-maps-static")
-(declare-function elmo-message-field "ext:elmo-pipe")
-(declare-function std11-narrow-to-header "ext:std11")
-(declare-function std11-fetch-field "ext:std11")
-
-(defconst org-contacts-property-values-separators "[,; \f\t\n\r\v]+"
- "The default value of separators for `org-contacts-split-property'.
-
-A regexp matching strings of whitespace, `,' and `;'.")
-
-(defvar org-contacts-keymap
- (let ((map (make-sparse-keymap)))
- (define-key map "M" 'org-contacts-view-send-email)
- (define-key map "i" 'org-contacts-view-switch-to-irc-buffer)
- map)
- "The keymap used in `org-contacts' result list.")
-
-(defvar org-contacts-db nil
- "Org Contacts database.")
-
-(defvar org-contacts-last-update nil
- "Last time the Org Contacts database has been updated.")
-
-(defun org-contacts-files ()
- "Return list of Org files to use for contact management."
- (or org-contacts-files (org-agenda-files t 'ifmode)))
-
-(defun org-contacts-db-need-update-p ()
- "Determine whether `org-contacts-db' needs to be refreshed."
- (or (null org-contacts-last-update)
- (cl-find-if (lambda (file)
- (or (time-less-p org-contacts-last-update
- (elt (file-attributes file) 5))))
- (org-contacts-files))
- (org-contacts-db-has-dead-markers-p org-contacts-db)))
-
-(defun org-contacts-db-has-dead-markers-p (org-contacts-db)
- "Returns t if at least one dead marker is found in
-ORG-CONTACTS-DB. A dead marker in this case is a marker pointing
-to dead or no buffer."
- ;; Scan contacts list looking for dead markers, and return t at first
found.
- (catch 'dead-marker-found
- (while org-contacts-db
- (unless (marker-buffer (nth 1 (car org-contacts-db)))
- (throw 'dead-marker-found t))
- (setq org-contacts-db (cdr org-contacts-db)))
- nil))
-
-(defun org-contacts-db ()
- "Return the latest Org Contacts Database."
- (let* ((org--matcher-tags-todo-only nil)
- (contacts-matcher (cdr (org-make-tags-matcher org-contacts-matcher)))
- result)
- (when (org-contacts-db-need-update-p)
- (let ((progress-reporter
- (make-progress-reporter "Updating Org Contacts Database..." 0
(length org-contacts-files)))
- (i 0))
- (dolist (file (org-contacts-files))
- (if (catch 'nextfile
- ;; if file doesn't exist and the user agrees to removing it
- ;; from org-agendas-list, 'nextfile is thrown. Catch it here
- ;; and skip processing the file.
- ;;
- ;; TODO: suppose that the user has set an org-contacts-files
- ;; list that contains an element that doesn't exist in the
- ;; file system: in that case, the org-agenda-files list could
- ;; be updated (and saved to the customizations of the user) if
- ;; it contained the same file even though the org-agenda-files
- ;; list wasn't actually used. I don't think it is normal that
- ;; org-contacts updates org-agenda-files in this case, but
- ;; short of duplicating org-check-agenda-files and
- ;; org-remove-files, I don't know how to avoid it.
- ;;
- ;; A side effect of the TODO is that the faulty
- ;; org-contacts-files list never gets updated and thus the
- ;; user is always queried about the missing files when
- ;; org-contacts-db-need-update-p returns true.
- (org-check-agenda-file file))
- (message "Skipped %s removed from org-agenda-files list."
- (abbreviate-file-name file))
- (with-current-buffer (org-get-agenda-file-buffer file)
- (unless (eq major-mode 'org-mode)
- (error "File %s is not in `org-mode'" file))
- (setf result
- (append result
- (org-scan-tags 'org-contacts-at-point
- contacts-matcher
- org--matcher-tags-todo-only)))))
- (progress-reporter-update progress-reporter (setq i (1+ i))))
- (setf org-contacts-db result
- org-contacts-last-update (current-time))
- (progress-reporter-done progress-reporter)))
- org-contacts-db))
-
-(defun org-contacts-at-point (&optional pom)
- "Return the contacts at point-or-marker POM or current position
-if nil."
- (setq pom (or pom (point)))
- (org-with-point-at pom
- (list (org-get-heading t) (set-marker (make-marker) pom)
(org-entry-properties pom 'all))))
-
-(defun org-contacts-filter (&optional name-match tags-match prop-match)
- "Search for a contact matching any of NAME-MATCH, TAGS-MATCH, PROP-MATCH.
-If all match values are nil, return all contacts.
-
-The optional PROP-MATCH argument is a single (PROP . VALUE) cons
-cell corresponding to the contact properties.
-"
- (if (and (null name-match)
- (null prop-match)
- (null tags-match))
- (org-contacts-db)
- (cl-loop for contact in (org-contacts-db)
- if (or
- (and name-match
- (string-match-p name-match
- (first contact)))
- (and prop-match
- (cl-find-if (lambda (prop)
- (and (string= (car prop-match) (car prop))
- (string-match-p (cdr prop-match) (cdr
prop))))
- (caddr contact)))
- (and tags-match
- (cl-find-if (lambda (tag)
- (string-match-p tags-match tag))
- (org-split-string
- (or (cdr (assoc-string "ALLTAGS" (caddr
contact))) "") ":"))))
- collect contact)))
-
-(when (not (fboundp 'completion-table-case-fold))
- ;; That function is new in Emacs 24...
- (defun completion-table-case-fold (table &optional dont-fold)
- (lambda (string pred action)
- (let ((completion-ignore-case (not dont-fold)))
- (complete-with-action action table string pred)))))
-
-(defun org-contacts-try-completion-prefix (to-match collection &optional
predicate)
- "Custom implementation of `try-completion'.
-This version works only with list and alist and it looks at all
-prefixes rather than just the beginning of the string."
- (cl-loop with regexp = (concat "\\b" (regexp-quote to-match))
- with ret = nil
- with ret-start = nil
- with ret-end = nil
-
- for el in collection
- for string = (if (listp el) (car el) el)
-
- for start = (when (or (null predicate) (funcall predicate string))
- (string-match regexp string))
-
- if start
- do (let ((end (match-end 0))
- (len (length string)))
- (if (= end len)
- (cl-return t)
- (cl-destructuring-bind (string start end)
- (if (null ret)
- (values string start end)
- (org-contacts-common-substring
- ret ret-start ret-end
- string start end))
- (setf ret string
- ret-start start
- ret-end end))))
-
- finally (cl-return
- (replace-regexp-in-string "\\`[ \t\n]*" "" ret))))
-
-(defun org-contacts-compare-strings (s1 start1 end1 s2 start2 end2 &optional
ignore-case)
- "Compare the contents of two strings, using `compare-strings'.
-
-This function works like `compare-strings' excepted that it
-returns a cons.
-- The CAR is the number of characters that match at the beginning.
-- The CDR is T is the two strings are the same and NIL otherwise."
- (let ((ret (compare-strings s1 start1 end1 s2 start2 end2 ignore-case)))
- (if (eq ret t)
- (cons (or end1 (length s1)) t)
- (cons (1- (abs ret)) nil))))
-
-(defun org-contacts-common-substring (s1 start1 end1 s2 start2 end2)
- "Extract the common substring between S1 and S2.
-
-This function extracts the common substring between S1 and S2 and
-adjust the part that remains common.
-
-START1 and END1 delimit the part in S1 that we know is common
-between the two strings. This applies to START2 and END2 for S2.
-
-This function returns a list whose contains:
-- The common substring found.
-- The new value of the start of the known inner substring.
-- The new value of the end of the known inner substring."
- ;; Given two strings:
- ;; s1: "foo bar baz"
- ;; s2: "fooo bar baz"
- ;; and the inner substring is "bar"
- ;; then: start1 = 4, end1 = 6, start2 = 5, end2 = 7
- ;;
- ;; To find the common substring we will compare two substrings:
- ;; " oof" and " ooof" to find the beginning of the common substring.
- ;; " baz" and " baz" to find the end of the common substring.
- (let* ((len1 (length s1))
- (start1 (or start1 0))
- (end1 (or end1 len1))
-
- (len2 (length s2))
- (start2 (or start2 0))
- (end2 (or end2 len2))
-
- (new-start (car (org-contacts-compare-strings
- (substring (org-reverse-string s1) (- len1 start1))
nil nil
- (substring (org-reverse-string s2) (- len2 start2))
nil nil)))
-
- (new-end (+ end1 (car (org-contacts-compare-strings
- (substring s1 end1) nil nil
- (substring s2 end2) nil nil)))))
- (list (substring s1 (- start1 new-start) new-end)
- new-start
- (+ new-start (- end1 start1)))))
-
-(defun org-contacts-all-completions-prefix (to-match collection &optional
predicate)
- "Custom version of `all-completions'.
-This version works only with list and alist and it looks at all
-prefixes rather than just the beginning of the string."
- (cl-loop with regexp = (concat "\\b" (regexp-quote to-match))
- for el in collection
- for string = (if (listp el) (car el) el)
- for match? = (when (and (or (null predicate) (funcall predicate
string)))
- (string-match regexp string))
- if match?
- collect (progn
- (let ((end (match-end 0)))
- (org-no-properties string)
- (when (< end (length string))
- ;; Here we add a text property that will be used
- ;; later to highlight the character right after
- ;; the common part between each addresses.
- ;; See `org-contacts-display-sort-function'.
- (put-text-property end (1+ end) 'org-contacts-prefix
't string)))
- string)))
-
-(defun org-contacts-make-collection-prefix (collection)
- "Make a collection function from COLLECTION which will match on prefixes."
- (lexical-let ((collection collection))
- (lambda (string predicate flag)
- (cond ((eq flag nil)
- (org-contacts-try-completion-prefix string collection predicate))
- ((eq flag t)
- ;; `org-contacts-all-completions-prefix' has already been
- ;; used to compute `all-completions'.
- collection)
- ((eq flag 'lambda)
- (org-contacts-test-completion-prefix string collection predicate))
- ((and (listp flag) (eq (car flag) 'boundaries))
- (cl-destructuring-bind (to-ignore &rest suffix)
- flag
- (org-contacts-boundaries-prefix string collection predicate
suffix)))
- ((eq flag 'metadata)
- (org-contacts-metadata-prefix string collection predicate))
- (t nil ; operation unsupported
- )))))
-
-(defun org-contacts-display-sort-function (completions)
- "Sort function for contacts display."
- (mapcar (lambda (string)
- (cl-loop with len = (1- (length string))
- for i upfrom 0 to len
- if (memq 'org-contacts-prefix
- (text-properties-at i string))
- do (set-text-properties
- i (1+ i)
- (list 'font-lock-face
- (if (char-equal (aref string i)
- (string-to-char " "))
- ;; Spaces can't be bold.
- 'underline
- 'bold)) string)
- else
- do (set-text-properties i (1+ i) nil string)
- finally (cl-return string)))
- completions))
-
-(defun org-contacts-test-completion-prefix (string collection predicate)
- (cl-find-if (lambda (el)
- (and (or (null predicate) (funcall predicate el))
- (string= string el)))
- collection))
-
-(defun org-contacts-boundaries-prefix (string collection predicate suffix)
- (list* 'boundaries (completion-boundaries string collection predicate
suffix)))
-
-(defun org-contacts-metadata-prefix (string collection predicate)
- '(metadata .
- ((cycle-sort-function . org-contacts-display-sort-function)
- (display-sort-function . org-contacts-display-sort-function))))
-
-(defun org-contacts-complete-group (start end string)
- "Complete text at START from a group.
-
-A group FOO is composed of contacts with the tag FOO."
- (let* ((completion-ignore-case org-contacts-completion-ignore-case)
- (group-completion-p (string-match-p
- (concat "^" org-contacts-group-prefix) string)))
- (when group-completion-p
- (let ((completion-list
- (all-completions
- string
- (mapcar (lambda (group)
- (propertize (concat org-contacts-group-prefix group)
- 'org-contacts-group group))
- (org-uniquify
- (cl-loop for contact in (org-contacts-filter)
- nconc (org-split-string
- (or (cdr (assoc-string "ALLTAGS" (caddr
contact))) "") ":")))))))
- (list start end
- (if (= (length completion-list) 1)
- ;; We've found the correct group, returns the address
- (lexical-let ((tag (get-text-property 0 'org-contacts-group
- (car completion-list))))
- (lambda (string pred &optional to-ignore)
- (mapconcat 'identity
- (cl-loop for contact in (org-contacts-filter
- nil
- tag)
- ;; The contact name is always the car
of the assoc-list
- ;; returned by `org-contacts-filter'.
- for contact-name = (car contact)
- ;; Grab the first email of the contact
- for email = (org-contacts-strip-link
- (or (car
(org-contacts-split-property
- (or
- (cdr
(assoc-string org-contacts-email-property
-
(cl-caddr contact)))
- ""))) ""))
- ;; If the user has an email address,
append USER <EMAIL>.
- if email collect
(org-contacts-format-email contact-name email))
- ", ")))
- ;; We haven't found the correct group
- (completion-table-case-fold completion-list
- (not
org-contacts-completion-ignore-case))))))))
-
-(defun org-contacts-complete-tags-props (start end string)
- "Insert emails that match the tags expression.
-
-For example: FOO-BAR will match entries tagged with FOO but not
-with BAR.
-
-See (org) Matching tags and properties for a complete
-description."
- (let* ((completion-ignore-case org-contacts-completion-ignore-case)
- (completion-p (string-match-p
- (concat "^" org-contacts-tags-props-prefix) string)))
- (when completion-p
- (let ((result
- (mapconcat
- 'identity
- (cl-loop for contact in (org-contacts-db)
- for contact-name = (car contact)
- for email = (org-contacts-strip-link (or (car
(org-contacts-split-property
- (or
- (cdr
(assoc-string org-contacts-email-property
-
(cl-caddr contact)))
- "")))
""))
- for tags = (cdr (assoc "TAGS" (nth 2 contact)))
- for tags-list = (if tags
- (split-string (substring (cdr (assoc
"TAGS" (nth 2 contact))) 1 -1) ":")
- '())
- for marker = (nth 1 contact)
- if (with-current-buffer (marker-buffer marker)
- (save-excursion
- (goto-char marker)
- (let (todo-only)
- (eval (cdr (org-make-tags-matcher (cl-subseq
string 1)))))))
- collect (org-contacts-format-email contact-name email))
- ",")))
- (when (not (string= "" result))
- ;; return (start end function)
- (lexical-let* ((to-return result))
- (list start end
- (lambda (string pred &optional to-ignore) to-return))))))))
-
-(defun org-contacts-remove-ignored-property-values (ignore-list list)
- "Remove all ignore-list's elements from list and you can use
- regular expressions in the ignore list."
- (cl-remove-if (lambda (el)
- (cl-find-if (lambda (x)
- (string-match-p x el))
- ignore-list))
- list))
-
-(defun org-contacts-complete-name (start end string)
- "Complete text at START with a user name and email."
- (let* ((completion-ignore-case org-contacts-completion-ignore-case)
- (completion-list
- (cl-loop for contact in (org-contacts-filter)
- ;; The contact name is always the car of the assoc-list
- ;; returned by `org-contacts-filter'.
- for contact-name = (car contact)
-
- ;; Build the list of the email addresses which has
- ;; been expired
- for ignore-list = (org-contacts-split-property
- (or (cdr (assoc-string
org-contacts-ignore-property
- (nth 2 contact)))
""))
- ;; Build the list of the user email addresses.
- for email-list = (org-contacts-remove-ignored-property-values
- ignore-list
- (org-contacts-split-property
- (or (cdr (assoc-string
org-contacts-email-property
- (nth 2 contact)))
"")))
- ;; If the user has email addresses…
- if email-list
- ;; … append a list of USER <EMAIL>.
- nconc (cl-loop for email in email-list
- collect (org-contacts-format-email
contact-name (org-contacts-strip-link email)))))
- (completion-list (org-contacts-all-completions-prefix
- string
- (org-uniquify completion-list))))
- (when completion-list
- (list start end
- (org-contacts-make-collection-prefix completion-list)))))
-
-(defun org-contacts-message-complete-function (&optional start)
- "Function used in `completion-at-point-functions' in `message-mode'."
- ;; Avoid to complete in `post-command-hook'.
- (when completion-in-region-mode
- (remove-hook 'post-command-hook #'completion-in-region--postch))
- (let ((mail-abbrev-mode-regexp
-
"^\\(Resent-To\\|To\\|B?Cc\\|Reply-To\\|From\\|Mail-Followup-To\\|Mail-Copies-To\\|Disposition-Notification-To\\|Return-Receipt-To\\):"))
- (when (mail-abbrev-in-expansion-header-p)
- (lexical-let*
- ((end (point))
- (start (or start
- (save-excursion
- (re-search-backward "\\(\\`\\|[\n:,]\\)[ \t]*")
- (goto-char (match-end 0))
- (point))))
- (string (buffer-substring start end)))
- (run-hook-with-args-until-success
- 'org-contacts-complete-functions start end string)))))
-
-(defun org-contacts-gnus-get-name-email ()
- "Get name and email address from Gnus message."
- (if (gnus-alive-p)
- (gnus-with-article-headers
- (mail-extract-address-components
- (or (mail-fetch-field "From") "")))))
-
-(defun org-contacts-gnus-article-from-get-marker ()
- "Return a marker for a contact based on From."
- (let* ((address (org-contacts-gnus-get-name-email))
- (name (car address))
- (email (cadr address)))
- (cl-cadar (or (org-contacts-filter
- nil
- nil
- (cons org-contacts-email-property (concat "\\b"
(regexp-quote email) "\\b")))
- (when name
- (org-contacts-filter
- (concat "^" name "$")))))))
-
-(defun org-contacts-gnus-article-from-goto ()
- "Go to contact in the From address of current Gnus message."
- (interactive)
- (let ((marker (org-contacts-gnus-article-from-get-marker)))
- (when marker
- (switch-to-buffer-other-window (marker-buffer marker))
- (goto-char marker)
- (when (eq major-mode 'org-mode) (org-show-context 'agenda)))))
-
-(with-no-warnings (defvar date)) ;; unprefixed, from calendar.el
-(defun org-contacts-anniversaries (&optional field format)
- "Compute FIELD anniversary for each contact, returning FORMAT.
-Default FIELD value is \"BIRTHDAY\".
-
-Format is a string matching the following format specification:
-
- %h - Heading name
- %l - Link to the heading
- %y - Number of year
- %Y - Number of year (ordinal)"
- (let ((calendar-date-style 'american)
- (entry ""))
- (unless format (setq format org-contacts-birthday-format))
- (cl-loop for contact in (org-contacts-filter)
- for anniv = (let ((anniv (cdr (assoc-string
- (or field
org-contacts-birthday-property)
- (nth 2 contact)))))
- (when anniv
- (calendar-gregorian-from-absolute
- (org-time-string-to-absolute anniv))))
- ;; Use `diary-anniversary' to compute anniversary.
- if (and anniv (apply 'diary-anniversary anniv))
- collect (format-spec format
- `((?l . ,(org-with-point-at (cadr contact)
(org-store-link nil)))
- (?h . ,(car contact))
- (?y . ,(- (calendar-extract-year date)
- (calendar-extract-year anniv)))
- (?Y . ,(let ((years (-
(calendar-extract-year date)
-
(calendar-extract-year anniv))))
- (format "%d%s" years
(diary-ordinal-suffix years)))))))))
-
-(defun org-completing-read-date (prompt collection
- &optional predicate require-match
initial-input
- hist def inherit-input-method)
- "Like `completing-read' but reads a date.
-Only PROMPT and DEF are really used."
- (org-read-date nil nil nil prompt nil def))
-
-(add-to-list 'org-property-set-functions-alist
- `(,org-contacts-birthday-property . org-completing-read-date))
-
-(defun org-contacts-template-name (&optional return-value)
- "Try to return the contact name for a template.
-If not found return RETURN-VALUE or something that would ask the user."
- (or (car (org-contacts-gnus-get-name-email))
- return-value
- "%^{Name}"))
-
-(defun org-contacts-template-email (&optional return-value)
- "Try to return the contact email for a template.
-If not found return RETURN-VALUE or something that would ask the user."
- (or (cadr (org-contacts-gnus-get-name-email))
- return-value
- (concat "%^{" org-contacts-email-property "}p")))
-
-(defun org-contacts-gnus-store-last-mail ()
- "Store a link between mails and contacts.
-
-This function should be called from `gnus-article-prepare-hook'."
- (let ((marker (org-contacts-gnus-article-from-get-marker)))
- (when marker
- (with-current-buffer (marker-buffer marker)
- (save-excursion
- (goto-char marker)
- (let* ((org-email-link-description-format (or
org-contacts-email-link-description-format
-
org-email-link-description-format))
- (link (gnus-with-article-buffer (org-store-link nil))))
- (org-set-property org-contacts-last-read-mail-property link)))))))
-
-(defun org-contacts-icon-as-string ()
- "Return the contact icon as a string."
- (let ((image (org-contacts-get-icon)))
- (concat
- (propertize "-" 'display
- (append
- (if image
- image
- `'(space :width (,org-contacts-icon-size)))
- '(:ascent center)))
- " ")))
-
-;;;###autoload
-(defun org-contacts (name)
- "Create agenda view for contacts matching NAME."
- (interactive (list (read-string "Name: ")))
- (let ((org-agenda-files (org-contacts-files))
- (org-agenda-skip-function
- (lambda () (org-agenda-skip-if nil `(notregexp ,name))))
- (org-agenda-prefix-format (propertize
- "%(org-contacts-icon-as-string)%
s%(org-contacts-irc-number-of-unread-messages) "
- 'keymap org-contacts-keymap))
- (org-agenda-overriding-header
- (or org-agenda-overriding-header
- (concat "List of contacts matching `" name "':"))))
- (setq org-agenda-skip-regexp name)
- (org-tags-view nil org-contacts-matcher)
- (with-current-buffer org-agenda-buffer-name
- (setq org-agenda-redo-command
- (list 'org-contacts name)))))
-
-(defun org-contacts-completing-read (prompt
- &optional predicate
- initial-input hist def
inherit-input-method)
- "Call `completing-read' with contacts name as collection."
- (org-completing-read
- prompt (org-contacts-filter) predicate t initial-input hist def
inherit-input-method))
-
-(defun org-contacts-format-name (name)
- "Trim any local formatting to get a bare NAME."
- ;; Remove radio targets characters
- (replace-regexp-in-string org-radio-target-regexp "\\1" name))
-
-(defun org-contacts-format-email (name email)
- "Format an EMAIL address corresponding to NAME."
- (unless email
- (error "`email' cannot be nul"))
- (if name
- (concat (org-contacts-format-name name) " <" email ">")
- email))
-
-(defun org-contacts-check-mail-address (mail)
- "Add MAIL address to contact at point if it does not have it."
- (let ((mails (org-entry-get (point) org-contacts-email-property)))
- (unless (member mail (split-string mails))
- (when (yes-or-no-p
- (format "Do you want to add this address to %s?" (org-get-heading
t)))
- (org-set-property org-contacts-email-property (concat mails " "
mail))))))
-
-(defun org-contacts-gnus-check-mail-address ()
- "Check that contact has the current address recorded.
-This function should be called from `gnus-article-prepare-hook'."
- (let ((marker (org-contacts-gnus-article-from-get-marker)))
- (when marker
- (org-with-point-at marker
- (org-contacts-check-mail-address (cadr
(org-contacts-gnus-get-name-email)))))))
-
-(defun org-contacts-gnus-insinuate ()
- "Add some hooks for Gnus user.
-This adds `org-contacts-gnus-check-mail-address' and
-`org-contacts-gnus-store-last-mail' to
-`gnus-article-prepare-hook'. It also adds a binding on `;' in
-`gnus-summary-mode-map' to `org-contacts-gnus-article-from-goto'"
- (require 'gnus)
- (require 'gnus-art)
- (define-key gnus-summary-mode-map ";" 'org-contacts-gnus-article-from-goto)
- (add-hook 'gnus-article-prepare-hook 'org-contacts-gnus-check-mail-address)
- (add-hook 'gnus-article-prepare-hook 'org-contacts-gnus-store-last-mail))
-
-(defun org-contacts-setup-completion-at-point ()
- "Add `org-contacts-message-complete-function' as a new function
-to complete the thing at point."
- (add-to-list 'completion-at-point-functions
- 'org-contacts-message-complete-function))
-
-(defun org-contacts-unload-hook ()
- (remove-hook 'message-mode-hook 'org-contacts-setup-completion-at-point))
-
-(when (and org-contacts-enable-completion
- (boundp 'completion-at-point-functions))
- (add-hook 'message-mode-hook 'org-contacts-setup-completion-at-point))
-
-(defun org-contacts-wl-get-from-header-content ()
- "Retrieve the content of the `From' header of an email.
-Works from wl-summary-mode and mime-view-mode - that is while viewing email.
-Depends on Wanderlust been loaded."
- (with-current-buffer (org-capture-get :original-buffer)
- (cond
- ((eq major-mode 'wl-summary-mode) (when (and (boundp
'wl-summary-buffer-elmo-folder)
- wl-summary-buffer-elmo-folder)
- (elmo-message-field
- wl-summary-buffer-elmo-folder
- (wl-summary-message-number)
- 'from)))
- ((eq major-mode 'mime-view-mode) (std11-narrow-to-header)
- (prog1
- (std11-fetch-field "From")
- (widen))))))
-
-(defun org-contacts-wl-get-name-email ()
- "Get name and email address from Wanderlust email.
-See `org-contacts-wl-get-from-header-content' for limitations."
- (let ((from (org-contacts-wl-get-from-header-content)))
- (when from
- (list (wl-address-header-extract-realname from)
- (wl-address-header-extract-address from)))))
-
-(defun org-contacts-template-wl-name (&optional return-value)
- "Try to return the contact name for a template from wl.
-If not found, return RETURN-VALUE or something that would ask the
-user."
- (or (car (org-contacts-wl-get-name-email))
- return-value
- "%^{Name}"))
-
-(defun org-contacts-template-wl-email (&optional return-value)
- "Try to return the contact email for a template from Wanderlust.
-If not found return RETURN-VALUE or something that would ask the user."
- (or (cadr (org-contacts-wl-get-name-email))
- return-value
- (concat "%^{" org-contacts-email-property "}p")))
-
-(defun org-contacts-view-send-email (&optional ask)
- "Send email to the contact at point.
-If ASK is set, ask for the email address even if there's only one
-address."
- (interactive "P")
- (let ((marker (org-get-at-bol 'org-hd-marker)))
- (org-with-point-at marker
- (let ((emails (org-entry-get (point) org-contacts-email-property)))
- (if emails
- (let ((email-list (org-contacts-split-property emails)))
- (if (and (= (length email-list) 1) (not ask))
- (compose-mail (org-contacts-format-email
- (org-get-heading t) emails))
- (let ((email (completing-read "Send mail to which address: "
email-list)))
- (setq email (org-contacts-strip-link email))
- (org-contacts-check-mail-address email)
- (compose-mail (org-contacts-format-email (org-get-heading t)
email)))))
- (error (format "This contact has no mail address set (no %s
property)"
- org-contacts-email-property)))))))
-
-(defun org-contacts-get-icon (&optional pom)
- "Get icon for contact at POM."
- (setq pom (or pom (point)))
- (catch 'icon
- ;; Use `org-contacts-icon-property'
- (let ((image-data (org-entry-get pom org-contacts-icon-property)))
- (when image-data
- (throw 'icon
- (if (fboundp 'gnus-rescale-image)
- (gnus-rescale-image (create-image image-data)
- (cons org-contacts-icon-size
org-contacts-icon-size))
- (create-image image-data)))))
- ;; Next, try Gravatar
- (when org-contacts-icon-use-gravatar
- (let* ((gravatar-size org-contacts-icon-size)
- (email-list (org-entry-get pom org-contacts-email-property))
- (gravatar
- (when email-list
- (cl-loop for email in (org-contacts-split-property email-list)
- for gravatar = (gravatar-retrieve-synchronously
(org-contacts-strip-link email))
- if (and gravatar
- (not (eq gravatar 'error)))
- return gravatar))))
- (when gravatar (throw 'icon gravatar))))))
-
-(defun org-contacts-irc-buffer (&optional pom)
- "Get the IRC buffer associated with the entry at POM."
- (setq pom (or pom (point)))
- (let ((nick (org-entry-get pom org-contacts-nickname-property)))
- (when nick
- (let ((buffer (get-buffer nick)))
- (when buffer
- (with-current-buffer buffer
- (when (eq major-mode 'erc-mode)
- buffer)))))))
-
-(defun org-contacts-irc-number-of-unread-messages (&optional pom)
- "Return the number of unread messages for contact at POM."
- (when (boundp 'erc-modified-channels-alist)
- (let ((number (cadr (assoc (org-contacts-irc-buffer pom)
erc-modified-channels-alist))))
- (if number
- (format (concat "%3d unread message" (if (> number 1) "s" " ") " ")
number)
- (make-string 21 ? )))))
-
-(defun org-contacts-view-switch-to-irc-buffer ()
- "Switch to the IRC buffer of the current contact if it has one."
- (interactive)
- (let ((marker (org-get-at-bol 'org-hd-marker)))
- (org-with-point-at marker
- (switch-to-buffer-other-window (org-contacts-irc-buffer)))))
-
-(defun org-contacts-completing-read-nickname (prompt collection
- &optional predicate
require-match initial-input
- hist def
inherit-input-method)
- "Like `completing-read' but reads a nickname."
- (org-completing-read prompt (append collection (erc-nicknames-list))
predicate require-match
- initial-input hist def inherit-input-method))
-
-(defun erc-nicknames-list ()
- "Return all nicknames of all ERC buffers."
- (cl-loop for buffer in (erc-buffer-list)
- nconc (with-current-buffer buffer
- (cl-loop for user-entry in (mapcar 'car
(erc-get-channel-user-list))
- collect (elt user-entry 1)))))
-
-(add-to-list 'org-property-set-functions-alist
- `(,org-contacts-nickname-property .
org-contacts-completing-read-nickname))
-
-(defun org-contacts-vcard-escape (str)
- "Escape ; , and \n in STR for the VCard format."
- ;; Thanks to this library for the regexp:
- ;; https://www.emacswiki.org/cgi-bin/wiki/bbdb-vcard-export.el
- (when str
- (replace-regexp-in-string
- "\n" "\\\\n"
- (replace-regexp-in-string "\\(;\\|,\\|\\\\\\)" "\\\\\\1" str))))
-
-(defun org-contacts-vcard-encode-name (name)
- "Try to encode NAME as VCard's N property.
-The N property expects
-
- FamilyName;GivenName;AdditionalNames;Prefix;Postfix.
-
-Org-contacts does not specify how to encode the name. So we try
-to do our best."
- (concat (replace-regexp-in-string "\\(\\w+\\) \\(.*\\)" "\\2;\\1" name)
";;;"))
-
-(defun org-contacts-vcard-format (contact)
- "Formats CONTACT in VCard 3.0 format."
- (let* ((properties (nth 2 contact))
- (name (org-contacts-vcard-escape (car contact)))
- (n (org-contacts-vcard-encode-name name))
- (email (cdr (assoc-string org-contacts-email-property properties)))
- (tel (cdr (assoc-string org-contacts-tel-property properties)))
- (ignore-list (cdr (assoc-string org-contacts-ignore-property
properties)))
- (ignore-list (when ignore-list
- (org-contacts-split-property ignore-list)))
- (note (cdr (assoc-string org-contacts-note-property properties)))
- (bday (org-contacts-vcard-escape (cdr (assoc-string
org-contacts-birthday-property properties))))
- (addr (cdr (assoc-string org-contacts-address-property properties)))
- (nick (org-contacts-vcard-escape (cdr (assoc-string
org-contacts-nickname-property properties))))
- (head (format "BEGIN:VCARD\nVERSION:3.0\nN:%s\nFN:%s\n" n name))
- emails-list result phones-list)
- (concat head
- (when email (progn
- (setq emails-list
(org-contacts-remove-ignored-property-values ignore-list
(org-contacts-split-property email)))
- (setq result "")
- (while emails-list
- (setq result (concat result "EMAIL:"
(org-contacts-strip-link (car emails-list)) "\n"))
- (setq emails-list (cdr emails-list)))
- result))
- (when addr
- (format "ADR:;;%s\n" (replace-regexp-in-string "\\, ?" ";" addr)))
- (when tel (progn
- (setq phones-list
(org-contacts-remove-ignored-property-values ignore-list
(org-contacts-split-property tel)))
- (setq result "")
- (while phones-list
- (setq result (concat result "TEL:"
(org-contacts-strip-link (org-link-unescape (car phones-list))) "\n"))
- (setq phones-list (cdr phones-list)))
- result))
- (when bday
- (let ((cal-bday (calendar-gregorian-from-absolute
(org-time-string-to-absolute bday))))
- (format "BDAY:%04d-%02d-%02d\n"
- (calendar-extract-year cal-bday)
- (calendar-extract-month cal-bday)
- (calendar-extract-day cal-bday))))
- (when nick (format "NICKNAME:%s\n" nick))
- (when note (format "NOTE:%s\n" note))
- "END:VCARD\n\n")))
-
-(defun org-contacts-export-as-vcard (&optional name file to-buffer)
- "Export org contacts to V-Card 3.0.
-
-By default, all contacts are exported to `org-contacts-vcard-file'.
-
-When NAME is \\[universal-argument], prompts for a contact name.
-
-When NAME is \\[universal-argument] \\[universal-argument],
-prompts for a contact name and a file name where to export.
-
-When NAME is \\[universal-argument] \\[universal-argument]
-\\[universal-argument], prompts for a contact name and a buffer where to
export.
-
-If the function is not called interactively, all parameters are
-passed to `org-contacts-export-as-vcard-internal'."
- (interactive "P")
- (when (called-interactively-p 'any)
- (cl-psetf name
- (when name
- (read-string "Contact name: "
- (nth 0 (org-contacts-at-point))))
- file
- (when (equal name '(16))
- (read-file-name "File: " nil org-contacts-vcard-file))
- to-buffer
- (when (equal name '(64))
- (read-buffer "Buffer: "))))
- (org-contacts-export-as-vcard-internal name file to-buffer))
-
-(defun org-contacts-export-as-vcard-internal (&optional name file to-buffer)
- "Export all contacts matching NAME as VCard 3.0.
-If TO-BUFFER is nil, the content is written to FILE or
-`org-contacts-vcard-file'. If TO-BUFFER is non-nil, the buffer
-is created and the VCard is written into that buffer."
- (let* ((filename (or file org-contacts-vcard-file))
- (buffer (if to-buffer
- (get-buffer-create to-buffer)
- (find-file-noselect filename))))
- (message "Exporting...")
- (set-buffer buffer)
- (let ((inhibit-read-only t)) (erase-buffer))
- (fundamental-mode)
- (when (fboundp 'set-buffer-file-coding-system)
- (set-buffer-file-coding-system coding-system-for-write))
- (cl-loop for contact in (org-contacts-filter name)
- do (insert (org-contacts-vcard-format contact)))
- (if to-buffer
- (current-buffer)
- (progn (save-buffer) (kill-buffer)))))
-
-(defun org-contacts-show-map (&optional name)
- "Show contacts on a map.
-Requires google-maps-el."
- (interactive)
- (unless (fboundp 'google-maps-static-show)
- (error "`org-contacts-show-map' requires `google-maps-el'"))
- (google-maps-static-show
- :markers
- (cl-loop
- for contact in (org-contacts-filter name)
- for addr = (cdr (assoc-string org-contacts-address-property (nth 2
contact)))
- if addr
- collect (cons (list addr) (list :label (string-to-char (car contact)))))))
-
-(defun org-contacts-strip-link (link)
- "Remove brackets, description, link type and colon from an org
-link string and return the pure link target."
- (let (startpos colonpos endpos)
- (setq startpos (string-match (regexp-opt '("[[tel:" "[[mailto:";)) link))
- (if startpos
- (progn
- (setq colonpos (string-match ":" link))
- (setq endpos (string-match "\\]" link))
- (if endpos (substring link (1+ colonpos) endpos) link))
- (progn
- (setq startpos (string-match "mailto:"; link))
- (setq colonpos (string-match ":" link))
- (if startpos (substring link (1+ colonpos)) link)))))
-
-;; Add the link type supported by org-contacts-strip-link
-;; so everything is in order for its use in Org files
-(org-link-set-parameters "tel")
-
-(defun org-contacts-split-property (string &optional separators omit-nulls)
- "Custom version of `split-string'.
-Split a property STRING into sub-strings bounded by matches
-for SEPARATORS but keep Org links intact.
-
-The beginning and end of STRING, and each match for SEPARATORS, are
-splitting points. The substrings matching SEPARATORS are removed, and
-the substrings between the splitting points are collected as a list,
-which is returned.
-
-If SEPARATORS is non-nil, it should be a regular expression
-matching text which separates, but is not part of, the
-substrings. If nil it defaults to `org-contacts-property-values-separators',
-normally \"[,; \f\t\n\r\v]+\", and OMIT-NULLS is forced to t.
-
-If OMIT-NULLS is t, zero-length substrings are omitted from the list \(so
-that for the default value of SEPARATORS leading and trailing whitespace
-are effectively trimmed). If nil, all zero-length substrings are retained."
- (let* ((omit-nulls (if separators omit-nulls t))
- (rexp (or separators org-contacts-property-values-separators))
- (inputlist (split-string string rexp omit-nulls))
- (linkstring "")
- (bufferstring "")
- (proplist (list "")))
- (while inputlist
- (setq bufferstring (pop inputlist))
- (if (string-match "\\[\\[" bufferstring)
- (progn
- (setq linkstring (concat bufferstring " "))
- (while (not (string-match "\\]\\]" bufferstring))
- (setq bufferstring (pop inputlist))
- (setq linkstring (concat linkstring bufferstring " ")))
- (setq proplist (cons (org-trim linkstring) proplist)))
- (setq proplist (cons bufferstring proplist))))
- (cdr (reverse proplist))))
-
-;;; Add an Org link type `org-contact:' for easy jump to or searching
org-contacts headline.
-;;; link spec: [[org-contact:query][desc]]
-(org-link-set-parameters "org-contact"
- :follow 'org-contacts-link-open
- :complete 'org-contacts-link-complete
- :store 'org-contacts-link-store
- :face 'org-contacts-link-face)
-
-(defun org-contacts-link-store ()
- "Store the contact in `org-contacts-files' with a link."
- (when (and (eq major-mode 'org-mode)
- (member (buffer-file-name) (mapcar 'expand-file-name
org-contacts-files)))
- (if (bound-and-true-p org-id-link-to-org-use-id)
- (org-id-store-link)
- (let ((headline-str (substring-no-properties (org-get-heading t t t t))))
- (org-store-link-props
- :type "org-contact"
- :link headline-str
- :description headline-str)
- (setq desc headline-str)
- (setq link (concat "org-contact:" headline-str))
- (org-add-link-props :link link :description desc)
- link))))
-
-(defun org-contacts--all-contacts ()
- "Return an alist (name . (file . position)) of all contacts in
`org-contacts-files'."
- (car (mapcar
- (lambda (file)
- (unless (buffer-live-p (get-buffer (file-name-nondirectory file)))
- (find-file file))
- (with-current-buffer (get-buffer (file-name-nondirectory file))
- (org-map-entries
- (lambda ()
- (let ((name (substring-no-properties (org-get-heading t t t t)))
- (file (buffer-file-name))
- (position (point)))
- `(:name ,name :file ,file :position ,position))))))
- org-contacts-files)))
-
-(defun org-contacts-link-open (path)
- "Open contacts: link type with jumping or searching."
- (let ((query path))
- (cond
- ;; /query/ format searching
- ((string-match "/.*/" query)
- (let* ((f (car org-contacts-files))
- (buf (get-buffer (file-name-nondirectory f))))
- (unless (buffer-live-p buf) (find-file f))
- (with-current-buffer buf
- (string-match "/\\(.*\\)/" query)
- (occur (match-string 1 query)))))
- ;; jump to contact headline directly
- (t
- (let* ((f (car org-contacts-files))
- (buf (get-buffer (file-name-nondirectory f))))
- (unless (buffer-live-p buf) (find-file f))
- (with-current-buffer buf
- (goto-char (marker-position (org-find-exact-headline-in-buffer
query))))
- (display-buffer buf '(display-buffer-below-selected)))
- ;; FIXME
- ;; (let* ((contact-entry (plist-get (org-contacts--all-contacts) query))
- ;; (contact-name (plist-get contact-entry :name))
- ;; (file (plist-get contact-entry :file))
- ;; (position (plist-get contact-entry :position))
- ;; (buf (get-buffer (file-name-nondirectory file))))
- ;; (unless (buffer-live-p buf) (find-file file))
- ;; (with-current-buffer buf (goto-char position)))
- ))))
-
-(defun org-contacts-link-complete (&optional arg)
- "Create a org-contacts link using completion."
- (let ((name (completing-read "org-contact Name: "
- (mapcar
- (lambda (plist) (plist-get plist :name))
- (org-contacts--all-contacts)))))
- (concat "org-contact:" name)))
-
-(defun org-contacts-link-face (path)
- "Different face color for different org-contacts link query."
- (cond
- ((string-match "/.*/" path)
- '(:background "sky blue" :overline t :slant 'italic))
- (t '(:inherit 'org-link))))
-
-(provide 'org-contacts)
-
-;;; org-contacts.el ends here
diff --git a/lisp/org-link-edit.el b/lisp/org-link-edit.el
deleted file mode 100644
index 9369dd78fe..0000000000
--- a/lisp/org-link-edit.el
+++ /dev/null
@@ -1,392 +0,0 @@
-;;; org-link-edit.el --- Slurp and barf with Org links -*- lexical-binding:
t; -*-
-
-;; Copyright (C) 2015-2021 Kyle Meyer <kyle@kyleam.com>
-
-;; Author: Kyle Meyer <kyle@kyleam.com>
-;; Homepage: https://git.kyleam.com/org-link-edit/about
-;; Keywords: convenience
-;; Version: 1.2.1
-;; Package-Requires: ((cl-lib "0.5") (org "9.3"))
-
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Org Link Edit provides Paredit-inspired slurping and barfing
-;; commands for Org link descriptions.
-;;
-;; There are four slurp and barf commands, all which operate when
-;; point is on an Org link.
-;;
-;; - org-link-edit-forward-slurp
-;; - org-link-edit-backward-slurp
-;; - org-link-edit-forward-barf
-;; - org-link-edit-backward-barf
-;;
-;; Org Link Edit doesn't bind these commands to any keys. Finding
-;; good keys for these commands is difficult because, while it's
-;; convenient to be able to quickly repeat these commands, they won't
-;; be used frequently enough to be worthy of a short, repeat-friendly
-;; binding. Using Hydra [1] provides a nice solution to this. After
-;; an initial key sequence, any of the commands will be repeatable
-;; with a single key. (Plus, you get a nice interface that displays
-;; the key for each command.) Below is one example of how you could
-;; configure this.
-;;
-;; (define-key org-mode-map YOUR-KEY
-;; (defhydra hydra-org-link-edit ()
-;; "Org Link Edit"
-;; ("j" org-link-edit-forward-slurp "forward slurp")
-;; ("k" org-link-edit-forward-barf "forward barf")
-;; ("u" org-link-edit-backward-slurp "backward slurp")
-;; ("i" org-link-edit-backward-barf "backward barf")
-;; ("q" nil "cancel")))
-;;
-;; In addition to the slurp and barf commands, the command
-;; `org-link-edit-transport-next-link' searches for the next (or
-;; previous) link and moves it to point, using the word at point or
-;; the selected region as the link's description.
-;;
-;; [1] https://github.com/abo-abo/hydra
-
-;;; Code:
-
-(require 'org)
-(require 'org-element)
-(require 'cl-lib)
-
-(defun org-link-edit--on-link-p (&optional element)
- (org-element-lineage (or element (org-element-context)) '(link) t))
-
-(defun org-link-edit--link-data ()
- "Return list with information about the link at point.
-The list includes
-- the position at the start of the link
-- the position at the end of the link
-- the link text
-- the link description (nil when on a plain link)"
- (let ((el (org-element-context)))
- (unless (org-link-edit--on-link-p el)
- (user-error "Point is not on a link"))
- (save-excursion
- (goto-char (org-element-property :begin el))
- (cond
- ;; Use match-{beginning,end} because match-end is consistently
- ;; positioned after ]], while the :end property is positioned
- ;; at the next word on the line, if one is present.
- ((looking-at org-link-bracket-re)
- (list (match-beginning 0)
- (match-end 0)
- (save-match-data
- (org-link-unescape (match-string-no-properties 1)))
- (or (match-string-no-properties 2) "")))
- ((looking-at org-link-plain-re)
- (list (match-beginning 0)
- (match-end 0)
- (match-string-no-properties 0)
- nil))
- (t
- (error "What am I looking at?"))))))
-
-(defun org-link-edit--forward-blob (n &optional no-punctuation)
- "Move forward N blobs (backward if N is negative).
-
-A block of non-whitespace characters is a blob. If
-NO-PUNCTUATION is non-nil, trailing punctuation characters are
-not considered part of the blob when going in the forward
-direction.
-
-If the edge of the buffer is reached before completing the
-movement, return nil. Otherwise, return t."
- (let* ((forward-p (> n 0))
- (nblobs (abs n))
- (skip-func (if forward-p 'skip-syntax-forward 'skip-syntax-backward))
- skip-func-retval)
- (while (/= nblobs 0)
- (funcall skip-func " ")
- (setq skip-func-retval (funcall skip-func "^ "))
- (setq nblobs (1- nblobs)))
- (when (and forward-p no-punctuation)
- (let ((punc-tail-offset (save-excursion (skip-syntax-backward "."))))
- ;; Don't consider trailing punctuation as part of the blob
- ;; unless the whole blob consists of punctuation.
- (unless (= skip-func-retval (- punc-tail-offset))
- (goto-char (+ (point) punc-tail-offset)))))
- (/= skip-func-retval 0)))
-
-;;;###autoload
-(defun org-link-edit-forward-slurp (&optional n)
- "Slurp N trailing blobs into link's description.
-
- The \[\[https://orgmode.org/\]\[Org mode\]\] site
-
- |
- v
-
- The \[\[https://orgmode.org/\]\[Org mode site\]\]
-
-A blob is a block of non-whitespace characters. When slurping
-forward, trailing punctuation characters are not considered part
-of a blob.
-
-After slurping, return the slurped text and move point to the
-beginning of the link.
-
-If N is negative, slurp leading blobs instead of trailing blobs."
- (interactive "p")
- (setq n (or n 1))
- (cond
- ((= n 0))
- ((< n 0)
- (org-link-edit-backward-slurp (- n)))
- (t
- (cl-multiple-value-bind (beg end link desc) (org-link-edit--link-data)
- (goto-char (save-excursion
- (goto-char end)
- (or (org-link-edit--forward-blob n 'no-punctuation)
- (user-error "Not enough blobs after the link"))
- (point)))
- (let ((slurped (buffer-substring-no-properties end (point))))
- (setq slurped (replace-regexp-in-string "\n+" " " slurped))
- (when (and (= (length desc) 0)
- (string-match "^\\s-+\\(.*\\)" slurped))
- (setq slurped (match-string 1 slurped)))
- (setq desc (concat desc slurped)
- end (+ end (length slurped)))
- (delete-region beg (point))
- (insert (org-link-make-string link desc))
- (goto-char beg)
- slurped)))))
-
-;;;###autoload
-(defun org-link-edit-backward-slurp (&optional n)
- "Slurp N leading blobs into link's description.
-
- The \[\[https://orgmode.org/\]\[Org mode\]\] site
-
- |
- v
-
- \[\[https://orgmode.org/\]\[The Org mode\]\] site
-
-A blob is a block of non-whitespace characters.
-
-After slurping, return the slurped text and move point to the
-beginning of the link.
-
-If N is negative, slurp trailing blobs instead of leading blobs."
- (interactive "p")
- (setq n (or n 1))
- (cond
- ((= n 0))
- ((< n 0)
- (org-link-edit-forward-slurp (- n)))
- (t
- (cl-multiple-value-bind (beg end link desc) (org-link-edit--link-data)
- (goto-char (save-excursion
- (goto-char beg)
- (or (org-link-edit--forward-blob (- n))
- (user-error "Not enough blobs before the link"))
- (point)))
- (let ((slurped (buffer-substring-no-properties (point) beg)))
- (when (and (= (length desc) 0)
- (string-match "\\(.*\\)\\s-+$" slurped))
- (setq slurped (match-string 1 slurped)))
- (setq slurped (replace-regexp-in-string "\n+" " " slurped))
- (setq desc (concat slurped desc)
- beg (- beg (length slurped)))
- (delete-region (point) end)
- (insert (org-link-make-string link desc))
- (goto-char beg)
- slurped)))))
-
-(defun org-link-edit--split-first-blobs (string n)
- "Split STRING into (N first blobs . other) cons cell.
-'N first blobs' contains all text from the start of STRING up to
-the start of the N+1 blob. 'other' includes the remaining text
-of STRING. If the number of blobs in STRING is fewer than N,
-'other' is nil."
- (when (< n 0) (user-error "N cannot be negative"))
- (with-temp-buffer
- (insert string)
- (goto-char (point-min))
- (with-syntax-table org-mode-syntax-table
- (let ((within-bound (org-link-edit--forward-blob n)))
- (skip-syntax-forward " ")
- (cons (buffer-substring 1 (point))
- (and within-bound
- (buffer-substring (point) (point-max))))))))
-
-(defun org-link-edit--split-last-blobs (string n)
- "Split STRING into (other . N last blobs) cons cell.
-'N last blobs' contains all text from the end of STRING back to
-the end of the N+1 last blob. 'other' includes the remaining
-text of STRING. If the number of blobs in STRING is fewer than
-N, 'other' is nil."
- (when (< n 0) (user-error "N cannot be negative"))
- (with-temp-buffer
- (insert string)
- (goto-char (point-max))
- (with-syntax-table org-mode-syntax-table
- (let ((within-bound (org-link-edit--forward-blob (- n))))
- (skip-syntax-backward " ")
- (cons (and within-bound
- (buffer-substring 1 (point)))
- (buffer-substring (point) (point-max)))))))
-
-;;;###autoload
-(defun org-link-edit-forward-barf (&optional n)
- "Barf N trailing blobs from link's description.
-
- The \[\[https://orgmode.org/\]\[Org mode\]\] site
-
- |
- v
-
- The \[\[https://orgmode.org/\]\[Org\]\] mode site
-
-A blob is a block of non-whitespace characters.
-
-After barfing, return the barfed text and move point to the
-beginning of the link.
-
-If N is negative, barf leading blobs instead of trailing blobs."
- (interactive "p")
- (setq n (or n 1))
- (cond
- ((= n 0))
- ((< n 0)
- (org-link-edit-backward-barf (- n)))
- (t
- (cl-multiple-value-bind (beg end link desc) (org-link-edit--link-data)
- (when (= (length desc) 0)
- (user-error "Link has no description"))
- (pcase-let ((`(,new-desc . ,barfed) (org-link-edit--split-last-blobs
- desc n)))
- (unless new-desc (user-error "Not enough blobs in description"))
- (goto-char beg)
- (delete-region beg end)
- (insert (org-link-make-string link new-desc))
- (when (string= new-desc "")
- (setq barfed (concat " " barfed)))
- (insert barfed)
- (goto-char beg)
- barfed)))))
-
-;;;###autoload
-(defun org-link-edit-backward-barf (&optional n)
- "Barf N leading blobs from link's description.
-
- The \[\[https://orgmode.org/\]\[Org mode\]\] site
-
- |
- v
-
- The Org \[\[https://orgmode.org/\]\[mode\]\] site
-
-A blob is a block of non-whitespace characters.
-
-After barfing, return the barfed text and move point to the
-beginning of the link.
-
-If N is negative, barf trailing blobs instead of leading blobs."
- (interactive "p")
- (setq n (or n 1))
- (cond
- ((= n 0))
- ((< n 0)
- (org-link-edit-forward-barf (- n)))
- (t
- (cl-multiple-value-bind (beg end link desc) (org-link-edit--link-data)
- (when (= (length desc) 0)
- (user-error "Link has no description"))
- (pcase-let ((`(,barfed . ,new-desc) (org-link-edit--split-first-blobs
- desc n)))
- (unless new-desc (user-error "Not enough blobs in description"))
- (goto-char beg)
- (delete-region beg end)
- (insert (org-link-make-string link new-desc))
- (when (string= new-desc "")
- (setq barfed (concat barfed " ")))
- (goto-char beg)
- (insert barfed)
- barfed)))))
-
-(defun org-link-edit--next-link-data (&optional previous)
- (save-excursion
- (if (funcall (if previous #'re-search-backward #'re-search-forward)
- org-link-any-re nil t)
- (org-link-edit--link-data)
- (user-error "No %s link found" (if previous "previous" "next")))))
-
-;;;###autoload
-(defun org-link-edit-transport-next-link (&optional previous beg end overwrite)
- "Move the next link to point.
-
-If the region is active, use the selected text as the link's
-description. Otherwise, use the word at point.
-
-With prefix argument PREVIOUS, move the previous link instead of
-the next link.
-
-Non-interactively, use the text between BEG and END as the
-description, moving the next (or previous) link relative to BEG
-and END. By default, refuse to overwrite an existing
-description. If OVERWRITE is `ask', prompt for confirmation
-before overwriting; for any other non-nil value, overwrite
-without asking."
- (interactive `(,current-prefix-arg
- ,@(if (use-region-p)
- (list (region-beginning) (region-end))
- (list nil nil))
- ask))
- (let ((pt (point))
- (desc-bounds (cond
- ((and beg end)
- (cons (progn (goto-char beg)
- (point-marker))
- (progn (goto-char end)
- (point-marker))))
- ((not (looking-at-p "\\s-"))
- (progn (skip-syntax-backward "w")
- (let ((beg (point-marker)))
- (skip-syntax-forward "w")
- (cons beg (point-marker))))))))
- (when (or (and desc-bounds
- (or (progn (goto-char (car desc-bounds))
- (org-link-edit--on-link-p))
- (progn (goto-char (cdr desc-bounds))
- (org-link-edit--on-link-p))))
- (progn (goto-char pt)
- (org-link-edit--on-link-p)))
- (user-error "Cannot transport next link with point on a link"))
- (goto-char (or (car desc-bounds) pt))
- (cl-multiple-value-bind (link-beg link-end link orig-desc)
- (org-link-edit--next-link-data previous)
- (unless (or (not desc-bounds)
- (= (length orig-desc) 0)
- (if (eq overwrite 'ask)
- (y-or-n-p "Overwrite existing description?")
- overwrite))
- (user-error "Link already has a description"))
- (delete-region link-beg link-end)
- (insert (org-link-make-string
- link
- (if desc-bounds
- (delete-and-extract-region (car desc-bounds)
- (cdr desc-bounds))
- orig-desc))))))
-
-(provide 'org-link-edit)
-;;; org-link-edit.el ends here
diff --git a/lisp/org-mac-link.el b/lisp/org-mac-link.el
deleted file mode 100644
index 68be8230ba..0000000000
--- a/lisp/org-mac-link.el
+++ /dev/null
@@ -1,1074 +0,0 @@
-;;; org-mac-link.el --- Insert org-mode links to items selected in various Mac
apps
-;;
-;; Copyright (c) 2010-2021 Free Software Foundation, Inc.
-;;
-;; Author: Anthony Lander <anthony.lander@gmail.com>
-;; John Wiegley <johnw@gnu.org>
-;; Christopher Suckling <suckling at gmail dot com>
-;; Daniil Frumin <difrumin@gmail.com>
-;; Alan Schmitt <alan.schmitt@polytechnique.org>
-;; Mike McLean <mike.mclean@pobox.com>
-;; Maintainer: Aimé Bertrand <aime.bertrand@macowners.club>
-;; Homepage: https://gitlab.com/aimebertrand/org-mac-link
-;;
-;; This file is not part of GNU Emacs.
-;;
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 3, or (at your option)
-;; any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
-;;
-;; Version: 1.1
-;; Keywords: org, mac, hyperlink
-;;
-;; Version: 1.2
-;; Keywords: outlook
-;; Author: Mike McLean <mike.mclean@pobox.com>
-;; Add support for Microsoft Outlook for Mac as Org mode links
-;;
-;; Version: 1.3
-;; Author: Alan Schmitt <alan.schmitt@polytechnique.org>
-;; Consistently use `org-mac-paste-applescript-links'
-;;
-;; Version 1.4
-;; Author: Mike McLean <mike.mclean@pobox.com>
-;; Make the path to Microsoft Outlook a `defcustom'
-;;
-;; Version 1.5
-;; Author: Mike McLean <mike.mclean@pobox.com>
-;; Add Support for Evernote
-;;
-;;; Commentary:
-;;
-;; This code allows you to grab either the current selected items, or
-;; the frontmost url in various mac appliations, and insert them as
-;; hyperlinks into the current org-mode document at point.
-;;
-;; This code is heavily based on, and indeed incorporates,
-;; org-mac-message.el written by John Wiegley and Christopher
-;; Suckling.
-;;
-;; Detailed comments for each application interface are inlined with
-;; the code. Here is a brief overview of how the code interacts with
-;; each application:
-;;
-;; Finder.app - grab links to the selected files in the frontmost window
-;; Mail.app - grab links to the selected messages in the message list
-;; AddressBook.app - Grab links to the selected addressbook Cards
-;; Firefox.app - Grab the url of the frontmost tab in the frontmost window
-;; Vimperator/Firefox.app - Grab the url of the frontmost tab in the frontmost
window
-;; Safari.app - Grab the url of the frontmost tab in the frontmost window
-;; Google Chrome.app - Grab the url of the frontmost tab in the frontmost
window
-;; Brave.app - Grab the url of the frontmost tab in the frontmost window
-;; Together.app - Grab links to the selected items in the library list
-;; Skim.app - Grab a link to the selected page in the topmost pdf document
-;; Microsoft Outlook.app - Grab a link to the selected message in the message
list
-;; DEVONthink Pro Office.app - Grab a link to the selected DEVONthink item(s);
open DEVONthink item by reference
-;; Evernote.app - Grab a link to the selected Evernote item(s); open Evernote
item by ID
-;;
-;;
-;; Installation:
-;;
-;; add (require 'org-mac-link) to your .emacs, and optionally bind a
-;; key to activate the link grabber menu, like this:
-;;
-;; (add-hook 'org-mode-hook (lambda ()
-;; (define-key org-mode-map (kbd "C-c g") 'org-mac-grab-link)))
-;;
-;; Usage:
-;;
-;; Type C-c g (or whatever key you defined, as above), or type M-x
-;; org-mac-grab-link RET to activate the link grabber. This will present
-;; you with a menu to choose an application from which to grab a link
-;; to insert at point. You may also type C-g to abort.
-;;
-;; Customizing:
-;;
-;; You may customize which applications appear in the grab menu by
-;; customizing the group `org-mac-link'. Changes take effect
-;; immediately.
-;;
-;;
-;;; Code:
-
-(require 'org)
-
-(defgroup org-mac-link nil
- "Options for grabbing links from Mac applications."
- :tag "Org Mac link"
- :group 'org-link)
-
-(defcustom org-mac-grab-Finder-app-p t
- "Add menu option [F]inder to grab links from the Finder."
- :tag "Grab Finder.app links"
- :group 'org-mac-link
- :type 'boolean)
-
-(defcustom org-mac-grab-Mail-app-p t
- "Add menu option [m]ail to grab links from Mail.app."
- :tag "Grab Mail.app links"
- :group 'org-mac-link
- :type 'boolean)
-
-(defcustom org-mac-grab-Outlook-app-p t
- "Add menu option [o]utlook to grab links from Microsoft Outlook.app."
- :tag "Grab Microsoft Outlook.app links"
- :group 'org-mac-link
- :type 'boolean)
-
-(defcustom org-mac-outlook-path "/Applications/Microsoft Outlook.app"
- "The path to the installed copy of Microsoft Outlook.app. Do not escape
spaces as the AppleScript call will quote this string."
- :tag "Path to Microsoft Outlook"
- :group 'org-mac-link
- :type 'string)
-
-(defcustom org-mac-grab-devonthink-app-p t
- "Add menu option [d]EVONthink to grab links from DEVONthink Pro Office.app."
- :tag "Grab DEVONthink Pro Office.app links"
- :group 'org-mac-link
- :type 'boolean)
-
-(defcustom org-mac-grab-Addressbook-app-p t
- "Add menu option [a]ddressbook to grab links from AddressBook.app."
- :tag "Grab AddressBook.app links"
- :group 'org-mac-link
- :type 'boolean)
-
-(defcustom org-mac-grab-Safari-app-p t
- "Add menu option [s]afari to grab links from Safari.app."
- :tag "Grab Safari.app links"
- :group 'org-mac-link
- :type 'boolean)
-
-(defcustom org-mac-grab-Firefox-app-p t
- "Add menu option [f]irefox to grab links from Firefox.app."
- :tag "Grab Firefox.app links"
- :group 'org-mac-link
- :type 'boolean)
-
-(defcustom org-mac-grab-Firefox+Vimperator-p nil
- "Add menu option [v]imperator to grab links from Firefox.app running the
Vimperator plugin."
- :tag "Grab Vimperator/Firefox.app links"
- :group 'org-mac-link
- :type 'boolean)
-
-(defcustom org-mac-grab-Chrome-app-p t
- "Add menu option [c]hrome to grab links from Google Chrome.app."
- :tag "Grab Google Chrome.app links"
- :group 'org-mac-link
- :type 'boolean)
-
-(defcustom org-mac-grab-Brave-app-p t
- "Add menu option [b]rave to grab links from Brave.app."
- :tag "Grab Brave.app links"
- :group 'org-mac-link
- :type 'boolean)
-
-(defcustom org-mac-grab-Together-app-p nil
- "Add menu option [t]ogether to grab links from Together.app."
- :tag "Grab Together.app links"
- :group 'org-mac-link
- :type 'boolean)
-
-(defcustom org-mac-grab-Skim-app-p
- (< 0 (length (shell-command-to-string
- "mdfind kMDItemCFBundleIdentifier ==
'net.sourceforge.skim-app.skim'")))
- "Add menu option [S]kim to grab page links from Skim.app."
- :tag "Grab Skim.app page links"
- :group 'org-mac-link
- :type 'boolean)
-
-(defcustom org-mac-Skim-highlight-selection-p nil
- "Highlight the active selection when grabbing a link from Skim.app."
- :tag "Highlight selection in Skim.app"
- :group 'org-mac-link
- :type 'boolean)
-
-(defcustom org-mac-grab-Acrobat-app-p t
- "Add menu option [A]crobat to grab page links from Acrobat.app."
- :tag "Grab Acrobat.app page links"
- :group 'org-mac-link
- :type 'boolean)
-
-(defgroup org-mac-flagged-mail nil
- "Options foring linking to flagged Mail.app messages."
- :tag "Org Mail.app"
- :group 'org-link)
-
-(defcustom org-mac-mail-account nil
- "The Mail.app account in which to search for flagged messages."
- :group 'org-mac-flagged-mail
- :type 'string)
-
-(defcustom org-mac-grab-Evernote-app-p nil
- "Add menu option [e]vernote to grab note links from Evernote.app."
- :tag "Grab Evernote.app note links"
- :group 'org-mac-link
- :type 'boolean)
-
-(defcustom org-mac-evernote-path nil
- "The path to the installed copy of Evernote.app. Do not escape spaces as the
AppleScript call will quote this string."
- :tag "Path to Evernote"
- :group 'org-mac-link
- :type 'string)
-
-(defcustom org-mac-grab-qutebrowser-app-p t
- "Add menu option [q]utebrowser to grab links from qutebrowser.app."
- :tag "Grab qutebrowser.app links"
- :group 'org-mac-link
- :type 'boolean)
-
-
-;; In mac.c, removed in Emacs 23.
-(declare-function do-applescript "org-mac-message" (script))
-(unless (fboundp 'do-applescript)
- ;; Need to fake this using shell-command-to-string
- (defun do-applescript (script)
- (let (start cmd return)
- (while (string-match "\n" script)
- (setq script (replace-match "\r" t t script)))
- (while (string-match "'" script start)
- (setq start (+ 2 (match-beginning 0))
- script (replace-match "\\'" t t script)))
- (setq cmd (concat "osascript -e '" script "'"))
- (setq return (shell-command-to-string cmd))
- (concat "\"" (org-trim return) "\""))))
-
-;;;###autoload
-(defun org-mac-grab-link ()
- "Prompt for an application to grab a link from.
-When done, go grab the link, and insert it at point."
- (interactive)
- (let* ((descriptors
- `(("F" "inder" org-mac-finder-insert-selected
,org-mac-grab-Finder-app-p)
- ("m" "ail" org-mac-message-insert-selected ,org-mac-grab-Mail-app-p)
- ("d" "EVONthink Pro Office" org-mac-devonthink-item-insert-selected
- ,org-mac-grab-devonthink-app-p)
- ("o" "utlook" org-mac-outlook-message-insert-selected
,org-mac-grab-Outlook-app-p)
- ("a" "ddressbook" org-mac-addressbook-insert-selected
,org-mac-grab-Addressbook-app-p)
- ("s" "afari" org-mac-safari-insert-frontmost-url
,org-mac-grab-Safari-app-p)
- ("f" "irefox" org-mac-firefox-insert-frontmost-url
,org-mac-grab-Firefox-app-p)
- ("v" "imperator" org-mac-vimperator-insert-frontmost-url
,org-mac-grab-Firefox+Vimperator-p)
- ("c" "hrome" org-mac-chrome-insert-frontmost-url
,org-mac-grab-Chrome-app-p)
- ("b" "rave" org-mac-brave-insert-frontmost-url
,org-mac-grab-Brave-app-p)
- ("e" "evernote" org-mac-evernote-note-insert-selected
,org-mac-grab-Evernote-app-p)
- ("t" "ogether" org-mac-together-insert-selected
,org-mac-grab-Together-app-p)
- ("S" "kim" org-mac-skim-insert-page ,org-mac-grab-Skim-app-p)
- ("A" "crobat" org-mac-acrobat-insert-page
,org-mac-grab-Acrobat-app-p)
- ("q" "utebrowser" org-mac-qutebrowser-insert-frontmost-url
,org-mac-grab-qutebrowser-app-p)))
- (menu-string (make-string 0 ?x))
- input)
-
- ;; Create the menu string for the keymap
- (mapc (lambda (descriptor)
- (when (elt descriptor 3)
- (setf menu-string (concat menu-string
- "[" (elt descriptor 0) "]"
- (elt descriptor 1) " "))))
- descriptors)
- (setf (elt menu-string (- (length menu-string) 1)) ?:)
-
- ;; Prompt the user, and grab the link
- (message menu-string)
- (setq input (read-char-exclusive))
- (mapc (lambda (descriptor)
- (let ((key (elt (elt descriptor 0) 0))
- (active (elt descriptor 3))
- (grab-function (elt descriptor 2)))
- (when (and active (eq input key))
- (call-interactively grab-function))))
- descriptors)))
-
-(defun org-mac-paste-applescript-links (as-link-list)
- "Paste in a list of links from an applescript handler.
-The links are of the form <link>::split::<name>."
- (let* ((noquote-as-link-list
- (if (string-prefix-p "\"" as-link-list)
- (substring as-link-list 1 -1)
- as-link-list))
- (link-list
- (mapcar (lambda (x) (if (string-match "\\`\"\\(.*\\)\"\\'" x)
- (setq x (match-string 1 x)))
- x)
- (split-string noquote-as-link-list "[\r\n]+")))
- split-link URL description orglink orglink-insert rtn orglink-list)
- (while link-list
- (setq split-link (split-string (pop link-list) "::split::"))
- (setq URL (car split-link))
- (setq description (cadr split-link))
- (when (not (string= URL ""))
- (setq orglink (org-make-link-string URL description))
- (push orglink orglink-list)))
- (setq rtn (mapconcat 'identity orglink-list "\n"))
- (kill-new rtn)
- rtn))
-
-
-;; Handle links from Firefox.app
-;;
-;; This code allows you to grab the current active url from the main
-;; Firefox.app window, and insert it as a link into an org-mode
-;; document. Unfortunately, firefox does not expose an applescript
-;; dictionary, so this is necessarily introduces some limitations.
-;;
-;; The applescript to grab the url from Firefox.app uses the System
-;; Events application to give focus to the firefox application, select
-;; the contents of the url bar, and copy it. It then uses the title of
-;; the window as the text of the link. There is no way to grab links
-;; from other open tabs, and further, if there is more than one window
-;; open, it is not clear which one will be used (though emperically it
-;; seems that it is always the last active window).
-
-(defun org-as-mac-firefox-get-frontmost-url ()
- (let ((result
- (do-applescript
- (concat
- "set oldClipboard to the clipboard\n"
- "set frontmostApplication to path to frontmost application\n"
- "tell application \"Firefox\"\n"
- " activate\n"
- " delay 0.15\n"
- " tell application \"System Events\"\n"
- " keystroke \"l\" using {command down}\n"
- " keystroke \"a\" using {command down}\n"
- " keystroke \"c\" using {command down}\n"
- " end tell\n"
- " delay 0.15\n"
- " set theUrl to the clipboard\n"
- " set the clipboard to oldClipboard\n"
- " set theResult to (get theUrl) & \"::split::\" & (get name of
window 1)\n"
- "end tell\n"
- "activate application (frontmostApplication as text)\n"
- "set links to {}\n"
- "copy theResult to the end of links\n"
- "return links as string\n"))))
- (car (split-string result "[\r\n]+" t))))
-
-;;;###autoload
-(defun org-mac-firefox-get-frontmost-url ()
- (interactive)
- (message "Applescript: Getting Firefox url...")
- (org-mac-paste-applescript-links (org-as-mac-firefox-get-frontmost-url)))
-
-;;;###autoload
-(defun org-mac-firefox-insert-frontmost-url ()
- (interactive)
- (insert (org-mac-firefox-get-frontmost-url)))
-
-
-;; Handle links from Google Firefox.app running the Vimperator extension
-;; Grab the frontmost url from Firefox+Vimperator. Same limitations are
-;; Firefox
-
-(defun org-as-mac-vimperator-get-frontmost-url ()
- (let ((result
- (do-applescript
- (concat
- "set oldClipboard to the clipboard\n"
- "set frontmostApplication to path to frontmost application\n"
- "tell application \"Firefox\"\n"
- " activate\n"
- " delay 0.15\n"
- " tell application \"System Events\"\n"
- " keystroke \"y\"\n"
- " end tell\n"
- " delay 0.15\n"
- " set theUrl to the clipboard\n"
- " set the clipboard to oldClipboard\n"
- " set theResult to (get theUrl) & \"::split::\" & (get name of
window 1)\n"
- "end tell\n"
- "activate application (frontmostApplication as text)\n"
- "set links to {}\n"
- "copy theResult to the end of links\n"
- "return links as string\n"))))
- (replace-regexp-in-string
- "\s+-\s+Vimperator" "" (car (split-string result "[\r\n]+" t)))))
-
-;;;###autoload
-(defun org-mac-vimperator-get-frontmost-url ()
- (interactive)
- (message "Applescript: Getting Vimperator url...")
- (org-mac-paste-applescript-links (org-as-mac-vimperator-get-frontmost-url)))
-
-;;;###autoload
-(defun org-mac-vimperator-insert-frontmost-url ()
- (interactive)
- (insert (org-mac-vimperator-get-frontmost-url)))
-
-
-;; Handle links from Google Chrome.app
-;; Grab the frontmost url from Google Chrome. Same limitations as
-;; Firefox because Chrome doesn't publish an Applescript dictionary
-
-(defun org-as-mac-chrome-get-frontmost-url ()
- (let ((result
- (do-applescript
- (concat
- "set frontmostApplication to path to frontmost application\n"
- "tell application \"Google Chrome\"\n"
- " set theUrl to get URL of active tab of first window\n"
- " set theResult to (get theUrl) & \"::split::\" & (get name of
window 1)\n"
- "end tell\n"
- "activate application (frontmostApplication as text)\n"
- "set links to {}\n"
- "copy theResult to the end of links\n"
- "return links as string\n"))))
- (replace-regexp-in-string
- "^\"\\|\"$" "" (car (split-string result "[\r\n]+" t)))))
-
-;;;###autoload
-(defun org-mac-chrome-get-frontmost-url ()
- (interactive)
- (message "Applescript: Getting Chrome url...")
- (org-mac-paste-applescript-links (org-as-mac-chrome-get-frontmost-url)))
-
-;;;###autoload
-(defun org-mac-chrome-insert-frontmost-url ()
- (interactive)
- (insert (org-mac-chrome-get-frontmost-url)))
-
-
-;; Handle links from Brave.app
-;; Grab the frontmost url from Brave. Same limitations as
-;; Firefox/Chrome because Brave doesn't publish an Applescript
-;; dictionary
-
-(defun org-as-mac-brave-get-frontmost-url ()
- (let ((result
- (do-applescript
- (concat
- "set frontmostApplication to path to frontmost application\n"
- "tell application \"Brave\"\n"
- " set theUrl to get URL of active tab of first window\n"
- " set theResult to (get theUrl) & \"::split::\" & (get name of
window 1)\n"
- "end tell\n"
- "activate application (frontmostApplication as text)\n"
- "set links to {}\n"
- "copy theResult to the end of links\n"
- "return links as string\n"))))
- (replace-regexp-in-string
- "^\"\\|\"$" "" (car (split-string result "[\r\n]+" t)))))
-
-;;;###autoload
-(defun org-mac-brave-get-frontmost-url ()
- (interactive)
- (message "Applescript: Getting Brave url...")
- (org-mac-paste-applescript-links (org-as-mac-brave-get-frontmost-url)))
-
-;;;###autoload
-(defun org-mac-brave-insert-frontmost-url ()
- (interactive)
- (insert (org-mac-brave-get-frontmost-url)))
-
-
-;; Handle links from Safari.app
-;; Grab the frontmost url from Safari.
-
-(defun org-as-mac-safari-get-frontmost-url ()
- (do-applescript
- (concat
- "tell application \"Safari\"\n"
- " set theUrl to URL of document 1\n"
- " set theName to the name of the document 1\n"
- " return theUrl & \"::split::\" & theName & \"\n\"\n"
- "end tell\n")))
-
-;;;###autoload
-(defun org-mac-safari-get-frontmost-url ()
- (interactive)
- (message "Applescript: Getting Safari url...")
- (org-mac-paste-applescript-links
- (org-as-mac-safari-get-frontmost-url)))
-
-;;;###autoload
-(defun org-mac-safari-insert-frontmost-url ()
- (interactive)
- (insert (org-mac-safari-get-frontmost-url)))
-
-
-;; Handle links from together.app
-(org-link-set-parameters "x-together-item" :follow
#'org-mac-together-item-open)
-
-(defun org-mac-together-item-open (uid _)
- "Open UID, which is a reference to an item in Together."
- (shell-command (concat "open -a Together \"x-together-item:" uid "\"")))
-
-(defun as-get-selected-together-items ()
- (do-applescript
- (concat
- "tell application \"Together\"\n"
- " set theLinkList to {}\n"
- " set theSelection to selected items\n"
- " repeat with theItem in theSelection\n"
- " set theLink to (get item link of theItem) & \"::split::\" &
(get name of theItem) & \"\n\"\n"
- " copy theLink to end of theLinkList\n"
- " end repeat\n"
- " return theLinkList as string\n"
- "end tell")))
-
-;;;###autoload
-(defun org-mac-together-get-selected ()
- (interactive)
- (message "Applescript: Getting Together items...")
- (org-mac-paste-applescript-links (as-get-selected-together-items)))
-
-;;;###autoload
-(defun org-mac-together-insert-selected ()
- (interactive)
- (insert (org-mac-together-get-selected)))
-
-
-;; Handle links from Finder.app
-
-(defun as-get-selected-finder-items ()
- (do-applescript
- (concat
- "tell application \"Finder\"\n"
- " set theSelection to the selection\n"
- " set links to {}\n"
- " repeat with theItem in theSelection\n"
- " set theLink to \"file://\" & (POSIX path of (theItem as string)) &
\"::split::\" & (get the name of theItem) & \"\n\"\n"
- " copy theLink to the end of links\n"
- " end repeat\n"
- " return links as string\n"
- "end tell\n")))
-
-;;;###autoload
-(defun org-mac-finder-item-get-selected ()
- (interactive)
- (message "Applescript: Getting Finder items...")
- (org-mac-paste-applescript-links (as-get-selected-finder-items)))
-
-;;;###autoload
-(defun org-mac-finder-insert-selected ()
- (interactive)
- (insert (org-mac-finder-item-get-selected)))
-
-
-;; Handle links from AddressBook.app
-(org-link-set-parameters "addressbook" :follow #'org-mac-addressbook-item-open)
-
-(defun org-mac-addressbook-item-open (uid _)
- "Open UID, which is a reference to an item in the addressbook."
- (shell-command (concat "open \"addressbook:" uid "\"")))
-
-(defun as-get-selected-addressbook-items ()
- (do-applescript
- (concat
- "tell application \"Address Book\"\n"
- " set theSelection to the selection\n"
- " set links to {}\n"
- " repeat with theItem in theSelection\n"
- " set theLink to \"addressbook://\" & (the id of theItem) &
\"::split::\" & (the name of theItem) & \"\n\"\n"
- " copy theLink to the end of links\n"
- " end repeat\n"
- " return links as string\n"
- "end tell\n")))
-
-;;;###autoload
-(defun org-mac-addressbook-item-get-selected ()
- (interactive)
- (message "Applescript: Getting Address Book items...")
- (org-mac-paste-applescript-links (as-get-selected-addressbook-items)))
-
-;;;###autoload
-(defun org-mac-addressbook-insert-selected ()
- (interactive)
- (insert (org-mac-addressbook-item-get-selected)))
-
-
-;; Handle links from Skim.app
-;;
-;; Original code & idea by Christopher Suckling (org-mac-protocol)
-
-(org-link-set-parameters "skim" :follow #'org-mac-skim-open)
-
-(defun org-mac-skim-open (uri _)
- "Visit page of pdf in Skim"
- (let* ((page (when (string-match "::\\(.+\\)\\'" uri)
- (match-string 1 uri)))
- (document (substring uri 0 (match-beginning 0))))
- (do-applescript
- (concat
- "tell application \"Skim\"\n"
- "activate\n"
- "set theDoc to \"" document "\"\n"
- "set thePage to " page "\n"
- "open theDoc\n"
- "go document 1 to page thePage of document 1\n"
- "end tell"))))
-
-(defun as-get-skim-page-link ()
- (do-applescript
- (concat
- "tell application \"Skim\"\n"
- "set theDoc to front document\n"
- "set theTitle to (name of theDoc)\n"
- "set thePath to (path of theDoc)\n"
- "set thePage to (get index for current page of theDoc)\n"
- "set theSelection to selection of theDoc\n"
- "set theContent to contents of (get text for theSelection)\n"
- "if theContent is missing value then\n"
- " set theContent to theTitle & \", p. \" & thePage\n"
- (when org-mac-Skim-highlight-selection-p
- (concat
- "else\n"
- " tell theDoc\n"
- " set theNote to make note with properties {type:highlight note,
selection:theSelection}\n"
- " set text of theNote to (get text for theSelection)\n"
- " end tell\n"))
- "end if\n"
- "set theLink to \"skim://\" & thePath & \"::\" & thePage & "
- "\"::split::\" & theContent\n"
- "end tell\n"
- "return theLink as string\n")))
-
-;;;###autoload
-(defun org-mac-skim-get-page ()
- (interactive)
- (message "Applescript: Getting Skim page link...")
- (org-mac-paste-applescript-links (as-get-skim-page-link)))
-
-;;;###autoload
-(defun org-mac-skim-insert-page ()
- (interactive)
- (insert (org-mac-skim-get-page)))
-
-;; Handle links from Adobe Acrobat Pro.app
-;;
-;; Original code & idea by Christopher Suckling (org-mac-protocol)
-;;
-;; The URI format is path_to_pdf_file::page_number
-
-(org-link-set-parameters "acrobat" :follow #'org-mac-acrobat-open)
-
-(defun org-mac-acrobat-open (uri _)
- "Visit page of pdf in Acrobat"
- (let* ((page (when (string-match "::\\(.+\\)\\'" uri)
- (match-string 1 uri)))
- (document (substring uri 0 (match-beginning 0))))
- (do-applescript
- (concat
- "tell application \"Adobe Acrobat Pro\"\n"
- " activate\n"
- " set theDoc to \"" document "\"\n"
- " set thePage to " page "\n"
- " open theDoc\n"
- " tell PDF Window 1\n"
- " goto page thePage\n"
- " end tell\n"
- "end tell"))))
-
-;; The applescript returns link in the format
-;; "adobe:path_to_pdf_file::page_number::split::document_title, p.page_label"
-
-(defun org-mac-as-get-acrobat-page-link ()
- (do-applescript
- (concat
- "tell application \"Adobe Acrobat Pro\"\n"
- " set theDoc to active doc\n"
- " set theWindow to (PDF Window 1 of theDoc)\n"
- " set thePath to (file alias of theDoc)\n"
- " set theTitle to (name of theWindow)\n"
- " set thePage to (page number of theWindow)\n"
- " set theLabel to (label text of (page thePage of theWindow))\n"
- "end tell\n"
- "set theResult to \"acrobat:\" & thePath & \"::\" & thePage &
\"::split::\" & theTitle & \", p.\" & theLabel\n"
- "return theResult as string\n")))
-
-;;;###autoload
-(defun org-mac-acrobat-get-page ()
- (interactive)
- (message "Applescript: Getting Acrobat page link...")
- (org-mac-paste-applescript-links (org-mac-as-get-acrobat-page-link)))
-
-;;;###autoload
-(defun org-mac-acrobat-insert-page ()
- (interactive)
- (insert (org-mac-acrobat-get-page)))
-
-
-;; Handle links from Microsoft Outlook.app
-
-(org-link-set-parameters "mac-outlook" :follow #'org-mac-outlook-message-open)
-
-(defun org-mac-outlook-message-open (msgid _)
- "Open a message in Outlook"
- (do-applescript
- (concat
- "tell application \"" org-mac-outlook-path "\"\n"
- (format "open message id %s\n" (substring-no-properties msgid))
- "activate\n"
- "end tell")))
-
-(defun org-as-get-selected-outlook-mail ()
- "AppleScript to create links to selected messages in Microsoft Outlook.app."
- (do-applescript
- (concat
- "tell application \"" org-mac-outlook-path "\"\n"
- "set msgCount to count current messages\n"
- "if (msgCount < 1) then\n"
- "return\n"
- "end if\n"
- "set theLinkList to {}\n"
- "set theSelection to (get current messages)\n"
- "repeat with theMessage in theSelection\n"
- "set theID to id of theMessage as string\n"
- "set theURL to \"mac-outlook:\" & theID\n"
- "set theSubject to subject of theMessage\n"
- "set theLink to theURL & \"::split::\" & theSubject & \"\n\"\n"
- "copy theLink to end of theLinkList\n"
- "end repeat\n"
- "return theLinkList as string\n"
- "end tell")))
-
-(defun org-sh-get-flagged-outlook-mail ()
- "Shell commands to create links to flagged messages in Microsoft
Outlook.app."
- (mapconcat
- (lambda (x) ""
- (concat
- "mac-outlook:"
- (mapconcat
- (lambda (y) "" y)
- (split-string
- (shell-command-to-string
- (format "mdls -raw -name com_microsoft_outlook_recordID -name
kMDItemDisplayName \"%s\"" x))
- "\000")
- "::split::")
- "\n"))
- (with-temp-buffer
- (let ((coding-system-for-read (or file-name-coding-system 'utf-8))
- (coding-system-for-write 'utf-8))
- (shell-command
- "mdfind com_microsoft_outlook_flagged==1"
- (current-buffer)))
- (split-string
- (buffer-string) "\n" t))
- ""))
-
-;;;###autoload
-(defun org-mac-outlook-message-get-links (&optional select-or-flag)
- "Create links to the messages currently selected or flagged in Microsoft
Outlook.app.
-This will use AppleScript to get the message-id and the subject of the
-messages in Microsoft Outlook.app and make a link out of it.
-When SELECT-OR-FLAG is \"s\", get the selected messages (this is also
-the default). When SELECT-OR-FLAG is \"f\", get the flagged messages.
-The Org-syntax text will be pushed to the kill ring, and also returned."
- (interactive "sLink to (s)elected or (f)lagged messages: ")
- (setq select-or-flag (or select-or-flag "s"))
- (message "Org Mac Outlook: searching mailboxes...")
- (org-mac-paste-applescript-links
- (if (string= select-or-flag "s")
- (org-as-get-selected-outlook-mail)
- (if (string= select-or-flag "f")
- (org-sh-get-flagged-outlook-mail)
- (error "Please select \"s\" or \"f\"")))))
-
-;;;###autoload
-(defun org-mac-outlook-message-insert-selected ()
- "Insert a link to the messages currently selected in Microsoft Outlook.app.
-This will use AppleScript to get the message-id and the subject
-of the active mail in Microsoft Outlook.app and make a link out
-of it."
- (interactive)
- (insert (org-mac-outlook-message-get-links "s")))
-
-;;;###autoload
-(defun org-mac-outlook-message-insert-flagged (org-buffer org-heading)
- "Asks for an org buffer and a heading within it, and replace message links.
-If heading exists, delete all mac-outlook:// links within
-heading's first level. If heading doesn't exist, create it at
-point-max. Insert list of mac-outlook:// links to flagged mail
-after heading."
- (interactive "bBuffer in which to insert links: \nsHeading after which to
insert links: ")
- (with-current-buffer org-buffer
- (goto-char (point-min))
- (let ((isearch-forward t)
- (message-re
"\\[\\[\\(mac-outlook:\\)\\([^]]+\\)\\]\\(\\[\\([^]]+\\)\\]\\)?\\]"))
- (if (org-goto-local-search-headings org-heading nil t)
- (if (not (eobp))
- (progn
- (save-excursion
- (while (re-search-forward
- message-re (save-excursion (outline-next-heading)) t)
- (delete-region (match-beginning 0) (match-end 0)))
- (insert "\n" (org-mac-outlook-message-get-links "f")))
- (flush-lines "^$" (point) (outline-next-heading)))
- (insert "\n" (org-mac-outlook-message-get-links "f")))
- (goto-char (point-max))
- (insert "\n")
- (org-insert-heading nil t)
- (insert org-heading "\n" (org-mac-outlook-message-get-links "f"))))))
-
-;; Handle links from Evernote.app
-
-(org-link-set-parameters "mac-evernote" :follow #'org-mac-evernote-note-open)
-
-(defun org-mac-evernote-path ()
- "Get path to evernote.
-First consider the value of ORG-MAC-EVERNOTE-PATH, then attempt to find it.
-Finding the path can be slow."
- (or org-mac-evernote-path
- (replace-regexp-in-string (rx (* (any " \t\n")) eos)
- ""
- (shell-command-to-string
- "mdfind kMDItemCFBundleIdentifier ==
'com.evernote.Evernote'"))))
-
-(defun org-mac-evernote-note-open (noteid _)
- "Open a note in Evernote"
- (do-applescript
- (concat
- "tell application \"" (org-mac-evernote-path) "\"\n"
- " set theNotes to get every note of every notebook where its local id
is \"" (substring-no-properties noteid) "\"\n"
- " repeat with _note in theNotes\n"
- " if length of _note is not 0 then\n"
- " set _selectedNote to _note\n"
- " end if\n"
- " end repeat\n"
- " open note window with item 1 of _selectedNote\n"
- " activate\n"
- "end tell")))
-
-(defun org-as-get-selected-evernote-notes ()
- "AppleScript to create links to selected notes in Evernote.app."
- (do-applescript
- (concat
- "tell application \"" (org-mac-evernote-path) "\"\n"
- " set noteCount to count selection\n"
- " if (noteCount < 1) then\n"
- " return\n"
- " end if\n"
- " set theLinkList to {}\n"
- " set theSelection to selection\n"
- " repeat with theNote in theSelection\n"
- " set theTitle to title of theNote\n"
- " set theID to local id of theNote\n"
- " set theURL to \"mac-evernote:\" & theID\n"
- " set theLink to theURL & \"::split::\" & theTitle & \"\n\"\n"
- " copy theLink to end of theLinkList\n"
- " end repeat\n"
- " return theLinkList as string\n"
- "end tell\n")))
-
-;;;###autoload
-(defun org-mac-evernote-note-insert-selected ()
- "Insert a link to the notes currently selected in Evernote.app.
-This will use AppleScript to get the note id and the title of the
-note(s) in Evernote.app and make a link out of it/them."
- (interactive)
- (message "Org Mac Evernote: searching notes...")
-(insert (org-mac-paste-applescript-links
- (org-as-get-selected-evernote-notes))))
-
-
-;; Handle links from DEVONthink Pro Office.app
-
-(org-link-set-parameters "x-devonthink-item" :follow
#'org-devonthink-item-open)
-
-(defun org-devonthink-item-open (uid _)
- "Open UID, which is a reference to an item in DEVONthink Pro Office."
- (shell-command (concat "open \"x-devonthink-item:" uid "\"")))
-
-(defun org-as-get-selected-devonthink-item ()
- "AppleScript to create links to selected items in DEVONthink Pro Office.app."
- (do-applescript
- (concat
- "set theLinkList to {}\n"
- "tell application \"DEVONthink Pro\"\n"
- "set selectedRecords to selection\n"
- "set selectionCount to count of selectedRecords\n"
- "if (selectionCount < 1) then\n"
- "return\n"
- "end if\n"
- "repeat with theRecord in selectedRecords\n"
- "set theID to uuid of theRecord\n"
- "set theURL to \"x-devonthink-item:\" & theID\n"
- "set theSubject to name of theRecord\n"
- "set theLink to theURL & \"::split::\" & theSubject & \"\n\"\n"
- "copy theLink to end of theLinkList\n"
- "end repeat\n"
- "end tell\n"
- "return theLinkList as string"
- )))
-
-(defun org-mac-devonthink-get-links ()
- "Create links to the item(s) currently selected in DEVONthink Pro Office.
-This will use AppleScript to get the `uuid' and the `name' of the
-selected items in DEVONthink Pro Office.app and make links out of
-it/them. This function will push the Org-syntax text to the kill
-ring, and also return it."
- (message "Org Mac DEVONthink: looking for selected items...")
- (org-mac-paste-applescript-links (org-as-get-selected-devonthink-item)))
-
-;;;###autoload
-(defun org-mac-devonthink-item-insert-selected ()
- "Insert a link to the item(s) currently selected in DEVONthink Pro Office.
-This will use AppleScript to get the `uuid'(s) and the name(s) of the
-selected items in DEVONthink Pro Office and make link(s) out of it/them."
- (interactive)
- (insert (org-mac-devonthink-get-links)))
-
-
-;; Handle links from Mail.app
-
-(org-link-set-parameters "message" :follow #'org-mac-message-open)
-
-(defun org-mac-message-open (message-id _)
- "Visit the message with MESSAGE-ID.
-This will use the command `open' with the message URL."
- (start-process (concat "open message:" message-id) nil
- "open" (concat "message://%3C" (substring message-id 2)
"%3E")))
-
-(defun org-as-get-selected-mail ()
- "AppleScript to create links to selected messages in Mail.app."
- (do-applescript
- (concat
- "tell application \"Mail\"\n"
- "set theLinkList to {}\n"
- "set theSelection to selection\n"
- "repeat with theMessage in theSelection\n"
- "set theID to message id of theMessage\n"
- "set theSubject to subject of theMessage\n"
- "set theLink to \"message://\" & theID & \"::split::\" & theSubject\n"
- "if (theLinkList is not equal to {}) then\n"
- "set theLink to \"\n\" & theLink\n"
- "end if\n"
- "copy theLink to end of theLinkList\n"
- "end repeat\n"
- "return theLinkList as string\n"
- "end tell")))
-
-(defun org-as-get-flagged-mail ()
- "AppleScript to create links to flagged messages in Mail.app."
- (unless org-mac-mail-account
- (error "You must set org-mac-mail-account"))
- (do-applescript
- (concat
- ;; Get links
- "tell application \"Mail\"\n"
- "set theMailboxes to every mailbox of account \"" org-mac-mail-account
"\"\n"
- "set theLinkList to {}\n"
- "repeat with aMailbox in theMailboxes\n"
- "set theSelection to (every message in aMailbox whose flagged status =
true)\n"
- "repeat with theMessage in theSelection\n"
- "set theID to message id of theMessage\n"
- "set theSubject to subject of theMessage\n"
- "set theLink to \"message://\" & theID & \"::split::\" & theSubject &
\"\n\"\n"
- "copy theLink to end of theLinkList\n"
- "end repeat\n"
- "end repeat\n"
- "return theLinkList as string\n"
- "end tell")))
-
-;;;###autoload
-(defun org-mac-message-get-links (&optional select-or-flag)
- "Create links to the messages currently selected or flagged in Mail.app.
-This will use AppleScript to get the message-id and the subject of the
-messages in Mail.app and make a link out of it.
-When SELECT-OR-FLAG is \"s\", get the selected messages (this is also
-the default). When SELECT-OR-FLAG is \"f\", get the flagged messages.
-The Org-syntax text will be pushed to the kill ring, and also returned."
- (interactive "sLink to (s)elected or (f)lagged messages: ")
- (setq select-or-flag (or select-or-flag "s"))
- (message "AppleScript: searching mailboxes...")
- (org-mac-paste-applescript-links
- (cond
- ((string= select-or-flag "s") (org-as-get-selected-mail))
- ((string= select-or-flag "f") (org-as-get-flagged-mail))
- (t (error "Please select \"s\" or \"f\"")))))
-
-;;;###autoload
-(defun org-mac-message-insert-selected ()
- "Insert a link to the messages currently selected in Mail.app.
-This will use AppleScript to get the message-id and the subject of the
-active mail in Mail.app and make a link out of it."
- (interactive)
- (insert (org-mac-message-get-links "s")))
-
-;; The following line is for backward compatibility
-(defalias 'org-mac-message-insert-link 'org-mac-message-insert-selected)
-
-;;;###autoload
-(defun org-mac-message-insert-flagged (org-buffer org-heading)
- "Asks for an org buffer and a heading within it, and replace message links.
-If heading exists, delete all message:// links within heading's first
-level. If heading doesn't exist, create it at point-max. Insert
-list of message:// links to flagged mail after heading."
- (interactive "bBuffer in which to insert links: \nsHeading after which to
insert links: ")
- (with-current-buffer org-buffer
- (goto-char (point-min))
- (let ((isearch-forward t)
- (message-re
"\\[\\[\\(message:\\)\\([^]]+\\)\\]\\(\\[\\([^]]+\\)\\]\\)?\\]"))
- (if (org-goto-local-search-headings org-heading nil t)
- (if (not (eobp))
- (progn
- (save-excursion
- (while (re-search-forward
- message-re (save-excursion (outline-next-heading)) t)
- (delete-region (match-beginning 0) (match-end 0)))
- (insert "\n" (org-mac-message-get-links "f")))
- (flush-lines "^$" (point) (outline-next-heading)))
- (insert "\n" (org-mac-message-get-links "f")))
- (goto-char (point-max))
- (insert "\n")
- (org-insert-heading nil t)
- (insert org-heading "\n" (org-mac-message-get-links "f"))))))
-
-
-;; Handle links from qutebrowser.app
-
-(defun org-as-mac-qutebrowser-get-frontmost-url ()
- (let ((result
- (do-applescript
- (concat
- "set oldClipboard to the clipboard\n"
- "set frontmostApplication to path to frontmost application\n"
- "tell application \"qutebrowser\"\n"
- " activate\n"
- " delay 0.15\n"
- " tell application \"System Events\"\n"
- " keystroke \"y\"\n"
- " keystroke \"y\"\n"
- " end tell\n"
- " delay 0.15\n"
- " set theUrl to the clipboard\n"
- " set the clipboard to oldClipboard\n"
- " delay 0.15\n"
- " tell application \"System Events\"\n"
- " keystroke \"y\"\n"
- " keystroke \"T\"\n"
- " end tell\n"
- " delay 0.15\n"
- " set theTitle to the clipboard\n"
- " set the clipboard to oldClipboard\n"
- " set theResult to (get theUrl) & \"::split::\" & (get
theTitle)\n"
- "end tell\n"
- "activate application (frontmostApplication as text)\n"
- "set links to {}\n"
- "copy theResult to the end of links\n"
- "return links as string\n"))))
- (car (split-string result "[\r\n]+" t))))
-
-;;;###autoload
-(defun org-mac-qutebrowser-get-frontmost-url ()
- (interactive)
- (message "Applescript: Getting qutebrowser url...")
- (org-mac-paste-applescript-links (org-as-mac-qutebrowser-get-frontmost-url)))
-
-;;;###autoload
-(defun org-mac-qutebrowser-insert-frontmost-url ()
- (interactive)
- (insert (org-mac-qutebrowser-get-frontmost-url)))
-
-
-(provide 'org-mac-link)
-
-;;; org-mac-link.el ends here
diff --git a/lisp/org-notify.el b/lisp/org-notify.el
deleted file mode 100644
index cee4ea46df..0000000000
--- a/lisp/org-notify.el
+++ /dev/null
@@ -1,407 +0,0 @@
-;;; org-notify.el --- Notifications for Org-mode
-
-;; Copyright (C) 2012-2021 Free Software Foundation, Inc.
-
-;; Author: Peter Münster <pmrb@free.fr>
-;; Homepage: https://github.com/p-m/org-notify
-;; Keywords: notification, todo-list, alarm, reminder, pop-up
-
-;; This file is not part of GNU Emacs.
-
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Get notifications, when there is something to do.
-;; Sometimes, you need a reminder a few days before a deadline, e.g. to buy a
-;; present for a birthday, and then another notification one hour before to
-;; have enough time to choose the right clothes.
-;; For other events, e.g. rolling the dustbin to the roadside once per week,
-;; you probably need another kind of notification strategy.
-;; This package tries to satisfy the various needs.
-
-;; In order to activate this package, you must add the following code
-;; into your .emacs:
-;;
-;; (require 'org-notify)
-;; (org-notify-start)
-
-;; Example setup:
-;;
-;; (org-notify-add 'appt
-;; '(:time "-1s" :period "20s" :duration 10
-;; :actions (-message -ding))
-;; '(:time "15m" :period "2m" :duration 100
-;; :actions -notify)
-;; '(:time "2h" :period "5m" :actions -message)
-;; '(:time "3d" :actions -email))
-;;
-;; This means for todo-items with `notify' property set to `appt': 3 days
-;; before deadline, send a reminder-email, 2 hours before deadline, start to
-;; send messages every 5 minutes, then 15 minutes before deadline, start to
-;; pop up notification windows every 2 minutes. The timeout of the window is
-;; set to 100 seconds. Finally, when deadline is overdue, send messages and
-;; make noise."
-
-;; Take also a look at the function `org-notify-add'.
-
-;;; Code:
-
-(eval-when-compile (require 'cl-lib))
-(require 'org-element)
-
-(declare-function appt-delete-window "appt" ())
-(declare-function notifications-notify "notifications" (&rest prms))
-(declare-function article-lapsed-string "gnus-art" (t &optional ms))
-
-(defgroup org-notify nil
- "Options for Org-mode notifications."
- :tag "Org Notify"
- :group 'org)
-
-(defcustom org-notify-audible t
- "Non-nil means beep to indicate notification."
- :type 'boolean
- :group 'org-notify)
-
-(defcustom org-notify-max-notifications-per-run 3
- "Maximum number of notifications per run of `org-notify-process'."
- :type 'integer
- :group 'org-notify)
-
-(defconst org-notify-actions
- '("show" "show" "done" "done" "hour" "one hour later" "day" "one day later"
- "week" "one week later")
- "Possible actions for call-back functions.")
-
-(defconst org-notify-window-buffer-name "*org-notify-%s*"
- "Buffer-name for the `org-notify-action-window' function.")
-
-(defvar org-notify-map nil
- "Mapping between names and parameter lists.")
-
-(defvar org-notify-timer nil
- "Timer of the notification daemon.")
-
-(defvar org-notify-parse-file nil
- "Index of current file, that `org-element-parse-buffer' is parsing.")
-
-(defvar org-notify-on-action-map nil
- "Mapping between on-action identifiers and parameter lists.")
-
-(defun org-notify-string->seconds (str)
- "Convert time string STR to number of seconds."
- (when str
- (let* ((conv `(("s" . 1) ("m" . 60) ("h" . ,(* 60 60))
- ("d" . ,(* 24 60 60)) ("w" . ,(* 7 24 60 60))
- ("M" . ,(* 30 24 60 60))))
- (letters (concat
- (mapcar (lambda (x) (string-to-char (car x))) conv)))
- (case-fold-search nil))
- (string-match (concat "\\(-?\\)\\([0-9]+\\)\\([" letters "]\\)") str)
- (* (string-to-number (match-string 2 str))
- (cdr (assoc (match-string 3 str) conv))
- (if (= (length (match-string 1 str)) 1) -1 1)))))
-
-(defun org-notify-convert-deadline (orig)
- "Convert original deadline from `org-element-parse-buffer' to
-simple timestamp string."
- (if orig
- (replace-regexp-in-string "^<\\|>$" ""
- (plist-get (plist-get orig 'timestamp)
- :raw-value))))
-
-(defun org-notify-make-todo (heading &rest ignored)
- "Create one todo item."
- (cl-macrolet ((get (k) `(plist-get list ,k))
- (pr (k v) `(setq result (plist-put result ,k ,v))))
- (let* ((list (nth 1 heading)) (notify (or (get :NOTIFY) "default"))
- (deadline (org-notify-convert-deadline (get :deadline)))
- (heading (get :raw-value))
- result)
- (when (and (eq (get :todo-type) 'todo) heading deadline)
- (pr :heading heading) (pr :notify (intern notify))
- (pr :begin (get :begin))
- (pr :file (nth org-notify-parse-file (org-agenda-files 'unrestricted)))
- (pr :timestamp deadline) (pr :uid (md5 (concat heading deadline)))
- (pr :deadline (- (org-time-string-to-seconds deadline)
- (float-time))))
- result)))
-
-(defun org-notify-todo-list ()
- "Create the todo-list for one org-agenda file."
- (let* ((files (org-agenda-files 'unrestricted))
- (max (1- (length files))))
- (when files
- (setq org-notify-parse-file
- (if (or (not org-notify-parse-file) (>= org-notify-parse-file max))
- 0
- (1+ org-notify-parse-file)))
- (save-excursion
- (with-current-buffer (find-file-noselect
- (nth org-notify-parse-file files))
- (org-element-map (org-element-parse-buffer 'headline)
- 'headline 'org-notify-make-todo))))))
-
-(defun org-notify-maybe-too-late (diff period heading)
- "Print warning message, when notified significantly later than defined by
-PERIOD."
- (if (> (/ diff period) 1.5)
- (message "Warning: notification for \"%s\" behind schedule!" heading))
- t)
-
-(cl-defun org-notify-process ()
- "Process the todo-list, and possibly notify user about upcoming or
-forgotten tasks."
- (let ((notification-cnt 0))
- (cl-macrolet ((prm (k) `(plist-get prms ,k)) (td (k) `(plist-get todo
,k)))
- (dolist (todo (org-notify-todo-list))
- (let* ((deadline (td :deadline)) (heading (td :heading))
- (uid (td :uid)) (last-run-sym
- (intern (concat ":last-run-" uid))))
- (cl-dolist (prms (plist-get org-notify-map (td :notify)))
- (when (< deadline (org-notify-string->seconds (prm :time)))
- (let ((period (org-notify-string->seconds (prm :period)))
- (last-run (prm last-run-sym)) (now (float-time))
- (actions (prm :actions)) diff plist)
- (when (or (not last-run)
- (and period (< period (setq diff (- now last-run)))
- (org-notify-maybe-too-late diff period
heading)))
- (setq prms (plist-put prms last-run-sym now)
- plist (append todo prms))
- (if (if (plist-member prms :audible)
- (prm :audible)
- org-notify-audible)
- (ding))
- (unless (listp actions)
- (setq actions (list actions)))
- (cl-incf notification-cnt)
- (dolist (action actions)
- (funcall (if (fboundp action) action
- (intern (concat "org-notify-action"
- (symbol-name action))))
- plist))
- (when (>= notification-cnt
org-notify-max-notifications-per-run)
- (cl-return-from org-notify-process)))
- (cl-return)))))))))
-
-(defun org-notify-add (name &rest params)
- "Add a new notification type.
-The NAME can be used in Org-mode property `notify'. If NAME is
-`default', the notification type applies for todo items without
-the `notify' property. This file predefines such a default
-notification type.
-
-Each element of PARAMS is a list with parameters for a given time
-distance to the deadline. This distance must increase from one
-element to the next.
-
-List of possible parameters:
-
- :time Time distance to deadline, when this type of notification shall
- start. It's a string: an integral value (positive or negative)
- followed by a unit (s, m, h, d, w, M).
- :actions A function or a list of functions to be called to notify the
- user. Instead of a function name, you can also supply a suffix
- of one of the various predefined `org-notify-action-xxx'
- functions.
- :period Optional: can be used to repeat the actions periodically.
- Same format as :time.
- :duration Some actions use this parameter to specify the duration of the
- notification. It's an integral number in seconds.
- :audible Overwrite the value of `org-notify-audible' for this action.
-
-For the actions, you can use your own functions or some of the predefined
-ones, whose names are prefixed with `org-notify-action-'."
- (setq org-notify-map (plist-put org-notify-map name params)))
-
-(defun org-notify-start (&optional secs)
- "Start the notification daemon.
-If SECS is positive, it's the period in seconds for processing
-the notifications of one org-agenda file, and if negative,
-notifications will be checked only when emacs is idle for -SECS
-seconds. The default value for SECS is 20."
- (interactive)
- (if org-notify-timer
- (org-notify-stop))
- (setq secs (or secs 20)
- org-notify-timer (if (< secs 0)
- (run-with-idle-timer (* -1 secs) t
- 'org-notify-process)
- (run-with-timer secs secs 'org-notify-process))))
-
-(defun org-notify-stop ()
- "Stop the notification daemon."
- (when org-notify-timer
- (cancel-timer org-notify-timer)
- (setq org-notify-timer nil)))
-
-(defun org-notify-on-action (plist key)
- "User wants to see action."
- (let ((file (plist-get plist :file))
- (begin (plist-get plist :begin)))
- (if (string-equal key "show")
- (progn
- (switch-to-buffer (find-file-noselect file))
- (org-with-wide-buffer
- (goto-char begin)
- (outline-show-entry))
- (goto-char begin)
- (search-forward "DEADLINE: <")
- (search-forward ":")
- (if (display-graphic-p)
- (x-focus-frame nil)))
- (save-excursion
- (with-current-buffer (find-file-noselect file)
- (org-with-wide-buffer
- (goto-char begin)
- (search-forward "DEADLINE: <")
- (cond
- ((string-equal key "done") (org-todo))
- ((string-equal key "hour") (org-timestamp-change 60 'minute))
- ((string-equal key "day") (org-timestamp-up-day))
- ((string-equal key "week") (org-timestamp-change 7 'day)))))))))
-
-(defun org-notify-on-action-notify (id key)
- "User wants to see action after mouse-click in notify window."
- (org-notify-on-action (plist-get org-notify-on-action-map id) key)
- (org-notify-on-close id nil))
-
-(defun org-notify-on-action-button (button)
- "User wants to see action after button activation."
- (cl-macrolet ((get (k) `(button-get button ,k)))
- (org-notify-on-action (get 'plist) (get 'key))
- (org-notify-delete-window (get 'buffer))
- (cancel-timer (get 'timer))))
-
-(defun org-notify-delete-window (buffer)
- "Delete the notification window."
- (require 'appt)
- (let ((appt-buffer-name buffer)
- (appt-audible nil))
- (appt-delete-window)))
-
-(defun org-notify-on-close (id reason)
- "Notification window has been closed."
- (setq org-notify-on-action-map (plist-put org-notify-on-action-map id nil)))
-
-(defun org-notify-action-message (plist)
- "Print a message."
- (message "TODO: \"%s\" at %s!" (plist-get plist :heading)
- (plist-get plist :timestamp)))
-
-(defun org-notify-action-ding (plist)
- "Make noise."
- (let ((timer (run-with-timer 0 1 'ding)))
- (run-with-timer (or (plist-get plist :duration) 3) nil
- 'cancel-timer timer)))
-
-(defun org-notify-body-text (plist)
- "Make human readable string for remaining time to deadline."
- (require 'gnus-art)
- (format "%s\n(%s)"
- (replace-regexp-in-string
- " in the future" ""
- (article-lapsed-string
- (time-add (current-time)
- (seconds-to-time (plist-get plist :deadline))) 2))
- (plist-get plist :timestamp)))
-
-(defun org-notify-action-email (plist)
- "Send email to user."
- (compose-mail user-mail-address (concat "TODO: " (plist-get plist :heading)))
- (insert (org-notify-body-text plist))
- (funcall send-mail-function)
- (cl-letf (((symbol-function 'yes-or-no-p) (lambda (x) t)))
- (kill-buffer)))
-
-(defun org-notify-select-highest-window ()
- "Select the highest window on the frame, that is not is not an
-org-notify window. Mostly copied from `appt-select-lowest-window'."
- (let ((highest-window (selected-window))
- (bottom-edge (nth 3 (window-edges)))
- next-bottom-edge)
- (walk-windows (lambda (w)
- (when (and
- (not (string-match "^\\*org-notify-.*\\*$"
- (buffer-name
- (window-buffer w))))
- (> bottom-edge (setq next-bottom-edge
- (nth 3 (window-edges w)))))
- (setq bottom-edge next-bottom-edge
- highest-window w))) 'nomini)
- (select-window highest-window)))
-
-(defun org-notify-action-window (plist)
- "Pop up a window, mostly copied from `appt-disp-window'."
- (save-excursion
- (cl-macrolet ((get (k) `(plist-get plist ,k)))
- (let ((this-window (selected-window))
- (buf (get-buffer-create
- (format org-notify-window-buffer-name (get :uid)))))
- (when (minibufferp)
- (other-window 1)
- (and (minibufferp) (display-multi-frame-p) (other-frame 1)))
- (if (cdr (assq 'unsplittable (frame-parameters)))
- (progn (set-buffer buf) (display-buffer buf))
- (unless (or (special-display-p (buffer-name buf))
- (same-window-p (buffer-name buf)))
- (org-notify-select-highest-window)
- (when (>= (window-height) (* 2 window-min-height))
- (select-window (split-window nil nil 'above))))
- (switch-to-buffer buf))
- (setq buffer-read-only nil buffer-undo-list t)
- (erase-buffer)
- (insert (format "TODO: %s, %s.\n" (get :heading)
- (org-notify-body-text plist)))
- (let ((timer (run-with-timer (or (get :duration) 10) nil
- 'org-notify-delete-window buf)))
- (dotimes (i (/ (length org-notify-actions) 2))
- (let ((key (nth (* i 2) org-notify-actions))
- (text (nth (1+ (* i 2)) org-notify-actions)))
- (insert-button text 'action 'org-notify-on-action-button
- 'key key 'buffer buf 'plist plist 'timer timer)
- (insert " "))))
- (shrink-window-if-larger-than-buffer (get-buffer-window buf t))
- (set-buffer-modified-p nil) (setq buffer-read-only t)
- (raise-frame (selected-frame)) (select-window this-window)))))
-
-(defun org-notify-action-notify (plist)
- "Pop up a notification window."
- (require 'notifications)
- (let* ((duration (plist-get plist :duration))
- (id (notifications-notify
- :title (plist-get plist :heading)
- :body (org-notify-body-text plist)
- :timeout (if duration (* duration 1000))
- :urgency (plist-get plist :urgency)
- :actions org-notify-actions
- :on-action 'org-notify-on-action-notify)))
- (setq org-notify-on-action-map
- (plist-put org-notify-on-action-map id plist))))
-
-(defun org-notify-action-notify/window (plist)
- "For a graphics display, pop up a notification window, for a text
-terminal an emacs window."
- (if (display-graphic-p)
- (org-notify-action-notify plist)
- (org-notify-action-window plist)))
-
-;;; Provide a minimal default setup.
-(org-notify-add 'default '(:time "1h" :actions -notify/window
- :period "2m" :duration 60))
-
-(provide 'org-notify)
-
-;;; org-notify.el ends here
diff --git a/lisp/org-passwords.el b/lisp/org-passwords.el
deleted file mode 100644
index a038b9959d..0000000000
--- a/lisp/org-passwords.el
+++ /dev/null
@@ -1,385 +0,0 @@
-;;; org-passwords.el --- org derived mode for managing passwords
-
-;; Author: Jorge A. Alfaro-Murillo <jorge.alfaro-murillo@yale.edu>
-;; Created: December 26, 2012
-;; Homepage: https://github.com/alfaromurillo/org-passwords.el
-;; Keywords: passwords, password
-
-;; This file is not part of GNU Emacs.
-;;
-;; This program is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;;; Commentary:
-
-;; This file contains the code for managing your passwords with
-;; Org-mode. It is part of org/contrib (see https://orgmode.org/). If
-;; you want to contribute with development, or have a problem, do it
-;; here: https://bitbucket.org/alfaromurillo/org-passwords.el
-
-;; A basic setup needs to indicate a passwords file, and a dictionary
-;; for the random words:
-
-;; (require 'org-passwords)
-;; (setq org-passwords-file "~/documents/passwords.gpg")
-;; (setq org-passwords-random-words-dictionary
"/etc/dictionaries-common/words")
-
-;; Basic usage:
-
-;; `M-x org-passwords' opens the passwords file in
-;; `org-passwords-mode'.
-
-;; `M-x org-passwords-generate-password' generates a random string
-;; of numbers, lowercase letters and uppercase letters.
-
-;; `C-u M-x org-passwords-generate-password' generates a random
-;; string of numbers, lowercase letters, uppercase letters and
-;; symbols.
-
-;; `M-x org-passwords-random-words' concatenates random words from
-;; the dictionary defined by `org-passwords-random-words-dictionary'
-;; into a string, each word separated by the string defined in
-;; `org-passwords-random-words-separator'.
-
-;; `C-u M-x org-passwords-random-words' does the same as above, and
-;; also makes substitutions according to
-;; `org-passwords-random-words-substitutions'.
-
-;; It is also useful to set up keybindings for the functions
-;; `org-passwords-copy-username', `org-passwords-copy-password' and
-;; `org-passwords-open-url' in the `org-passwords-mode', to easily
-;; make the passwords and usernames available to the facility for
-;; pasting text of the window system (clipboard on X and MS-Windows,
-;; pasteboard on Nextstep/Mac OS, etc.), without inserting them in the
-;; kill-ring. You can set for example:
-
-;; (eval-after-load "org-passwords"
-;; '(progn
-;; (define-key org-passwords-mode-map
-;; (kbd "C-c u")
-;; 'org-passwords-copy-username)
-;; (define-key org-passwords-mode-map
-;; (kbd "C-c p")
-;; 'org-passwords-copy-password)
-;; (kbd "C-c o")
-;; 'org-passwords-open-url)))
-
-;; Finally, to enter new passwords, you can use `org-capture' and a
-;; minimal template like:
-
-;; ("p" "password" entry (file "~/documents/passwords.gpg")
-;; "* %^{Title}\n %^{URL}p %^{USERNAME}p %^{PASSWORD}p")
-
-;; When asked for the password you can then call either
-;; `org-passwords-generate-password' or `org-passwords-random-words'.
-;; Be sure to enable recursive minibuffers to call those functions
-;; from the minibuffer:
-
-;; (setq enable-recursive-minibuffers t)
-
-;;; Code:
-
-(require 'org)
-
-;;;###autoload
-(define-derived-mode org-passwords-mode org-mode
- "org-passwords-mode"
- "Mode for storing passwords"
- nil)
-
-(defgroup org-passwords nil
- "Options for password management."
- :group 'org)
-
-(defcustom org-passwords-password-property "PASSWORD"
- "Name of the property for password entry."
- :type 'string
- :group 'org-passwords)
-
-(defcustom org-passwords-username-property "USERNAME"
- "Name of the property for user name entry."
- :type 'string
- :group 'org-passwords)
-
-(defcustom org-passwords-url-property "URL"
- "Name of the property for URL entry."
- :type 'string
- :group 'org-passwords)
-
-(defcustom org-passwords-file nil
- "Default file name for the file that contains the passwords."
- :type 'file
- :group 'org-passwords)
-
-(defcustom org-passwords-time-opened "1 min"
- "Time that the password file will remain open. It has to be a
-string, a number followed by units."
- :type 'str
- :group 'org-passwords)
-
-(defcustom org-passwords-default-password-size "20"
- "Default number of characters to use in
-org-passwords-generate-password. It has to be a string."
- :type 'str
- :group 'org-passwords)
-
-(defcustom org-passwords-random-words-dictionary nil
- "Default file name for the file that contains a dictionary of
-words for `org-passwords-random-words'. Each non-empty line in
-the file is considered a word."
- :type 'file
- :group 'org-passwords)
-
-(defcustom org-passwords-default-random-words-number "5"
- "Default number of words to use in org-passwords-random-words.
-It has to be a string."
- :type 'str
- :group 'org-passwords)
-
-(defvar org-passwords-random-words-separator "-"
- "A string to separate words in `org-passwords-random-words'.")
-
-(defvar org-passwords-random-words-substitutions
- '(("a" . "@")
- ("e" . "3")
- ("o" . "0"))
-"A list of substitutions to be made with
-`org-passwords-random-words' if it is called with
-`universal-argument'. Each element is pair of
-strings (SUBSTITUTE-THIS . BY-THIS).")
-
-(defun org-passwords-copy-password ()
- "Makes the password available to other programs. Puts the
-password of the entry at the location of the cursor in the
-facility for pasting text of the window system (clipboard on X
-and MS-Windows, pasteboard on Nextstep/Mac OS, etc.), without
-putting it in the kill ring."
- (interactive)
- (funcall interprogram-cut-function
- (org-entry-get (point)
- org-passwords-password-property)))
-
-(defun org-passwords-copy-username ()
- "Makes the password available to other programs. Puts the
-username of the entry at the location of the cursor in the
-facility for pasting text of the window system (clipboard on X
-and MS-Windows, pasteboard on Nextstep/Mac OS, etc.), without
-putting it in the kill ring."
- (interactive)
- (funcall interprogram-cut-function
- (org-entry-get (point)
- org-passwords-username-property
- t)))
-
-(defun org-passwords-open-url ()
- "Browse the URL associated with the entry at the location of
-the cursor."
- (interactive)
- (browse-url (org-entry-get (point)
- org-passwords-url-property
- t)))
-
-;;;###autoload
-(defun org-passwords (&optional arg)
- "Open the password file. Open the password file defined by the
-variable `org-password-file' in read-only mode and kill that
-buffer later according to the value of the variable
-`org-passwords-time-opened'. It also adds the `org-password-file'
-to the auto-mode-alist so that it is opened with its mode being
-`org-passwords-mode'.
-
-With prefix arg ARG, the command does not set up a timer to kill the buffer.
-
-With a double prefix arg \\[universal-argument] \\[universal-argument], open
the file for editing.
-"
- (interactive "P")
- (if org-passwords-file
- (progn
- (add-to-list 'auto-mode-alist
- (cons
- (regexp-quote
- (expand-file-name org-passwords-file))
- 'org-passwords-mode))
- (if (equal arg '(4))
- (find-file-read-only org-passwords-file)
- (if (equal arg '(16))
- (find-file org-passwords-file)
- (progn
- (find-file-read-only org-passwords-file)
- (org-passwords-set-up-kill-password-buffer)))))
- (minibuffer-message "No default password file defined. Set the variable
`org-password-file'.")))
-
-(defun org-passwords-set-up-kill-password-buffer ()
- (run-at-time org-passwords-time-opened
- nil
- '(lambda ()
- (if (get-file-buffer org-passwords-file)
- (kill-buffer
- (get-file-buffer org-passwords-file))))))
-
-;;; Password generator
-
-;; Set random number seed from current time and pid. Otherwise
-;; `random' gives the same results every time emacs restarts.
-(random t)
-
-(defun org-passwords-generate-password (arg)
- "Ask a number of characters and insert a password of that size.
-Password has a random string of numbers, lowercase letters, and
-uppercase letters. Argument ARG include symbols."
- (interactive "P")
- (let ((number-of-chars
- (read-from-minibuffer
- (concat "Number of characters (default "
- org-passwords-default-password-size
- "): ")
- nil
- nil
- t
- nil
- org-passwords-default-password-size)))
- (if arg
- (insert (org-passwords-generate-password-with-symbols ""
number-of-chars))
- (insert (org-passwords-generate-password-without-symbols ""
number-of-chars)))))
-
-(defun org-passwords-generate-password-with-symbols (previous-string
nums-of-chars)
- "Return a string consisting of PREVIOUS-STRING and
-NUMS-OF-CHARS random characters."
- (if (eq nums-of-chars 0) previous-string
- (org-passwords-generate-password-with-symbols
- (concat previous-string
- (char-to-string
- ;; symbols, letters, numbers are from 33 to 126
- (+ (random (- 127 33)) 33)))
- (1- nums-of-chars))))
-
-(defun org-passwords-generate-password-without-symbols (previous-string
nums-of-chars)
- "Return string consisting of PREVIOUS-STRING and NUMS-OF-CHARS
-random numbers, lowercase letters, and numbers."
- (if (eq nums-of-chars 0)
- previous-string
- ; There are 10 numbers, 26 lowercase letters and 26 uppercase
- ; letters. 10 + 26 + 26 = 62. The number characters go from 48
- ; to 57, the uppercase letters from 65 to 90, and the lowercase
- ; from 97 to 122. The following makes each equally likely.
- (let ((temp-value (random 62)))
- (cond ((< temp-value 10)
- ; If temp-value<10, then add a number
- (org-passwords-generate-password-without-symbols
- (concat previous-string
- (char-to-string (+ 48 temp-value)))
- (1- nums-of-chars)))
- ((and (> temp-value 9) (< temp-value 36))
- ; If 9<temp-value<36, then add an uppercase letter
- (org-passwords-generate-password-without-symbols
- (concat previous-string
- (char-to-string (+ 65 (- temp-value 10))))
- (1- nums-of-chars)))
- ((> temp-value 35)
- ; If temp-value>35, then add a lowecase letter
- (org-passwords-generate-password-without-symbols
- (concat previous-string
- (char-to-string (+ 97 (- temp-value 36))))
- (1- nums-of-chars)))))))
-
-;;; Random words
-
-(defun org-passwords-random-words (arg)
- "Ask for a number of words and inserts a sequence of that many
-random words from the list in the file
-`org-passwords-random-words-dictionary' separated by
-`org-passwords-random-words-separator'. ARG make substitutions in
-the words as defined by
-`org-passwords-random-words-substitutions'."
- (interactive "P")
- (if org-passwords-random-words-dictionary
- (let ((number-of-words
- (read-from-minibuffer
- (concat "Number of words (default "
- org-passwords-default-random-words-number
- "): ")
- nil
- nil
- t
- nil
- org-passwords-default-random-words-number))
- (list-of-words
- (with-temp-buffer
- (insert-file-contents
- org-passwords-random-words-dictionary)
- (split-string (buffer-string) "\n" t))))
- (insert
- (org-passwords-substitute
- (org-passwords-random-words-attach-number-of-words
- (nth (random (length list-of-words))
- list-of-words)
- (1- number-of-words)
- list-of-words
- org-passwords-random-words-separator)
- (if arg
- org-passwords-random-words-substitutions
- nil))))
- (minibuffer-message
- "No default dictionary file defined. Set the variable
`org-passwords-random-words-dictionary'.")))
-
-(defun org-passwords-random-words-attach-number-of-words
- (previous-string number-of-words list-of-words separator)
- "Returns a string consisting of PREVIOUS-STRING followed by a
-succession of NUMBER-OF-WORDS random words from the list LIST-OF-WORDS
-separated SEPARATOR."
- (if (eq number-of-words 0)
- previous-string
- (org-passwords-random-words-attach-number-of-words
- (concat previous-string
- separator
- (nth (random (length list-of-words)) list-of-words))
- (1- number-of-words)
- list-of-words
- separator)))
-
-(defun org-passwords-substitute (string-to-change list-of-substitutions)
- "Substitutes each appearance in STRING-TO-CHANGE of the `car' of
-each element of LIST-OF-SUBSTITUTIONS by the `cdr' of that
-element. For example:
- (org-passwords-substitute \"ab\" \'((\"a\" . \"b\") (\"b\" . \"c\")))
- => \"bc\"
-Substitutions are made in order of the list, so for example:
- (org-passwords-substitute \"ab\" \'((\"ab\" . \"c\") (\"b\" . \"d\")))
- => \"c\""
- (if list-of-substitutions
- (concat (org-passwords-concat-this-with-string
- (cdar list-of-substitutions)
- (mapcar (lambda (x)
- (org-passwords-substitute
- x
- (cdr list-of-substitutions)))
- (split-string string-to-change
- (caar list-of-substitutions)))))
- string-to-change))
-
-(defun org-passwords-concat-this-with-string (this list-of-strings)
- "Put the string THIS in between every string in LIST-OF-STRINGS. For example:
- (org-passwords-concat-this-with-string \"Here\" \'(\"First\" \"Second\"
\"Third\"))
- => \"FirstHereSencondHereThird\""
- (if (cdr list-of-strings)
- (concat (car list-of-strings)
- this
- (org-passwords-concat-this-with-string
- this
- (cdr list-of-strings)))
- (car list-of-strings)))
-
-(provide 'org-passwords)
-
-;;; org-passwords.el ends here
diff --git a/lisp/org-velocity.el b/lisp/org-velocity.el
deleted file mode 100644
index 5e6f4b4236..0000000000
--- a/lisp/org-velocity.el
+++ /dev/null
@@ -1,823 +0,0 @@
-;;; org-velocity.el --- something like Notational Velocity for Org. -*-
lexical-binding: t -*-
-
-;; Copyright (C) 2010-2014, 2021 Paul M. Rodriguez
-
-;; Author: Paul M. Rodriguez <paulmrodriguez@gmail.com>
-;; Maintainer: Paul M. Rodriguez <paulmrodriguez@gmail.com>
-;; Homepage: https://github.com/ruricolist/org-velocity
-;; Created: 2010-05-05
-;; Version: 4.1
-
-;; This file is not part of GNU Emacs.
-
-;; This program is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Org-Velocity.el is an interface for Org inspired by the minimalist
-;; notetaking program Notational Velocity. The idea is to let you
-;; amass and access brief notes on many subjects with minimal fuss.
-;; Each note is an entry in an ordinary Org file.
-
-;; Org-Velocity can be used in two ways: when called outside Org, to
-;; store and access notes in a designated bucket file; or, when called
-;; inside Org, as a method for navigating any Org file. (Setting the
-;; option `org-velocity-always-use-bucket' disables navigation inside
-;; Org files by default, although you can still force this behavior by
-;; calling `org-velocity-read' with an argument.)
-
-;; Org-Velocity prompts for search terms in the minibuffer. A list of
-;; headings of entries whose text matches your search is updated as
-;; you type; you can end the search and visit an entry at any time by
-;; clicking on its heading.
-
-;; RET displays the results. If there are no matches, Org-Velocity
-;; offers to create a new entry with your search string as its
-;; heading. If there are matches, it displays a list of results where
-;; the heading of each matching entry is hinted with a number or
-;; letter; clicking a result, or typing the matching hint, opens the
-;; entry for editing in an indirect buffer. 0 forces a new entry; RET
-;; reopens the search for editing.
-
-;; You can customize every step in this process, including the search
-;; method, completion for search terms, and templates for creating new
-;; entries; M-x customize-group RET org-velocity RET to see all the
-;; options.
-
-;; Thanks to Richard Riley, Carsten Dominik, Bastien Guerry, and Jeff
-;; Horn for their suggestions.
-
-;;; Usage:
-;; (require 'org-velocity)
-;; (setq org-velocity-bucket (expand-file-name "bucket.org" org-directory))
-;; (global-set-key (kbd "C-c v") 'org-velocity)
-
-;;; Code:
-(require 'org)
-(require 'button)
-(require 'electric)
-(require 'dabbrev)
-(require 'cl-lib)
-
-(defgroup org-velocity nil
- "Notational Velocity-style interface for Org."
- :tag "Org-Velocity"
- :group 'outlines
- :group 'hypermedia
- :group 'org)
-
-(defcustom org-velocity-bucket ""
- "Where is the bucket file?"
- :group 'org-velocity
- :type 'file)
-
-(defcustom org-velocity-show-previews t
- "Show previews of the text of each heading?"
- :group 'velocity
- :type 'boolean
- :safe 'booleanp)
-
-(defcustom org-velocity-exit-on-match nil
- "When searching incrementally, exit on a single match?"
- :group 'org-velocity
- :type 'boolean
- :safe 'booleanp)
-
-(defcustom org-velocity-force-new nil
- "Should exiting the minibuffer with C-j force a new entry?"
- :group 'org-velocity
- :type 'boolean
- :safe 'booleanp)
-
-(defcustom org-velocity-use-search-ring t
- "Push search to `search-ring' when visiting an entry?
-
-This means that C-s C-s will take you directly to the first
-instance of the search string."
- :group 'org-velocity
- :type 'boolean
- :safe 'booleanp)
-
-(defcustom org-velocity-always-use-bucket nil
- "Use bucket file even when called from an Org buffer?"
- :group 'org-velocity
- :type 'boolean
- :safe 'booleanp)
-
-(defcustom org-velocity-use-completion nil
- "Use completion?
-
-Notwithstanding the value of this option, calling
-`dabbrev-expand' always completes against the text of the bucket
-file."
- :group 'org-velocity
- :type '(choice
- (const :tag "Do not use completion" nil)
- (const :tag "Use completion" t))
- :safe 'booleanp)
-
-(defcustom org-velocity-search-method 'phrase
- "Match on whole phrase, any word, or all words?"
- :group 'org-velocity
- :type '(choice
- (const :tag "Match whole phrase" phrase)
- (const :tag "Match any word" any)
- (const :tag "Match all words" all)
- (const :tag "Match a regular expression" regexp))
- :safe (lambda (v) (memq v '(phrase any all regexp))))
-
-(defcustom org-velocity-capture-templates
- '(("v"
- "Velocity entry"
- entry
- (file "")
- "* %:search\n\n%i%?"))
- "Use these template with `org-capture'.
-Meanwhile `org-default-notes-file' is bound to `org-velocity-bucket-file'.
-The keyword :search inserts the current search.
-See the documentation for `org-capture-templates'."
- :group 'org-velocity
- :type (or (get 'org-capture-templates 'custom-type) 'list))
-
-(defcustom org-velocity-heading-level 1
- "Only match headings at this level or higher.
-0 means to match headings at any level."
- :group 'org-velocity
- :type 'integer
- :safe (lambda (x)
- (and (integerp x)
- (>= x 0))))
-
-(defvar crm-separator) ;Ensure dynamic binding.
-
-(defsubst org-velocity-grab-preview ()
- "Grab preview of a subtree.
-The length of the preview is determined by `window-width'.
-
-Replace all contiguous whitespace with single spaces."
- (let* ((start (progn
- (forward-line 1)
- (if (looking-at org-property-start-re)
- (re-search-forward org-property-end-re)
- (1- (point)))))
- (string+props (buffer-substring
- start
- (min
- (+ start (window-width))
- (point-max)))))
- ;; We want to preserve the text properties so that, for example,
- ;; we don't end up with the raw text of links in the preview.
- (with-temp-buffer
- (insert string+props)
- (goto-char (point-min))
- (save-match-data
- (while (re-search-forward split-string-default-separators
- (point-max)
- t)
- (replace-match " ")))
- (buffer-string))))
-
-(cl-defstruct org-velocity-heading buffer position name level preview)
-
-(defsubst org-velocity-nearest-heading (position)
- "Return last heading at POSITION.
-If there is no last heading, return nil."
- (save-excursion
- (goto-char position)
- (re-search-backward (org-velocity-heading-regexp))
- (let ((components (org-heading-components)))
- (make-org-velocity-heading
- :buffer (current-buffer)
- :position (point)
- :name (nth 4 components)
- :level (nth 0 components)
- :preview (if org-velocity-show-previews
- (org-velocity-grab-preview))))))
-
-(defconst org-velocity-index
- (eval-when-compile
- (nconc (number-sequence 49 57) ;numbers
- (number-sequence 97 122) ;lowercase letters
- (number-sequence 65 90))) ;uppercase letters
- "List of chars for indexing results.")
-
-(defconst org-velocity-match-buffer-name "*Velocity matches*")
-
-(cl-defun org-velocity-heading-regexp (&optional (level
org-velocity-heading-level))
- "Regexp to match headings at LEVEL or deeper."
- (if (zerop level)
- "^\\*+ "
- (format "^\\*\\{1,%d\\} " level)))
-
-(defvar org-velocity-search nil
- "Variable to bind to current search.")
-
-(defun org-velocity-buffer-file-name (&optional buffer)
- "Return the name of the file BUFFER saves to.
-Same as function `buffer-file-name' unless BUFFER is an indirect
-buffer or a minibuffer. In the former case, return the file name
-of the base buffer; in the latter, return the file name of
-`minibuffer-selected-window' (or its base buffer)."
- (let ((buffer (if (minibufferp buffer)
- (window-buffer (minibuffer-selected-window))
- buffer)))
- (buffer-file-name
- (or (buffer-base-buffer buffer)
- buffer))))
-
-(defun org-velocity-minibuffer-contents ()
- "Return the contents of the minibuffer when it is active."
- (when (active-minibuffer-window)
- (with-current-buffer (window-buffer (active-minibuffer-window))
- (minibuffer-contents))))
-
-(defun org-velocity-nix-minibuffer ()
- "Return the contents of the minibuffer and clear it."
- (when (active-minibuffer-window)
- (with-current-buffer (window-buffer (active-minibuffer-window))
- (prog1 (minibuffer-contents)
- (delete-minibuffer-contents)))))
-
-(defun org-velocity-bucket-file ()
- "Return the proper file for Org-Velocity to search.
-If `org-velocity-always-use-bucket' is t, use bucket file;
-complain if missing. Otherwise, if an Org file is current, then
-use it."
- (let ((org-velocity-bucket
- (when org-velocity-bucket (expand-file-name org-velocity-bucket)))
- (buffer
- (let ((buffer-file (org-velocity-buffer-file-name)))
- (when buffer-file
- ;; Use the target in capture buffers.
- (org-find-base-buffer-visiting buffer-file)))))
- (if org-velocity-always-use-bucket
- (or org-velocity-bucket (error "Bucket required but not defined"))
- (if (and (eq (buffer-local-value 'major-mode (or buffer
(current-buffer)))
- 'org-mode)
- (org-velocity-buffer-file-name))
- (org-velocity-buffer-file-name)
- (or org-velocity-bucket
- (error "No bucket and not an Org file"))))))
-
-(defvar org-velocity-bucket-buffer nil)
-(defvar org-velocity-navigating nil)
-
-(defsubst org-velocity-bucket-buffer ()
- (or org-velocity-bucket-buffer
- (find-file-noselect (org-velocity-bucket-file))))
-
-(defsubst org-velocity-match-buffer ()
- "Return the proper buffer for Org-Velocity to display in."
- (get-buffer-create org-velocity-match-buffer-name))
-
-(defsubst org-velocity-match-window ()
- (get-buffer-window (org-velocity-match-buffer)))
-
-(defun org-velocity-beginning-of-headings ()
- "Goto the start of the first heading."
- (goto-char (point-min))
- ;; If we are before the first heading we could still be at the
- ;; first heading.
- (or (looking-at (org-velocity-heading-regexp))
- (re-search-forward (org-velocity-heading-regexp))))
-
-(defun org-velocity-make-indirect-buffer (heading)
- "Make or switch to an indirect buffer visiting HEADING."
- (let* ((bucket (org-velocity-heading-buffer heading))
- (name (org-velocity-heading-name heading))
- (existing (get-buffer name)))
- (if (and existing (buffer-base-buffer existing)
- (equal (buffer-base-buffer existing) bucket))
- existing
- (make-indirect-buffer
- bucket
- (generate-new-buffer-name (org-velocity-heading-name heading))
- t))))
-
-(defun org-velocity-capture ()
- "Record a note with `org-capture'."
- (let ((org-capture-templates
- org-velocity-capture-templates))
- (org-capture nil
- ;; This is no longer automatically selected.
- (when (null (cdr org-capture-templates))
- (caar org-capture-templates)))
- (when org-capture-mode
- (rename-buffer org-velocity-search t))))
-
-(defvar org-velocity-saved-winconf nil)
-(make-variable-buffer-local 'org-velocity-saved-winconf)
-
-(defun org-velocity-edit-entry (heading)
- (if org-velocity-navigating
- (org-velocity-edit-entry/inline heading)
- (org-velocity-edit-entry/indirect heading)))
-
-(cl-defun org-velocity-goto-entry (heading &key narrow)
- (goto-char (org-velocity-heading-position heading))
- (save-excursion
- (when narrow
- (org-narrow-to-subtree))
- (outline-show-all)))
-
-(defun org-velocity-edit-entry/inline (heading)
- "Edit entry at HEADING in the original buffer."
- (let ((buffer (org-velocity-heading-buffer heading)))
- (pop-to-buffer buffer)
- (with-current-buffer buffer
- (org-velocity-goto-entry heading))))
-
-(defun org-velocity-format-header-line (control-string &rest args)
- (set (make-local-variable 'header-line-format)
- (apply #'format control-string args)))
-
-(defun org-velocity-edit-entry/indirect (heading)
- "Edit entry at HEADING in an indirect buffer."
- (let ((winconf (current-window-configuration))
- (dd default-directory)
- (buffer (org-velocity-make-indirect-buffer heading))
- (inhibit-point-motion-hooks t)
- (inhibit-field-text-motion t))
- (with-current-buffer buffer
- (setq default-directory dd) ;Inherit default directory.
- (setq org-velocity-saved-winconf winconf)
- (org-velocity-goto-entry heading :narrow t)
- (goto-char (point-max))
- (add-hook 'org-ctrl-c-ctrl-c-hook 'org-velocity-dismiss nil t))
- (pop-to-buffer buffer)
- (org-velocity-format-header-line
- "%s Use C-c C-c to finish."
- (abbreviate-file-name
- (buffer-file-name
- (org-velocity-heading-buffer heading))))))
-
-(defun org-velocity-dismiss ()
- "Save current entry and close indirect buffer."
- (let ((winconf org-velocity-saved-winconf))
- (prog1 t ;Tell hook we're done.
- (save-buffer)
- (kill-buffer)
- (when (window-configuration-p winconf)
- (set-window-configuration winconf)))))
-
-(defun org-velocity-visit-button (button)
- (run-hooks 'mouse-leave-buffer-hook)
- (when org-velocity-use-search-ring
- (add-to-history 'search-ring
- (button-get button 'search)
- search-ring-max))
- (let ((match (button-get button 'match)))
- (throw 'org-velocity-done match)))
-
-(define-button-type 'org-velocity-button
- 'action #'org-velocity-visit-button
- 'follow-link 'mouse-face)
-
-(defsubst org-velocity-buttonize (heading)
- "Insert HEADING as a text button with no hints."
- (insert-text-button
- (propertize (org-velocity-heading-name heading) 'face 'link)
- :type 'org-velocity-button
- 'match heading
- 'search org-velocity-search))
-
-(defsubst org-velocity-insert-preview (heading)
- (when org-velocity-show-previews
- (insert-char ?\ 1)
- (insert
- (propertize
- (org-velocity-heading-preview heading)
- 'face 'shadow))))
-
-(defvar org-velocity-recursive-headings nil)
-(defvar org-velocity-recursive-search nil)
-
-(cl-defun org-velocity-search-with (fun style search
- &key (headings
org-velocity-recursive-headings))
- (if headings
- (save-restriction
- (dolist (heading headings)
- (widen)
- (let ((start (org-velocity-heading-position heading)))
- (goto-char start)
- (let ((end (save-excursion
- (org-end-of-subtree)
- (point))))
- (narrow-to-region start end)
- (org-velocity-search-with fun style search
- :headings nil)))))
- (cl-ecase style
- ((phrase any regexp)
- (cl-block nil
- (while (re-search-forward search nil t)
- (let ((match (org-velocity-nearest-heading (point))))
- (funcall fun match))
- ;; Skip to the next heading.
- (unless (re-search-forward (org-velocity-heading-regexp) nil t)
- (cl-return)))))
- ((all)
- (let ((keywords
- (cl-loop for word in (split-string search)
- collect (concat "\\<" (regexp-quote word) "\\>"))))
- (org-map-entries
- (lambda ()
- ;; Only search the subtree once.
- (setq org-map-continue-from
- (save-excursion
- (org-end-of-subtree)
- (point)))
- (when (cl-loop for word in keywords
- always (save-excursion
- (re-search-forward word
org-map-continue-from t)))
- (let ((match (org-velocity-nearest-heading (match-end 0))))
- (funcall fun match))))))))))
-
-(defun org-velocity-all-results (style search)
- (with-current-buffer (org-velocity-bucket-buffer)
- (save-excursion
- (goto-char (point-min))
- (let (matches)
- (org-velocity-search-with (lambda (match)
- (push match matches))
- style
- search)
- (nreverse matches)))))
-
-(defsubst org-velocity-present-match (hint match)
- (with-current-buffer (org-velocity-match-buffer)
- (when hint (insert "#" hint " "))
- (org-velocity-buttonize match)
- (org-velocity-insert-preview match)
- (newline)))
-
-(defun org-velocity-present-search (style search hide-hints)
- (let ((hints org-velocity-index) matches)
- (cl-block nil
- (org-velocity-search-with (lambda (match)
- (unless hints
- (cl-return))
- (let ((hint (if hide-hints
- nil
- (car hints))))
- (org-velocity-present-match hint match))
- (pop hints)
- (push match matches))
- style
- search))
- (nreverse matches)))
-
-(defun org-velocity-restrict-search ()
- (interactive)
- (let ((search (org-velocity-nix-minibuffer)))
- (when (equal search "")
- (error "No search to restrict to"))
- (push search org-velocity-recursive-search)
- (setq org-velocity-recursive-headings
- (org-velocity-all-results
- org-velocity-search-method
- search))
- ;; TODO We could extend the current search instead of starting
- ;; over.
- (org-velocity-update-match-header)
- (minibuffer-message "Restricting search to %s" search)))
-
-(cl-defun org-velocity-update-match-header (&key (match-buffer
(org-velocity-match-buffer))
- (bucket-buffer
(org-velocity-bucket-buffer))
- (search-method
org-velocity-search-method))
- (let ((navigating? org-velocity-navigating)
- (recursive? org-velocity-recursive-search))
- (with-current-buffer match-buffer
- (org-velocity-format-header-line
- "%s search in %s%s (%s mode)"
- (capitalize (symbol-name search-method))
- (abbreviate-file-name (buffer-file-name bucket-buffer))
- (if (not recursive?)
- ""
- (let ((sep " > "))
- (concat sep (string-join (reverse recursive?) sep))))
- (if navigating? "nav" "notes")))))
-
-(cl-defun org-velocity-present (search &key hide-hints)
- "Buttonize matches for SEARCH in `org-velocity-match-buffer'.
-If HIDE-HINTS is non-nil, display entries without indices. SEARCH
-binds `org-velocity-search'.
-
-Return matches."
- (let ((match-buffer (org-velocity-match-buffer))
- (bucket-buffer (org-velocity-bucket-buffer))
- (search-method org-velocity-search-method))
- (if (and (stringp search) (not (string= "" search)))
- ;; Fold case when the search string is all lowercase.
- (let ((case-fold-search (equal search (downcase search)))
- (truncate-partial-width-windows t))
- (with-current-buffer match-buffer
- (erase-buffer)
- ;; Permanent locals.
- (setq cursor-type nil
- truncate-lines t)
- (org-velocity-update-match-header
- :match-buffer match-buffer
- :bucket-buffer bucket-buffer
- :search-method search-method))
- (prog1
- (with-current-buffer bucket-buffer
- (widen)
- (let* ((inhibit-point-motion-hooks t)
- (inhibit-field-text-motion t)
- (anchored? (string-match-p "^\\s-" search))
- (search
- (cl-ecase search-method
- (all search)
- (phrase
- (if anchored?
- (regexp-quote search)
- ;; Anchor the search to the start of a word.
- (concat "\\<" (regexp-quote search))))
- (any
- (concat "\\<" (regexp-opt (split-string search))))
- (regexp search))))
- (save-excursion
- (org-velocity-beginning-of-headings)
- (condition-case lossage
- (org-velocity-present-search search-method search
hide-hints)
- (invalid-regexp
- (minibuffer-message "%s" lossage))))))
- (with-current-buffer match-buffer
- (goto-char (point-min)))))
- (with-current-buffer match-buffer
- (erase-buffer)))))
-
-(defun org-velocity-store-link ()
- "Function for `org-store-link-functions'."
- (if org-velocity-search
- (org-store-link-props
- :search org-velocity-search)))
-
-(add-hook 'org-store-link-functions 'org-velocity-store-link)
-
-(cl-defun org-velocity-create (search &key ask)
- "Create new heading named SEARCH.
-If ASK is non-nil, ask first."
- (when (or (null ask) (y-or-n-p "No match found, create? "))
- (let ((org-velocity-search search)
- (org-default-notes-file (org-velocity-bucket-file))
- ;; save a stored link
- org-store-link-plist)
- (org-velocity-capture))
- search))
-
-(defun org-velocity-engine (search)
- "Display a list of headings where SEARCH occurs."
- (let ((org-velocity-search search))
- (unless (or
- (not (stringp search))
- (string= "" search)) ;exit on empty string
- (cl-case
- (if (and org-velocity-force-new (eq last-command-event ?\C-j))
- :force
- (let* ((org-velocity-index (org-velocity-adjust-index))
- (matches (org-velocity-present search)))
- (cond ((null matches) :new)
- ((null (cdr matches)) :follow)
- (t :prompt))))
- (:prompt (progn
- (pop-to-buffer (org-velocity-match-buffer))
- (let ((hint (org-velocity-electric-read-hint)))
- (when hint (cl-case hint
- (:edit (org-velocity-read nil search))
- (:force (org-velocity-create search))
- (otherwise (org-velocity-activate-button
hint)))))))
- (:new (unless (org-velocity-create search :ask t)
- (org-velocity-read nil search)))
- (:force (org-velocity-create search))
- (:follow (if (y-or-n-p "One match, follow? ")
- (progn
- (set-buffer (org-velocity-match-buffer))
- (goto-char (point-min))
- (button-activate (next-button (point))))
- (org-velocity-read nil search)))))))
-
-(defun org-velocity-activate-button (char)
- "Go to button on line number associated with CHAR in `org-velocity-index'."
- (goto-char (point-min))
- (forward-line (cl-position char org-velocity-index))
- (goto-char
- (button-start
- (next-button (point))))
- (message "%s" (button-label (button-at (point))))
- (button-activate (button-at (point))))
-
-(defun org-velocity-electric-undefined ()
- "Complain about an undefined key."
- (interactive)
- (message "%s"
- (substitute-command-keys
- "\\[org-velocity-electric-new] for new entry,
-\\[org-velocity-electric-edit] to edit search,
-\\[scroll-up] to scroll up,
-\\[scroll-down] to scroll down,
-\\[keyboard-quit] to quit."))
- (sit-for 4))
-
-(defun org-velocity-electric-follow (ev)
- "Follow a hint indexed by keyboard event EV."
- (interactive (list last-command-event))
- (if (not (> (cl-position ev org-velocity-index)
- (1- (count-lines (point-min) (point-max)))))
- (throw 'org-velocity-select ev)
- (call-interactively 'org-velocity-electric-undefined)))
-
-(defun org-velocity-electric-edit ()
- "Edit the search string."
- (interactive)
- (throw 'org-velocity-select :edit))
-
-(defun org-velocity-electric-new ()
- "Force a new entry."
- (interactive)
- (throw 'org-velocity-select :force))
-
-(defvar org-velocity-electric-map
- (let ((map (make-sparse-keymap)))
- (define-key map [t] 'org-velocity-electric-undefined)
- (dolist (c org-velocity-index)
- (define-key map (char-to-string c)
- 'org-velocity-electric-follow))
- (define-key map "0" 'org-velocity-electric-new)
- (define-key map "\C-v" 'scroll-up)
- (define-key map "\M-v" 'scroll-down)
- (define-key map (kbd "RET") 'org-velocity-electric-edit)
- (define-key map [mouse-1] nil)
- (define-key map [mouse-2] nil)
- (define-key map [escape] 'keyboard-quit)
- (define-key map "\C-h" 'help-command)
- map))
-
-(defun org-velocity-electric-read-hint ()
- "Read index of button electrically."
- (with-current-buffer (org-velocity-match-buffer)
- (when (featurep 'evil)
- ;; NB Idempotent.
- (evil-make-overriding-map org-velocity-electric-map))
- (use-local-map org-velocity-electric-map)
- (catch 'org-velocity-select
- (Electric-command-loop 'org-velocity-select "Follow: "))))
-
-(defvar org-velocity-incremental-keymap
- (let ((map (make-sparse-keymap)))
- (define-key map "\C-v" 'scroll-up)
- (define-key map "\M-v" 'scroll-down)
- map))
-
-(defun org-velocity-displaying-completions-p ()
- "Is there a *Completions* buffer showing?"
- (get-window-with-predicate
- (lambda (w)
- (eq (buffer-local-value 'major-mode (window-buffer w))
- 'completion-list-mode))))
-
-(defun org-velocity-update ()
- "Display results of search without hinting."
- (unless (org-velocity-displaying-completions-p)
- (let* ((search (org-velocity-minibuffer-contents))
- (matches (org-velocity-present search :hide-hints t)))
- (cond ((null matches)
- (select-window (active-minibuffer-window))
- (unless (or (null search) (= (length search) 0))
- (minibuffer-message "No match; RET to create")))
- ((and (null (cdr matches))
- org-velocity-exit-on-match)
- (throw 'click search))
- (t
- (with-current-buffer (org-velocity-match-buffer)
- (use-local-map org-velocity-incremental-keymap)))))))
-
-(defvar dabbrev--last-abbreviation)
-
-(defun org-velocity-dabbrev-completion-list (abbrev)
- "Return all dabbrev completions for ABBREV."
- ;; This is based on `dabbrev-completion'.
- (dabbrev--reset-global-variables)
- (setq dabbrev--last-abbreviation abbrev)
- (dabbrev--find-all-expansions abbrev case-fold-search))
-
-(defvar org-velocity-local-completion-map
- (let ((map (make-sparse-keymap)))
- (set-keymap-parent map minibuffer-local-completion-map)
- (define-key map " " 'self-insert-command)
- (define-key map "?" 'self-insert-command)
- (define-key map [remap minibuffer-complete] 'minibuffer-complete-word)
- (define-key map [(control ?@)] 'org-velocity-restrict-search)
- (define-key map [(control ?\s)] 'org-velocity-restrict-search)
- map)
- "Keymap for completion with `completing-read'.")
-
-(defun org-velocity-read-with-completion (prompt)
- "Completing read with PROMPT."
- (let ((minibuffer-local-completion-map
- org-velocity-local-completion-map)
- (completion-no-auto-exit t)
- (crm-separator " "))
- (completing-read prompt
- (completion-table-dynamic
- 'org-velocity-dabbrev-completion-list))))
-
-(cl-defun org-velocity-adjust-index
- (&optional (match-window (org-velocity-match-window)))
- "Truncate or extend `org-velocity-index' to the lines in
-MATCH-WINDOW."
- (with-selected-window match-window
- (let ((lines (window-height))
- (hints (length org-velocity-index)))
- (cond ((= lines hints)
- org-velocity-index)
- ;; Truncate the index to the size of
- ;; the buffer to be displayed.
- ((< lines hints)
- (cl-subseq org-velocity-index 0 lines))
- ;; If the window is so tall we run out of indices, at
- ;; least make the additional results clickable.
- ((> lines hints)
- (append org-velocity-index
- (make-list (- lines hints) nil)))))))
-
-(defun org-velocity-incremental-read (prompt)
- "Read string with PROMPT and display results incrementally.
-Stop searching once there are more matches than can be
-displayed."
- (let ((res
- (unwind-protect
- (let* ((match-window (display-buffer (org-velocity-match-buffer)))
- (org-velocity-index (org-velocity-adjust-index
match-window)))
- (catch 'click
- (add-hook 'post-command-hook 'org-velocity-update)
- (cond ((eq org-velocity-search-method 'regexp)
- (read-regexp prompt))
- (org-velocity-use-completion
- (org-velocity-read-with-completion prompt))
- (t (read-string prompt)))))
- (remove-hook 'post-command-hook 'org-velocity-update))))
- (if (bufferp res) (org-pop-to-buffer-same-window res) res)))
-
-(defun org-velocity (arg &optional search)
- "Read a search string SEARCH for Org-Velocity interface.
-This means that a buffer will display all headings where SEARCH
-occurs, where one can be selected by a mouse click or by typing
-its index. If SEARCH does not occur, then a new heading may be
-created named SEARCH.
-
-If `org-velocity-bucket' is defined and
-`org-velocity-always-use-bucket' is non-nil, then the bucket file
-will be used; otherwise, this will work when called in any Org
-file.
-
-Calling with ARG reverses which file – the current file or the
-bucket file – to use. If the bucket file would have been used,
-then the current file is used instead, and vice versa."
- (interactive "P")
- (let ((org-velocity-always-use-bucket
- (if org-velocity-always-use-bucket
- (not arg)
- arg)))
- ;; complain if inappropriate
- (cl-assert (org-velocity-bucket-file))
- (let* ((starting-buffer (current-buffer))
- (org-velocity-bucket-buffer
- (find-file-noselect (org-velocity-bucket-file)))
- (org-velocity-navigating
- (eq starting-buffer org-velocity-bucket-buffer))
- (org-velocity-recursive-headings '())
- (org-velocity-recursive-search '())
- (org-velocity-heading-level
- (if org-velocity-navigating
- 0
- org-velocity-heading-level))
- (dabbrev-search-these-buffers-only
- (list org-velocity-bucket-buffer)))
- (unwind-protect
- (let ((match
- (catch 'org-velocity-done
- (org-velocity-engine
- (or search
- (org-velocity-incremental-read "Velocity search: ")))
- nil)))
- (when (org-velocity-heading-p match)
- (org-velocity-edit-entry match)))
- (kill-buffer (org-velocity-match-buffer))))))
-
-(defalias 'org-velocity-read 'org-velocity)
-
-(provide 'org-velocity)
-
-;;; org-velocity.el ends here
diff --git a/lisp/ox-rss.el b/lisp/ox-rss.el
deleted file mode 100644
index c98cac88e6..0000000000
--- a/lisp/ox-rss.el
+++ /dev/null
@@ -1,421 +0,0 @@
-;;; ox-rss.el --- RSS 2.0 Back-End for Org Export Engine
-
-;; Copyright (C) 2013-2021 Free Software Foundation, Inc.
-
-;; Author: Bastien Guerry <bzg@gnu.org>
-;; Maintainer: Bastien Guerry <bzg@gnu.org>
-;; Keywords: org, wp, blog, feed, rss
-;; Homepage: https://gitlab.com/nsavage/ox-rss
-
-;; This file is not part of GNU Emacs.
-
-;; This program is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This library implements an RSS 2.0 back-end for Org exporter, based
-;; on the `html' back-end.
-;;
-;; It requires Emacs 24.1 at least.
-;;
-;; It provides two commands for export, depending on the desired output:
-;; `org-rss-export-as-rss' (temporary buffer) and `org-rss-export-to-rss'
-;; (as a ".xml" file).
-;;
-;; This backend understands three new option keywords:
-;;
-;; #+RSS_EXTENSION: xml
-;; #+RSS_IMAGE_URL: https://myblog.org/mypicture.jpg
-;; #+RSS_FEED_URL: https://myblog.org/feeds/blog.xml
-;;
-;; It uses #+HTML_LINK_HOME: to set the base url of the feed.
-;;
-;; Exporting an Org file to RSS modifies each top-level entry by adding a
-;; PUBDATE property. If `org-rss-use-entry-url-as-guid', it will also add
-;; an ID property, later used as the guid for the feed's item.
-;;
-;; The top-level headline is used as the title of each RSS item unless
-;; an RSS_TITLE property is set on the headline.
-;;
-;; You typically want to use it within a publishing project like this:
-;;
-;; (add-to-list
-;; 'org-publish-project-alist
-;; '("homepage_rss"
-;; :base-directory "~/myhomepage/"
-;; :base-extension "org"
-;; :rss-image-url "http://lumiere.ens.fr/~guerry/images/faces/15.png";
-;; :html-link-home "http://lumiere.ens.fr/~guerry/";
-;; :html-link-use-abs-url t
-;; :rss-extension "xml"
-;; :publishing-directory "/home/guerry/public_html/"
-;; :publishing-function (org-rss-publish-to-rss)
-;; :section-numbers nil
-;; :exclude ".*" ;; To exclude all files...
-;; :include ("index.org") ;; ... except index.org.
-;; :table-of-contents nil))
-;;
-;; ... then rsync /home/guerry/public_html/ with your server.
-;;
-;; By default, the permalink for a blog entry points to the headline.
-;; You can specify a different one by using the :RSS_PERMALINK:
-;; property within an entry.
-
-;;; Code:
-
-(require 'ox-html)
-(declare-function url-encode-url "url-util" (url))
-
-;;; Variables and options
-
-(defgroup org-export-rss nil
- "Options specific to RSS export back-end."
- :tag "Org RSS"
- :group 'org-export
- :version "24.4"
- :package-version '(Org . "8.0"))
-
-(defcustom org-rss-image-url
"https://orgmode.org/img/org-mode-unicorn-logo.png";
- "The URL of the image for the RSS feed."
- :group 'org-export-rss
- :type 'string)
-
-(defcustom org-rss-extension "xml"
- "File extension for the RSS 2.0 feed."
- :group 'org-export-rss
- :type 'string)
-
-(defcustom org-rss-categories 'from-tags
- "Where to extract items category information from.
-The default is to extract categories from the tags of the
-headlines. When set to another value, extract the category
-from the :CATEGORY: property of the entry."
- :group 'org-export-rss
- :type '(choice
- (const :tag "From tags" from-tags)
- (const :tag "From the category property" from-category)))
-
-(defcustom org-rss-use-entry-url-as-guid t
- "Use the URL for the <guid> metatag?
-When nil, Org will create ids using `org-icalendar-create-uid'."
- :group 'org-export-rss
- :type 'boolean)
-
-;;; Define backend
-
-(org-export-define-derived-backend 'rss 'html
- :menu-entry
- '(?r "Export to RSS"
- ((?R "As RSS buffer"
- (lambda (a s v b) (org-rss-export-as-rss a s v)))
- (?r "As RSS file" (lambda (a s v b) (org-rss-export-to-rss a s v)))
- (?o "As RSS file and open"
- (lambda (a s v b)
- (if a (org-rss-export-to-rss t s v)
- (org-open-file (org-rss-export-to-rss nil s v)))))))
- :options-alist
- '((:description "DESCRIPTION" nil nil newline)
- (:keywords "KEYWORDS" nil nil space)
- (:with-toc nil nil nil) ;; Never include HTML's toc
- (:rss-extension "RSS_EXTENSION" nil org-rss-extension)
- (:rss-image-url "RSS_IMAGE_URL" nil org-rss-image-url)
- (:rss-feed-url "RSS_FEED_URL" nil nil t)
- (:rss-categories nil nil org-rss-categories))
- :filters-alist '((:filter-final-output . org-rss-final-function))
- :translate-alist '((headline . org-rss-headline)
- (comment . (lambda (&rest args) ""))
- (comment-block . (lambda (&rest args) ""))
- (timestamp . (lambda (&rest args) ""))
- (plain-text . org-rss-plain-text)
- (section . org-rss-section)
- (template . org-rss-template)))
-
-;;; Export functions
-
-;;;###autoload
-(defun org-rss-export-as-rss (&optional async subtreep visible-only)
- "Export current buffer to an RSS buffer.
-
-If narrowing is active in the current buffer, only export its
-narrowed part.
-
-If a region is active, export that region.
-
-A non-nil optional argument ASYNC means the process should happen
-asynchronously. The resulting buffer should be accessible
-through the `org-export-stack' interface.
-
-When optional argument SUBTREEP is non-nil, export the sub-tree
-at point, extracting information from the headline properties
-first.
-
-When optional argument VISIBLE-ONLY is non-nil, don't export
-contents of hidden elements.
-
-Export is done in a buffer named \"*Org RSS Export*\", which will
-be displayed when `org-export-show-temporary-export-buffer' is
-non-nil."
- (interactive)
- (let ((file (buffer-file-name (buffer-base-buffer))))
- (org-icalendar-create-uid file 'warn-user)
- (org-rss-add-pubdate-property))
- (org-export-to-buffer 'rss "*Org RSS Export*"
- async subtreep visible-only nil nil (lambda () (text-mode))))
-
-;;;###autoload
-(defun org-rss-export-to-rss (&optional async subtreep visible-only)
- "Export current buffer to an RSS file.
-
-If narrowing is active in the current buffer, only export its
-narrowed part.
-
-If a region is active, export that region.
-
-A non-nil optional argument ASYNC means the process should happen
-asynchronously. The resulting file should be accessible through
-the `org-export-stack' interface.
-
-When optional argument SUBTREEP is non-nil, export the sub-tree
-at point, extracting information from the headline properties
-first.
-
-When optional argument VISIBLE-ONLY is non-nil, don't export
-contents of hidden elements.
-
-Return output file's name."
- (interactive)
- (let ((file (buffer-file-name (buffer-base-buffer))))
- (org-icalendar-create-uid file 'warn-user)
- (org-rss-add-pubdate-property))
- (let ((outfile (org-export-output-file-name
- (concat "." org-rss-extension) subtreep)))
- (org-export-to-file 'rss outfile async subtreep visible-only)))
-
-;;;###autoload
-(defun org-rss-publish-to-rss (plist filename pub-dir)
- "Publish an org file to RSS.
-
-FILENAME is the filename of the Org file to be published. PLIST
-is the property list for the given project. PUB-DIR is the
-publishing directory.
-
-Return output file name."
- (let ((bf (get-file-buffer filename)))
- (if bf
- (with-current-buffer bf
- (org-icalendar-create-uid filename 'warn-user)
- (org-rss-add-pubdate-property)
- (write-file filename))
- (find-file filename)
- (org-icalendar-create-uid filename 'warn-user)
- (org-rss-add-pubdate-property)
- (write-file filename) (kill-buffer)))
- (org-publish-org-to
- 'rss filename (concat "." org-rss-extension) plist pub-dir))
-
-;;; Main transcoding functions
-
-(defun org-rss-headline (headline contents info)
- "Transcode HEADLINE element into RSS format.
-CONTENTS is the headline contents. INFO is a plist used as a
-communication channel."
- (if (> (org-export-get-relative-level headline info) 1)
- (org-export-data-with-backend headline 'html info)
- (unless (org-element-property :footnote-section-p headline)
- (let* ((email (org-export-data (plist-get info :email) info))
- (author (and (plist-get info :with-author)
- (let ((auth (plist-get info :author)))
- (and auth (org-export-data auth info)))))
- (htmlext (plist-get info :html-extension))
- (hl-number (org-export-get-headline-number headline info))
- (hl-home (file-name-as-directory (plist-get info :html-link-home)))
- (hl-pdir (plist-get info :publishing-directory))
- (hl-perm (org-element-property :RSS_PERMALINK headline))
- (anchor (org-export-get-reference headline info))
- (category (org-rss-plain-text
- (or (org-element-property :CATEGORY headline) "") info))
- (pubdate0 (org-element-property :PUBDATE headline))
- (pubdate (let ((system-time-locale "C"))
- (if (and pubdate0 (not (string-empty-p pubdate0)))
- (format-time-string
- "%a, %d %b %Y %H:%M:%S %z"
- (org-time-string-to-time pubdate0)))))
- (title (org-rss-plain-text
- (or (org-element-property :RSS_TITLE headline)
- (replace-regexp-in-string
- org-bracket-link-regexp
- (lambda (m) (or (match-string 3 m)
- (match-string 1 m)))
- (org-element-property :raw-value headline))) info))
- (publink
- (or (and hl-perm (concat (or hl-home hl-pdir) hl-perm))
- (concat
- (or hl-home hl-pdir)
- (file-name-nondirectory
- (file-name-sans-extension
- (plist-get info :input-file))) "." htmlext "#" anchor)))
- (guid (if org-rss-use-entry-url-as-guid
- publink
- (org-rss-plain-text
- (or (org-element-property :ID headline)
- (org-element-property :CUSTOM_ID headline)
- publink)
- info))))
- (if (not pubdate) "" ;; Skip entries with no PUBDATE prop
- (format
- (concat
- "<item>\n"
- "<title>%s</title>\n"
- "<link>%s</link>\n"
- "<author>%s (%s)</author>\n"
- "<guid isPermaLink=\"false\">%s</guid>\n"
- "<pubDate>%s</pubDate>\n"
- (org-rss-build-categories headline info) "\n"
- "<description><![CDATA[%s]]></description>\n"
- "</item>\n")
- title publink email author guid pubdate contents))))))
-
-(defun org-rss-build-categories (headline info)
- "Build categories for the RSS item."
- (if (eq (plist-get info :rss-categories) 'from-tags)
- (mapconcat
- (lambda (c) (format "<category><![CDATA[%s]]></category>" c))
- (org-element-property :tags headline)
- "\n")
- (let ((c (org-element-property :CATEGORY headline)))
- (format "<category><![CDATA[%s]]></category>" c))))
-
-(defun org-rss-template (contents info)
- "Return complete document string after RSS conversion.
-CONTENTS is the transcoded contents string. INFO is a plist used
-as a communication channel."
- (concat
- (format "<?xml version=\"1.0\" encoding=\"%s\"?>"
- (symbol-name org-html-coding-system))
- "\n<rss version=\"2.0\"
- xmlns:content=\"http://purl.org/rss/1.0/modules/content/\";
- xmlns:wfw=\"http://wellformedweb.org/CommentAPI/\";
- xmlns:dc=\"http://purl.org/dc/elements/1.1/\";
- xmlns:atom=\"http://www.w3.org/2005/Atom\";
- xmlns:sy=\"http://purl.org/rss/1.0/modules/syndication/\";
- xmlns:slash=\"http://purl.org/rss/1.0/modules/slash/\";
- xmlns:georss=\"http://www.georss.org/georss\";
- xmlns:geo=\"http://www.w3.org/2003/01/geo/wgs84_pos#\";
- xmlns:media=\"http://search.yahoo.com/mrss/\";>"
- "<channel>"
- (org-rss-build-channel-info info) "\n"
- contents
- "</channel>\n"
- "</rss>"))
-
-(defun org-rss-build-channel-info (info)
- "Build the RSS channel information."
- (let* ((system-time-locale "C")
- (title (org-export-data (plist-get info :title) info))
- (email (org-export-data (plist-get info :email) info))
- (author (and (plist-get info :with-author)
- (let ((auth (plist-get info :author)))
- (and auth (org-export-data auth info)))))
- (date (format-time-string "%a, %d %b %Y %H:%M:%S %z")) ;; RFC 882
- (description (org-export-data (plist-get info :description) info))
- (lang (plist-get info :language))
- (keywords (plist-get info :keywords))
- (rssext (plist-get info :rss-extension))
- (blogurl (or (plist-get info :html-link-home)
- (plist-get info :publishing-directory)))
- (image (url-encode-url (plist-get info :rss-image-url)))
- (ifile (plist-get info :input-file))
- (publink
- (or (plist-get info :rss-feed-url)
- (concat (file-name-as-directory blogurl)
- (file-name-nondirectory
- (file-name-sans-extension ifile))
- "." rssext))))
- (format
- "\n<title>%s</title>
-<atom:link href=\"%s\" rel=\"self\" type=\"application/rss+xml\" />
-<link>%s</link>
-<description><![CDATA[%s]]></description>
-<language>%s</language>
-<pubDate>%s</pubDate>
-<lastBuildDate>%s</lastBuildDate>
-<generator>%s</generator>
-<webMaster>%s (%s)</webMaster>
-<image>
-<url>%s</url>
-<title>%s</title>
-<link>%s</link>
-</image>
-"
- title publink blogurl description lang date date
- (concat (format "Emacs %d.%d"
- emacs-major-version
- emacs-minor-version)
- " Org-mode " (org-version))
- email author image title blogurl)))
-
-(defun org-rss-section (section contents info)
- "Transcode SECTION element into RSS format.
-CONTENTS is the section contents. INFO is a plist used as
-a communication channel."
- contents)
-
-(defun org-rss-timestamp (timestamp contents info)
- "Transcode a TIMESTAMP object from Org to RSS.
-CONTENTS is nil. INFO is a plist holding contextual
-information."
- (org-html-encode-plain-text
- (org-timestamp-translate timestamp)))
-
-(defun org-rss-plain-text (contents info)
- "Convert plain text into RSS encoded text."
- (let (output)
- (setq output (org-html-encode-plain-text contents)
- output (org-export-activate-smart-quotes
- output :html info))))
-
-;;; Filters
-
-(defun org-rss-final-function (contents backend info)
- "Prettify the RSS output."
- (with-temp-buffer
- (xml-mode)
- (insert contents)
- (indent-region (point-min) (point-max))
- (buffer-substring-no-properties (point-min) (point-max))))
-
-;;; Miscellaneous
-
-(defun org-rss-add-pubdate-property ()
- "Set the PUBDATE property for top-level headlines."
- (let (msg)
- (org-map-entries
- (lambda ()
- (let* ((entry (org-element-at-point))
- (level (org-element-property :level entry)))
- (when (= level 1)
- (unless (org-entry-get (point) "PUBDATE")
- (setq msg t)
- (org-set-property
- "PUBDATE" (format-time-string
- (cdr org-time-stamp-formats)))))))
- nil nil 'comment 'archive)
- (when msg
- (message "Property PUBDATE added to top-level entries in %s"
- (buffer-file-name))
- (sit-for 2))))
-
-(provide 'ox-rss)
-
-;;; ox-rss.el ends here