Changes
[emacs.git] / .emacs.d / elisp / local / ganneff-org.el
1 ;;; ganneff-org.el --- Some functions and stuff I use
2
3 ;; Copyright (C) 2012.2013 Joerg Jaspert
4
5 ;;; Commentary:
6
7 ;; This file contains all extra functions that deal with my
8 ;; org-mode setup (which in large parts is copied from Bernt Hansen,
9 ;; see below).
10 ;;
11 ;; The functions in the bh/ namespace are taken from
12 ;; http://doc.norang.ca/org-mode.org.html which has:
13 ;; #+AUTHOR: Bernt Hansen (IRC:Thumper_ on freenode)
14 ;; #+EMAIL: bernt@norang.ca
15 ;; and the following license statement:
16 ;;
17 ;; This document http://doc.norang.ca/org-mode.html and (either in its
18 ;; HTML format or in its Org format) is licensed under the GNU Free
19 ;; Documentation License version 1.3 or later
20 ;; (http://www.gnu.org/copyleft/fdl.html).
21
22 ;; The code examples and css stylesheets are licensed under the GNU
23 ;; General Public License v3 or later
24 ;; (http://www.gnu.org/licenses/gpl.html).
25
26 ;;; Code:
27
28 ;;;###autoload
29 (defun bh/show-org-agenda ()
30 "Show org-modes agenda."
31 (interactive)
32 (switch-to-buffer "*Org Agenda( )*")
33 (delete-other-windows))
34
35 ; Exclude DONE state tasks from refile targets
36 ;;;###autoload
37 (defun bh/verify-refile-target ()
38 "Exclude todo keywords with a done state from refile targets."
39 (not (member (nth 2 (org-heading-components)) org-done-keywords)))
40
41 ;;;###autoload
42 (defmacro bh/agenda-sort-test (fn a b)
43 "Test for agenda sort."
44 `(cond
45 ; if both match leave them unsorted
46 ((and (apply ,fn (list ,a))
47 (apply ,fn (list ,b)))
48 (setq result nil))
49 ; if a matches put a first
50 ((apply ,fn (list ,a))
51 (setq result -1))
52 ; otherwise if b matches put b first
53 ((apply ,fn (list ,b))
54 (setq result 1))
55 ; if none match leave them unsorted
56 (t nil)))
57
58 ;;;###autoload
59 (defmacro bh/agenda-sort-test-num (fn compfn a b)
60 `(cond
61 ((apply ,fn (list ,a))
62 (setq num-a (string-to-number (match-string 1 ,a)))
63 (if (apply ,fn (list ,b))
64 (progn
65 (setq num-b (string-to-number (match-string 1 ,b)))
66 (setq result (if (apply ,compfn (list num-a num-b))
67 -1
68 1)))
69 (setq result -1)))
70 ((apply ,fn (list ,b))
71 (setq result 1))
72 (t nil)))
73
74 ;;;###autoload
75 (defun bh/agenda-sort (a b)
76 "Sorting strategy for agenda items.
77 Late deadlines first, then scheduled, then non-late deadlines"
78 (let (result num-a num-b)
79 (cond
80 ; time specific items are already sorted first by org-agenda-sorting-strategy
81
82 ; non-deadline and non-scheduled items next
83 ((bh/agenda-sort-test 'bh/is-not-scheduled-or-deadline a b))
84
85 ; deadlines for today next
86 ((bh/agenda-sort-test 'bh/is-due-deadline a b))
87
88 ; late deadlines next
89 ((bh/agenda-sort-test-num 'bh/is-late-deadline '< a b))
90
91 ; scheduled items for today next
92 ((bh/agenda-sort-test 'bh/is-scheduled-today a b))
93
94 ; late scheduled items next
95 ((bh/agenda-sort-test-num 'bh/is-scheduled-late '> a b))
96
97 ; pending deadlines last
98 ((bh/agenda-sort-test-num 'bh/is-pending-deadline '< a b))
99
100 ; finally default to unsorted
101 (t (setq result nil)))
102 result))
103
104 ;;;###autoload
105 (defun bh/is-not-scheduled-or-deadline (date-str)
106 (and (not (bh/is-deadline date-str))
107 (not (bh/is-scheduled date-str))))
108
109 ;;;###autoload
110 (defun bh/is-due-deadline (date-str)
111 (string-match "Deadline:" date-str))
112
113 ;;;###autoload
114 (defun bh/is-late-deadline (date-str)
115 (string-match "In *\\(-.*\\)d\.:" date-str))
116
117 ;;;###autoload
118 (defun bh/is-pending-deadline (date-str)
119 (string-match "In \\([^-]*\\)d\.:" date-str))
120
121 ;;;###autoload
122 (defun bh/is-deadline (date-str)
123 (or (bh/is-due-deadline date-str)
124 (bh/is-late-deadline date-str)
125 (bh/is-pending-deadline date-str)))
126
127 ;;;###autoload
128 (defun bh/is-scheduled (date-str)
129 (or (bh/is-scheduled-today date-str)
130 (bh/is-scheduled-late date-str)))
131
132 ;;;###autoload
133 (defun bh/is-scheduled-today (date-str)
134 (string-match "Scheduled:" date-str))
135
136 ;;;###autoload
137 (defun bh/is-scheduled-late (date-str)
138 (string-match "Sched\.\\(.*\\)x:" date-str))
139
140 ;;;###autoload
141 (defun bh/hide-other ()
142 (interactive)
143 (save-excursion
144 (org-back-to-heading 'invisible-ok)
145 (hide-other)
146 (org-cycle)
147 (org-cycle)
148 (org-cycle)))
149
150 ;;;###autoload
151 (defun bh/set-truncate-lines ()
152 "Toggle value of truncate-lines and refresh window display."
153 (interactive)
154 (setq truncate-lines (not truncate-lines))
155 ;; now refresh window display (an idiom from simple.el):
156 (save-excursion
157 (set-window-start (selected-window)
158 (window-start (selected-window)))))
159
160 ;;;###autoload
161 (defun bh/skip-non-archivable-tasks ()
162 "Skip trees that are not available for archiving"
163 (save-restriction
164 (widen)
165 (let ((next-headline (save-excursion (or (outline-next-heading) (point-max)))))
166 ;; Consider only tasks with done todo headings as archivable candidates
167 (if (member (org-get-todo-state) org-done-keywords)
168 (let* ((subtree-end (save-excursion (org-end-of-subtree t)))
169 (daynr (string-to-int (format-time-string "%d" (current-time))))
170 (a-month-ago (* 60 60 24 (+ daynr 1)))
171 (last-month (format-time-string "%Y-%m-" (time-subtract (current-time) (seconds-to-time a-month-ago))))
172 (this-month (format-time-string "%Y-%m-" (current-time)))
173 (subtree-is-current (save-excursion
174 (forward-line 1)
175 (and (< (point) subtree-end)
176 (re-search-forward (concat last-month "\\|" this-month) subtree-end t)))))
177 (if subtree-is-current
178 next-headline ; Has a date in this month or last month, skip it
179 nil)) ; available to archive
180 (or next-headline (point-max))))))
181
182 ;;;###autoload
183 (defun bh/make-org-scratch ()
184 (interactive)
185 (find-file "/tmp/publish/scratch.org")
186 (gnus-make-directory "/tmp/publish"))
187
188 ;;;###autoload
189 (defun bh/switch-to-scratch ()
190 (interactive)
191 (switch-to-buffer "*scratch*"))
192
193 ;;;###autoload
194 (defun bh/org-todo (arg)
195 (interactive "p")
196 (if (equal arg 4)
197 (save-restriction
198 (widen)
199 (org-narrow-to-subtree)
200 (org-show-todo-tree nil))
201 (widen)
202 (org-narrow-to-subtree)
203 (org-show-todo-tree nil)))
204
205 ;;;###autoload
206 (defun bh/widen ()
207 (interactive)
208 (if (equal major-mode 'org-agenda-mode)
209 (org-agenda-remove-restriction-lock)
210 (widen)
211 (org-agenda-remove-restriction-lock)))
212
213 ;;;###autoload
214 (defun bh/insert-inactive-timestamp ()
215 (interactive)
216 (org-insert-time-stamp nil t t nil nil nil))
217
218 ;;;###autoload
219 (defun bh/insert-heading-inactive-timestamp ()
220 (save-excursion
221 (org-return)
222 (org-cycle)
223 (bh/insert-inactive-timestamp)))
224
225 ;; Remove empty LOGBOOK drawers on clock out
226 ;;;###autoload
227 (defun bh/remove-empty-drawer-on-clock-out ()
228 (interactive)
229 (save-excursion
230 (beginning-of-line 0)
231 (org-remove-empty-drawer-at "LOGBOOK" (point))))
232
233 ;;;###autoload
234 (defun bh/prepare-meeting-notes ()
235 "Prepare meeting notes for email
236 Take selected region and convert tabs to spaces, mark TODOs with leading >>>, and copy to kill ring for pasting"
237 (interactive)
238 (let (prefix)
239 (save-excursion
240 (save-restriction
241 (narrow-to-region (region-beginning) (region-end))
242 (untabify (point-min) (point-max))
243 (goto-char (point-min))
244 (while (re-search-forward "^\\( *-\\\) \\(TODO\\|DONE\\): " (point-max) t)
245 (replace-match (concat (make-string (length (match-string 1)) ?>) " " (match-string 2) ": ")))
246 (goto-char (point-min))
247 (kill-ring-save (point-min) (point-max))))))
248
249 ;; Phone capture template handling with BBDB lookup
250 ;; Adapted from code by Gregory J. Grubbs
251 ;;;###autoload
252 (defun bh/phone-call ()
253 "Return name and company info for caller from bbdb lookup"
254 (interactive)
255 (let* (name rec caller)
256 (setq name (completing-read "Who is calling? "
257 (bbdb-hashtable)
258 'bbdb-completion-predicate
259 'confirm))
260 (when (> (length name) 0)
261 ; Something was supplied - look it up in bbdb
262 (setq rec
263 (or (first
264 (or (bbdb-search (bbdb-records) name nil nil)
265 (bbdb-search (bbdb-records) nil name nil)))
266 name)))
267
268 ; Build the bbdb link if we have a bbdb record, otherwise just return the name
269 (setq caller (cond ((and rec (vectorp rec))
270 (let ((name (bbdb-record-name rec))
271 (company (bbdb-record-company rec)))
272 (concat "[[bbdb:"
273 name "]["
274 name "]]"
275 (when company
276 (concat " - " company)))))
277 (rec)
278 (t "NameOfCaller")))
279 (insert caller)))
280
281 ;;;###autoload
282 (defun org-my-archive-done-tasks ()
283 (interactive)
284 (save-excursion
285 (goto-char (point-min))
286 (let ((done-regexp
287 (concat "\\* \\(" (regexp-opt org-done-keywords) "\\) "))
288 (state-regexp
289 (concat "- State \"\\(" (regexp-opt org-done-keywords)
290 "\\)\"\\s-*\\[\\([^]\n]+\\)\\]")))
291 (while (re-search-forward done-regexp nil t)
292 (let ((end (save-excursion
293 (outline-next-heading)
294 (point)))
295 begin)
296 (goto-char (line-beginning-position))
297 (setq begin (point))
298 (if (re-search-forward state-regexp end t)
299 (let* ((time-string (match-string 2))
300 (when-closed (org-parse-time-string time-string)))
301 (if (>= (time-to-number-of-days
302 (time-subtract (current-time)
303 (apply #'encode-time when-closed)))
304 org-my-archive-expiry-days)
305 (org-archive-subtree)))
306 (goto-char end)))))
307 (save-buffer)))
308 (setq safe-local-variable-values (quote ((after-save-hook archive-done-tasks))))
309 ;;;###autoload
310 (defalias 'archive-done-tasks 'org-my-archive-done-tasks)
311
312 ;;;###autoload
313 (defun bh/is-project-p ()
314 "Any task with a todo keyword subtask"
315 (save-restriction
316 (widen)
317 (let ((has-subtask)
318 (subtree-end (save-excursion (org-end-of-subtree t)))
319 (is-a-task (member (nth 2 (org-heading-components)) org-todo-keywords-1)))
320 (save-excursion
321 (forward-line 1)
322 (while (and (not has-subtask)
323 (< (point) subtree-end)
324 (re-search-forward "^\*+ " subtree-end t))
325 (when (member (org-get-todo-state) org-todo-keywords-1)
326 (setq has-subtask t))))
327 (and is-a-task has-subtask))))
328
329 ;;;###autoload
330 (defun bh/is-project-subtree-p ()
331 "Any task with a todo keyword that is in a project subtree.
332 Callers of this function already widen the buffer view."
333 (let ((task (save-excursion (org-back-to-heading 'invisible-ok)
334 (point))))
335 (save-excursion
336 (bh/find-project-task)
337 (if (equal (point) task)
338 nil
339 t))))
340
341 ;;;###autoload
342 (defun bh/is-task-p ()
343 "Any task with a todo keyword and no subtask"
344 (save-restriction
345 (widen)
346 (let ((has-subtask)
347 (subtree-end (save-excursion (org-end-of-subtree t)))
348 (is-a-task (member (nth 2 (org-heading-components)) org-todo-keywords-1)))
349 (save-excursion
350 (forward-line 1)
351 (while (and (not has-subtask)
352 (< (point) subtree-end)
353 (re-search-forward "^\*+ " subtree-end t))
354 (when (member (org-get-todo-state) org-todo-keywords-1)
355 (setq has-subtask t))))
356 (and is-a-task (not has-subtask)))))
357
358 ;;;###autoload
359 (defun bh/is-subproject-p ()
360 "Any task which is a subtask of another project"
361 (let ((is-subproject)
362 (is-a-task (member (nth 2 (org-heading-components)) org-todo-keywords-1)))
363 (save-excursion
364 (while (and (not is-subproject) (org-up-heading-safe))
365 (when (member (nth 2 (org-heading-components)) org-todo-keywords-1)
366 (setq is-subproject t))))
367 (and is-a-task is-subproject)))
368
369 ;;;###autoload
370 (defun bh/list-sublevels-for-projects-indented ()
371 "Set org-tags-match-list-sublevels so when restricted to a subtree we list all subtasks.
372 This is normally used by skipping functions where this variable is already local to the agenda."
373 (if (marker-buffer org-agenda-restrict-begin)
374 (setq org-tags-match-list-sublevels 'indented)
375 (setq org-tags-match-list-sublevels nil))
376 nil)
377
378 ;;;###autoload
379 (defun bh/list-sublevels-for-projects ()
380 "Set org-tags-match-list-sublevels so when restricted to a subtree we list all subtasks.
381 This is normally used by skipping functions where this variable is already local to the agenda."
382 (if (marker-buffer org-agenda-restrict-begin)
383 (setq org-tags-match-list-sublevels t)
384 (setq org-tags-match-list-sublevels nil))
385 nil)
386
387 (defvar bh/hide-scheduled-and-waiting-next-tasks t)
388
389 (defun bh/toggle-next-task-display ()
390 (interactive)
391 (setq bh/hide-scheduled-and-waiting-next-tasks (not bh/hide-scheduled-and-waiting-next-tasks))
392 (when (equal major-mode 'org-agenda-mode)
393 (org-agenda-redo))
394 (message "%s WAITING and SCHEDULED NEXT Tasks" (if bh/hide-scheduled-and-waiting-next-tasks "Hide" "Show")))
395
396 ;;;###autoload
397 (defun bh/skip-stuck-projects ()
398 "Skip trees that are not stuck projects"
399 (save-restriction
400 (widen)
401 (let ((next-headline (save-excursion (or (outline-next-heading) (point-max)))))
402 (if (bh/is-project-p)
403 (let* ((subtree-end (save-excursion (org-end-of-subtree t)))
404 (has-next ))
405 (save-excursion
406 (forward-line 1)
407 (while (and (not has-next) (< (point) subtree-end) (re-search-forward "^\\*+ NEXT " subtree-end t))
408 (unless (member "WAITING" (org-get-tags-at))
409 (setq has-next t))))
410 (if has-next
411 nil
412 next-headline)) ; a stuck project, has subtasks but no next task
413 nil))))
414
415 ;;;###autoload
416 (defun bh/skip-non-stuck-projects ()
417 "Skip trees that are not stuck projects"
418 (bh/list-sublevels-for-projects-indented)
419 (save-restriction
420 (widen)
421 (let ((next-headline (save-excursion (or (outline-next-heading) (point-max)))))
422 (if (bh/is-project-p)
423 (let* ((subtree-end (save-excursion (org-end-of-subtree t)))
424 (has-next ))
425 (save-excursion
426 (forward-line 1)
427 (while (and (not has-next) (< (point) subtree-end) (re-search-forward "^\\*+ NEXT " subtree-end t))
428 (unless (member "WAITING" (org-get-tags-at))
429 (setq has-next t))))
430 (if has-next
431 next-headline
432 nil)) ; a stuck project, has subtasks but no next task
433 next-headline))))
434
435 ;;;###autoload
436 (defun bh/skip-non-projects ()
437 "Skip trees that are not projects"
438 (bh/list-sublevels-for-projects-indented)
439 (if (save-excursion (bh/skip-non-stuck-projects))
440 (save-restriction
441 (widen)
442 (let ((subtree-end (save-excursion (org-end-of-subtree t))))
443 (if (bh/is-project-p)
444 nil
445 subtree-end)))
446 (org-end-of-subtree t)))
447
448 ;;;###autoload
449 (defun bh/skip-project-trees-and-habits ()
450 "Skip trees that are projects"
451 (save-restriction
452 (widen)
453 (let ((subtree-end (save-excursion (org-end-of-subtree t))))
454 (cond
455 ((bh/is-project-p)
456 subtree-end)
457 ((org-is-habit-p)
458 subtree-end)
459 (t
460 nil)))))
461
462 ;;;###autoload
463 (defun bh/skip-projects-and-habits-and-single-tasks ()
464 "Skip trees that are projects, tasks that are habits, single non-project tasks"
465 (save-restriction
466 (widen)
467 (let ((next-headline (save-excursion (or (outline-next-heading) (point-max)))))
468 (cond
469 ((org-is-habit-p)
470 next-headline)
471 ((bh/is-project-p)
472 next-headline)
473 ((and (bh/is-task-p) (not (bh/is-project-subtree-p)))
474 next-headline)
475 (t
476 nil)))))
477
478 ;;;###autoload
479 (defun bh/skip-project-tasks-maybe ()
480 "Show tasks related to the current restriction.
481 When restricted to a project, skip project and sub project tasks, habits, NEXT tasks, and loose tasks.
482 When not restricted, skip project and sub-project tasks, habits, and project related tasks."
483 (save-restriction
484 (widen)
485 (let* ((subtree-end (save-excursion (org-end-of-subtree t)))
486 (next-headline (save-excursion (or (outline-next-heading) (point-max))))
487 (limit-to-project (marker-buffer org-agenda-restrict-begin)))
488 (cond
489 ((bh/is-project-p)
490 next-headline)
491 ((org-is-habit-p)
492 subtree-end)
493 ((and (not limit-to-project)
494 (bh/is-project-subtree-p))
495 subtree-end)
496 ((and limit-to-project
497 (bh/is-project-subtree-p)
498 (member (org-get-todo-state) (list "NEXT")))
499 subtree-end)
500 (t
501 nil)))))
502
503 ;;;###autoload
504 (defun bh/skip-projects-and-habits ()
505 "Skip trees that are projects and tasks that are habits"
506 (save-restriction
507 (widen)
508 (let ((subtree-end (save-excursion (org-end-of-subtree t))))
509 (cond
510 ((bh/is-project-p)
511 subtree-end)
512 ((org-is-habit-p)
513 subtree-end)
514 (t
515 nil)))))
516
517 ;;;###autoload
518 (defun bh/skip-non-subprojects ()
519 "Skip trees that are not projects"
520 (let ((next-headline (save-excursion (outline-next-heading))))
521 (if (bh/is-subproject-p)
522 nil
523 next-headline)))
524
525 ; Erase all reminders and rebuilt reminders for today from the agenda
526 ;;;###autoload
527 (defun bh/org-agenda-to-appt ()
528 (interactive)
529 (setq appt-time-msg-list nil)
530 (org-agenda-to-appt))
531
532
533 ;;;###autoload
534 (defun bh/restrict-to-file-or-follow (arg)
535 "Set agenda restriction to 'file or with argument invoke follow mode.
536 I don't use follow mode very often but I restrict to file all the time
537 so change the default 'F' binding in the agenda to allow both"
538 (interactive "p")
539 (if (equal arg 4)
540 (org-agenda-follow-mode)
541 (if (equal major-mode 'org-agenda-mode)
542 (bh/set-agenda-restriction-lock 4)
543 (widen))))
544
545 ;;;###autoload
546 (defun bh/narrow-to-org-subtree ()
547 (widen)
548 (org-narrow-to-subtree)
549 (save-restriction
550 (org-agenda-set-restriction-lock)))
551
552 ;;;###autoload
553 (defun bh/narrow-to-subtree ()
554 (interactive)
555 (if (equal major-mode 'org-agenda-mode)
556 (org-with-point-at (org-get-at-bol 'org-hd-marker)
557 (bh/narrow-to-org-subtree))
558 (bh/narrow-to-org-subtree)))
559
560 ;;;###autoload
561 (defun bh/narrow-up-one-org-level ()
562 (widen)
563 (save-excursion
564 (outline-up-heading 1 'invisible-ok)
565 (bh/narrow-to-org-subtree)))
566
567 ;;;###autoload
568 (defun bh/narrow-up-one-level ()
569 (interactive)
570 (if (equal major-mode 'org-agenda-mode)
571 (org-with-point-at (org-get-at-bol 'org-hd-marker)
572 (bh/narrow-up-one-org-level))
573 (bh/narrow-up-one-org-level)))
574
575 ;;;###autoload
576 (defun bh/narrow-to-org-project ()
577 (widen)
578 (save-excursion
579 (bh/find-project-task)
580 (bh/narrow-to-org-subtree)))
581
582 ;;;###autoload
583 (defun bh/narrow-to-project ()
584 (interactive)
585 (if (equal major-mode 'org-agenda-mode)
586 (org-with-point-at (org-get-at-bol 'org-hd-marker)
587 (bh/narrow-to-org-project))
588 (bh/narrow-to-org-project)))
589
590 ;;;###autoload
591 (defun bh/clock-in-to-next (kw)
592 "Switch a task from TODO to NEXT when clocking in.
593 Skips capture tasks, projects, and subprojects.
594 Switch projects and subprojects from NEXT back to TODO"
595 (when (not (and (boundp 'org-capture-mode) org-capture-mode))
596 (cond
597 ((and (member (org-get-todo-state) (list "TODO"))
598 (bh/is-task-p))
599 "NEXT")
600 ((and (member (org-get-todo-state) (list "NEXT"))
601 (bh/is-project-p))
602 "TODO"))))
603
604 ;;;###autoload
605 (defun bh/find-project-task ()
606 "Move point to the parent (project) task if any"
607 (save-restriction
608 (widen)
609 (let ((parent-task (save-excursion (org-back-to-heading 'invisible-ok) (point))))
610 (while (org-up-heading-safe)
611 (when (member (nth 2 (org-heading-components)) org-todo-keywords-1)
612 (setq parent-task (point))))
613 (goto-char parent-task)
614 parent-task)))
615
616 ;;;###autoload
617 (defun bh/punch-in (arg)
618 "Start continuous clocking and set the default task to the
619 selected task. If no task is selected set the Organization task
620 as the default task."
621 (interactive "p")
622 (setq bh/keep-clock-running t)
623 (if (equal major-mode 'org-agenda-mode)
624 ;;
625 ;; We're in the agenda
626 ;;
627 (let* ((marker (org-get-at-bol 'org-hd-marker))
628 (tags (org-with-point-at marker (org-get-tags-at))))
629 (if (and (eq arg 4) tags)
630 (org-agenda-clock-in '(16))
631 (bh/clock-in-organization-task-as-default)))
632 ;;
633 ;; We are not in the agenda
634 ;;
635 (save-restriction
636 (widen)
637 ; Find the tags on the current task
638 (if (and (equal major-mode 'org-mode) (not (org-before-first-heading-p)) (eq arg 4))
639 (org-clock-in '(16))
640 (bh/clock-in-organization-task-as-default)))))
641
642 ;;;###autoload
643 (defun bh/punch-out ()
644 (interactive)
645 (setq bh/keep-clock-running nil)
646 (when (org-clock-is-active)
647 (org-clock-out))
648 (org-agenda-remove-restriction-lock))
649
650 ;;;###autoload
651 (defun bh/clock-in-default-task ()
652 (save-excursion
653 (org-with-point-at org-clock-default-task
654 (org-clock-in))))
655
656 ;;;###autoload
657 (defun bh/clock-in-parent-task ()
658 "Move point to the parent (project) task if any and clock in"
659 (let ((parent-task))
660 (save-excursion
661 (save-restriction
662 (widen)
663 (while (and (not parent-task) (org-up-heading-safe))
664 (when (member (nth 2 (org-heading-components)) org-todo-keywords-1)
665 (setq parent-task (point))))
666 (if parent-task
667 (org-with-point-at parent-task
668 (org-clock-in))
669 (when bh/keep-clock-running
670 (bh/clock-in-default-task)))))))
671
672 ;;;###autoload
673 (defun bh/clock-in-organization-task-as-default ()
674 (interactive)
675 (org-with-point-at (org-id-find bh/organization-task-id 'marker)
676 (org-clock-in '(16))))
677
678 ;;;###autoload
679 (defun bh/clock-out-maybe ()
680 (when (and bh/keep-clock-running
681 (not org-clock-clocking-in)
682 (marker-buffer org-clock-default-task)
683 (not org-clock-resolving-clocks-due-to-idleness))
684 (bh/clock-in-parent-task)))
685
686 ;;;###autoload
687 (defun bh/clock-in-last-task (arg)
688 "Clock in the interrupted task if there is one
689 Skip the default task and get the next one.
690 A prefix arg forces clock in of the default task."
691 (interactive "p")
692 (let ((clock-in-to-task
693 (cond
694 ((eq arg 4) org-clock-default-task)
695 ((and (org-clock-is-active)
696 (equal org-clock-default-task (cadr org-clock-history)))
697 (caddr org-clock-history))
698 ((org-clock-is-active) (cadr org-clock-history))
699 ((equal org-clock-default-task (car org-clock-history)) (cadr org-clock-history))
700 (t (car org-clock-history)))))
701 (org-with-point-at clock-in-to-task
702 (org-clock-in nil))))
703
704 ;;;###autoload
705 (defun bh/set-agenda-restriction-lock (arg)
706 "Set restriction lock to current task subtree or file if prefix is specified"
707 (interactive "p")
708 (let* ((pom (bh/get-pom-from-agenda-restriction-or-point))
709 (tags (org-with-point-at pom (org-get-tags-at))))
710 (let ((restriction-type (if (equal arg 4) 'file 'subtree)))
711 (save-restriction
712 (cond
713 ((and (equal major-mode 'org-agenda-mode) pom)
714 (org-with-point-at pom
715 (org-agenda-set-restriction-lock restriction-type)))
716 ((and (equal major-mode 'org-mode) (org-before-first-heading-p))
717 (org-agenda-set-restriction-lock 'file))
718 (pom
719 (org-with-point-at pom
720 (org-agenda-set-restriction-lock restriction-type))))))))
721
722 ;;;###autoload
723 (defun bh/get-pom-from-agenda-restriction-or-point ()
724 (or (org-get-at-bol 'org-hd-marker)
725 (and (marker-position org-agenda-restrict-begin) org-agenda-restrict-begin)
726 (and (equal major-mode 'org-mode) (point))
727 org-clock-marker))
728
729
730
731 ;;;###autoload
732 (defun bh/view-next-project ()
733 (interactive)
734 (unless (marker-position org-agenda-restrict-begin)
735 (goto-char (point-min))
736 (re-search-forward "^Projects$")
737 (setq bh/current-view-project (point)))
738 (bh/widen)
739 (goto-char bh/current-view-project)
740 (forward-visible-line 1)
741 (setq bh/current-view-project (point))
742 (if (org-get-at-bol 'org-hd-marker)
743 (bh/narrow-to-project)
744 (message "All projects viewed.")
745 (ding)))
746
747 ;;;###autoload
748 (defun bh/display-inline-images ()
749 (condition-case nil
750 (org-display-inline-images)
751 (error nil)))
752
753 ; I'm lazy and don't want to remember the name of the project to publish when I modify
754 ; a file that is part of a project. So this function saves the file, and publishes
755 ; the project that includes this file
756 ;
757 ; It's bound to C-S-F12 so I just edit and hit C-S-F12 when I'm done and move on to the next thing
758 ;;;###autoload
759 (defun bh/save-then-publish (&optional force)
760 (interactive "P")
761 (save-buffer)
762 (org-save-all-org-buffers)
763 (let ((org-html-head-extra)
764 (org-html-validation-link "<a href=\"http://validator.w3.org/check?uri=referer\">Validate XHTML 1.0</a>"))
765 (org-publish-current-project force)))
766
767
768 ;;;###autoload
769 (defun org-mycal-export-limit ()
770 "Limit the export to items that have a date, time and a range. Also exclude certain categories."
771 (setq org-tst-regexp "<\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} ... [0-9]\\{2\\}:[0-9]\\{2\\}[^\r\n>]*?\\)>")
772 (setq org-tstr-regexp (concat org-tst-regexp "--?-?" org-tst-regexp))
773 (save-excursion
774 ; get categories
775 (setq mycategory (org-get-category))
776 ; get start and end of tree
777 (org-back-to-heading t)
778 (setq mystart (point))
779 (org-end-of-subtree)
780 (setq myend (point))
781 (goto-char mystart)
782 ; search for timerange
783 (setq myresult (re-search-forward org-tstr-regexp myend t))
784 ; search for categories to exclude
785 (setq mycatp (member mycategory org-export-exclude-category))
786 ; return t if ok, nil when not ok
787 (if (and myresult (not mycatp)) t nil)))
788
789 ;;;###autoload
790 (defun mycal-export-limit ()
791 "Limit the export to items that don't match an unwanted category "
792 (setq mycategory (org-get-category))
793 (not (member mycategory org-export-exclude-category)))
794
795 ;;; activate filter and call export function
796 ;;;###autoload
797 (defun org-mycal-export ()
798 (interactive)
799 (let ((org-icalendar-verify-function 'mycal-export-limit))
800 (org-icalendar-combine-agenda-files)))
801
802 ;;;###autoload
803 (defun jj/punch-in-hw (arg)
804 "Start clocking the hwmigration task"
805 (interactive "p")
806 (setq bh/keep-clock-running t)
807 (org-with-point-at (org-id-find "a46a4d6d-b4c9-4a4c-bfaf-81586be451da" 'marker)
808 (org-clock-in '(16))))
809
810 (defun jj/punch-out-hw ()
811 (interactive)
812 (bh/clock-in-organization-task-as-default))
813
814
815
816
817
818
819 (provide 'ganneff-org)
820
821 ;;; ganneff-org.el ends here