emacs: lisp/textmodes/org.el comparison

comparison lisp/textmodes/org.el @ 90488:4094c5298ae1

Merge from emacs--devo--0 Patches applied: * emacs--devo--0 (patch 314-319) - Update from CVS - Merge from gnus--rel--5.10 * gnus--rel--5.10 (patch 107) - Update from CVS Revision: emacs@sv.gnu.org/emacs--unicode--0--patch-78

author	Miles Bader <miles@gnu.org>
date	Tue, 20 Jun 2006 07:35:06 +0000
parents	138027c8c982 9853142939b3
children	138ce2701550

comparison

equal deleted inserted replaced

-:ef80dfaa8269
+:4094c5298ae1
 ;; Copyright (C) 2004, 2005, 2006 Free Software Foundation, Inc.
 ;;
 ;; Author: Carsten Dominik <dominik at science dot uva dot nl>
 ;; Keywords: outlines, hypermedia, calendar, wp
 ;; Homepage: http://www.astro.uva.nl/~dominik/Tools/org/
-;; Version: 4.36b
+;; Version: 4.38
 ;;
 ;; This file is part of GNU Emacs.
 ;;
 ;; GNU Emacs is free software; you can redistribute it and/or modify
 ;; it under the terms of the GNU General Public License as published by
 ;; excellent reference card made by Philip Rooke.  This card can be found
 ;; in the etc/ directory of Emacs 22.
 ;;
 ;; Recent changes
 ;; --------------
+;; Version 4.38
+;;    - noutline.el is now required (important for XEmacs users only).
+;;    - Dynamic blocks.
+;;    - Archiving of all level 1 trees without open TODO items.
+;;    - Clock reports can be inserted into the file in a special section.
+;;    - FAQ removed from the manual, now only on the web.
+;;    - Bug fixes.
+;;
 ;; Version 4.37
 ;;    - Clock-feature for measuring time spent on specific items.
 ;;    - Improved emphasizing allows configuration and stacking.
 ;;
 ;; Version 4.36
 ;;; Code:
 (eval-when-compile
 (require 'cl)
 (require 'calendar))
-(require 'outline)
+;; For XEmacs, noutline is not yet provided by outline.el, so arrange for
+;; the file noutline.el being loaded.
+(if (featurep 'xemacs) (condition-case nil (require 'noutline)))
+;; We require noutline, which might be provided in outline.el
+(require 'outline) (require 'noutline)
+;; Other stuff we need.
 (require 'time-date)
 (require 'easymenu)
 ;;; Customization variables
-(defvar org-version "4.36b"
+(defvar org-version "4.38"
 "The version number of the file org.el.")
 (defun org-version ()
 (interactive)
 (message "Org-mode version %s" org-version))
 stacked      Non-nil means, allow stacked styles.  This works only in HTML
 export.  When this is set, all marker characters (as given in
 `org-emphasis-alist') will be allowed as pre/post, aiding
 inside-out matching.
 Use customize to modify this, or restart emacs after changing it."
-:group 'org-fixme
+:group 'org-font-lock
 :set 'org-set-emph-re
 :type '(list
 	  (sexp    :tag "Allowed chars in pre      ")
 	  (sexp    :tag "Allowed chars in post     ")
 	  (sexp    :tag "Forbidden chars in border ")
 (defcustom org-emphasis-alist
 '(("*" bold "<b>" "</b>")
 ("/" italic "<i>" "</i>")
 ("_" underline "<u>" "</u>")
-("=" shadow "<code>" "</code>"))
+("=" shadow "<code>" "</code>")
+("+" (:strike-through t) "<del>" "</del>")
+)
 "Special syntax for emphasised text.
 Text starting and ending with a special character will be emphasized, for
 example *bold*, _underlined_ and /italic/.  This variable sets the marker
 characters, the face to bbe used by font-lock for highlighting in Org-mode
 emacs buffers, and the HTML tags to be used for this.
 Use customize to modify this, or restart emacs after changing it."
-:group 'org-fixme
+:group 'org-font-lock
 :set 'org-set-emph-re
 :type '(repeat
 	  (list
 	   (string :tag "Marker character")
-	   (face :tag "Font-lock-face")
+	   (choice
+	    (face :tag "Font-lock-face")
+	    (plist :tag "Face property list"))
 	   (string :tag "HTML start tag")
 	   (string :tag "HTML end tag"))))
 (defgroup org-faces nil
 "Faces in Org-mode."
 (defvar wl-summary-buffer-elmo-folder) ; from wanderlust
 (defvar wl-summary-buffer-folder-name) ; from wanderlust
 (defvar gnus-group-name) ; from gnus
 (defvar gnus-article-current) ; from gnus
 (defvar w3m-current-url) ; from w3m
+(defvar w3m-current-title) ; from w3m
 (defvar mh-progs) ; from MH-E
 (defvar mh-current-folder) ; from MH-E
 (defvar mh-show-folder-buffer) ; from MH-E
 (defvar mh-index-folder) ; from MH-E
 (defvar mh-searcher) ; from MH-E
 	   (interactive-p)
 	   (= (point-min) (point-max)))
 (insert "    -*- mode: org -*-\n\n"))
 (unless org-inhibit-startup
-(if org-startup-align-all-tables
+(when org-startup-align-all-tables
-	(org-table-map-tables 'org-table-align))
+(let ((bmp (buffer-modified-p)))
+	(org-table-map-tables 'org-table-align)
+	(set-buffer-modified-p bmp)))
 (if org-startup-with-deadline-check
 	(call-interactively 'org-check-deadlines)
 (cond
 ((eq org-startup-folded t)
 	(org-cycle '(4)))
 	 (diff (abs (- level (length up-head)))))
 (if (= level 1) (error "Cannot promote to level 0. UNDO to recover"))
 (replace-match up-head nil t)
 ;; Fixup tag positioning
 (and org-auto-align-tags (org-set-tags nil t))
-(if org-adapt-indentation
+(if org-adapt-indentation (org-fixup-indentation (- diff)))))
-	(org-fixup-indentation (if (> diff 1) "^  " "^ ") ""
-			       (if (> diff 1) "^ ? ?\\S-" "^ ?\\S-")))))
 (defun org-demote ()
 "Demote the current heading lower down the tree.
 If the region is active in `transient-mark-mode', demote all headings
 in the region."
 	 (down-head (make-string (org-get-legal-level level 1) ?*))
 	 (diff (abs (- level (length down-head)))))
 (replace-match down-head nil t)
 ;; Fixup tag positioning
 (and org-auto-align-tags (org-set-tags nil t))
-(if org-adapt-indentation
+(if org-adapt-indentation (org-fixup-indentation diff))))
-	(org-fixup-indentation "^ " (if (> diff 1) "   " "  ") "^\\S-"))))
 (defun org-map-tree (fun)
 "Call FUN for every heading underneath the current one."
 (org-back-to-heading)
 (let ((level (funcall outline-level)))
 		    (outline-next-heading)
 		    (< (point) end))
 		  (not (eobp)))
 	(funcall fun)))))
