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 ;;
  57 ;; Limitations and warnings:
  58 ;;
  59 ;;   - when triggering an update (by pressing "C-c C-c" while in the line mentioned above)
  60 ;;     the COMPLETE REGION BETWEEN "#+BEGIN_FSTREE" AND "#+END_FSTREE" IS REPLACED.
  61 ;;   - problems matching links to files with exotic characters in their names
  62 ;;   - speed
  63 ;;
  64 ;; Code:
  65
  66 (provide 'org-fstree)
  67
  68 (require 'org)
  69
  70 (defun org-fstree-generate (dir level options)
  71   (if (file-directory-p dir)
  72      (let (
  73            (non-recursive (plist-get options :non-recursive))
  74            (exclude-regexp-name-list (plist-get options :exclude-regexp-name))
  75            (exclude-regexp-fullpath-list (plist-get options :exclude-regexp-fullpath))
  76            (links-as-properties (plist-get options :links-as-properties))
  77            (fullFileNames (directory-files dir 1 nil t) )
  78            (fileNames (directory-files dir nil nil t) )
  79            fileName
  80            fullFileName
  81            currentHeadline
  82            orgHeadlineInfo
  83            curTags
  84            curPos
  85            (linksList nil)
  86            retString
  87            )
  88        (while fileNames
  89          (setq fullFileName (car fullFileNames))
  90          (setq fullFileNames (cdr fullFileNames))
  91          (setq fileName (car fileNames))
  92          (setq fileNames (cdr fileNames))
  93          (setq linksList nil)
  94          (setq curTags nil)
  95          (cond ((member fileName '("." "..")))
  96                ;; the following two lines is a really ugly. I'll be glad if someone with more lisp experience tidies this up.
  97                ((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))
  98                ((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))
  99                (t
 100                 (save-excursion
 101                 ;; Search for links in current buffer
 102                 (goto-char (point-min))
 103                 (setq curPos (point))
 104                 (while (re-search-forward org-bracket-link-regexp nil t)
 105                   (cond ( (string= fullFileName (expand-file-name (car (split-string (replace-regexp-in-string "^file:" "" (match-string 1) ) ":" ) ) ) )
 106                           (let ((p (point)))
 107                             (cond ((org-before-first-heading-p))
 108                                   (t
 109                                    ;; go to associated heading
 110                                    (org-back-to-heading t)
 111                                    (setq orgHeadlineInfo (org-heading-components))
 112                                    (setq curTags (concat curTags (nth 5 orgHeadlineInfo) ))
 113                                    (setq currentHeadline (nth 4 orgHeadlineInfo))
 114                                    ;; filter all links from headline, generate link to it and append to linksList
 115                                    (let ((cleanedHeadline (replace-regexp-in-string "\\[\\[.*\\]\\]" "" currentHeadline)))
 116
 117                                      (setq linksList (cons (concat "[[*"  cleanedHeadline "]["
 118                                                                    (replace-regexp-in-string fullFileName "" cleanedHeadline) "]]") linksList))
 119                                      )
 120                                    (goto-char p)
 121                                    )
 122                                   )
 123                             )
 124                           )
 125                         )
 126                   )
 127                 (cond ((or (not (plist-get options :show-only-matches)) (not (null linksList)))
 128                        ;; construct headline for current file/directory
 129                        (let* ((tagString (cond ((not (null curTags)) (concat "  " (replace-regexp-in-string "::" ":" curTags)) ) ))
 130                               (headingString
 131                                (concat retString "\n" (make-string level ?*) (if (file-directory-p fullFileName) " [D]" " [ ]")
 132                                        (format " [[file:%s][%s]]" (if (plist-get options :relative-links) (file-relative-name fullFileName) fullFileName) fileName)
 133
 134                                        )
 135                                )
 136                               (linkCount 0)
 137                               )
 138                          (setq retString
 139                                (cond ( links-as-properties
 140
 141                                        (concat headingString 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:" ) )
 142                                                )
 143                                        )
 144                                      (t
 145                                       (concat headingString
 146                                               (cond ((not (null linksList))
 147                                                      (concat "      { " (mapconcat 'identity linksList " | ") " }" )
 148                                                      )
 149                                                     )
 150                                               tagString
 151                                               )
 152                                       )
 153                                      )
 154                                )
 155                          )
 156                        (if (and (null non-recursive) (file-directory-p fullFileName) )
 157                            (setq retString (concat retString (org-fstree-generate fullFileName (1+ level) options) ) )
 158                          )
 159                        )
 160                       )
 161
 162                 )
 163                 )
 164                )
 165          )
 166        retString)
 167     (message "%s is not a directory" dir)
 168     )
 169   )
 170
 171 (defun org-fstree-apply-maybe ()
 172   (save-excursion
 173      (if (save-excursion (beginning-of-line 1) (looking-at "#\\+END_FSTREE"))
 174          (re-search-backward "#\\+BEGIN_FSTREE" nil t))
 175      (cond
 176       ((save-excursion (beginning-of-line 1) (looking-at "#\\+BEGIN_FSTREE"))
 177        (let* ((params (org-fstree-gather-parameters))
 178               (dir (plist-get params :dir))
 179               (options (plist-get params :params))
 180               level)
 181          ;; get current level; there is a BUG if "#+BEGIN_FSTREE" is inserted after the last headlines dots, that indicate its folded state.
 182          (let ((p (point)))
 183            (cond ((org-before-first-heading-p)
 184                   (setq level 1))
 185                  (t (org-back-to-heading)
 186                     (setq level (+ (funcall outline-level) 1))
 187                     (goto-char p)
 188                     )
 189                  )
 190            )
 191            (forward-line)
 192            (let ((beg (point)))
 193              (re-search-forward "#\\+END_FSTREE" nil t)
 194              (cond ( (looking-back "#\\+END_FSTREE")
 195                      (forward-line -1)
 196                      (end-of-line 1)
 197                      (delete-region beg (point) )
 198                      (insert (concat (org-fstree-generate dir level options) "\n") )
 199                      )
 200                    (t (goto-char beg)
 201                       (insert (concat (concat (org-fstree-generate dir level options) "\n") "\n#+END_FSTREE"))
 202                       )
 203                    )
 204              )
 205          )
 206        1
 207        )
 208       )
 209      )
 210   )
 211
 212
 213 (defun org-fstree-gather-parameters ()
 214   (save-excursion
 215     (let (rtn)
 216       (beginning-of-line 1)
 217       (if (looking-at "#\\+BEGIN_FSTREE[: \t][ \t]*\\([^ \t\r\n]+\\)\\( +.*\\)?")
 218         (let ((dir (org-no-properties (match-string 1)))
 219               (params (if (match-end 2)
 220                           (read (concat "(" (match-string 2) ")")))))
 221           ;; no additional parameters yet
 222           (setq rtn (list :dir dir :params params) )
 223           ))
 224       rtn)
 225     )
 226 )
 227
 228 (add-hook 'org-ctrl-c-ctrl-c-hook 'org-fstree-apply-maybe)