From ac37ba4c7bc5a1543787e407c4053d5f517e3806 Mon Sep 17 00:00:00 2001 From: andy Date: Sun, 5 Apr 2009 22:38:43 +0200 Subject: [PATCH] import org-fstree.el --- org-fstree.el | 267 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 267 insertions(+) create mode 100644 org-fstree.el diff --git a/org-fstree.el b/org-fstree.el new file mode 100644 index 0000000..4f191be --- /dev/null +++ b/org-fstree.el @@ -0,0 +1,267 @@ +;;; org-fstree.el --- include a filesystem subtree into an org file + + +;; Copyright 2009 Andreas Burtzlaff +;; +;; Author: Andreas Burtzlaff < andreas at burtz[REMOVE]laff dot de > +;; Version: 0.3 +;; Keywords: org-mode filesystem tree +;; X-URL: +;; +;; 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 2, 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, write to the Free Software +;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +;;; 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) +;; and is assigned their tags. +;; +;; Installation: +;; - put this file into your load-path +;; - insert "(require 'org-fstree)" into ~/.emacs +;; +;; Usage: +;; - enter a line containing "#+BEGIN_FSTREE: " into an org buffer, +;; where is the directory, that is to be inserted. +;; - while the cursor is in the line mentioned, press "C-c C-c" +;; +;; Options: +;; Specify options in the form: +;; "#+BEGIN_FSTREE: : : ... +;; Options are: +;; - :non-recursive t , to suppress recursion into directories +;; - :exclude-regexp-name , 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 , 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 +;; +;; 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. +;; - problems matching links to files with exotic characters in their names +;; - speed +;; +;; Code: + +(provide 'org-fstree) + +(require 'org) + +(defun org-fstree-generate (dir level options) +;; (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)) + (fullFileNames (directory-files dir 1 nil t) ) + (fileNames (directory-files dir nil nil t) ) + 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 is a 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)) + (t + (save-excursion + ;; 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]] %s" + (make-string level ?*) + (if (file-directory-p fullFileName) "D" " ") + (if (plist-get options :relative-links) (file-relative-name fullFileName) fullFileName) fileName + (if tagString tagString "")))) + + (setq retString (concat retString headingString + (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:" ) ))) + (if (and (null non-recursive) (file-directory-p fullFileName) ) + (setq retString (concat retString (org-fstree-generate fullFileName (1+ level) options) ) ) + )))))))) + retString) + (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 (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))) + (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" nil t) + (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") ) + ) + (t (goto-char beg) + (insert (concat (concat (org-fstree-generate dir level options) "\n") "\n#+END_FSTREE")) + ) + ) + ) + ) + 1 + ) + ) + ) + ) + + +(defun org-fstree-show-entry-maybe () + (interactive) + (message "show-entry-maybe..") (sit-for 1) ;; DEBUG + (let* ( (parameters (org-fstree-get-parameters-if-inside-fstree-block)) + (options (plist-get parameters :params))) + + (cond ((and parameters (message "p") (not (plist-get options :non-recursive)) (message "nr") (plist-get options :dynamic-update) (message "du") ) + ;; we are inside the FSTREE block and have to update + ;; delete existing content + (message "show-entry-maybe deleting subtree") (sit-for 1) ;; DEBUG + (save-excursion + (forward-line 1) + (let ((beg (point))) + (org-end-of-subtree) + (delete-region beg (point)) + ) + ) + ;; insert new content + (message "show-entry-maybe generate and insert subtree") (sit-for 1) ;; DEBUG + (save-excursion + (let ((level (1+ (funcall outline-level))) + (dir (org-fstree-extract-path-from-headline))) + (end-of-line 1) + (insert (org-fstree-generate dir level (plist-get parameters :parms)))))))) + (sit-for 1)) + +(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:\\(.*\\)\\]\\[.*\\]\\]" +(defconst org-fstree-heading-regexp ".*\\[\\[file:\\(.*\\)\\]\\[.*\\]\\]" + + "Matches first line of a hidden block.") +(make-variable-buffer-local 'org-fstree-heading-regexp) + +(defun org-fstree-get-parameters-if-inside-fstree-block () + (interactive) +;; (message "org-fstree-get-parameters-if-inside-fstree-block") (sit-for 1) ;; DEBUG + (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 () +;; (message "org-fstree-gather-parameters") (sit-for 1) ;; DEBUG + (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) ) +;; (message (format "Got %s parameters for dir: %s" (number-to-string (length params)) dir)) (sit-for 1) ;; DEBUG + )) + + rtn) + ) +) + +(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))))) + +(add-hook 'org-ctrl-c-ctrl-c-hook 'org-fstree-apply-maybe) +(add-hook 'org-show-entry-hook 'org-fstree-show-entry-maybe) \ No newline at end of file -- 2.11.4.GIT