-;; FIXME: this does not work well with Tabulators.  This has to be re-written entirely.
+(defun org-fixup-indentation (diff)
-(defun org-fixup-indentation (from to prohibit)
+"Change the indentation in the current entry by DIFF
-"Change the indentation in the current entry by re-replacing FROM with TO.
+However, if any line in the current entry has no indentation, or if it
-However, if the regexp PROHIBIT matches at all, don't do anything.
+would end up with no indentation after the change, nothing at all is done."
-This is being used to change indentation along with the length of the
-heading marker.  But if there are any lines which are not indented, nothing
-is changed at all."
 (save-excursion
 (let ((end (save-excursion (outline-next-heading)
-			       (point-marker))))
+			       (point-marker)))
+	  (prohibit (if (> diff 0)
+			"^\\S-"
+		      (concat "^ \\{0," (int-to-string (- diff)) "\\}\\S-")))
+	  col)
 (unless (save-excursion (re-search-forward prohibit end t))
-	(while (re-search-forward from end t)
+	(while (re-search-forward "^[ \t]+" end t)
-	  (replace-match to)
+	  (goto-char (match-end 0))
-	  (beginning-of-line 2)))
+	  (setq col (current-column))
+	  (if (< diff 0) (replace-match ""))
+	  (indent-to (+ diff col))))
 (move-marker end nil))))
 ;;; Vertical tree motion, cutting and pasting of subtrees
 (defun org-move-subtree-up (&optional arg)
 	(while (setq start (string-match re kill (1+ start)))
 	  (if (< (- (match-end 0) (match-beginning 0)) start-level)
 	      (throw 'exit nil)))
 	t))))
+(defun org-narrow-to-subtree ()
+"Narrow buffer to the current subtree."
+(interactive)
+(save-excursion
+(narrow-to-region
+(progn (org-back-to-heading) (point))
+(progn (org-end-of-subtree t) (point)))))
 ;;; Plain list items
 (defun org-at-item-p ()
 "Is point in a line starting a hand-formatted item?"
 (let ((llt org-plain-list-ordered-item-terminator))
 	(indent-to-column (+ ind1 arg))
 	(beginning-of-line 2)))))
 ;;; Archiving
