diff options
| -rw-r--r-- | emacs.d/custom/fcuny-defuns.el | 240 | ||||
| -rw-r--r-- | emacs.d/custom/fcuny-org.el | 43 |
2 files changed, 44 insertions, 239 deletions
diff --git a/emacs.d/custom/fcuny-defuns.el b/emacs.d/custom/fcuny-defuns.el index cb117f4..955650c 100644 --- a/emacs.d/custom/fcuny-defuns.el +++ b/emacs.d/custom/fcuny-defuns.el @@ -74,245 +74,6 @@ (decode-coding-string title 'utf-8)) (concat "[[" url "][" title "]]")))) -(defun fcuny/org-archive-subtree-as-completed () - "Archives the current subtree to today's current journal entry." - (interactive) - (ignore-errors - ;; According to the docs for `org-archive-subtree', the state should be - ;; automatically marked as DONE, but I don't notice that: - (when (not (equal "DONE" (org-get-todo-state))) - (org-todo "DONE"))) - - (let* ((org-archive-file (or org-default-completed-file - (fcuny/this-month-archive-entry))) - (org-archive-location (format "%s::" org-archive-file))) - (org-archive-subtree))) - -(defun fcuny/this-month-archive-entry () - "Return the full pathname to the month's archive entry file. -Granted, this assumes each journal's file entry to be formatted -with year/month, as in `201901' for January 4th. - -Note: `org-journal-dir' variable must be set to the directory -where all good journal entries live, e.g. ~/journal." - (let* ((daily-name (format "%s-archive.org" (format-time-string "%Y-%m"))) - (file-name (concat org-archive-dir daily-name))) - (expand-file-name file-name))) - -(defun fcuny/org-subtree-region () - "Return a list of the start and end of a subtree." - (save-excursion - (list (progn (org-back-to-heading) (point)) - (progn (org-end-of-subtree) (point))))) - -(defun fcuny/org-refile-directly (file-dest) - "Move the current subtree to the end of FILE-DEST. -If SHOW-AFTER is non-nil, show the destination window, -otherwise, this destination buffer is not shown." - (interactive "fDestination: ") - - (defun dump-it (file contents) - (find-file-other-window file-dest) - (goto-char (point-max)) - (insert "\n" contents)) - - (save-excursion - (let* ((region (fcuny/org-subtree-region)) - (contents (buffer-substring (first region) (second region)))) - (apply 'kill-region region) - (save-window-excursion (dump-it file-dest contents))))) - -(defun fcuny/org-refile-to-task () - "Refile (move) the current Org subtree to `org-default-tasks-file'." - (interactive) - (fcuny/org-refile-directly org-default-tasks-file)) - -(defun fcuny/org-refile-to-task () - "Refile (move) the current Org subtree to `org-default-tasks-file'." - (interactive) - (fcuny/org-refile-directly org-default-tasks-file)) - -(defun fcuny/org-refile-to-personal-notes () - "Refile (move) the current Org subtree to `org-default-notes-file'." - (interactive) - (fcuny/org-refile-directly org-default-notes-file)) - -(defun fcuny/org-refile-subtree-to-file (dir) - "Archive the org-mode subtree and create an entry in the -directory folder specified by DIR. It attempts to move as many of -the subtree's properties and other features to the new file." - (interactive "DDestination: ") - (let* ((props (fcuny/org-subtree-metadata)) - (head (plist-get props :header)) - (body (plist-get props :body)) - (tags (plist-get props :tags)) - (properties (plist-get props :properties)) - (area (plist-get props :region)) - (filename (fcuny/org-filename-from-title head)) - (filepath (format "%s/%s.org" dir filename))) - (apply #'delete-region area) - (fcuny/org-create-org-file filepath head body tags properties))) - -(defun fcuny/org-set-file-property (key value &optional spot) - "Make sure file contains a top-level, file-wide property. -KEY is something like `TITLE' or `FILETAGS'. This function makes -sure that the property contains the contents of VALUE, and if the -file doesn't have the property, it is inserted at either SPOT, or -if nil,the top of the file." - (save-excursion - (goto-char (point-min)) - (let ((case-fold-search t)) - (if (re-search-forward (format "^#\\+%s:\s*\\(.*\\)" key) nil t) - (replace-match value nil nil nil 1) - - (cond - ;; if SPOT is a number, go to it: - ((numberp spot) (goto-char spot)) - ;; If SPOT is not given, jump to first blank line: - ((null spot) (progn (goto-char (point-min)) - (re-search-forward "^\s*$" nil t))) - (t (goto-char (point-min)))) - - (insert (format "#+%s: %s\n" (upcase key) value)))))) - -(defun fcuny/org-create-org-file (filepath header body tags properties) - "Create a new Org file by FILEPATH. The contents of the file is -pre-populated with the HEADER, BODY and any associated TAGS." - (find-file-other-window filepath) - (fcuny/org-set-file-property "TITLE" header t) - (when tags - (fcuny/org-set-file-property "FILETAGS" (s-join " " tags))) - - ;; Insert any drawer properties as #+PROPERTY entries: - (when properties - (goto-char (point-min)) - (or (re-search-forward "^\s*$" nil t) (point-max)) - (--map (insert (format "#+PROPERTY: %s %s" (first it) (second it))) properties)) - - ;; My auto-insert often adds an initial headline for a subtree, and in this - ;; case, I don't want that... Yeah, this isn't really globally applicable, - ;; but it shouldn't cause a problem for others. - (when (re-search-forward "^\\* [0-9]$" nil t) - (replace-match "")) - - (delete-blank-lines) - (goto-char (point-max)) - (insert "\n") - (insert body)) - -(defun fcuny/org-subtree-metadata () - "Return a list of key aspects of an org-subtree. Includes the -following: header text, body contents, list of tags, region list -of the start and end of the subtree." - (save-excursion - ;; Jump to the parent header if not already on a header - (when (not (org-at-heading-p)) - (org-previous-visible-heading 1)) - - (let* ((context (org-element-context)) - (attrs (second context)) - (props (org-entry-properties))) - - (list :region (list (plist-get attrs :begin) (plist-get attrs :end)) - :header (plist-get attrs :title) - :tags (fcuny/org-get-subtree-tags props) - :properties (fcuny/org-get-subtree-properties attrs) - :body (fcuny/org-get-subtree-content attrs))))) - -(defun fcuny/org-filename-from-title (title) - "Creates a useful filename based on a header string, TITLE. -For instance, given the string: What's all this then? - This function will return: whats-all-this-then" - (let* ((no-letters (rx (one-or-more (not alphanumeric)))) - (init-try (->> title - downcase - (replace-regexp-in-string "'" "") - (replace-regexp-in-string no-letters "-")))) - (string-trim init-try "-+" "-+"))) - -(defun fcuny/org-get-subtree-content (attributes) - "Return the contents of the current subtree as a string." - (let ((header-components '(clock diary-sexp drawer headline inlinetask - node-property planning property-drawer section))) - - (goto-char (plist-get attributes :contents-begin)) - - ;; Walk down past the properties, etc. - (while - (let* ((cntx (org-element-context)) - (elem (first cntx)) - (props (second cntx))) - (when (member elem header-components) - (goto-char (plist-get props :end))))) - - ;; At this point, we are at the beginning of what we consider - ;; the contents of the subtree, so we can return part of the buffer: - (buffer-substring-no-properties (point) (org-end-of-subtree)))) - -(defun fcuny/org-get-subtree-properties (attributes) - "Return a list of tuples of a subtrees properties where the keys are strings." - - (defun symbol-upcase? (sym) - (let ((case-fold-search nil)) - (string-match-p "^:[A-Z]+$" (symbol-name sym)))) - - (defun convert-tuple (tup) - (let ((key (first tup)) - (val (second tup))) - (list (substring (symbol-name key) 1) val))) - - (->> attributes - (-partition 2) ; Convert plist to list of tuples - (--filter (symbol-upcase? (first it))) ; Remove lowercase tuples - (-map 'convert-tuple))) - -(defun fcuny/org-get-subtree-tags (&optional props) - "Given the properties, PROPS, from a call to -`org-entry-properties', return a list of tags." - (unless props - (setq props (org-entry-properties))) - (let ((tag-label "ALLTAGS" )) - (-some->> props - (assoc tag-label) - cdr - substring-no-properties - (s-split ":") - (--filter (not (equalp "" it)))))) - -(defun fcuny/org-refile-to-projects-dir () - "Move the current subtree to a file in the `projects' directory." - (interactive) - (fcuny/org-refile-subtree-to-file org-default-projects-dir)) - -(defun fcuny/org-refile-to-personal-dir () - "Move the current subtree to a file in the `personal' directory." - (interactive) - (fcuny/org-refile-subtree-to-file org-default-personal-dir)) - -(defun fcuny/org-refile-to-incubate () - "Refile (move) the current Org subtree to `org-default-incubate-fire'." - (interactive) - (fcuny/org-refile-directly org-default-incubate-file)) - -(defun fcuny/org-refile-to-technical-dir () - "Move the current subtree to a file in the `technical' directory." - (interactive) - (fcuny/org-refile-subtree-to-file org-default-technical-dir)) - -(defun fcuny/org-journal-date-format-func (time) - "Custom function to insert journal date header. - - When buffer is empty prepend a header in front the entry header." - (concat (when (= (buffer-size) 0) - (concat - (pcase org-journal-file-type - (`daily "#+TITLE: Daily Journal") - (`weekly "#+TITLE: Weekly Journal") - (`monthly "#+TITLE: Monthly Journal") - (`yearly "#+TITLE: Yearly Journal")))) - org-journal-date-prefix - (format-time-string "%x (%A)" time))) - (defun fcuny/uniquify-region-lines (beg end) "Remove duplicate adjacent lines in region." (interactive "*r") @@ -322,6 +83,7 @@ For instance, given the string: What's all this then? (replace-match "\\1")))) (defun fcuny/gocs () + """Custom function to research a term using go/cs" (interactive) (let ((text (read-string "Search for: " (thing-at-point 'word)))) (browse-url (format "http://go/cs/%s" text)))) diff --git a/emacs.d/custom/fcuny-org.el b/emacs.d/custom/fcuny-org.el index dae6c7a..8ab36f4 100644 --- a/emacs.d/custom/fcuny-org.el +++ b/emacs.d/custom/fcuny-org.el @@ -293,4 +293,47 @@ The current time is used if the entry has no timestamp." (interactive) (fcuny/org-refile-to-datetree org-default-work-journal-file)) +(defun fcuny/org-subtree-region () + "Return a list of the start and end of a subtree." + (save-excursion + (list (progn (org-back-to-heading) (point)) + (progn (org-end-of-subtree) (point))))) + +(defun fcuny/org-refile-directly (file-dest) + "Move the current subtree to the end of FILE-DEST. +If SHOW-AFTER is non-nil, show the destination window, +otherwise, this destination buffer is not shown." + (interactive "fDestination: ") + + (defun dump-it (file contents) + (find-file-other-window file-dest) + (goto-char (point-max)) + (insert "\n" contents)) + + (save-excursion + (let* ((region (fcuny/org-subtree-region)) + (contents (buffer-substring (first region) (second region)))) + (apply 'kill-region region) + (save-window-excursion (dump-it file-dest contents))))) + +(defun fcuny/org-refile-to-task () + "Refile (move) the current Org subtree to `org-default-tasks-file'." + (interactive) + (fcuny/org-refile-directly org-default-tasks-file)) + +(defun fcuny/org-refile-to-personal () + "Refile (move) the current Org subtree to `org-default-personal-file'." + (interactive) + (fcuny/org-refile-directly org-default-personal-file)) + +(defun fcuny/org-refile-to-notes () + "Refile (move) the current Org subtree to `org-default-notes-file'." + (interactive) + (fcuny/org-refile-directly org-default-notes-file)) + +(defun fcuny/org-refile-to-work () + "Refile (move) the current Org subtree to `org-default-work-file'." + (interactive) + (fcuny/org-refile-directly org-default-work-file)) + (provide 'fcuny-org) |