org-fstree.el

   1 ;;; org-fstree.el --- include a filesystem subtree into an org file
   2
   3
   4 ;; Copyright 2009 Andreas Burtzlaff
   5 ;;
   6 ;; Author: Andreas Burtzlaff < andreas at burtz[REMOVE]laff dot de >
   7 ;; Version: 0.3
   8 ;; Keywords: org-mode filesystem tree
   9 ;; X-URL: <http://www.burtzlaff.de/org-fstree/org-fstree.el>
  10 ;;
  11 ;; This file is not part of GNU Emacs.
  12 ;;
  13 ;; This program is free software; you can redistribute it and/or
  14 ;; modify it under the terms of the GNU General Public License as
  15 ;; published by the Free Software Foundation; either version 2, or (at
  16 ;; your option) any later version.
  17 ;;
  18 ;; This program is distributed in the hope that it will be useful, but
  19 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  21 ;; General Public License for more details.
  22 ;;
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with this program; if not, write to the Free Software
  25 ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  26
  27 ;;; Commentary:
  28
  29 ;; org-fstree inserts the filesystem subtree for a given directory.
  30 ;; Each file/directory is formatted as a headline, provides links back
  31 ;; to all headlines that are associated with it (by containing links to the file)
  32 ;; and is assigned their tags.
  33 ;;
  34 ;; Installation:
  35 ;;   - put this file into your load-path
  36 ;;   - insert "(require 'org-fstree)" into ~/.emacs
  37 ;;
  38 ;; Usage:
  39 ;;   - enter a line containing "#+BEGIN_FSTREE: <dir>" into an org buffer,
  40 ;;     where <dir> is the directory, that is to be inserted.
  41 ;;   - while the cursor is in the line mentioned, press "C-c C-c"
  42 ;;
  43 ;; Options:
  44 ;;   Specify options in the form:
  45 ;;   "#+BEGIN_FSTREE: <dir> :<optionname1> <optionvalue1> :<optionname2> <optionvalue2>  ...
  46 ;;   Options are:
  47 ;;     - :non-recursive t , to suppress recursion into directories
  48 ;;     - :exclude-regexp-name <list of regexp strings> , exclude file/directory names matching either
  49 ;;                                                  of the given regexp expressions
  50 ;;       Examples:
  51 ;;         :exclude-regexp-name (".*\\.pdf$" ".*\\.zip$"), excludes files/directories ending with either ".pdf" or ".zip"
  52 ;;         :exclude-regexp-name ("^\\.git$") , excludes files/directories named ".git"
  53 ;;
  54 ;;     - :exclude-regexp-fullpath <list of regexp strings>, same as :exclude-regexp-name but matches absolute path to file/directory
  55 ;;     - :relative-links t , generates relative instead of absolute links
  56 ;;     - :show-only-matches t , only files that are being linked to show up
  57 ;;
  58 ;; Limitations and warnings:
  59 ;;
  60 ;;   - when triggering an update (by pressing "C-c C-c" while in the line mentioned above)
  61 ;;     the COMPLETE REGION BETWEEN "#+BEGIN_FSTREE" AND "#+END_FSTREE" IS REPLACED.
  62 ;;   - problems matching links to files with exotic characters in their names
  63 ;;   - speed
  64 ;;
  65 ;; Code:
  66
  67 (provide 'org-fstree)
  68
  69 (require 'org)
  70
  71 (defun org-fstree-generate (dir level options)
  72 ;;  (message "org-fstree-generate") ;; DEBUG
  73   (if (file-directory-p dir)
  74      (let (
  75            (non-recursive (plist-get options :non-recursive))
  76            (exclude-regexp-name-list (plist-get options :exclude-regexp-name))
  77            (exclude-regexp-fullpath-list (plist-get options :exclude-regexp-fullpath))
  78            (links-as-properties (plist-get options :links-as-properties))
  79            (fullFileNames (directory-files dir 1 nil t) )
  80            (fileNames (directory-files dir nil nil t) )
  81            fileName
  82            fullFileName
  83            currentHeadline
  84            orgHeadlineInfo
  85            curTags
  86            curPos
  87            (linksList nil)
  88            retString
  89            )
  90        (while fileNames
  91          (setq fullFileName (car fullFileNames))
  92          (setq fullFileNames (cdr fullFileNames))
  93          (setq fileName (car fileNames))
  94          (setq fileNames (cdr fileNames))
  95          (setq linksList nil)
  96          (setq curTags nil)
  97          (cond ((member fileName '("." "..")))
  98                ;; the following two lines is a really ugly. I'll be glad if someone with more lisp experience tidies this up.
  99                ((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))
 100                ((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))
 101                (t
 102                 (save-excursion
 103                 ;; Search for links in current buffer
 104                 (goto-char (point-min))
 105                 (setq curPos (point))
 106                 (while (re-search-forward org-bracket-link-regexp nil t)
 107                   (let ((filenameInLink (match-string 1)))
 108                   (cond ( (org-fstree-get-parameters-if-inside-fstree-block) (re-search-forward "#\\+END_FSTREE" nil t) )
 109                         ( (string= fullFileName (expand-file-name (replace-regexp-in-string "^file:" "" filenameInLink ) ":" ) )
 110                           (let ((p (point)))
 111                             (cond ((org-before-first-heading-p))
 112                                   (t
 113                                    ;; go to associated heading
 114                                    (org-back-to-heading t)
 115                                    (setq orgHeadlineInfo (org-heading-components))
 116                                    (setq curTags (concat curTags (nth 5 orgHeadlineInfo) ))
 117                                    (setq currentHeadline (nth 4 orgHeadlineInfo))
 118                                    ;; filter all links from headline, generate link to it and append to linksList
 119                                    (let ((cleanedHeadline (replace-regexp-in-string "\\[\\[.*\\]\\]" "" currentHeadline)))
 120
 121                                      (setq linksList (cons (concat "[[*"  cleanedHeadline "]"
 122                                                                    (cond ( (plist-get options :show-only-matches)
 123                                                                            "[" (replace-regexp-in-string (regexp-quote fullFileName) "" cleanedHeadline) "]" ) )
 124                                                                    "]")
 125                                                            linksList) ) )
 126                                    (goto-char p)
 127                                    )))))))
 128
 129                 (cond ((or (not (plist-get options :show-only-matches)) (not (null linksList)))
 130                        ;; construct headline for current file/directory
 131                        (let* ((tagString (cond ((not (null curTags)) (concat "  " (replace-regexp-in-string "::" ":" curTags)) ) ))
 132                               (linkCount 0)
 133                               (headingString (format "\n%s [%s] [[file:%s][%s]] %s"
 134                                                      (make-string level ?*)
 135                                                      (if (file-directory-p fullFileName) "D" " ")
 136                                                      (if (plist-get options :relative-links) (file-relative-name fullFileName) fullFileName) fileName
 137                                                      (if tagString tagString ""))))
 138
 139                          (setq retString (concat retString headingString
 140                                                  (if (not (null linksList))
 141                                                      (concat "\n :PROPERTIES:\n "
 142                                                              (mapconcat (function (lambda (string) (setq linkCount (1+ linkCount)) (concat ":Link" (number-to-string linkCount) ":" string ))) linksList "\n")
 143                                                              "\n :END:" ) )))
 144                          (if (and (null non-recursive) (file-directory-p fullFileName) )
 145                              (setq retString (concat retString (org-fstree-generate fullFileName (1+ level) options) ) )
 146                            ))))))))
 147        retString)
 148     (message "%s is not a directory" dir)))
 149
 150 (defun org-fstree-apply-maybe ()
 151   (interactive)
 152   (message "org-fstree-apply-maybe") (sit-for 1) ;; DEBUG
 153   (save-excursion
 154      (if (save-excursion (beginning-of-line 1) (looking-at "#\\+END_FSTREE"))
 155          (re-search-backward "#\\+BEGIN_FSTREE" nil t))
 156      (cond
 157       ((save-excursion (beginning-of-line 1) (looking-at "#\\+BEGIN_FSTREE"))
 158        (let* ((params (org-fstree-gather-parameters))
 159               (dir (plist-get params :dir))
 160               (options (plist-get params :params))
 161               level)
 162          ;; get current level; there is a BUG if "#+BEGIN_FSTREE" is inserted after the last headlines dots, that indicate its folded state.
 163          (let ((p (point)))
 164            (cond ((org-before-first-heading-p)
 165                   (setq level 1))
 166                  (t (org-back-to-heading)
 167                     (setq level (+ (funcall outline-level) 1))
 168                     (goto-char p)
 169                     )
 170                  )
 171            )
 172            (forward-line)
 173            (let ((beg (point)))
 174              (re-search-forward "#\\+END_FSTREE" nil t)
 175              (cond ( (looking-back "#\\+END_FSTREE")
 176                      (forward-line -1)
 177                      (end-of-line 1)
 178                      (delete-region beg (point) )
 179                      (insert (concat (org-fstree-generate dir level options) "\n") )
 180                      )
 181                    (t (goto-char beg)
 182                       (insert (concat (concat (org-fstree-generate dir level options) "\n") "\n#+END_FSTREE"))
 183                       )
 184                    )
 185              )
 186          )
 187        1
 188        )
 189       )
 190      )
 191   )
 192
 193
 194 (defun org-fstree-show-entry-maybe ()
 195   (interactive)
 196   (message "show-entry-maybe..") (sit-for 1) ;; DEBUG
 197   (let* ( (parameters (org-fstree-get-parameters-if-inside-fstree-block))
 198          (options (plist-get parameters :params)))
 199
 200     (cond ((and parameters (message "p") (not (plist-get options :non-recursive)) (message "nr") (plist-get options :dynamic-update) (message "du") )
 201            ;; we are inside the FSTREE block and have to update
 202            ;; delete existing content
 203            (message "show-entry-maybe deleting subtree") (sit-for 1) ;; DEBUG
 204            (save-excursion
 205              (forward-line 1)
 206              (let ((beg (point)))
 207                (org-end-of-subtree)
 208                (delete-region beg (point))
 209                )
 210              )
 211          ;; insert new content
 212          (message "show-entry-maybe generate and insert subtree") (sit-for 1) ;; DEBUG
 213          (save-excursion
 214            (let ((level (1+ (funcall outline-level)))
 215                  (dir (org-fstree-extract-path-from-headline)))
 216              (end-of-line 1)
 217              (insert (org-fstree-generate dir level (plist-get parameters :parms))))))))
 218   (sit-for 1))
 219
 220 (defun org-fstree-extract-path-from-headline ()
 221   (interactive) ;;DEBUG
 222   (save-excursion
 223     (beginning-of-line 1)
 224     (if (looking-at org-fstree-heading-regexp)
 225         (match-string-no-properties 1))))
 226
 227 ;;(defconst org-fstree-heading-regexp "\\*+ \\[.\\] \\[\\[file:\\(.*\\)\\]\\[.*\\]\\]"
 228 (defconst org-fstree-heading-regexp ".*\\[\\[file:\\(.*\\)\\]\\[.*\\]\\]"
 229
 230   "Matches first line of a hidden block.")
 231 (make-variable-buffer-local 'org-fstree-heading-regexp)
 232
 233 (defun org-fstree-get-parameters-if-inside-fstree-block ()
 234   (interactive)
 235 ;;  (message "org-fstree-get-parameters-if-inside-fstree-block") (sit-for 1) ;; DEBUG
 236   (and   (save-excursion
 237          (re-search-forward "#\\+END_FSTREE" nil t) )
 238          (save-excursion
 239          (re-search-backward "#\\+BEGIN_FSTREE" nil t)
 240          (org-fstree-gather-parameters))))
 241
 242 (defun org-fstree-gather-parameters ()
 243 ;;  (message "org-fstree-gather-parameters") (sit-for 1) ;; DEBUG
 244   (save-excursion
 245     (let (rtn)
 246       (beginning-of-line 1)
 247       (if (looking-at "#\\+BEGIN_FSTREE[: \t][ \t]*\\([^ \t\r\n]+\\)\\( +.*\\)?")
 248         (let ((dir (org-no-properties (match-string 1)))
 249               (params (if (match-end 2)
 250                           (read (concat "(" (match-string 2) ")")))))
 251           (setq rtn (list :dir dir :params params) )
 252 ;; (message (format "Got %s parameters for dir: %s" (number-to-string (length params)) dir)) (sit-for 1) ;; DEBUG
 253   ))
 254
 255        rtn)
 256     )
 257 )
 258
 259 (defun org-fstree-get-current-outline-level ()
 260   (save-excursion
 261     (cond ((org-before-first-heading-p) 1)
 262           (t
 263            (org-back-to-heading)
 264            (+ (funcall outline-level) 1)))))
 265
 266 (add-hook 'org-ctrl-c-ctrl-c-hook 'org-fstree-apply-maybe)
 267 (add-hook 'org-show-entry-hook 'org-fstree-show-entry-maybe)