-(defun org-archive-subtree ()
+(defun org-archive-subtree (&optional find-done)
 "Move the current subtree to the archive.
 The archive can be a certain top-level heading in the current file, or in
 a different file.  The tree will be moved to that location, the subtree
-heading be marked DONE, and the current time will be added."
+heading be marked DONE, and the current time will be added.
-(interactive)
-;; Save all relevant TODO keyword-relatex variables
+When called with prefix argument FIND-DONE, find whole trees without any
-(let ((tr-org-todo-line-regexp org-todo-line-regexp) ; keep despite compiler
+open TODO items and archive them (after getting confirmation from the user).
-	(tr-org-todo-keywords org-todo-keywords)
+If the cursor is not at a headline when this comand is called, try all level
-	(tr-org-todo-interpretation org-todo-interpretation)
+1 trees.  If the cursor is on a headline, only try the direct children of
-	(tr-org-done-string org-done-string)
+this heading. "
-	(tr-org-todo-regexp org-todo-regexp)
+(interactive "P")
-	(tr-org-todo-line-regexp org-todo-line-regexp)
+(if find-done
-	(this-buffer (current-buffer))
+(org-archive-all-done)
-	file heading buffer level newfile-p)
+;; Save all relevant TODO keyword-relatex variables
-(if (string-match "\\(.*\\)::\\(.*\\)" org-archive-location)
+(let ((tr-org-todo-line-regexp org-todo-line-regexp) ; keep despite compiler
+	  (tr-org-todo-keywords org-todo-keywords)
+	  (tr-org-todo-interpretation org-todo-interpretation)
+	  (tr-org-done-string org-done-string)
+	  (tr-org-todo-regexp org-todo-regexp)
+	  (tr-org-todo-line-regexp org-todo-line-regexp)
+	  (this-buffer (current-buffer))
+	  file heading buffer level newfile-p)
+(if (string-match "\\(.*\\)::\\(.*\\)" org-archive-location)
+	  (progn
+	    (setq file (format (match-string 1 org-archive-location)
+			       (file-name-nondirectory buffer-file-name))
+		  heading (match-string 2 org-archive-location)))
+	(error "Invalid `org-archive-location'"))
+(if (> (length file) 0)
+	  (setq newfile-p (not (file-exists-p file))
+		buffer (find-file-noselect file))
+	(setq buffer (current-buffer)))
+(unless buffer
+	(error "Cannot access file \"%s\"" file))
+(if (and (> (length heading) 0)
+	       (string-match "^\\*+" heading))
+	  (setq level (match-end 0))
+	(setq heading nil level 0))
+(save-excursion
+	;; We first only copy, in case something goes wrong
+	;; we need to protect this-command, to avoid kill-region sets it,
+	;; which would lead to duplication of subtrees
+	(let (this-command) (org-copy-subtree))
+	(set-buffer buffer)
+	;; Enforce org-mode for the archive buffer
+	(if (not (eq major-mode 'org-mode))
+	    ;; Force the mode for future visits.
+	    (let ((org-insert-mode-line-in-empty-file t))
+	      (call-interactively 'org-mode)))
+	(when newfile-p
+	  (goto-char (point-max))
+	  (insert (format "\nArchived entries from file %s\n\n"
+			  (buffer-file-name this-buffer))))
+	;; Force the TODO keywords of the original buffer
+	(let ((org-todo-line-regexp tr-org-todo-line-regexp)
+	      (org-todo-keywords tr-org-todo-keywords)
+	      (org-todo-interpretation tr-org-todo-interpretation)
+	      (org-done-string tr-org-done-string)
+	      (org-todo-regexp tr-org-todo-regexp)
+	      (org-todo-line-regexp tr-org-todo-line-regexp))
+	  (goto-char (point-min))
+	  (if heading
+	      (progn
+		(if (re-search-forward
+		     (concat "\\(^\\|\r\\)"
+			     (regexp-quote heading) "[ \t]*\\($\\|\r\\)")
+		     nil t)
+		    (goto-char (match-end 0))
+		  ;; Heading not found, just insert it at the end
+		  (goto-char (point-max))
+		  (or (bolp) (insert "\n"))
+		  (insert "\n" heading "\n")
+		  (end-of-line 0))
+		;; Make the subtree visible
+		(show-subtree)
+		(org-end-of-subtree t)
+		(skip-chars-backward " \t\r\n]")
+		(and (looking-at "[ \t\r\n]*")
+		     (replace-match "\n\n")))
+	    ;; No specific heading, just go to end of file.
+	    (goto-char (point-max)) (insert "\n"))
+	  ;; Paste
+	  (org-paste-subtree (1+ level))
+	  ;; Mark the entry as done, i.e. set to last work in org-todo-keywords
+	  (if org-archive-mark-done
+	      (org-todo (length org-todo-keywords)))
+	  ;; Move cursor to right after the TODO keyword
+	  (when org-archive-stamp-time
+	    (beginning-of-line 1)
+	    (looking-at org-todo-line-regexp)
+	    (goto-char (or (match-end 2) (match-beginning 3)))
+	    (insert "(" (format-time-string (cdr org-time-stamp-formats)
+					    (org-current-time))
+		    ")"))
+	  ;; Save the buffer, if it is not the same buffer.
+	  (if (not (eq this-buffer buffer)) (save-buffer))))
+;; Here we are back in the original buffer.  Everything seems to have
+;; worked.  So now cut the tree and finish up.
+(let (this-command) (org-cut-subtree))
+(if (and (not (eobp)) (looking-at "[ \t]*$")) (kill-line))
+(message "Subtree archived %s"
+	       (if (eq this-buffer buffer)
+		   (concat "under heading: " heading)
+		 (concat "in file: " (abbreviate-file-name file)))))))
+(defun org-archive-all-done ()
+"Archive sublevels of the current tree without open TODO items.
+If the cursor is not on a headline, try all level 1 trees.  If
+it is on a headline, try all direct children."
+(let ((re (concat "^\\*+ +" org-not-done-regexp)) re1
+	(begm (make-marker))
+	(endm (make-marker))
+	beg end (cntarch 0))
+(if (org-on-heading-p)
 	(progn
-	  (setq file (format (match-string 1 org-archive-location)
+	  (setq re1 (concat "^" (regexp-quote
-			     (file-name-nondirectory buffer-file-name))
+				 (make-string
-		heading (match-string 2 org-archive-location)))
+				  (1+ (- (match-end 0) (match-beginning 0)))
-(error "Invalid `org-archive-location'"))
+				  ?*))
-(if (> (length file) 0)
+			    " "))
-	(setq newfile-p (not (file-exists-p file))
+	  (move-marker begm (point))
-	      buffer (find-file-noselect file))
+	  (move-marker endm (org-end-of-subtree)))
-(setq buffer (current-buffer)))
+(setq re1 "^* ")
-(unless buffer
+(move-marker begm (point-min))
-(error "Cannot access file \"%s\"" file))
+(move-marker endm (point-max)))
-(if (and (> (length heading) 0)
-	     (string-match "^\\*+" heading))
-	(setq level (match-end 0))
-(setq heading nil level 0))
 (save-excursion
-;; We first only copy, in case something goes wrong
+(goto-char begm)
-;; we need to protect this-command, to avoid kill-region sets it,
+(while (re-search-forward re1 endm t)
-;; which would lead to duplication of subtrees
+	      beg (match-beginning 0)
-(let (this-command) (org-copy-subtree))
+	      end (save-excursion (org-end-of-subtree t) (point)))
-(set-buffer buffer)
+	(goto-char beg)
-;; Enforce org-mode for the archive buffer
+	(if (re-search-forward re end t)
-(if (not (eq major-mode 'org-mode))
+	    (goto-char end)
-	  ;; Force the mode for future visits.
+	  (goto-char beg)
-	  (let ((org-insert-mode-line-in-empty-file t))
+	  (if (y-or-n-p "Archive this subtree (no open TODO items)? ")
-	    (call-interactively 'org-mode)))
+	      (progn
-(when newfile-p
+		(org-archive-subtree)
-	(goto-char (point-max))
+		(setq cntarch (1+ cntarch)))
-	(insert (format "\nArchived entries from file %s\n\n"
+	    (goto-char end))))
-			(buffer-file-name this-buffer))))
+(message "%d trees archived" cntarch)))
-;; Force the TODO keywords of the original buffer
-(let ((org-todo-line-regexp tr-org-todo-line-regexp)
+;;; Dynamic blocks
-	    (org-todo-keywords tr-org-todo-keywords)
-	    (org-todo-interpretation tr-org-todo-interpretation)
+(defun org-find-dblock (name)
-	    (org-done-string tr-org-done-string)
+"Find the first dynamic block with name NAME in the buffer.
-	    (org-todo-regexp tr-org-todo-regexp)
+If not found, stay at current position and return nil."
-	    (org-todo-line-regexp tr-org-todo-line-regexp))
+(let (pos)
-	(goto-char (point-min))
+(save-excursion
-	(if heading
+(goto-char (point-min))
-	    (progn
+(setq pos (and (re-search-forward (concat "^#\\+BEGIN:[ \t]+" name "\\>")
-	      (if (re-search-forward
+					nil t)
-		   (concat "\\(^\\|\r\\)"
+		     (match-beginning 0))))
-			   (regexp-quote heading) "[ \t]*\\($\\|\r\\)")
+(if pos (goto-char pos))
-		   nil t)
+pos))
-		  (goto-char (match-end 0))
-		;; Heading not found, just insert it at the end
+(defconst org-dblock-start-re
-		(goto-char (point-max))
+"^#\\+BEGIN:[ \t]+\\(\\S-+\\)[ \t]+\\(.*\\)"
-		(or (bolp) (insert "\n"))
+"Matches the startline of a dynamic block, with parameters.")
-		(insert "\n" heading "\n")
-		(end-of-line 0))
+(defconst org-dblock-end-re "^#\\+END\\([: \t\r\n]\\|$\\)"
-	      ;; Make the subtree visible
+"Matches the end of a dyhamic block.")
-	      (show-subtree)
-	      (org-end-of-subtree t)
+(defun org-create-dblock (plist)
-	      (skip-chars-backward " \t\r\n]")
+"Create a dynamic block section, with parameters taken from PLIST.
-	      (and (looking-at "[ \t\r\n]*")
+PLIST must containe a :name entry which is used as name of the block."
-		   (replace-match "\n\n")))
+(unless (bolp) (newline))
-	  ;; No specific heading, just go to end of file.
+(let ((name (plist-get plist :name)))
-	  (goto-char (point-max)) (insert "\n"))
+(insert "#+BEGIN: " name)
-	;; Paste
+(while plist
-	(org-paste-subtree (1+ level))
+(if (eq (car plist) :name)
-	;; Mark the entry as done, i.e. set to last work in org-todo-keywords
+	  (setq plist (cddr plist))
-	(if org-archive-mark-done
+	(insert " " (prin1-to-string (pop plist)))))
-	    (org-todo (length org-todo-keywords)))
+(insert "\n\n#+END:\n")
-	;; Move cursor to right after the TODO keyword
+(beginning-of-line -2)))
-	(when org-archive-stamp-time
-	  (beginning-of-line 1)
+(defun org-prepare-dblock ()
-	  (looking-at org-todo-line-regexp)
+"Prepare dynamic block for refresh.
-	  (goto-char (or (match-end 2) (match-beginning 3)))
+This empties the block, puts the cursor at the insert position and returns
-	  (insert "(" (format-time-string (cdr org-time-stamp-formats)
+the property list including an extra property :name with the block name."
-					  (org-current-time))
+(unless (looking-at org-dblock-start-re)
-		  ")"))
+(error "Not at a dynamic block"))
-	;; Save the buffer, if it is not the same buffer.
+(let* ((beg (match-beginning 0))
-	(if (not (eq this-buffer buffer)) (save-buffer))))
+	 (begdel (1+ (match-end 0)))
-;; Here we are back in the original buffer.  Everything seems to have
+	 (name (match-string 1))
-;; worked.  So now cut the tree and finish up.
+	 (params (append (list :name name)
-(let (this-command) (org-cut-subtree))
+			 (read (concat "(" (match-string 2) ")")))))
-(if (and (not (eobp)) (looking-at "[ \t]*$")) (kill-line))
+(unless (re-search-forward org-dblock-end-re nil t)
-(message "Subtree archived %s"
+(error "Dynamic block not terminated"))
-	     (if (eq this-buffer buffer)
+(delete-region begdel (match-beginning 0))
-		 (concat "under heading: " heading)
+(goto-char begdel)
-	       (concat "in file: " (abbreviate-file-name file))))))
+(open-line 1)
+params))
+(defun org-map-dblocks (&optional command)
+"Apply COMMAND to all dynamic blocks in the current buffer.
+If COMMAND is not given, use `org-update-dblock'."
+(let ((cmd (or command 'org-update-dblock))
+	pos)
+(save-excursion
+(goto-char (point-min))
+(while (re-search-forward org-dblock-start-re nil t)
+	(goto-char (setq pos (match-beginning 0)))
+	(condition-case nil
+	    (funcall cmd)
+	  (error (message "Error during update of dynamic block")))
+	(goto-char pos)
+	(unless (re-search-forward org-dblock-end-re nil t)
+	  (error "Dynamic block not terminated"))))))
+(defun org-dblock-update (&optional arg)
+"User command for updating dynamic blocks.
+Update the dynamic block at point.  With prefix ARG, update all dynamic
+blocks in the buffer."
+(interactive "P")
+(if arg
+(org-update-all-dblocks)
+(or (looking-at org-dblock-start-re)
+	(org-beginning-of-dblock))
+(org-update-dblock)))
+(defun org-update-dblock ()
+"Update the dynamic block at point
+This means to empty the block, parse for parameters and then call
+the correct writing function."
+(let* ((pos (point))
+	 (params (org-prepare-dblock))
+	 (name (plist-get params :name))
+	 (cmd (intern (concat "org-dblock-write:" name))))
+(funcall cmd params)
+(goto-char pos)))
+(defun org-beginning-of-dblock ()
+"Find the beginning of the dynamic block at point.
+Error if there is no scuh block at point."
+(let ((pos (point))
+	beg end)
+(end-of-line 1)
+(if (and (re-search-backward org-dblock-start-re nil t)
+	     (setq beg (match-beginning 0))
+	     (re-search-forward org-dblock-end-re nil t)
+	     (> (match-end 0) pos))
+	(goto-char beg)
+(goto-char pos)
+(error "Not in a dynamic block"))))
+(defun org-update-all-dblocks ()
+"Update all dynamic blocks in the buffer.
+This function can be used in a hook."
+(when (eq major-mode 'org-mode)
+(org-map-dblocks 'org-update-dblock)))
 ;;; Completion
 (defun org-complete (&optional arg)
 "Perform completion on word at point.
 "Highlight from BEG to END and mark the highlight is an occur headline."
 (let ((ov (org-make-overlay beg end)))
 (org-overlay-put ov 'face 'secondary-selection)
 (push ov org-occur-highlights)))
+(defvar org-inhibit-highlight-removal nil)
 (defun org-remove-occur-highlights (&optional beg end noremove)
 "Remove the occur highlights from the buffer.
 BEG and END are ignored.  If NOREMOVE is nil, remove this function
 from the `before-change-functions' in the current buffer."
 (interactive)
-(mapc 'org-delete-overlay org-occur-highlights)
+(unless org-inhibit-highlight-removal
-(setq org-occur-highlights nil)
+(mapc 'org-delete-overlay org-occur-highlights)
-(unless noremove
+(setq org-occur-highlights nil)
-(remove-hook 'before-change-functions
+(unless noremove
-		 'org-remove-occur-highlights 'local)))
+(remove-hook 'before-change-functions
+		   'org-remove-occur-highlights 'local))))
 ;;; Priorities
 (defvar org-priority-regexp ".*?\\(\\[#\\([A-Z]\\)\\] ?\\)"
 "Regular expression matching the priority indicator.")
 (defun org-clock-sum ()
 "Sum the times for each subtree.
 Puts the resulting times in minutes as a text property on each headline."
 (interactive)
-(remove-text-properties (point-min) (point-max) '(:org-clock-minutes t))
+(let* ((bmp (buffer-modified-p))
-(let* ((re (concat "^\\(\\*+\\)[ \t]\\|^[ \t]*"
+	 (re (concat "^\\(\\*+\\)[ \t]\\|^[ \t]*"
 		     org-clock-string
 		     ".*=>[ \t]*\\([0-9]+\\):\\([0-9]+\\)[ \t]*$"))
 	 (lmax 30)
 	 (ltimes (make-vector lmax 0))
 	 (t1 0)
 	 (level 0)
 	 (lastlevel 0) time)
+(remove-text-properties (point-min) (point-max) '(:org-clock-minutes t))
 (save-excursion
 (goto-char (point-max))
 (while (re-search-backward re nil t)
 	(if (match-end 2)
 	    ;; A time
 	    (setq t1 0 time (aref ltimes level))
 	    (loop for l from level to (1- lmax) do
 		  (aset ltimes l 0))
 	    (goto-char (match-beginning 0))
 	    (put-text-property (point) (point-at-eol) :org-clock-minutes time))))
-(setq org-clock-file-total-minutes (aref ltimes 0)))))
+(setq org-clock-file-total-minutes (aref ltimes 0)))
+(set-buffer-modified-p bmp)))
 (defun org-clock-display (&optional total-only)
 "Show subtree times in the entire buffer.
 If TOTAL-ONLY is non-nil, only show the total time for the entire file
 in the echo area."
 (let* ((c 60) (h (floor (/ time 60))) (m (- time (* 60 h)))
 	 (l (if level (org-get-legal-level level 0) 0))
 	 (off 0)
 	 ov tx)
 (move-to-column c)
-(if (eolp) (setq off 1))
 (unless (eolp) (skip-chars-backward "^ \t"))
 (skip-chars-backward " \t")
-(setq ov (org-make-overlay (- (point) off) (point-at-eol))
+(setq ov (org-make-overlay (1- (point)) (point-at-eol))
-	  tx (concat (make-string (+ off (max 0 (- c (current-column)))) ?.)
+	  tx (concat (buffer-substring (1- (point)) (point))
+		     (make-string (+ off (max 0 (- c (current-column)))) ?.)
 		     (org-add-props (format "%s %2d:%02d%s"
 					    (make-string l ?*) h m
 					    (make-string (- 10 l) ?\ ))
 			 '(face secondary-selection))
 		     ""))
 (defun org-remove-clock-overlays (&optional beg end noremove)
 "Remove the occur highlights from the buffer.
 BEG and END are ignored.  If NOREMOVE is nil, remove this function
 from the `before-change-functions' in the current buffer."
 (interactive)
-(mapc 'org-delete-overlay org-clock-overlays)
+(unless org-inhibit-highlight-removal
-(setq org-clock-overlays nil)
+(mapc 'org-delete-overlay org-clock-overlays)
-(unless noremove
+(setq org-clock-overlays nil)
-(remove-hook 'before-change-functions
+(unless noremove
-		 'org-remove-clock-overlays 'local)))
+(remove-hook 'before-change-functions
+		   'org-remove-clock-overlays 'local))))
 (defun org-clock-out-if-current ()
 "Clock out if the current entry contains the running clock.
 This is used to stop the clock after a TODO entry is marked DONE."
 (when (and (equal state org-done-string)
 	     (y-or-n-p (format "Clock-out in buffer %s before killing it? "
 			       (buffer-name))))
 (org-clock-out)
 (when (y-or-n-p "Save changed buffer?")
 (save-buffer))))
+(defun org-clock-report ()
+"Create a table containing a report about clocked time.
+If the buffer contains lines
+#+BEGIN: clocktable :maxlevel 3 :emphasize nil
+#+END: clocktable
+then the table will be inserted between these lines, replacing whatever
+is was there before.  If these lines are not in the buffer, the table
+is inserted at point, surrounded by the special lines.
+The BEGIN line can contain parameters.  Allowed are:
+:maxlevel   The maximum level to be included in the table.  Default is 3.
+:emphasize  t/nil, if levell 1 and level 2 should be bold/italic in the table."
+(interactive)
+(org-remove-clock-overlays)
+(unless (org-find-dblock "clocktable")
+(org-create-dblock  (list :name "clocktable"
+			      :maxlevel 2 :emphasize nil)))
+(org-update-dblock))
+(defun org-dblock-write:clocktable (params)
+"Write the standard clocktable."
+(let ((hlchars '((1 . "*") (2 . ?/)))
+	(emph nil)
+	(pos (point)) ipos
+	(ins (make-marker))
+	time h m p level hlc hdl maxlevel)
+(setq maxlevel (or (plist-get params :maxlevel) 3)
+	  emph (plist-get params :emphasize))
+(move-marker ins (point))
+(setq ipos (point))
+(insert-before-markers "Clock summary at ["
+			   (substring
+			    (format-time-string (cdr org-time-stamp-formats))
+			    1 -1)
+			   "]\n|L|Headline|Time|\n")
+(org-clock-sum)
+(setq h (/ org-clock-file-total-minutes 60)
+	  m (- org-clock-file-total-minutes (* 60 h)))
+(insert-before-markers "|-\n|0|" "*Total file time*| "
+			   (format "*%d:%02d*" h m)
+			   "|\n")
+(goto-char (point-min))
+(while (setq p (next-single-property-change (point) :org-clock-minutes))
+(goto-char p)
+(when (setq time (get-text-property p :org-clock-minutes))
+	(beginning-of-line 1)
+	(when (and (looking-at "\\(\\*+\\)[ \t]+\\(.*?\\)\\([ \t]+:[0-9a-zA-Z_@:]+:\\)?[ \t]*$")
+		   (setq level (- (match-end 1) (match-beginning 1)))
+		   (<= level maxlevel))
+	  (setq hlc (if emph (or (cdr (assoc level hlchars)) "") "")
+		hdl (match-string 2)
+		h (/ time 60)
+		m (- time (* 60 h)))
+	  (save-excursion
+	    (goto-char ins)
+	    (if (= level 1) (insert-before-markers "|-\n"))
+	    (insert-before-markers
+	     "| " (int-to-string level) "|" hlc hdl hlc " |"
+	     (make-string (1- level) ?|)
+	     hlc
+	     (format "%d:%02d" h m)
+	     hlc
+	     " |\n")))))
+(goto-char ins)
+(backward-delete-char 1)
+(goto-char ipos)
+(skip-chars-forward "^|")
+(org-table-align)))
+(defun org-collect-clock-time-entries ()
+"Return an internal list with clocking information.
+This list has one entry for each CLOCK interval.
+FIXME: describe the elements."
+(interactive)
+(let ((re (concat "^[ \t]*" org-clock-string
+		    " *\\[\\(.*?\\)\\]--\\[\\(.*?\\)\\]"))
+	rtn beg end next cont level title total closedp leafp
+	clockpos titlepos h m donep)
+(save-excursion
+(org-clock-sum)
+(goto-char (point-min))
+(while (re-search-forward re nil t)
+	(setq clockpos (match-beginning 0)
+	      beg (match-string 1) end (match-string 2)
+	      cont (match-end 0))
+	(setq beg (apply 'encode-time (org-parse-time-string beg))
+	      end (apply 'encode-time (org-parse-time-string end)))
+	(org-back-to-heading t)
+	(setq donep (org-entry-is-done-p))
+	(setq titlepos (point)
+	      total (or (get-text-property (1+ (point)) :org-clock-minutes) 0)
+	      h (/ total 60) m (- total (* 60 h))
+	      total (cons h m))
+	(looking-at "\\(\\*+\\) +\\(.*\\)")
+	(setq level (- (match-end 1) (match-beginning 1))
+	      title (org-match-string-no-properties 2))
+	(save-excursion (outline-next-heading) (setq next (point)))
+	(setq closedp (re-search-forward org-closed-time-regexp next t))
+	(goto-char next)
+	(setq leafp (and (looking-at "^\\*+ ")
+			 (<= (- (match-end 0) (point)) level)))
+	(push (list beg end clockpos closedp donep
+		    total title titlepos level leafp)
+	      rtn)
+	(goto-char cont)))
+(nreverse rtn)))
 ;;; Agenda, and Diary Integration
 ;;; Define the mode
 ((eq major-mode 'w3-mode)
 (setq cpltxt (url-view-url t)
 	    link (org-make-link cpltxt)))
 ((eq major-mode 'w3m-mode)
-(setq cpltxt w3m-current-url
+(setq cpltxt (or w3m-current-title w3m-current-url)
-	    link (org-make-link cpltxt)))
+	    link (org-make-link w3m-current-url)))
 ((setq search (run-hook-with-args-until-success
 		    'org-create-file-search-functions))
 (setq link (concat "file:" (abbreviate-file-name buffer-file-name)
 			 "::" search))
 (setq cpltxt (or description link)))
+((eq major-mode 'image-mode)
+(setq cpltxt (concat "file:"
+			   (abbreviate-file-name buffer-file-name))
+	    link (org-make-link cpltxt)))
 ((eq major-mode 'org-mode)
 ;; Just link to current headline
 (setq cpltxt (concat "file:"
 			   (abbreviate-file-name buffer-file-name)))
 the current directory if the file is in the current directory or a
 subdirectory.  Otherwise, the link will be the absolute path as
 completed in the minibuffer (i.e. normally ~/path/to/file).
 With two \\[universal-argument] prefixes, enforce an absolute path even if the file
-is in the current directory or below."
+is in the current directory or below.
+With three \\[universal-argument] prefixes, negate the meaning of
+`org-keep-stored-link-after-insertion'."
 (interactive "P")
 (let (link desc entry remove file (pos (point)))
 (cond
 ((save-excursion
 	(skip-chars-forward "^]\n\r")
 (setq remove (list (match-beginning 0) (match-end 0)))
 (setq desc (if (match-end 3) (org-match-string-no-properties 3)))
 (setq link (read-string "Link: "
 			      (org-link-unescape
 			       (org-match-string-no-properties 1)))))
-(complete-file
+((equal complete-file '(4))
 ;; Completing read for file names.
 (setq file (read-file-name "File: "))
 (let ((pwd (file-name-as-directory (expand-file-name ".")))
 	    (pwd1 (file-name-as-directory (abbreviate-file-name
 					   (expand-file-name ".")))))
 (setq link (org-completing-read
 		  "Link: " org-stored-links nil nil nil
 		  org-insert-link-history
 		  (or (car (car org-stored-links)))))
 (setq entry (assoc link org-stored-links))
-(if (not org-keep-stored-link-after-insertion)
+(if (funcall (if (equal complete-file '(64)) 'not 'identity)
+		   (not org-keep-stored-link-after-insertion))
 	  (setq org-stored-links (delq (assoc link org-stored-links)
 				       org-stored-links)))
 (setq link (if entry (nth 1 entry) link)
 	    desc (or desc (nth 2 entry)))))
 \[F] publish current file
 \[P] publish current project
 \[X] publish... (project will be prompted for)
 \[A] publish all projects")
 	(cmds
-	 '((?v . org-export-visible)
+	 '((?t . org-insert-export-options-template)
+	   (?v . org-export-visible)
 	   (?a . org-export-as-ascii)
 	   (?h . org-export-as-html)
 	   (?b . org-export-as-html-and-open)
 	   (?x . org-export-as-xoxo)
 	   (?i . org-export-icalendar-this-file)
 	(replace-match
 	 (concat
 	  (match-string 1) "[[" (match-string 2) ":" (match-string 3) "]]")
 	 t t))
 ;; Find multiline emphasis and put them into single line
-(when (assq :emph-multiline parameters)
+(when (memq :emph-multiline parameters)
 	(goto-char (point-min))
 	(while (re-search-forward org-emph-re nil t)
 	  (subst-char-in-region (match-beginning 0) (match-end 0) ?\n ?\  t)
 	  (goto-char (1- (match-end 0)))))
 continue to use it.  The prefix arg ARG is passed through to the exporting
 command."
 (interactive
 (list (progn
 	   (message "Export visible: [a]SCII  [h]tml  [b]rowse HTML  [x]OXO  [ ]keep buffer")
-	   (char-to-string (read-char-exclusive)))
+	   (read-char-exclusive))
 	 current-prefix-arg))
-(if (not (member type '("a" "\C-a" "b" "\C-b" "h" "x" " ")))
+(if (not (member type '(?a ?\C-a ?b ?\C-b ?h ?x ?\ )))
 (error "Invalid export key"))
-;; FIXME: do this more explicit?
+(let* ((binding (cdr (assoc type
-(let* ((binding (key-binding (concat "\C-c\C-x" type)))
+			      '((?a . org-export-as-ascii)
-	 (keepp (equal type " "))
+				(?\C-a . org-export-as-ascii)
+				(?b . org-export-as-html-and-open)
+				(?\C-b . org-export-as-html-and-open)
+				(?h . org-export-as-html)
+				(?x . org-export-as-xoxo)))))
+	 (keepp (equal type ?\ ))
 	 (file buffer-file-name)
 	 (buffer (get-buffer-create "*Org Export Visible*"))
 	 s e)
 (with-current-buffer buffer (erase-buffer))
 (save-excursion
 (let* ((opt-plist (org-combine-plists (org-default-export-plist)
 					ext-plist
 					(org-infile-export-plist)))
 	 (style (plist-get opt-plist :style))
+	 (link-validate (plist-get opt-plist :link-validation-function))
+	 valid
 	 (odd org-odd-levels-only)
 	 (region-p (org-region-active-p))
 (region
 (buffer-substring
 (if region-p (region-beginning) (point-min))
 (filename (concat (file-name-as-directory
 			    (org-export-directory :html opt-plist))
 			   (file-name-sans-extension
 			    (file-name-nondirectory buffer-file-name))
 			   ".html"))
+	 (current-dir (file-name-directory buffer-file-name))
 (buffer (find-file-noselect filename))
 (levels-open (make-vector org-level-max nil))
 	 (date (format-time-string "%Y/%m/%d" (current-time)))
 	 (time  (format-time-string "%X" (org-current-time)))
 (author      (plist-get opt-plist :author))
 		     thefile file-is-image-p search)
 		(save-match-data
 		  (if (string-match "::\\(.*\\)" filename)
 		      (setq search (match-string 1 filename)
 			    filename (replace-match "" t nil filename)))
+		  (setq valid
+			(if (functionp link-validate)
+			    (funcall link-validate filename current-dir)
+			  t))
 		  (setq file-is-image-p
 			(string-match (org-image-file-name-regexp) filename))
 		  (setq thefile (if abs-p (expand-file-name filename) filename))
 		  (when (and org-export-html-link-org-files-as-html
 			     (string-match "\\.org$" thefile))
 		(setq rpl (if (and file-is-image-p
 				   (or (eq t org-export-html-inline-images)
 				       (and org-export-html-inline-images
 					    (not descp))))
 			      (concat "<img src=\"" thefile "\"/>")
-			    (concat "<a href=\"" thefile "\">" desc "</a>")))))
+			    (concat "<a href=\"" thefile "\">" desc "</a>")))
+		(if (not valid) (setq rpl desc))))
 	     ((member type '("bbdb" "vm" "wl" "mhe" "rmail" "gnus" "shell" "info" "elisp"))
 	      (setq rpl (concat "<i>&lt;" type ":"
 				(save-match-data (org-link-unescape path))
 				"&gt;</i>"))))
 	    (setq line (replace-match rpl t t line)
 (set-buffer " org-tmp2 ")
 (buffer-substring (point-min) (point-max))))
 (defun org-html-handle-time-stamps (s)
 "Format time stamps in string S, or remove them."
-(let (r b)
+(catch 'exit
-(while (string-match org-maybe-keyword-time-regexp s)
+(let (r b)
-(or b (setq b (substring s 0 (match-beginning 0))))
+(while (string-match org-maybe-keyword-time-regexp s)
-(if (not org-export-with-timestamps)
+	;; FIXME: is it good to never export CLOCK, or do we need control?
-	  (setq r (concat r (substring s 0 (match-beginning 0)))
+	(if (and (match-end 1) (equal (match-string 1 s) org-clock-string))
-		s (substring s (match-end 0)))
+	    (throw 'exit ""))
-	(setq r (concat
+	(or b (setq b (substring s 0 (match-beginning 0))))
-		 r (substring s 0 (match-beginning 0))
+	(if (not org-export-with-timestamps)
-		 (if (match-end 1)
+	    (setq r (concat r (substring s 0 (match-beginning 0)))
-		     (format "@<span class=\"timestamp-kwd\">%s @</span>"
+		  s (substring s (match-end 0)))
-			     (match-string 1 s)))
+	  (setq r (concat
-		 (format " @<span class=\"timestamp\">%s@</span>"
+		   r (substring s 0 (match-beginning 0))
-			 (substring (match-string 3 s) 1 -1)))
+		   (if (match-end 1)
-	      s (substring s (match-end 0)))))
+		       (format "@<span class=\"timestamp-kwd\">%s @</span>"
-;; Line break of line started and ended with time stamp stuff
+			       (match-string 1 s)))
-(if (not r)
+		   (format " @<span class=\"timestamp\">%s@</span>"
-	s
+			   (substring (match-string 3 s) 1 -1)))
-(setq r (concat r s))
+		s (substring s (match-end 0)))))
-(unless (string-match "\\S-" (concat b s))
+;; Line break if line started and ended with time stamp stuff
-	(setq r (concat r "@<br/>")))
+(if (not r)
-r)))
+	  s
+	(setq r (concat r s))
+	(unless (string-match "\\S-" (concat b s))
+	  (setq r (concat r "@<br/>")))
+	r))))
 (defun org-html-protect (s)
 ;; convert & to &amp;, < to &lt; and > to &gt;
 (let ((start 0))
 (while (string-match "&" s start)
 (define-key org-mode-map [?\C-c ?\C-x (right)] 'org-shiftright)
 ;; All the other keys
 (define-key org-mode-map "\C-c\C-a" 'show-all)  ; in case allout messed up.
+(define-key org-mode-map "\C-xns" 'org-narrow-to-subtree)
 (define-key org-mode-map "\C-c$"    'org-archive-subtree)
 (define-key org-mode-map "\C-c\C-j" 'org-goto)
 (define-key org-mode-map "\C-c\C-t" 'org-todo)
 (define-key org-mode-map "\C-c\C-s" 'org-schedule)
 (define-key org-mode-map "\C-c\C-d" 'org-deadline)
 (define-key org-mode-map "\C-c*"          'org-table-recalculate)
 (define-key org-mode-map [(control ?#)]   'org-table-rotate-recalc-marks)
 (define-key org-mode-map "\C-c~"          'org-table-create-with-table.el)
 (define-key org-mode-map "\C-c\C-q"       'org-table-wrap-region)
 (define-key org-mode-map "\C-c\C-e"       'org-export)
-;(define-key org-mode-map "\C-c\C-xa"      'org-export-as-ascii)
-;(define-key org-mode-map "\C-c\C-x\C-a"   'org-export-as-ascii)
-;(define-key org-mode-map "\C-c\C-xv"      'org-export-visible)
-;(define-key org-mode-map "\C-c\C-x\C-v"   'org-export-visible)
-;; OPML support is only an option for the future
-;(define-key org-mode-map "\C-c\C-xo"      'org-export-as-opml)
-;(define-key org-mode-map "\C-c\C-x\C-o"   'org-export-as-opml)
-;(define-key org-mode-map "\C-c\C-xi"      'org-export-icalendar-this-file)
-;(define-key org-mode-map "\C-c\C-x\C-i"   'org-export-icalendar-all-agenda-files)
-;(define-key org-mode-map "\C-c\C-xc"      'org-export-icalendar-combine-agenda-files)
-;(define-key org-mode-map "\C-c\C-x\C-c"   'org-export-icalendar-combine-agenda-files)
-;(define-key org-mode-map "\C-c\C-xt"      'org-insert-export-options-template)
 (define-key org-mode-map "\C-c:"          'org-toggle-fixed-width-section)
-;(define-key org-mode-map "\C-c\C-xh"      'org-export-as-html)
-;(define-key org-mode-map "\C-c\C-xx"      'org-export-as-xoxo)
-;(define-key org-mode-map "\C-c\C-x\C-x"   'org-export-as-xoxo)
-;(define-key org-mode-map "\C-c\C-xb"      'org-export-as-html-and-open)
-;(define-key org-mode-map "\C-c\C-x\C-b"   'org-export-as-html-and-open)
 (define-key org-mode-map "\C-c\C-x\C-k"   'org-cut-special)
 (define-key org-mode-map "\C-c\C-x\C-w"   'org-cut-special)
 (define-key org-mode-map "\C-c\C-x\M-w"   'org-copy-special)
 (define-key org-mode-map "\C-c\C-x\C-y"   'org-paste-special)
 (define-key org-mode-map "\C-c\C-x\C-i" 'org-clock-in)
 (define-key org-mode-map "\C-c\C-x\C-o" 'org-clock-out)
 (define-key org-mode-map "\C-c\C-x\C-x" 'org-clock-cancel)
 (define-key org-mode-map "\C-c\C-x\C-d" 'org-clock-display)
+(define-key org-mode-map "\C-c\C-x\C-r" 'org-clock-report)
-;(define-key org-mode-map "\C-c\C-ef"    'org-publish-current-file)
-;(define-key org-mode-map "\C-c\C-ep"    'org-publish-current-project)
+(define-key org-mode-map "\C-c\C-x\C-u" 'org-dblock-update)
-;(define-key org-mode-map "\C-c\C-ec"    'org-publish)
-;(define-key org-mode-map "\C-c\C-ea"    'org-publish-all)
-;(define-key org-mode-map "\C-c\C-e\C-f" 'org-publish-current-file)
-;(define-key org-mode-map "\C-c\C-e\C-p" 'org-publish-current-project)
-;(define-key org-mode-map "\C-c\C-e\C-c" 'org-publish)
-;(define-key org-mode-map "\C-c\C-e\C-a" 'org-publish-all)
 (when (featurep 'xemacs)
 (define-key org-mode-map 'button3   'popup-mode-menu))
 (defsubst org-table-p () (org-at-table-p))
 ("Logging work"
 ["Clock in" org-clock-in t]
 ["Clock out" org-clock-out t]
 ["Clock cancel" org-clock-cancel t]
 ["Display times" org-clock-display t]
+["Create clock table" org-clock-report t]
 "--"
 ["Record DONE time"
 (progn (setq org-log-done (not org-log-done))
 	     (message "Switching to %s will %s record a timestamp"
 		      org-done-string
 	(progn
 	  ;; Go to end of line before heading
 	  (forward-char -1)
 	  (if (memq (preceding-char) '(?\n ?\^M))
 	      ;; leave blank line before heading
-	      (forward-char -1))))))
+	      (forward-char -1)))))
+(point))
 (defun org-show-subtree ()
 "Show everything after this heading at deeper levels."
 (outline-flag-region
 (point)
 (or (org-invisible-p)
 	   (save-excursion (goto-char (max (point-min) (1- (point))))
 			   (org-invisible-p)))
 (org-show-hierarchy-above)))
+;;; Experimental code
 ;;; Finish up
 (provide 'org)
 (run-hooks 'org-load-hook)
 ;; arch-tag: e77da1a7-acc7-4336-b19e-efa25af3f9fd

Mercurial > emacs

comparison lisp/textmodes/org.el @ 90488:4094c5298ae1