-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathorg-colview.el
1882 lines (1711 loc) · 71.6 KB
/
org-colview.el
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
;;; org-colview.el --- Column View in Org -*- lexical-binding: t; -*-
;; Copyright (C) 2004-2025 Free Software Foundation, Inc.
;; Author: Carsten Dominik <[email protected]>
;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://orgmode.org
;;
;; 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
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:
;; This file contains the column view for Org.
;;; Code:
(require 'org-macs)
(org-assert-version)
(require 'cl-lib)
(require 'org)
(declare-function org-agenda-redo "org-agenda" (&optional all))
(declare-function org-agenda-do-context-action "org-agenda" ())
(declare-function org-clock-sum-today "org-clock" (&optional headline-filter))
(declare-function org-element-extract "org-element-ast" (node))
(declare-function org-element-interpret-data "org-element" (data))
(declare-function org-element-map "org-element" (data types fun &optional info first-match no-recursion with-affiliated))
(declare-function org-element-parse-secondary-string "org-element" (string restriction &optional parent))
(declare-function org-element-property "org-element-ast" (property node))
(declare-function org-element-restriction "org-element" (element))
(declare-function org-element-type-p "org-element-ast" (node types))
(declare-function org-dynamic-block-define "org" (type func))
(declare-function org-link-display-format "ol" (s))
(declare-function org-link-open-from-string "ol" (s &optional arg))
(declare-function face-remap-remove-relative "face-remap" (cookie))
(declare-function face-remap-add-relative "face-remap" (face &rest specs))
(defvar org-agenda-columns-add-appointments-to-effort-sum)
(defvar org-agenda-columns-compute-summary-properties)
(defvar org-agenda-columns-show-summaries)
(defvar org-agenda-view-columns-initially)
(defvar org-inlinetask-min-level)
;;; Configuration
(defcustom org-columns-checkbox-allowed-values '("[ ]" "[X]")
"Allowed values for columns with SUMMARY-TYPE that uses checkbox.
The affected summary types are \"X%\", \"X/\", and \"X\" (see info
node `(org)Column attributes')."
:group 'org-properties
:package-version '(Org . "9.6")
:type '(repeat (choice
(const :tag "Unchecked [ ]" "[ ]")
(const :tag "Checked [X]" "[X]")
(const :tag "No checkbox" "")
(const :tag "Intermediate state [-]" "[-]")
(string :tag "Arbitrary string"))))
(defcustom org-columns-modify-value-for-display-function nil
"Function that modifies values for display in column view.
For example, it can be used to cut out a certain part from a time stamp.
The function must take 2 arguments:
column-title The title of the column (*not* the property name)
value The value that should be modified.
The function should return the value that should be displayed,
or nil if the normal value should be used."
:group 'org-properties
:type '(choice (const nil) (function)))
(defcustom org-columns-summary-types nil
"Alist between operators and summarize functions.
Each association follows the pattern (LABEL . SUMMARIZE),
or (LABEL SUMMARIZE COLLECT) where
LABEL is a string used in #+COLUMNS definition describing the
summary type. It can contain any character but \"}\". It is
case-sensitive.
SUMMARIZE is a function called with two arguments. The first
argument is a non-empty list of values, as non-empty strings.
The second one is a format string or nil. It has to return
a string summarizing the list of values.
COLLECT is a function called with one argument, a property
name. It is called in the context of a headline and must
return the collected property, or the empty string. You can
use this to only collect a property if a related conditional
properties is set, e.g., to return VACATION_DAYS only if
CONFIRMED is true.
Note that the return value can become one value for an higher
order summary, so the function is expected to handle its own
output.
Types defined in this variable take precedence over those defined
in `org-columns-summary-types-default', which see."
:group 'org-properties
:version "26.1"
:package-version '(Org . "9.0")
:type '(alist :key-type (string :tag " Label")
:value-type
(choice (function :tag "Summarize")
(list :tag "Collect and summarize"
(function :tag "Summarize")
(function :tag "Collect")))))
(defcustom org-columns-dblock-formatter #'org-columns-dblock-write-default
"Function to format data in column view dynamic blocks.
For more information, see `org-columns-dblock-write-default'."
:group 'org-properties
:package-version '(Org . "9.7")
:type 'function)
;;; Column View
(defvar-local org-columns-overlays nil
"Holds the list of current column overlays.")
(put 'org-columns-overlays 'permanent-local t)
(defvar-local org-columns-global nil
"Local variable, holds non-nil when current columns are global.")
(defvar-local org-columns-current-fmt nil
"Local variable, holds the currently active column format.")
(defvar-local org-columns-current-fmt-compiled nil
"Local variable, holds the currently active column format.
This is the compiled version of the format.")
(defvar-local org-columns-current-maxwidths nil
"Currently active maximum column widths, as a vector.")
(defvar-local org-columns-begin-marker nil
"Points to the position where last a column creation command was called.")
(defvar-local org-columns-top-level-marker nil
"Points to the position where current columns region starts.")
(defvar org-columns--time 0.0
"Number of seconds since the epoch, as a floating point number.")
(defvar org-columns-map (make-sparse-keymap)
"The keymap valid in column display.")
(defconst org-columns-summary-types-default
'(("+" . org-columns--summary-sum)
("$" . org-columns--summary-currencies)
("X" . org-columns--summary-checkbox)
("X/" . org-columns--summary-checkbox-count)
("X%" . org-columns--summary-checkbox-percent)
("max" . org-columns--summary-max)
("mean" . org-columns--summary-mean)
("min" . org-columns--summary-min)
(":" . org-columns--summary-sum-times)
(":max" . org-columns--summary-max-time)
(":mean" . org-columns--summary-mean-time)
(":min" . org-columns--summary-min-time)
("@max" . org-columns--summary-max-age)
("@mean" . org-columns--summary-mean-age)
("@min" . org-columns--summary-min-age)
("est+" . org-columns--summary-estimate))
"Map operators to summarize functions.
See `org-columns-summary-types' for details.")
(defun org-columns-content ()
"Switch to contents view while in columns view."
(interactive)
(org-cycle-overview)
(org-cycle-content))
(org-defkey org-columns-map "c" #'org-columns-content)
(org-defkey org-columns-map "o" #'org-overview)
(org-defkey org-columns-map "e" #'org-columns-edit-value)
(org-defkey org-columns-map "\C-c\C-t" #'org-columns-todo)
(org-defkey org-columns-map "\C-c\C-c" #'org-columns-toggle-or-columns-quit)
(org-defkey org-columns-map "\C-c\C-o" #'org-columns-open-link)
(org-defkey org-columns-map "v" #'org-columns-show-value)
(org-defkey org-columns-map "q" #'org-columns-quit)
(org-defkey org-columns-map "r" #'org-columns-redo)
(org-defkey org-columns-map "g" #'org-columns-redo)
(org-defkey org-columns-map [left] #'backward-char)
(org-defkey org-columns-map "\M-b" #'backward-char)
(org-defkey org-columns-map "a" #'org-columns-edit-allowed)
(org-defkey org-columns-map "s" #'org-columns-edit-attributes)
(org-defkey org-columns-map "\M-f" #'forward-char)
(org-defkey org-columns-map [right] #'forward-char)
(org-defkey org-columns-map [up] #'org-columns-move-up)
(org-defkey org-columns-map [down] #'org-columns-move-down)
(org-defkey org-columns-map [(shift right)] #'org-columns-next-allowed-value)
(org-defkey org-columns-map "n" #'org-columns-next-allowed-value)
(org-defkey org-columns-map [(shift left)] #'org-columns-previous-allowed-value)
(org-defkey org-columns-map "p" #'org-columns-previous-allowed-value)
(org-defkey org-columns-map "<" #'org-columns-narrow)
(org-defkey org-columns-map ">" #'org-columns-widen)
(org-defkey org-columns-map [(meta right)] #'org-columns-move-right)
(org-defkey org-columns-map [(meta left)] #'org-columns-move-left)
(org-defkey org-columns-map [(meta down)] #'org-columns-move-row-down)
(org-defkey org-columns-map [(meta up)] #'org-columns-move-row-up)
(org-defkey org-columns-map [(shift meta right)] #'org-columns-new)
(org-defkey org-columns-map [(shift meta left)] #'org-columns-delete)
(dotimes (i 10)
(org-defkey org-columns-map (number-to-string i)
(lambda () (interactive)
(org-columns-next-allowed-value nil i))))
(easy-menu-define org-columns-menu org-columns-map "Org Column Menu."
'("Column"
["Edit property" org-columns-edit-value t]
["Next allowed value" org-columns-next-allowed-value t]
["Previous allowed value" org-columns-previous-allowed-value t]
["Show full value" org-columns-show-value t]
["Edit allowed values" org-columns-edit-allowed t]
"--"
["Edit column attributes" org-columns-edit-attributes t]
["Increase column width" org-columns-widen t]
["Decrease column width" org-columns-narrow t]
"--"
["Move column right" org-columns-move-right t]
["Move column left" org-columns-move-left t]
["Move row up" org-columns-move-row-up t]
["Move row down" org-columns-move-row-down t]
["Add column" org-columns-new t]
["Delete column" org-columns-delete t]
"--"
["CONTENTS" org-columns-content t]
["OVERVIEW" org-overview t]
["Refresh columns display" org-columns-redo t]
"--"
["Open link" org-columns-open-link t]
"--"
["Quit" org-columns-quit t]))
(defun org-columns--displayed-value (spec value &optional no-star)
"Return displayed value for specification SPEC in current entry.
SPEC is a column format specification as stored in
`org-columns-current-fmt-compiled'. VALUE is the real value to
display, as a string.
When NO-STAR is non-nil, do not add asterisks before displayed
value for ITEM property."
(or (and (functionp org-columns-modify-value-for-display-function)
(funcall org-columns-modify-value-for-display-function
(nth 1 spec) ;column name
value))
(pcase spec
(`("ITEM" . ,_)
(let ((stars
(and (not no-star)
(concat (make-string (1- (org-current-level))
(if org-hide-leading-stars ?\s ?*))
"* "))))
(concat stars (org-link-display-format value))))
(`(,(or "DEADLINE" "SCHEDULED" "TIMESTAMP") . ,_)
(replace-regexp-in-string org-ts-regexp "[\\1]" value))
(`(,_ ,_ ,_ ,_ nil) value)
;; If PRINTF is set, assume we are displaying a number and
;; obey to the format string.
(`(,_ ,_ ,_ ,_ ,printf) (format printf (string-to-number value)))
(_ (error "Invalid column specification format: %S" spec)))))
(defun org-columns--collect-values (&optional compiled-fmt agenda-marker)
"Collect values for columns on the current line.
Return a list of triplets (SPEC VALUE DISPLAYED) suitable for
`org-columns--display-here'.
This function assumes `org-columns-current-fmt-compiled' is
initialized is set in the current buffer. However, it is
possible to override it with optional argument COMPILED-FMT.
The optional argument AGENDA-MARKER is used when called from the
agenda to pass a marker to the agenda line.
"
(let ((summaries (get-text-property (point) 'org-summaries)))
(mapcar
(lambda (spec)
(pcase spec
(`(,p . ,_)
(let* ((v (or (cdr (assoc spec summaries))
(org-entry-get (point) p 'selective t)
(and compiled-fmt ;assume `org-agenda-columns'
;; Effort property is not defined. Try
;; to use appointment duration.
org-agenda-columns-add-appointments-to-effort-sum
agenda-marker
(string= p (upcase org-effort-property))
(get-text-property
(marker-position agenda-marker)
'duration
(marker-buffer agenda-marker))
(propertize
(org-duration-from-minutes
(get-text-property
(marker-position agenda-marker)
'duration
(marker-buffer agenda-marker)))
'face 'org-warning))
"")))
;; A non-nil COMPILED-FMT means we're calling from Org
;; Agenda mode, where we do not want leading stars for
;; ITEM. Hence the optional argument for
;; `org-columns--displayed-value'.
(list spec v (org-columns--displayed-value spec v compiled-fmt))))))
(or compiled-fmt org-columns-current-fmt-compiled))))
(defun org-columns--set-widths (cache)
"Compute the maximum column widths from the format and CACHE.
This function sets `org-columns-current-maxwidths' as a vector of
integers greater than 0."
(setq org-columns-current-maxwidths
(apply #'vector
(mapcar
(lambda (spec)
(pcase spec
(`(,_ ,_ ,(and width (pred wholenump)) . ,_) width)
(`(,_ ,name . ,_)
;; No width is specified in the columns format.
;; Compute it by checking all possible values for
;; PROPERTY.
(let ((width (length name)))
(dolist (entry cache width)
(let ((value (nth 2 (assoc spec (cdr entry)))))
(setq width (max (length value) width))))))))
org-columns-current-fmt-compiled))))
(defun org-columns--new-overlay (beg end &optional string face)
"Create a new column overlay and add it to the list."
(let ((ov (make-overlay beg end)))
(overlay-put ov 'face (or face 'secondary-selection))
(org-overlay-display ov string face)
(push ov org-columns-overlays)
ov))
(defun org-columns--summarize (operator)
"Return summary function associated to string OPERATOR."
(pcase (or (assoc operator org-columns-summary-types)
(assoc operator org-columns-summary-types-default))
(`nil (error "Unknown %S operator" operator))
(`(,_ . ,(and (pred functionp) summarize)) summarize)
(`(,_ ,summarize ,_) summarize)
(_ (error "Invalid definition for operator %S" operator))))
(defun org-columns--collect (operator)
"Return collect function associated to string OPERATOR.
Return nil if no collect function is associated to OPERATOR."
(pcase (or (assoc operator org-columns-summary-types)
(assoc operator org-columns-summary-types-default))
(`nil (error "Unknown %S operator" operator))
(`(,_ . ,(pred functionp)) nil) ;default value
(`(,_ ,_ ,collect) collect)
(_ (error "Invalid definition for operator %S" operator))))
(defun org-columns--overlay-text (value fmt width property original)
"Return decorated VALUE string for columns overlay display.
FMT is a format string. WIDTH is the width of the column, as an
integer. PROPERTY is the property being displayed, as a string.
ORIGINAL is the real string, i.e., before it is modified by
`org-columns--displayed-value'."
(format fmt
(let ((v (org-columns-add-ellipses value width)))
(pcase property
("PRIORITY"
(propertize v 'face (org-get-priority-face original)))
("TAGS"
(if (not org-tags-special-faces-re)
(propertize v 'face 'org-tag)
(replace-regexp-in-string
org-tags-special-faces-re
(lambda (m) (propertize m 'face (org-get-tag-face m)))
v nil nil 1)))
("TODO" (propertize v 'face (org-get-todo-face original)))
(_ v)))))
(defvar org-columns-header-line-remap nil
"Store the relative remapping of column header-line.
This is needed to later remove this relative remapping.")
(defvar org-columns--read-only-string nil)
(defun org-columns--display-here (columns &optional dateline)
"Overlay the current line with column display.
COLUMNS is an alist (SPEC VALUE DISPLAYED). Optional argument
DATELINE is non-nil when the face used should be
`org-agenda-column-dateline'."
(when (and (not org-columns-header-line-remap)
(or (fboundp 'face-remap-add-relative)
(ignore-errors (require 'face-remap))))
(setq org-columns-header-line-remap
(face-remap-add-relative 'header-line '(:inherit default))))
(save-excursion
(forward-line 0)
(let* ((level-face (and (looking-at "\\(\\**\\)\\(\\* \\)")
(org-get-level-face 2)))
(ref-face (or level-face
(and (eq major-mode 'org-agenda-mode)
(org-get-at-bol 'face))
'default))
(color (list :foreground (face-attribute ref-face :foreground)))
(font (list :family (face-attribute 'default :family)))
(face (list color font 'org-column ref-face))
(face1 (list color font 'org-agenda-column-dateline ref-face)))
;; Each column is an overlay on top of a character. So there has
;; to be at least as many characters available on the line as
;; columns to display.
(let ((columns (length org-columns-current-fmt-compiled))
(chars (- (line-end-position) (line-beginning-position))))
(when (> columns chars)
(save-excursion
(end-of-line)
(let ((inhibit-read-only t))
(insert (make-string (- columns chars) ?\s))))))
;; Display columns. Create and install the overlay for the
;; current column on the next character.
(let ((i 0)
(last (1- (length columns))))
(dolist (column columns)
(pcase column
(`(,spec ,original ,value)
(let* ((property (car spec))
(width (aref org-columns-current-maxwidths i))
(fmt (format (if (= i last) "%%-%d.%ds |"
"%%-%d.%ds | ")
width width))
(ov (org-columns--new-overlay
(point) (1+ (point))
(org-columns--overlay-text
value fmt width property original)
(if dateline face1 face))))
(overlay-put ov 'keymap org-columns-map)
(overlay-put ov 'org-columns-key property)
(overlay-put ov 'org-columns-value original)
(overlay-put ov 'org-columns-value-modified value)
(overlay-put ov 'org-columns-format fmt)
(overlay-put ov 'line-prefix "")
(overlay-put ov 'wrap-prefix "")
(forward-char))))
(cl-incf i)))
;; Make the rest of the line disappear.
(let ((ov (org-columns--new-overlay (point) (line-end-position))))
(overlay-put ov 'invisible t)
(overlay-put ov 'keymap org-columns-map)
(overlay-put ov 'line-prefix "")
(overlay-put ov 'wrap-prefix ""))
(let ((ov (make-overlay (1- (line-end-position))
(line-beginning-position 2))))
(overlay-put ov 'keymap org-columns-map)
(push ov org-columns-overlays))
(with-silent-modifications
(let ((inhibit-read-only t))
(put-text-property
(line-end-position 0)
(line-beginning-position 2)
'read-only
(or org-columns--read-only-string
(setq org-columns--read-only-string
(substitute-command-keys
"Type \\<org-columns-map>`\\[org-columns-edit-value]' \
to edit property")))))))))
(defun org-columns--truncate-below-width (string width)
"Return a substring of STRING no wider than WIDTH.
This substring must start at 0, and must be the longest possible
substring whose `string-width' does not exceed WIDTH."
(declare (side-effect-free t))
(let ((end (min width (length string))) res)
(while (and end (>= end 0))
(let* ((curr (string-width (substring string 0 end)))
(excess (- curr width)))
(if (> excess 0)
(cl-decf end (max 1 (/ excess 2)))
(setq res (substring string 0 end) end nil))))
res))
(defun org-columns-add-ellipses (string width)
"Truncate STRING with WIDTH characters, with ellipses."
(cond
((<= (string-width string) width) string)
((<= width (string-width org-columns-ellipses))
(org-columns--truncate-below-width org-columns-ellipses width))
(t (concat
(org-columns--truncate-below-width
string (- width (string-width org-columns-ellipses)))
org-columns-ellipses))))
(defvar org-columns-full-header-line-format nil
"The full header line format, will be shifted by horizontal scrolling." )
(defvar org-previous-header-line-format nil
"The header line format before column view was turned on.")
(defvar org-columns-inhibit-recalculation nil
"Inhibit recomputing of columns on column view startup.")
(defvar org-columns-flyspell-was-active nil
"Remember the state of `flyspell-mode' before column view.
Flyspell-mode can cause problems in columns view, so it is turned off
for the duration of the command.")
(defvar header-line-format)
(defvar org-columns-previous-hscroll 0)
(defun org-columns--display-here-title ()
"Overlay the newline before the current line with the table title."
(interactive)
(let ((title "")
(linum-offset (org-line-number-display-width 'columns))
(i 0))
(dolist (column org-columns-current-fmt-compiled)
(pcase column
(`(,property ,name . ,_)
(let* ((width (aref org-columns-current-maxwidths i))
(fmt (format "%%-%d.%ds | " width width)))
(setq title (concat title (format fmt (or name property)))))))
(cl-incf i))
(setq-local org-previous-header-line-format header-line-format)
(setq org-columns-full-header-line-format
(concat
(org-add-props " " nil 'display `(space :align-to ,linum-offset))
(org-add-props (substring title 0 -1) nil 'face 'org-column-title)))
(setq org-columns-previous-hscroll -1)
(add-hook 'post-command-hook #'org-columns-hscroll-title nil 'local)))
(defun org-columns-hscroll-title ()
"Set the `header-line-format' so that it scrolls along with the table."
(sit-for .0001) ; need to force a redisplay to update window-hscroll
(let ((hscroll (window-hscroll)))
(when (/= org-columns-previous-hscroll hscroll)
(setq header-line-format
(concat (substring org-columns-full-header-line-format 0 1)
(substring org-columns-full-header-line-format
(min (length org-columns-full-header-line-format)
(1+ hscroll))))
org-columns-previous-hscroll hscroll)
(force-mode-line-update))))
(defvar org-colview-initial-truncate-line-value nil
"Remember the value of `truncate-lines' across colview.")
;;;###autoload
(defun org-columns-remove-overlays ()
"Remove all currently active column overlays."
(interactive)
(when org-columns-header-line-remap
(face-remap-remove-relative org-columns-header-line-remap)
(setq org-columns-header-line-remap nil))
(when org-columns-overlays
(when (local-variable-p 'org-previous-header-line-format)
(setq header-line-format org-previous-header-line-format)
(kill-local-variable 'org-previous-header-line-format)
(remove-hook 'post-command-hook #'org-columns-hscroll-title 'local))
(when (markerp org-columns-begin-marker)
(set-marker org-columns-begin-marker nil))
(when (markerp org-columns-top-level-marker)
(set-marker org-columns-top-level-marker nil))
(with-silent-modifications
(mapc #'delete-overlay org-columns-overlays)
(setq org-columns-overlays nil)
(let ((inhibit-read-only t))
(remove-text-properties (point-min) (point-max) '(read-only t))))
(when org-columns-flyspell-was-active
(flyspell-mode 1))
(when (local-variable-p 'org-colview-initial-truncate-line-value)
(setq truncate-lines org-colview-initial-truncate-line-value))))
(defun org-columns-show-value ()
"Show the full value of the property."
(interactive)
(let ((value (get-char-property (point) 'org-columns-value)))
(message "Value is: %s" (or value ""))))
(defvar org-agenda-columns-active) ;; defined in org-agenda.el
(defun org-columns-quit ()
"Remove the column overlays and in this way exit column editing."
(interactive)
(with-silent-modifications
(org-columns-remove-overlays)
(let ((inhibit-read-only t))
(remove-text-properties (point-min) (point-max) '(read-only t))))
(if (not (eq major-mode 'org-agenda-mode))
(setq org-columns-current-fmt nil)
(setq org-agenda-columns-active nil)
(message
"Modification not yet reflected in Agenda buffer, use `r' to refresh")))
(defun org-columns-check-computed ()
"Throw an error if current column value is computed."
(let ((spec (nth (org-current-text-column) org-columns-current-fmt-compiled)))
(and
(nth 3 spec)
(assoc spec (get-text-property (line-beginning-position) 'org-summaries))
(error "This value is computed from the entry's children"))))
(defun org-columns-todo (&optional _arg)
"Change the TODO state during column view."
(interactive "P")
(org-columns-edit-value "TODO"))
(defun org-columns-toggle-or-columns-quit ()
"Toggle checkbox at point, or quit column view."
(interactive)
(or (org-columns--toggle)
(org-columns-quit)))
(defun org-columns--toggle ()
"Toggle checkbox at point. Return non-nil if toggle happened, else nil.
See info documentation about realizing a suitable checkbox."
(when (string-match "\\`\\[[ xX-]\\]\\'"
(get-char-property (point) 'org-columns-value))
(org-columns-next-allowed-value)
t))
(defvar org-overriding-columns-format nil
"When set, overrides any other format definition for the agenda.
Don't set this, this is meant for dynamic scoping. Set
`org-columns-default-format' and `org-columns-default-format-for-agenda'
instead. You should use this variable only in the local settings
section for a custom agenda view.")
(defvar-local org-local-columns-format nil
"When set, overrides any other format definition for the agenda.
This can be set as a buffer local value to avoid interfering with
dynamic scoping for `org-overriding-columns-format'.")
(defun org-columns-edit-value (&optional key)
"Edit the value of the property at point in column view.
Where possible, use the standard interface for changing this line."
(interactive)
(org-columns-check-computed)
(let* ((col (current-column))
(bol (line-beginning-position))
(eol (line-end-position))
(pom (or (get-text-property bol 'org-hd-marker) (point)))
(key (or key (get-char-property (point) 'org-columns-key)))
(org-columns--time (float-time))
(action
(pcase key
("CLOCKSUM"
(user-error "This special column cannot be edited"))
("ITEM"
(lambda () (org-with-point-at pom (org-edit-headline))))
("TODO"
(lambda ()
(org-with-point-at pom (call-interactively #'org-todo))))
("PRIORITY"
(lambda ()
(org-with-point-at pom
(call-interactively #'org-priority))))
("TAGS"
(lambda ()
(org-with-point-at pom
(let ((org-fast-tag-selection-single-key
(if (eq org-fast-tag-selection-single-key 'expert)
t
org-fast-tag-selection-single-key)))
(call-interactively #'org-set-tags-command)))))
("DEADLINE"
(lambda ()
(org-with-point-at pom (call-interactively #'org-deadline))))
("SCHEDULED"
(lambda ()
(org-with-point-at pom (call-interactively #'org-schedule))))
("BEAMER_ENV"
(lambda ()
(org-with-point-at pom
(call-interactively #'org-beamer-select-environment))))
(_
(let* ((allowed (org-property-get-allowed-values pom key 'table))
(value (get-char-property (point) 'org-columns-value))
(nval (org-trim
(if (null allowed) (read-string "Edit: " value)
(completing-read
"Value: " allowed nil
(not (get-text-property
0 'org-unrestricted (caar allowed))))))))
(and (not (equal nval value))
(lambda () (org-entry-put pom key nval))))))))
(cond
((null action))
((eq major-mode 'org-agenda-mode)
(org-columns--call action)
;; The following let preserves the current format, and makes
;; sure that in only a single file things need to be updated.
(let* ((org-overriding-columns-format org-columns-current-fmt)
(buffer (marker-buffer pom))
(org-agenda-contributing-files
(list (with-current-buffer buffer
(buffer-file-name (buffer-base-buffer))))))
(org-agenda-columns)))
(t
(let ((inhibit-read-only t))
(with-silent-modifications
(remove-text-properties (max (point-min) (1- bol)) eol '(read-only t)))
(org-columns--call action))
;; Some properties can modify headline (e.g., "TODO"), and
;; possible shuffle overlays. Make sure they are still all at
;; the right place on the current line.
(let ((org-columns-inhibit-recalculation)) (org-columns-redo))
(org-columns-update key)
(org-move-to-column col)))))
(defun org-columns-edit-allowed ()
"Edit the list of allowed values for the current property."
(interactive)
(let* ((pom (or (org-get-at-bol 'org-marker)
(org-get-at-bol 'org-hd-marker)
(point)))
(key (concat (or (get-char-property (point) 'org-columns-key)
(user-error "No column to edit at point"))
"_ALL"))
(allowed (org-entry-get pom key t))
(new-value (read-string "Allowed: " allowed)))
;; FIXME: Cover editing TODO, TAGS etc in-buffer settings.????
;; FIXME: Write back to #+PROPERTY setting if that is needed.
(org-entry-put
(cond ((marker-position org-entry-property-inherited-from)
org-entry-property-inherited-from)
((marker-position org-columns-top-level-marker)
org-columns-top-level-marker)
(t pom))
key new-value)))
(defun org-columns--call (fun)
"Call function FUN while preserving heading visibility.
FUN is a function called with no argument."
(let ((hide-body (and (/= (line-end-position) (point-max))
(save-excursion
(move-beginning-of-line 2)
(org-at-heading-p)))))
(unwind-protect (funcall fun)
(when hide-body (org-fold-hide-entry)))))
(defun org-columns-previous-allowed-value ()
"Switch to the previous allowed value for this column."
(interactive)
(org-columns-next-allowed-value t))
(defun org-columns-next-allowed-value (&optional previous nth)
"Switch to the next allowed value for this column.
When PREVIOUS is set, go to the previous value. When NTH is
an integer, select that value."
(interactive)
(org-columns-check-computed)
(let* ((column (org-current-text-column))
(visible-column (current-column))
(key (get-char-property (point) 'org-columns-key))
(value (get-char-property (point) 'org-columns-value))
(pom (or (get-text-property (line-beginning-position) 'org-hd-marker)
(point)))
(allowed
(let ((all
(or (org-property-get-allowed-values pom key)
(pcase (nth column org-columns-current-fmt-compiled)
(`(,_ ,_ ,_ ,(or "X" "X/" "X%") ,_) org-columns-checkbox-allowed-values))
(org-colview-construct-allowed-dates value))))
(if previous (reverse all) all))))
(when (equal key "ITEM") (error "Cannot edit item headline from here"))
(unless (or allowed (member key '("SCHEDULED" "DEADLINE" "CLOCKSUM")))
(error "Allowed values for this property have not been defined"))
(let* ((l (length allowed))
(new
(cond
((member key '("SCHEDULED" "DEADLINE" "CLOCKSUM"))
(if previous 'earlier 'later))
((integerp nth)
(when (> (abs nth) l)
(user-error "Only %d allowed values for property `%s'" l key))
(nth (mod (1- nth) l) allowed))
((member value allowed)
(when (= l 1) (error "Only one allowed value for this property"))
(or (nth 1 (member value allowed)) (car allowed)))
(t (car allowed))))
(action (lambda () (org-entry-put pom key new))))
(cond
((eq major-mode 'org-agenda-mode)
(org-columns--call action)
;; The following let preserves the current format, and makes
;; sure that in only a single file things need to be updated.
(let* ((org-overriding-columns-format org-columns-current-fmt)
(buffer (marker-buffer pom))
(org-agenda-contributing-files
(list (with-current-buffer buffer
(buffer-file-name (buffer-base-buffer))))))
(org-agenda-columns)))
(t
(let ((inhibit-read-only t))
(remove-text-properties (line-end-position 0) (line-end-position)
'(read-only t))
(org-columns--call action))
;; Some properties can modify headline (e.g., "TODO"), and
;; possible shuffle overlays. Make sure they are still all at
;; the right place on the current line.
(let ((org-columns-inhibit-recalculation)) (org-columns-redo))
(org-columns-update key)
(org-move-to-column visible-column))))))
(defun org-colview-construct-allowed-dates (s)
"Construct a list of three dates around the date in S.
This respects the format of the time stamp in S, active or non-active,
and also including time or not. S must be just a time stamp, no text
around it."
(when (and s (string-match (concat "^" org-ts-regexp3 "$") s))
(let* ((time (org-parse-time-string s 'nodefaults))
(active (equal (string-to-char s) ?<))
(fmt (org-time-stamp-format (nth 1 time) (not active)))
time-before time-after)
(setf (car time) (or (car time) 0))
(setf (nth 1 time) (or (nth 1 time) 0))
(setf (nth 2 time) (or (nth 2 time) 0))
(setq time-before (copy-sequence time))
(setq time-after (copy-sequence time))
(setf (nth 3 time-before) (1- (nth 3 time)))
(setf (nth 3 time-after) (1+ (nth 3 time)))
(mapcar (lambda (x) (format-time-string fmt (org-encode-time x)))
(list time-before time time-after)))))
(defun org-columns-open-link (&optional arg)
(interactive "P")
(let ((value (get-char-property (point) 'org-columns-value)))
(org-link-open-from-string value arg)))
;;;###autoload
(defun org-columns-get-format-and-top-level ()
(let ((fmt (org-columns-get-format)))
(org-columns-goto-top-level)
fmt))
(defun org-columns-get-format (&optional fmt-string)
"Return columns format specifications.
When optional argument FMT-STRING is non-nil, use it as the
current specifications. This function also sets
`org-columns-current-fmt-compiled' and
`org-columns-current-fmt'."
(interactive)
(let ((format
(or fmt-string
(org-entry-get nil "COLUMNS" t)
(org-with-wide-buffer
(goto-char (point-min))
(catch :found
(let ((case-fold-search t))
(while (re-search-forward "^[ \t]*#\\+COLUMNS: .+$" nil t)
(let ((element (org-element-at-point)))
(when (org-element-type-p element 'keyword)
(throw :found (org-element-property :value element)))))
nil)))
org-columns-default-format)))
(setq org-columns-current-fmt format)
(org-columns-compile-format format)
format))
(defun org-columns-goto-top-level ()
"Move to the beginning of the column view area.
Also sets `org-columns-top-level-marker' to the new position."
(unless (markerp org-columns-top-level-marker)
(setq org-columns-top-level-marker (make-marker)))
(goto-char
(move-marker
org-columns-top-level-marker
(cond ((org-before-first-heading-p) (point-min))
((org-entry-get nil "COLUMNS" t) org-entry-property-inherited-from)
(t (org-back-to-heading) (point))))))
;;;###autoload
(defun org-columns (&optional global columns-fmt-string)
"Turn on column view on an Org mode file.
Column view applies to the whole buffer if point is before the first
headline. Otherwise, it applies to the first ancestor setting
\"COLUMNS\" property. If there is none, it defaults to the current
headline. With a `\\[universal-argument]' prefix \ argument, GLOBAL,
turn on column view for the whole buffer unconditionally.
When COLUMNS-FMT-STRING is non-nil, use it as the column format."
(interactive "P")
(org-columns-remove-overlays)
(setq-local org-columns-global global)
(save-excursion
(when global (goto-char (point-min)))
(if (markerp org-columns-begin-marker)
(move-marker org-columns-begin-marker (point))
(setq org-columns-begin-marker (point-marker)))
(org-columns-goto-top-level)
;; Initialize `org-columns-current-fmt' and
;; `org-columns-current-fmt-compiled'.
(let ((org-columns--time (float-time)))
(org-columns-get-format columns-fmt-string)
(unless org-columns-inhibit-recalculation (org-columns-compute-all))
(save-restriction
(when (and (not global) (org-at-heading-p))
(narrow-to-region (point) (org-end-of-subtree t t)))
(when (assoc "CLOCKSUM" org-columns-current-fmt-compiled)
(org-clock-sum))
(when (assoc "CLOCKSUM_T" org-columns-current-fmt-compiled)
(org-clock-sum-today))
(let ((cache
;; Collect contents of columns ahead of time so as to
;; compute their maximum width.
(org-scan-tags
(lambda () (cons (point-marker) (org-columns--collect-values))) t org--matcher-tags-todo-only)))
(when cache
(org-columns--set-widths cache)
(org-columns--display-here-title)
(when (setq-local org-columns-flyspell-was-active
(bound-and-true-p flyspell-mode))
(flyspell-mode 0))
(unless (local-variable-p 'org-colview-initial-truncate-line-value)
(setq-local org-colview-initial-truncate-line-value
truncate-lines))
(if (not global-visual-line-mode)
(setq truncate-lines t))
(dolist (entry cache)
(goto-char (car entry))
(org-columns--display-here (cdr entry)))))))))
(defun org-columns-new (&optional spec &rest attributes)
"Insert a new column, to the left of the current column.
Interactively fill attributes for new column. When column format
specification SPEC is provided, edit it instead.
When optional argument attributes can be a list of columns
specifications attributes to create the new column
non-interactively. See `org-columns-compile-format' for
details."
(interactive)
(let ((new (or attributes
(let ((prop
(completing-read
"Property: "
(mapcar #'list (org-buffer-property-keys t nil t))
nil nil (nth 0 spec))))
(list prop
;; Discard useless whitespace-only titles.
(org-string-nw-p
(read-string (format "Column title [%s]: " prop)
(nth 1 spec)))
;; Use `read-string' instead of `read-number'
;; to allow empty width.
(let ((w (read-string
"Column width: "
(and (nth 2 spec)
(number-to-string (nth 2 spec))))))
(and (org-string-nw-p w) (string-to-number w)))
(org-string-nw-p
(completing-read
"Summary: "
(delete-dups
(cons '("") ;Allow empty operator.
(mapcar (lambda (x) (list (car x)))
(append
org-columns-summary-types
org-columns-summary-types-default))))
nil t (nth 3 spec)))
(org-string-nw-p
(read-string "Format: " (nth 4 spec))))))))
(if spec
(progn (setcar spec (car new))
(setcdr spec (cdr new)))
(push new (nthcdr (org-current-text-column) org-columns-current-fmt-compiled)))
(org-columns-store-format)
(org-columns-redo)))
(defun org-columns-delete ()
"Delete the column at point from columns view."
(interactive)
(let ((spec (nth (org-current-text-column) org-columns-current-fmt-compiled)))
(when (y-or-n-p (format "Are you sure you want to remove column %S? "
(nth 1 spec)))
(setq org-columns-current-fmt-compiled
(delq spec org-columns-current-fmt-compiled))
(org-columns-store-format)
;; This may leave a now wrong value in a node property. However
;; updating it may prove counter-intuitive. See comments in
;; `org-columns-move-right' for details.
(let ((org-columns-inhibit-recalculation t)) (org-columns-redo))
(when (>= (org-current-text-column) (length org-columns-current-fmt-compiled))
(backward-char)))))
(defun org-columns-edit-attributes ()
"Edit the attributes of the current column."
(interactive)
(org-columns-new (nth (org-current-text-column) org-columns-current-fmt-compiled)))