* [PATCH] Various improvements to org-fstree.
2009-10-17 20:53 org-fstree James TD Smith
@ 2009-10-17 20:53 ` James TD Smith
0 siblings, 0 replies; 2+ messages in thread
From: James TD Smith @ 2009-10-17 20:53 UTC (permalink / raw)
To: andy13; +Cc: emacs-orgmode
Fstree blocks are now org dblocks, which removes the need for the code for
finding fstree blocks and parsing the options.
Make the recursive directory filtering less ugly (and faster).
Trigger the dynamic updates from properties. It still doesn't quite work right,
but it was experimental anyway.
---
org-fstree.el | 419 ++++++++++++++++++++++++---------------------------------
1 files changed, 174 insertions(+), 245 deletions(-)
diff --git a/org-fstree.el b/org-fstree.el
index a4a5847..3be7f35 100644
--- a/org-fstree.el
+++ b/org-fstree.el
@@ -1,9 +1,11 @@
;;; org-fstree.el --- include a filesystem subtree into an org file
-;; Copyright 2009 Andreas Burtzlaff
+;; Copyright 2009 Andreas Burtzlaff, James TD Smith
;;
;; Author: Andreas Burtzlaff < andreas at burtz[REMOVE]laff dot de >
+;; James TD Smith < ahktenzero at mohorovi dot cc >
+;;
;; Version: 0.4
;; Keywords: org-mode filesystem tree
;; X-URL: <http://www.burtzlaff.de/org-fstree/org-fstree.el>
@@ -27,282 +29,209 @@
;;; Commentary:
;; org-fstree inserts the filesystem subtree for a given directory.
-;; Each file/directory is formatted as a headline, provides links back
-;; to all headlines that are associated with it (by containing links to the file)
+;; Each file/directory is formatted as a headline, provides links back
+;; to all headlines that are associated with it (by containing links to the file)
;; and is assigned their tags.
;;
;; Installation:
-;; - put this file into your load-path
+;; - put this file into your load-path
;; - insert "(require 'org-fstree)" into ~/.emacs
;;
;; Usage:
-;; - enter a line containing "#+BEGIN_FSTREE: <dir>" into an org buffer,
-;; where <dir> is the directory, that is to be inserted.
+;; - enter a line containing "#+BEGIN fstree :dir <dir>" into an org buffer,
+;; where <dir> is the directory that is to be inserted, and an #+END line
+;; afterwards.
;; - while the cursor is in the line mentioned, press "C-c C-c"
;;
;; Options:
;; Specify options in the form:
-;; "#+BEGIN_FSTREE: <dir> :<optionname1> <optionvalue1> :<optionname2> <optionvalue2> ...
+;; "#+BEGIN fstree :dir <dir> [:<optionname1> <optionvalue1>]...
;; Options are:
;; - :non-recursive t , to suppress recursion into directories
-;; - :exclude-regexp-name <list of regexp strings> , exclude file/directory names matching either
-;; of the given regexp expressions
-;; Examples:
-;; :exclude-regexp-name (".*\\.pdf$" ".*\\.zip$"), excludes files/directories ending with either ".pdf" or ".zip"
-;; :exclude-regexp-name ("^\\.git$") , excludes files/directories named ".git"
;;
-;; - :exclude-regexp-fullpath <list of regexp strings>, same as :exclude-regexp-name but matches absolute path to file/directory
+;; - :exclude-regexp-name <list of regexp strings>, exclude file / directory
+;; names matching either of the given regexp expressions
+;;
+;; Examples:
+;;
+;; :exclude-regexp-name (".*\\.pdf$" ".*\\.zip$"), excludes files /
+;; directories ending with either ".pdf" or ".zip"
+;;
+;; :exclude-regexp-name ("^\\.git$"), excludes files/directories named
+;; ".git"
+;;
+;; - :exclude-regexp-fullpath <list of regexp strings>, same as
+;; :exclude-regexp-name but matches absolute path to file/directory
+;;
;; - :relative-links t , generates relative instead of absolute links
+;;
;; - :show-only-matches t , only files that are being linked to show up
+;;
;; - :only-directories t , only directories are listed
+;;
;; - :only-regular-files t , only regular files are listed
-;; - :dynamic-update t , [EXPERIMENTAL] dynamically update a subtree on visibility cycling.
-;; - :links-as-properties t, sets the links as properties Link1, Link2,... for use in column view [Does not work with dynamic-update!]
-;; - :no-annotations t, suppresses the search and display of file annotations
+;; - :dynamic-update t , [EXPERIMENTAL] dynamically update a subtree on
+;; visibility cycling.
+;; - :links-as-properties t, sets the links as properties Link1, Link2,...
+;; for use in column view [Does not work with dynamic-update!]
+;; - :no-annotations t, suppresses the search and display of file
+;; annotations
;;
-;; Limitations and warnings:
+;; - :links-as-properties t, sets the links as properties Link1, Link2,...
+;; for use in column view [Does not work with dynamic-update!]
;;
-;; - when triggering an update (by pressing "C-c C-c" while in the line mentioned above)
-;; the COMPLETE REGION BETWEEN "#+BEGIN_FSTREE" AND "#+END_FSTREE" IS REPLACED.
-;; - speed
-;;
-;; Code:
-
-(provide 'org-fstree)
+;; - :no-annotations t, suppresses the search and display of file
+;; annotations
+;;
+;; To automatically update the contents of fstree blocks set the FSTREE_UPDATE
+;; property to t
+;;
+;; Limitations and warnings:
+;;
+;; - when triggering an update (by pressing "C-c C-c" while in the line
+;; mentioned above) the COMPLETE REGION BETWEEN "#+BEGIN_FSTREE" AND
+;; "#+END_FSTREE" IS REPLACED.
+;; - Chokes on filenames containing [s or ]s.
+;;
+;;; Code:
(require 'org)
-
-(defun org-fstree-generate (dir level options)
- (interactive)
+(require 'cl)
+
+(defgroup org-fstree nil
+ "Org dynamic blocks for file system trees"
+ :tag 'Org-fstree
+ :group 'org)
+
+(defcustom org-fstree-default-excludes (list "^\\.git" "^\\.svn" "^CVS" "\\.?\\#" "~$")
+ "Default files and directories to ignore when filling the fstree dblock"
+ :group 'org-fstree
+ :type 'list)
+
+(defun org-dblock-write:fstree (params)
+ "org-dblocks wrapper for org-fstree-generate"
+ (org-fstree-generate (if (stringp (plist-get params :dir))
+ (plist-get params :dir)
+ (format "%s" (plist-get params :dir)))
+ (org-fstree-get-current-outline-level)
+ params)
+ (insert "\n"))
+
+(defun org-fstree-generate (dir level params)
+ "Insert an org tree for files under `dir' at `level'"
;; (message "org-fstree-generate") ;; DEBUG
(if (file-directory-p dir)
- (let (
- (non-recursive (plist-get options :non-recursive))
- (exclude-regexp-name-list (plist-get options :exclude-regexp-name))
- (exclude-regexp-fullpath-list (plist-get options :exclude-regexp-fullpath))
- (links-as-properties (plist-get options :links-as-properties))
- (dynamic-update (plist-get options :dynamic-update))
- (fullFileNames (directory-files dir 1 nil nil) )
- (fileNames (directory-files dir nil nil nil) )
- fileName
- fullFileName
- currentHeadline
- orgHeadlineInfo
- curTags
- curPos
- (linksList nil)
- (retString "")
- )
- (while fileNames
- (setq fullFileName (car fullFileNames))
- (setq fullFileNames (cdr fullFileNames))
- (setq fileName (car fileNames))
- (setq fileNames (cdr fileNames))
- (setq linksList nil)
- (setq curTags nil)
- (cond ((member fileName '("." "..")))
- ;; the following two lines are really ugly. I'll be glad if someone with more lisp experience tidies this up.
- ((reduce (function (lambda (a b) (or a b))) (mapcar (function (lambda (regexp) (not (string= fullFileName (replace-regexp-in-string regexp "" fullFileName) )) )) exclude-regexp-fullpath-list ) :initial-value nil))
- ((reduce (function (lambda (a b) (or a b))) (mapcar (function (lambda (regexp) (not (string= fileName (replace-regexp-in-string regexp "" fileName) )) )) exclude-regexp-name-list ) :initial-value nil))
- ((and (not (file-directory-p fullFileName)) (plist-get options :only-directories)))
- ((and (not (file-regular-p fullFileName)) (plist-get options :only-regular-files)))
- (t
- (save-excursion
- (cond ((plist-get options :no-annotations))
- (t
- ;; Search for links in current buffer
- (goto-char (point-min))
- (setq curPos (point))
- (while (re-search-forward org-bracket-link-regexp nil t)
- (let ((filenameInLink (match-string 1)))
- (cond ( (org-fstree-get-parameters-if-inside-fstree-block) (re-search-forward "#\\+END_FSTREE" nil t) )
- ( (string= fullFileName (expand-file-name (replace-regexp-in-string "^file:" "" filenameInLink ) ":" ) )
- (let ((p (point)))
- (cond ((org-before-first-heading-p))
- (t
- ;; go to associated heading
- (org-back-to-heading t)
- (setq orgHeadlineInfo (org-heading-components))
- (setq curTags (concat curTags (nth 5 orgHeadlineInfo) ))
- (setq currentHeadline (nth 4 orgHeadlineInfo))
- ;; filter all links from headline, generate link to it and append to linksList
- (let ((cleanedHeadline (replace-regexp-in-string "\\[\\[.*\\]\\]" "" currentHeadline)))
-
- (setq linksList (cons (concat "[[*" cleanedHeadline "]"
- (cond ( (plist-get options :show-only-matches)
- "[" (replace-regexp-in-string (regexp-quote fullFileName) "" cleanedHeadline) "]" ) )
- "]")
- linksList) ) )
- (goto-char p)
- )))))))))
-
- (cond ((or (not (plist-get options :show-only-matches)) (not (null linksList)))
- ;; construct headline for current file/directory
- (let* ((tagString (cond ((not (null curTags)) (concat " " (replace-regexp-in-string "::" ":" curTags)) ) ))
- (linkCount 0)
- (headingString (format "\n%s |%s| [[file:%s][%s]] "
- (make-string level ?*)
- (cond ((file-directory-p fullFileName) "D") ((file-symlink-p fullFileName) "L") (t " "))
- (if (plist-get options :relative-links) (file-relative-name fullFileName) fullFileName) fileName)))
- (cond (links-as-properties
- (setq retString (concat retString headingString (if tagString tagString "")
- (if (not (null linksList))
- (concat "\n :PROPERTIES:\n "
- (mapconcat (function (lambda (string) (setq linkCount (1+ linkCount)) (concat ":Link" (number-to-string linkCount) ":" string ))) linksList "\n")
- "\n :END:" ) ))))
- (t
- (setq retString (concat retString headingString
- (make-string (max 0 (- 100 (length headingString))) ? )
- (if linksList (concat "{ " (mapconcat 'identity linksList " | ") " }"))
- (if tagString tagString)
- ))))
- (if (and (not non-recursive) (not dynamic-update) (file-directory-p fullFileName) )
- (setq retString (concat retString (org-fstree-generate fullFileName (1+ level) options) ) )
- ))))))))
- retString)
+ (let* ((recursive (not (plist-get params :non-recursive)))
+ (show-only-matches (plist-get params :show-only-matches))
+ (exclude-name-regexp
+ (org-fstree-list-to-regex org-fstree-default-excludes
+ (plist-get params :exclude-regexp-name)))
+ (exclude-fullpath-regexp
+ (org-fstree-list-to-regex (plist-get params :exclude-regexp-fullpath)))
+ (links-as-properties (plist-get params :links-as-properties))
+ (rel-links (plist-get params :relative-links))
+ (dynamic-update (plist-get params :dynamic-update)))
+ (dolist (absFileName
+ (remove-if (lambda (x)
+ (or (string-match "/\\(\\.\\|\\.\\.\\)$" x)
+ (and exclude-name-regexp
+ (string-match exclude-name-regexp
+ (file-name-nondirectory x)))
+ (and exclude-fullpath-regexp
+ (string-match exclude-fullpath-regexp x))))
+ (directory-files dir t nil t)))
+ (let* ((fileName (file-name-nondirectory absFileName))
+ (relFileName (file-relative-name absFileName))
+ (link-regexp (concat "file:\\(" absFileName "\\|"
+ (org-link-escape absFileName)
+ "\\|" absFileName "\\|"
+ (org-link-escape relFileName)
+ "\\|" relFileName "\\)\\]"))
+ curTags linksList)
+ ;; Search for links in current buffer
+ (save-excursion
+ (goto-char (point-min))
+ ;;Need escaped and unescaped versions to deal with old
+ ;;org files, manually edited links etc.
+ (while (re-search-forward link-regexp nil t)
+ (save-excursion
+ ;; go to associated heading
+ (org-back-to-heading t)
+ ;; filter all links from headline, generate
+ ;; link to it and append to linksList
+ (let* ((heading-parts (org-heading-components))
+ (cleanedHeadline (replace-regexp-in-string
+ "\\[\\[.*\\]\\]" ""
+ (nth 4 heading-parts))))
+ (append-to-list 'curTags (org-get-tags-at))
+ (add-to-list 'linksList
+ (org-make-link-string
+ (concat "id:" (org-id-get-create))
+ cleanedHeadline))))))
+ (when (or (not show-only-matches) linksList)
+ ;; construct headline for current file/directory
+ (insert "\n" (make-string level ?*) " ["
+ (if (file-directory-p absFileName) "D" " ") "] "
+ (org-make-link-string
+ (concat "file:"
+ (if rel-links relFileName fileName))
+ fileName)
+ (or (org-fstree-join-lists " :" ":" ":" curTags)
+ ""))
+ ;;Set link properties or append links if required
+ (when linksList
+ (if links-as-properties
+ (progn (org-back-to-heading)
+ (loop for link in linksList
+ for linkIndex from 0
+ do (org-set-property
+ (format "Link_%d" linkIndex) link))
+ (re-search-forward ":END:"))
+ (insert "\n")
+ (mapc (lambda (link)
+ (unless (org-insert-item)
+ (org-indent-line-function)
+ (insert "- "))
+ (insert link))
+ linksList)))
+ (save-excursion
+ (org-back-to-heading)
+ (org-set-tags nil t)) ;Align tags
+ (if (and recursive (file-directory-p absFileName))
+ (org-fstree-generate absFileName (1+ level) params))))))
(message "%s is not a directory" dir)))
-(defun org-fstree-apply-maybe ()
- (interactive)
-;; (message "org-fstree-apply-maybe") (sit-for 1) ;; DEBUG
- (save-excursion
- (if (save-excursion (beginning-of-line 1) (looking-at "#\\+END_FSTREE"))
- (re-search-backward "#\\+BEGIN_FSTREE" nil t))
- (cond
- ((save-excursion (beginning-of-line 1) (looking-at "#\\+BEGIN_FSTREE"))
- (let* ((params (org-fstree-gather-parameters))
- (dir (org-link-expand-abbrev (plist-get params :dir)))
- (options (plist-get params :params))
- level)
- ;; get current level; there is a BUG if "#+BEGIN_FSTREE" is inserted after the last headlines dots, that indicate its folded state.
- ;; (let ((p (point)))
- (save-excursion
- (cond ((org-before-first-heading-p)
- (setq level 1))
- (t (org-back-to-heading)
- (setq level (+ (funcall outline-level) 1))
- ;; (goto-char p)
- )))
- (forward-line)
- (let ((beg (point)))
- (re-search-forward "#\\+END_FSTREE\\|#\\+BEGIN_FSTREE" nil t)
- ;;(let ((generatedString (org-fstree-generate dir level options)))
- (cond ( (looking-back "#\\+END_FSTREE")
- (forward-line -1)
- (end-of-line 1)
- (delete-region beg (point) )
- (insert (concat (org-fstree-generate dir level options) "\n\n")))
- (t (goto-char beg)
- (insert (concat (org-fstree-generate dir level options) "\n\n\n#+END_FSTREE"))))
- ;; hide all subtrees
- (org-map-region (function (lambda () (hide-subtree))) beg (point))
-
- ;;)
- ))
- 1))))
-
-
(defun org-fstree-show-entry-maybe (state)
(interactive)
-;; (message "show-entry-maybe..") (sit-for 1) ;; DEBUG
- (let* ( (parameters (save-excursion (org-fstree-get-parameters-if-inside-fstree-block)))
- (options (plist-get parameters :params)))
-
- (cond ((and parameters (not (plist-get options :non-recursive)) (plist-get options :dynamic-update) )
- ;; we are inside the FSTREE block and have to update
- ;; delete existing content
- (save-excursion
- (let* ((endfstree (save-excursion (re-search-forward "#\\+END_FSTREE" nil t) (beginning-of-line) (point)))
- (end (save-excursion
- ;; go to the end of the subtree, specifically to the beginning of the next headline
- (org-end-of-subtree nil t)
- ;; check whether the end of the fstree block has been trespassed
- (and (> (point) endfstree) (goto-char endfstree))
- ;; got back on character, because editing heading lines in column mode is not possible.
- ;; this line is supposed to be either empty or an entry.
- (forward-char -1)
- (point)
- )))
- (beginning-of-line 2)
- (if (looking-at " *:PROPERTIES:") (progn (re-search-forward ":END:" nil t) (forward-line 1)))
-
-
- (when (and (> (count-lines (point) end) 0) (< (point) end))
- (delete-region (point) end)
- )
- )
- )
- (cond ((eq state 'folded))
- (t
- ;; insert new content
- (save-excursion
- (let ((beg (point))
- end
- (level (1+ (funcall outline-level)))
- (dir (org-fstree-extract-path-from-headline))
- (newOptions (plist-put (plist-get parameters :params) ':non-recursive 't)))
- (when (file-directory-p dir)
- ;;(when (plist-get options :links-as-properties) (forward-line 1))
- (if (looking-at " *:PROPERTIES:") (progn (re-search-forward ":END" nil t) (forward-line 1)))
- (end-of-line 1)
- (when (plist-get options :links-as-parameters)
- (org-columns-quit))
-
- (insert (org-fstree-generate dir level newOptions))
-
- (when (plist-get options :links-as-parameters)
- (org-columns))
- (setq end (point))
- ;; hide all subtrees
- ;;(if (plist-get options :links-as-properties)
- ;;(progn
- ;; (org-map-region (function (lambda () (hide-subtree))) beg (point)))
- (org-end-of-subtree)
- (hide-subtree)
- ))))
- )))))
-
-
-(defun org-fstree-extract-path-from-headline ()
-;; (interactive) ;;DEBUG
(save-excursion
- (beginning-of-line 1)
- (if (looking-at org-fstree-heading-regexp)
- (match-string-no-properties 1))))
-
-(defconst org-fstree-heading-regexp ".*\\[\\[file:\\(.*\\)\\]\\[.*\\]\\]"
- "Matches headline in org-fstree section.")
-(make-variable-buffer-local 'org-fstree-heading-regexp)
-
-(defun org-fstree-get-parameters-if-inside-fstree-block ()
- (interactive)
- (and (save-excursion
- (re-search-forward "#\\+END_FSTREE" nil t) )
- (save-excursion
- (re-search-backward "#\\+BEGIN_FSTREE" nil t)
- (org-fstree-gather-parameters))))
-
-(defun org-fstree-gather-parameters ()
- (save-excursion
- (let (rtn)
- (beginning-of-line 1)
- (if (looking-at "#\\+BEGIN_FSTREE[: \t][ \t]*\\([^ \t\r\n]+\\)\\( +.*\\)?")
- (let ((dir (org-no-properties (match-string 1)))
- (params (if (match-end 2)
- (read (concat "(" (match-string 2) ")")))))
- (setq rtn (list :dir dir :params params) )
- ))
-
- rtn)
- )
-)
+ (save-restriction
+ (when (and (car (read-from-string (or (org-entry-get (point) "FSTREE_UPDATE" nil)
+ "nil")))
+ (memq state '(children subtree)))
+ (let ((start (progn (org-back-to-heading t) (point)))
+ (end (progn (re-search-forward "#\\+END:")
+ (forward-line)
+ (point))))
+ (narrow-to-region start end)
+ (message "from %d to %d" start end)
+ (org-update-all-dblocks))))))
(defun org-fstree-get-current-outline-level ()
(save-excursion
(cond ((org-before-first-heading-p) 1)
(t
(org-back-to-heading)
- (+ (funcall outline-level) 1)))))
+ (1+ (funcall outline-level))))))
+
+(defun org-fstree-list-to-regex (&rest lists)
+ "Turn a multiple list of regex components into a single or-ed regex"
+ (apply 'org-fstree-join-lists "\\(" "\\)" "\\|" lists))
-(add-hook 'org-ctrl-c-ctrl-c-hook 'org-fstree-apply-maybe)
-(add-hook 'org-pre-cycle-hook 'org-fstree-show-entry-maybe)
\ No newline at end of file
+(defun org-fstree-join-lists (start end sep &rest lists)
+ (let ((items (remove-duplicates (apply 'append lists))))
+ (if items
+ (concat start (reduce (lambda (a b) (concat a sep b)) items)
+ end))))
+(add-hook 'org-pre-cycle-hook 'org-fstree-show-entry-maybe)
+
+(provide 'org-fstree)
--
1.6.3.3
^ permalink raw reply related [flat|nested] 2+ messages in thread