/
my-redef.el
1469 lines (1410 loc) · 71.9 KB
/
my-redef.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
;;; my-redef.el --- Global redefinitions of Emacs's own code -*- lexical-binding: t; -*-
;;; Commentary:
;; This file contains redefinitions of the internals that are broken
;; on my system
;;; Code:
;; /usr/local/share/emacs/24.3/lisp/net/browse-url.el.gz
(eval-after-load "browse-url"
'(defun browse-url-can-use-xdg-open ()
"Return non-nil if the \"xdg-open\" program can be used.
xdg-open is a desktop utility that calls your preferred web browser.
This requires you to be running either Gnome, KDE, Xfce4 or LXDE."
t))
;; redefines the silly indent of keyword lists
;; before
;; (:foo bar
;; :baz qux)
;; after
;; (:foo bar
;; :baz qux)
(eval-after-load "lisp-mode"
'(defun lisp-indent-function (indent-point state)
"This function is the normal value of the variable `lisp-indent-function'.
The function `calculate-lisp-indent' calls this to determine
if the arguments of a Lisp function call should be indented specially.
INDENT-POINT is the position at which the line being indented begins.
Point is located at the point to indent under (for default indentation);
STATE is the `parse-partial-sexp' state for that position.
If the current line is in a call to a Lisp function that has a non-nil
property `lisp-indent-function' (or the deprecated `lisp-indent-hook'),
it specifies how to indent. The property value can be:
* `defun', meaning indent `defun'-style
\(this is also the case if there is no property and the function
has a name that begins with \"def\", and three or more arguments);
* an integer N, meaning indent the first N arguments specially
(like ordinary function arguments), and then indent any further
arguments like a body;
* a function to call that returns the indentation (or nil).
`lisp-indent-function' calls this function with the same two arguments
that it itself received.
This function returns either the indentation to use, or nil if the
Lisp function does not specify a special indentation."
(let ((normal-indent (current-column))
(orig-point (point)))
(goto-char (1+ (elt state 1)))
(parse-partial-sexp (point) calculate-lisp-indent-last-sexp 0 t)
(cond
;; car of form doesn't seem to be a symbol, or is a keyword
((and (elt state 2)
(or (not (looking-at "\\sw\\|\\s_"))
(looking-at ":")))
(if (not (> (save-excursion (forward-line 1) (point))
calculate-lisp-indent-last-sexp))
(progn (goto-char calculate-lisp-indent-last-sexp)
(beginning-of-line)
(parse-partial-sexp (point)
calculate-lisp-indent-last-sexp 0 t)))
;; Indent under the list or under the first sexp on the same
;; line as calculate-lisp-indent-last-sexp. Note that first
;; thing on that line has to be complete sexp since we are
;; inside the innermost containing sexp.
(backward-prefix-chars)
(current-column))
((and (save-excursion
(goto-char indent-point)
(skip-syntax-forward " ")
(not (looking-at ":")))
(save-excursion
(goto-char orig-point)
(looking-at ":")))
(save-excursion
(goto-char (+ 2 (elt state 1)))
(current-column)))
(t
(let ((function (buffer-substring (point)
(progn (forward-sexp 1) (point))))
method)
(setq method (or (function-get (intern-soft function)
'lisp-indent-function)
(get (intern-soft function) 'lisp-indent-hook)))
(cond ((or (eq method 'defun)
(and (null method)
(> (length function) 3)
(string-match "\\`def" function)))
(lisp-indent-defform state indent-point))
((integerp method)
(lisp-indent-specform method state
indent-point normal-indent))
(method
(funcall method indent-point state)))))))))
(eval-after-load "org-table"
'(progn
(el-patch-defun org-table-expand-lhs-ranges (equations)
"Expand list of formulas.
If some of the RHS in the formulas are ranges or a row reference,
expand them to individual field equations for each field. This
function assumes the table is already analyzed (i.e., using
`org-table-analyze')."
(let (res)
(dolist (e equations (nreverse res))
(let ((lhs (car e))
(rhs (cdr e)))
(cond
((string-match-p "\\`@[-+0-9]+\\$-?[0-9]+\\'" lhs)
;; This just refers to one fixed field.
(push e res))
((string-match-p "\\`[a-zA-Z][_a-zA-Z0-9]*\\'" lhs)
;; This just refers to one fixed named field.
(push e res))
((string-match-p "\\`\\$[0-9]+\\'" lhs)
;; Column formulas are treated specially and are not
;; expanded.
(push e res))
(el-patch-add
((string-match "\\`\\@[I]+\\$\\([0-9]+\\)\\'" lhs)
;; Hline relative LHS formulas are expanded on the left and
;; pushed
(let* ((current-col (string-to-number (match-string 1 lhs)))
(range (org-table-get-range
lhs org-table-current-begin-pos current-col
nil 'corners))
(r1 (org-table-line-to-dline (nth 0 range)))
(c1 (nth 1 range))
(r2 (org-table-line-to-dline (nth 2 range) 'above))
(c2 (nth 3 range)))
(push (cons (format "@%d$%d" r1 c1) rhs) res))))
((string-match "\\`@[0-9]+\\'" lhs)
(dotimes (ic org-table-current-ncol)
(push (cons (propertize (format "%s$%d" lhs (1+ ic)) :orig-eqn e)
rhs)
res)))
(t
(let* ((range (org-table-get-range
lhs org-table-current-begin-pos 1 nil 'corners))
(r1 (org-table-line-to-dline (nth 0 range)))
(c1 (nth 1 range))
(r2 (org-table-line-to-dline (nth 2 range) 'above))
(c2 (nth 3 range)))
(cl-loop for ir from r1 to r2 do
(cl-loop for ic from c1 to c2 do
(push (cons (propertize
(format "@%d$%d" ir ic) :orig-eqn e)
rhs)
res))))))))))
(el-patch-defun org-table-recalculate (&optional all noalign)
"Recalculate the current table line by applying all stored formulas.
With prefix arg ALL, do this for all lines in the table.
When called with a `\\[universal-argument] \\[universal-argument]' prefix, or \
if ALL is the symbol `iterate',
recompute the table until it no longer changes.
If NOALIGN is not nil, do not re-align the table after the computations
are done. This is typically used internally to save time, if it is
known that the table will be realigned a little later anyway."
(interactive "P")
(unless (memq this-command org-recalc-commands)
(push this-command org-recalc-commands))
(unless (org-at-table-p) (user-error "Not at a table"))
(if (or (eq all 'iterate) (equal all '(16)))
(org-table-iterate)
(org-table-analyze)
(let* ((eqlist (sort (org-table-get-stored-formulas)
(lambda (a b) (string< (car a) (car b)))))
(inhibit-redisplay (not debug-on-error))
(line-re org-table-dataline-regexp)
(log-first-time (current-time))
(log-last-time log-first-time)
(cnt 0)
beg end eqlcol eqlfield)
;; Insert constants in all formulas.
(when eqlist
(org-table-with-shrunk-columns
(org-table-save-field
;; Expand equations, then split the equation list between
;; column formulas and field formulas.
(dolist (eq eqlist)
(let* ((rhs (org-table-formula-substitute-names
(org-table-formula-handle-first/last-rc (cdr eq))))
(old-lhs (car eq))
(lhs
(org-table-formula-handle-first/last-rc
(cond
(el-patch-remove
((string-match "\\`@-?I+" old-lhs)
(user-error "Can't assign to hline relative reference")))
((string-match "\\`\\$[<>]" old-lhs)
(let ((new (org-table-formula-handle-first/last-rc
old-lhs)))
(when (assoc new eqlist)
(user-error "\"%s=\" formula tries to overwrite \
existing formula for column %s"
old-lhs
new))
new))
(t old-lhs)))))
(if (string-match-p "\\`\\$[0-9]+\\'" lhs)
(push (cons lhs rhs) eqlcol)
(push (cons lhs rhs) eqlfield))))
(setq eqlcol (nreverse eqlcol))
;; Expand ranges in lhs of formulas
(setq eqlfield (org-table-expand-lhs-ranges (nreverse eqlfield)))
;; Get the correct line range to process.
(if all
(progn
(setq end (copy-marker (org-table-end)))
(goto-char (setq beg org-table-current-begin-pos))
(cond
((re-search-forward org-table-calculate-mark-regexp end t)
;; This is a table with marked lines, compute selected
;; lines.
(setq line-re org-table-recalculate-regexp))
;; Move forward to the first non-header line.
((and (re-search-forward org-table-dataline-regexp end t)
(re-search-forward org-table-hline-regexp end t)
(re-search-forward org-table-dataline-regexp end t))
(setq beg (match-beginning 0)))
;; Just leave BEG at the start of the table.
(t nil)))
(setq beg (line-beginning-position)
end (copy-marker (line-beginning-position 2))))
(goto-char beg)
;; Mark named fields untouchable. Also check if several
;; field/range formulas try to set the same field.
(remove-text-properties beg end '(:org-untouchable t))
(let ((current-line (count-lines org-table-current-begin-pos
(line-beginning-position)))
seen-fields)
(dolist (eq eqlfield)
(let* ((name (car eq))
(location (assoc name org-table-named-field-locations))
(eq-line (or (nth 1 location)
(and (string-match "\\`@\\([0-9]+\\)" name)
(aref org-table-dlines
(string-to-number
(match-string 1 name))))))
(reference
(if location
;; Turn field coordinates associated to NAME
;; into an absolute reference.
(format "@%d$%d"
(org-table-line-to-dline eq-line)
(nth 2 location))
name)))
(when (member reference seen-fields)
(user-error "Several field/range formulas try to set %s"
reference))
(push reference seen-fields)
(when (or all (eq eq-line current-line))
(org-table-goto-field name)
(org-table-put-field-property :org-untouchable t)))))
;; Evaluate the column formulas, but skip fields covered by
;; field formulas.
(goto-char beg)
(while (re-search-forward line-re end t)
(unless (string-match "\\` *[_^!$/] *\\'" (org-table-get-field 1))
;; Unprotected line, recalculate.
(cl-incf cnt)
(when all
(setq log-last-time
(org-table-message-once-per-second
log-last-time
"Re-applying formulas to full table...(line %d)" cnt)))
(if (markerp org-last-recalc-line)
(move-marker org-last-recalc-line (line-beginning-position))
(setq org-last-recalc-line
(copy-marker (line-beginning-position))))
(dolist (entry eqlcol)
(goto-char org-last-recalc-line)
(org-table-goto-column
(string-to-number (substring (car entry) 1)) nil 'force)
(unless (get-text-property (point) :org-untouchable)
(org-table-eval-formula
nil (cdr entry) 'noalign 'nocst 'nostore 'noanalysis)))))
;; Evaluate the field formulas.
(dolist (eq eqlfield)
(let ((reference (car eq))
(formula (cdr eq)))
(setq log-last-time
(org-table-message-once-per-second
(and all log-last-time)
"Re-applying formula to field: %s" (car eq)))
(org-table-goto-field
reference
;; Possibly create a new column, as long as
;; `org-table-formula-create-columns' allows it.
(let ((column-count (progn (end-of-line)
(1- (org-table-current-column)))))
(lambda (column)
(when (> column 1000)
(user-error "Formula column target too large"))
(and (> column column-count)
(or (eq org-table-formula-create-columns t)
(and (eq org-table-formula-create-columns 'warn)
(progn
(org-display-warning
"Out-of-bounds formula added columns")
t))
(and (eq org-table-formula-create-columns 'prompt)
(yes-or-no-p
"Out-of-bounds formula. Add columns? "))
(user-error
"Missing columns in the table. Aborting"))))))
(org-table-eval-formula nil formula t t t t)))
;; Clean up marker.
(set-marker end nil)))
(unless noalign
(when org-table-may-need-update (org-table-align))
(when all
(org-table-message-once-per-second
log-first-time "Re-applying formulas to %d lines... done" cnt)))
(org-table-message-once-per-second
(and all log-first-time) "Re-applying formulas... done")))))))
;; Fix the annoying assumption where it grabs the FIRST line from
;; .authinfo as the user to auth with. This in itself is not "that"
;; bad, but gmail rewrites the From: address to the address ofthe user
;; you auth against smtp with, which breaks outgoing email
(eval-after-load "smtpmail"
'(progn
(el-patch-defun smtpmail-try-auth-methods (process supported-extensions host port
&optional ask-for-password)
(message "[smtpmail-try-auth-methods] host %s port %s" host port)
(setq port
(if port
(format "%s" port)
"smtp"))
(let* ((mechs (seq-intersection
smtpmail-auth-supported
(cdr-safe (assoc 'auth supported-extensions))
#'eq))
(auth-source-creation-prompts
'((user . "SMTP user name for %h: ")
(secret . "SMTP password for %u@%h: ")))
(el-patch-add (smtpmail-smtp-user
(if (eq mail-envelope-from 'header)
(-when-let ((field (mail-fetch-field "From")))
(nth 1 (mail-extract-address-components field)))
mail-envelope-from)))
(auth-info (car
(auth-source-search
:host host
:port port
:user smtpmail-smtp-user
:max 1
:require (and ask-for-password
'(:user :secret))
:create ask-for-password)))
(mech (or (plist-get auth-info :smtp-auth) (car mechs)))
(user (plist-get auth-info :user))
(password (plist-get auth-info :secret))
(save-function (and ask-for-password
(plist-get auth-info :save-function))))
(when (functionp password)
(setq password (funcall password)))
(when (and user
(not password))
;; The user has stored the user name, but not the password, so
;; ask for the password, even if we're not forcing that through
;; `ask-for-password'.
(setq auth-info
(car
(auth-source-search
:max 1
:host host
:port port
:user smtpmail-smtp-user
:require '(:user :secret)
:create t))
password (plist-get auth-info :secret)))
(when (functionp password)
(setq password (funcall password)))
(let ((result (catch 'done
(if (and mech user password)
(smtpmail-try-auth-method process mech user password)
;; No mechanism, or no credentials.
mech))))
(if (stringp result)
(progn
(auth-source-forget+ :host host :port port)
(throw 'done result))
(when save-function
(funcall save-function))
result))))))
;; Fix incorrectly returned default value when user simply hits RET
;; without doing any selection
(eval-after-load "ediff-util"
'(progn
(el-patch-defun ediff-files (file-A file-B &optional startup-hooks)
"Run Ediff on a pair of files, FILE-A and FILE-B.
STARTUP-HOOKS is a list of functions that Emacs calls without
arguments after setting up the Ediff buffers."
(interactive
(let ((dir-A (if ediff-use-last-dir
ediff-last-dir-A
default-directory))
dir-B f)
(list (setq f (ediff-read-file-name
"File A to compare"
dir-A
(ediff-get-default-file-name)
'no-dirs))
(ediff-read-file-name
"File B to compare"
(setq dir-B
(if ediff-use-last-dir
ediff-last-dir-B
(el-patch-wrap 2 0
(or
(dired-dwim-target-directory)
(file-name-directory f)))))
(progn
(add-to-history
'file-name-history
(ediff-abbreviate-file-name
(expand-file-name
(file-name-nondirectory f)
dir-B)))
(ediff-get-default-file-name f 1)))
)))
(ediff-files-internal file-A
(if (file-directory-p file-B)
(expand-file-name
(file-name-nondirectory file-A) file-B)
file-B)
nil ; file-C
startup-hooks
'ediff-files))
(defun ediff-read-file-name (prompt default-dir default-file &optional no-dirs)
;; hack default-dir if it is not set
(setq default-dir
(file-name-as-directory
(ediff-abbreviate-file-name
(expand-file-name (or default-dir
(and default-file
(file-name-directory default-file))
default-directory)))))
;; strip the directory from default-file
(if default-file
(setq default-file (file-name-nondirectory default-file)))
(if (string= default-file "")
(setq default-file nil))
(let ((defaults (and (fboundp 'dired-dwim-target-defaults)
(dired-dwim-target-defaults
(and default-file (list default-file))
default-dir)))
f)
(setq f (ediff-minibuffer-with-setup-hook
(lambda () (when defaults
(setq minibuffer-default defaults)))
(read-file-name
(format "%s%s "
prompt
(cond (default-file
(concat " (default " default-file "):"))
(t (concat " (default " default-dir "):"))))
default-dir
nil ;; FUCO: WAS: (or default-file default-dir)
t ; must match, no-confirm
(if default-file (file-name-directory default-file))
)))
(setq f (expand-file-name f default-dir))
;; If user entered a directory name, expand the default file in that
;; directory. This allows the user to enter a directory name for the
;; B-file and diff against the default-file in that directory instead
;; of a DIRED listing!
(if (and (file-directory-p f) default-file)
(setq f (expand-file-name
(file-name-nondirectory default-file) f)))
(if (and no-dirs (file-directory-p f))
(error "File %s is a directory" f))
f))))
(eval-after-load "hi-lock"
'(progn
(defun hi-lock-read-face-name ()
"Read face name from minibuffer with completion and history."
(intern (completing-read
"Highlight using face: "
(mapcar 'symbol-name (face-list))
nil
nil
"hi-"
'face-name-history
(car hi-lock-face-defaults))))))
(eval-after-load "calendar"
'(el-patch-defun calendar-basic-setup (&optional arg nodisplay)
"Create a three-month calendar.
If optional prefix argument ARG is non-nil, prompts for the month
and year, else uses the current date. If NODISPLAY is non-nil, don't
display the generated calendar."
(interactive "P")
(let ((buff (current-buffer)))
(set-buffer (get-buffer-create calendar-buffer))
(calendar-mode)
(let* ((pop-up-windows t)
;; Not really needed now, but means we use exactly the same
;; behavior as before in the non-wide case (see below).
(split-height-threshold (el-patch-swap 1000 1))
(split-width-threshold calendar-split-width-threshold)
(date (if arg (calendar-read-date t)
(calendar-current-date)))
(month (calendar-extract-month date))
(year (calendar-extract-year date)))
(calendar-increment-month month year (- calendar-offset))
;; Display the buffer before calling calendar-generate-window so that it
;; can get a chance to adjust the window sizes to the frame size.
(unless nodisplay
;; We want a window configuration that looks something like
;; X X | Y
;; - -----
;; C Z | C
;; where C is the calendar, and the LHS is the traditional,
;; non-wide frame, and the RHS is the wide frame case.
;; We should end up in the same state regardless of whether the
;; windows were initially split or not.
;; Previously, we only thought about the non-wide case.
;; We could just set split-height-threshold to 1000, relying on
;; the fact that the window splitting treated a single window as
;; a special case and would always split it (vertically). The
;; same thing does not work in the wide-frame case, so now we do
;; the splitting by hand.
;; See discussion in bug#1806.
;; Actually, this still does not do quite the right thing in the
;; wide frame case if started from a configuration like the LHS.
;; Eg if you start with a non-wide frame, call calendar, then
;; make the frame wider. This one is problematic because you
;; might need to split a totally unrelated window. Oh well, it
;; seems unlikely, and perhaps respecting the original layout is
;; the right thing in that case.
;;
;; Is this a wide frame? If so, split it horizontally.
;; The following doesn't sound useful: If we split horizontally
;; here, the subsequent `pop-to-buffer' will likely split again
;; horizontally and we end up with three side-by-side windows.
(when (window-splittable-p (selected-window) t)
(split-window-right))
(pop-to-buffer calendar-buffer)
;; Has the window already been split vertically?
(when (and (not (window-dedicated-p))
(window-splittable-p (selected-window))
(window-full-height-p))
(let ((win (split-window-below)))
;; In the upper window, show whatever was visible before.
;; This looks better than using other-buffer.
(switch-to-buffer buff)
;; Switch to the lower window with the calendar buffer.
(select-window win))))
(calendar-generate-window month year)
(if (and calendar-view-diary-initially-flag
(calendar-date-is-visible-p date))
;; Do not clobber the calendar with the diary, if the diary
;; has previously been shown in the window that now shows the
;; calendar (bug#18381).
(let ((display-buffer-overriding-action
'(nil . ((inhibit-same-window . t)))))
(diary-view-entries)))))
(if calendar-view-holidays-initially-flag
(let* ((diary-buffer (diary-live-p))
(diary-window (if diary-buffer (get-buffer-window diary-buffer)))
(split-height-threshold (if diary-window 2 1000)))
;; FIXME display buffer?
(calendar-list-holidays)))
(run-hooks 'calendar-initial-window-hook)))
(eval-after-load "org"
'(progn
;; What we want to achieve here is a detailed scheduling scheme
;; for repeating tasks. By default, org can only plan on a "+
;; time interval basis", so you can't schedule things like "do
;; task on monday and friday every week" or specify different
;; hour to do the task at for each day (eg. during week when I
;; work I want to tidy the appartment at 19:00 when I return
;; home, but on weekends I want to do it when I wake up at 10:00).
;; We achieve this objective by adding multiple SCHEDULED (plain)
;; timestamps for different days/times we want to do the task.
;; We then set the repeater for each timestamp separately (so we
;; can even have a scheme like "every monday each week but on
;; friday only every other week"). This all works in org by
;; default, the problem is that when we mark the task DONE *all*
;; the timestamps are shifted at once, so if we have a timestamp
;; for each day and we mark it 7 times this week, all the
;; timestamps will shift 7 weeks into the future.
;; The fix is relatively simple: only update the *past*
;; timestamps and leave the future timestamps alone. The
;; rationale is simple, we don't want to repeat a task which
;; didn't even happen yet.
;; One problem which can occur is that we might finish a task
;; early. To solve this, either the user reschedules the task
;; prior to starting working on it (from the original time to
;; "now"), or simply leaves it scheduled and, when we DONE the
;; task next day (or the next interval *before* the shifted
;; repeat time) it will already be in the past and shift
;; accordingly. In practice, this should be rare as this scheme
;; is mostly useful for repeating *habitual* tasks which we
;; rarely want to do ahead of schedule (eg. workout, language
;; lessons, school material review etc.)
(defun org-auto-repeat-maybe (done-word)
"Check if the current headline contains a repeated time-stamp.
If yes, set TODO state back to what it was and change the base date
of repeating deadline/scheduled time stamps to new date.
This function is run automatically after each state change to a DONE state."
(let* ((repeat (org-get-repeat))
(aa (assoc org-last-state org-todo-kwd-alist))
(interpret (nth 1 aa))
(head (nth 2 aa))
(whata '(("h" . hour) ("d" . day) ("m" . month) ("y" . year)))
(msg "Entry repeats: ")
(org-log-done nil)
(org-todo-log-states nil))
(when (and repeat (not (zerop (string-to-number (substring repeat 1)))))
(when (eq org-log-repeat t) (setq org-log-repeat 'state))
(let ((to-state (or (org-entry-get nil "REPEAT_TO_STATE" 'selective)
org-todo-repeat-to-state)))
(org-todo (cond ((and to-state (member to-state org-todo-keywords-1))
to-state)
((eq interpret 'type) org-last-state)
(head)
(t 'none))))
(when (or org-log-repeat (org-entry-get nil "CLOCK"))
(org-entry-put nil "LAST_REPEAT" (format-time-string
(org-time-stamp-format t t))))
(when org-log-repeat
(if (or (memq 'org-add-log-note (default-value 'post-command-hook))
(memq 'org-add-log-note post-command-hook))
;; We are already setup for some record.
(when (eq org-log-repeat 'note)
;; Make sure we take a note, not only a time stamp.
(setq org-log-note-how 'note))
;; Set up for taking a record.
(org-add-log-setup 'state
(or done-word (car org-done-keywords))
org-last-state
org-log-repeat)))
(org-back-to-heading t)
(org-add-planning-info nil nil 'closed)
(let ((end (save-excursion (outline-next-heading) (point)))
(planning-re (regexp-opt
(list org-scheduled-string org-deadline-string))))
(while (re-search-forward org-ts-regexp end t)
(let* ((ts (match-string 0))
(planning? (org-at-planning-p))
(type (if (not planning?) "Plain:"
(save-excursion
(re-search-backward
planning-re (line-beginning-position) t)
(match-string 0)))))
(cond
;; Ignore fake time-stamps (e.g., within comments).
((and (not planning?)
(not (org-at-property-p))
(not (eq 'timestamp
(org-element-type (save-excursion
(backward-char)
(org-element-context)))))))
;; Time-stamps without a repeater are usually skipped.
;; However, a SCHEDULED time-stamp without one is
;; removed, as it is considered as no longer relevant.
((not (string-match "\\([.+]\\)?\\(\\+[0-9]+\\)\\([hdwmy]\\)" ts))
(when (equal type org-scheduled-string)
(org-remove-timestamp-with-keyword type)))
(t
(let ((n (string-to-number (match-string 2 ts)))
(what (match-string 3 ts))
;; FUCO: time moved here from ##time## becase we
;; need it sooner
(time (save-match-data (org-time-string-to-time ts))))
(when (time-less-p time (current-time))
(when (equal what "w") (setq n (* n 7) what "d"))
(when (and (equal what "h")
(not (string-match-p "[0-9]\\{1,2\\}:[0-9]\\{2\\}"
ts)))
(user-error
"Cannot repeat in Repeat in %d hour(s) because no hour \
has been set"
n))
;; Preparation, see if we need to modify the start
;; date for the change.
(when (match-end 1)
;; FUCO: ##time## was here
;; FUCO: test if the time is in the past and
;; only update then
(cond
((equal (match-string 1 ts) ".")
;; Shift starting date to today
(org-timestamp-change
(- (org-today) (time-to-days time))
'day))
((equal (match-string 1 ts) "+")
(let ((nshiftmax 10)
(nshift 0))
(while (or (= nshift 0)
(not (time-less-p (current-time) time)))
(when (= (cl-incf nshift) nshiftmax)
(or (y-or-n-p
(format "%d repeater intervals were not \
enough to shift date past today. Continue? "
nshift))
(user-error "Abort")))
(org-timestamp-change n (cdr (assoc what whata)))
(org-at-timestamp-p t)
(setq ts (match-string 1))
(setq time
(save-match-data
(org-time-string-to-time ts)))))
(org-timestamp-change (- n) (cdr (assoc what whata)))
;; Rematch, so that we have everything in place
;; for the real shift.
(org-at-timestamp-p t)
(setq ts (match-string 1))
(string-match "\\([.+]\\)?\\(\\+[0-9]+\\)\\([hdwmy]\\)"
ts))))
(save-excursion
(org-timestamp-change n (cdr (assoc what whata)) nil t))
(setq msg
(concat
msg type " " org-last-changed-timestamp " ")))))))))
(setq org-log-post-message msg)
(message "%s" msg))))
;; Add a quick binding to remove org occur highlights/overlays
(defun org-sparse-tree (&optional arg type)
"Create a sparse tree, prompt for the details.
This command can create sparse trees. You first need to select the type
of match used to create the tree:
t Show all TODO entries.
T Show entries with a specific TODO keyword.
m Show entries selected by a tags/property match.
p Enter a property name and its value (both with completion on existing
names/values) and show entries with that property.
r Show entries matching a regular expression (`/' can be used as well).
b Show deadlines and scheduled items before a date.
a Show deadlines and scheduled items after a date.
d Show deadlines due within `org-deadline-warning-days'.
D Show deadlines and scheduled items between a date range."
(interactive "P")
(setq type (or type org-sparse-tree-default-date-type))
(setq org-ts-type type)
(message "Sparse tree: [/]regexp [t]odo [T]odo-kwd [m]atch [p]roperty
[d]eadlines [b]efore-date [a]fter-date [D]ates range [\\]remove overlays
[c]ycle through date types: %s"
(case type
(all "all timestamps")
(scheduled "only scheduled")
(deadline "only deadline")
(active "only active timestamps")
(inactive "only inactive timestamps")
(scheduled-or-deadline "scheduled/deadline")
(closed "with a closed time-stamp")
(otherwise "scheduled/deadline")))
(let ((answer (read-char-exclusive)))
(case answer
(?c
(org-sparse-tree
arg
(cadr (memq type '(scheduled-or-deadline all scheduled deadline active
inactive closed)))))
(?d (call-interactively #'org-check-deadlines))
(?b (call-interactively #'org-check-before-date))
(?a (call-interactively #'org-check-after-date))
(?D (call-interactively #'org-check-dates-range))
(?t (call-interactively #'org-show-todo-tree))
(?T (org-show-todo-tree '(4)))
(?m (call-interactively #'org-match-sparse-tree))
((?p ?P)
(let* ((kwd (org-icompleting-read
"Property: " (mapcar #'list (org-buffer-property-keys))))
(value (org-icompleting-read
"Value: " (mapcar #'list (org-property-values kwd)))))
(unless (string-match "\\`{.*}\\'" value)
(setq value (concat "\"" value "\"")))
(org-match-sparse-tree arg (concat kwd "=" value))))
((?r ?R ?/) (call-interactively #'org-occur))
(?\\ (call-interactively #'org-remove-occur-highlights))
(otherwise (user-error "No such sparse tree command \"%c\"" answer)))))
(el-patch-defun org-babel-execute-src-block (&optional arg info params)
"Execute the current source code block.
Insert the results of execution into the buffer. Source code
execution and the collection and formatting of results can be
controlled through a variety of header arguments.
With prefix argument ARG, force re-execution even if an existing
result cached in the buffer would otherwise have been returned.
Optionally supply a value for INFO in the form returned by
`org-babel-get-src-block-info'.
Optionally supply a value for PARAMS which will be merged with
the header arguments specified at the front of the source code
block."
(interactive)
(let* ((org-babel-current-src-block-location
(or org-babel-current-src-block-location
(nth 5 info)
(org-babel-where-is-src-block-head)))
(info (if info (copy-tree info) (org-babel-get-src-block-info))))
;; Merge PARAMS with INFO before considering source block
;; evaluation since both could disagree.
(cl-callf org-babel-merge-params (nth 2 info) params)
(when (org-babel-check-evaluate info)
(cl-callf org-babel-process-params (nth 2 info))
(let* ((params (nth 2 info))
(cache (let ((c (cdr (assq :cache params))))
(and (not arg) c (string= "yes" c))))
(new-hash (and cache (org-babel-sha1-hash info :eval)))
(old-hash (and cache (org-babel-current-result-hash)))
(current-cache (and new-hash (equal new-hash old-hash))))
(cond
(current-cache
(save-excursion ;Return cached result.
(goto-char (org-babel-where-is-src-block-result nil info))
(forward-line)
(skip-chars-forward " \t")
(let ((result (org-babel-read-result)))
(el-patch-remove (message (replace-regexp-in-string "%" "%%" (format "%S" result))))
result)))
((org-babel-confirm-evaluate info)
(let* ((lang (nth 0 info))
(result-params (cdr (assq :result-params params)))
;; Expand noweb references in BODY and remove any
;; coderef.
(body
(let ((coderef (nth 6 info))
(expand
(if (org-babel-noweb-p params :eval)
(org-babel-expand-noweb-references info)
(nth 1 info))))
(if (not coderef) expand
(replace-regexp-in-string
(org-src-coderef-regexp coderef) "" expand nil nil 1))))
(dir (cdr (assq :dir params)))
(default-directory
(or (and dir (file-name-as-directory (expand-file-name dir)))
default-directory))
(cmd (intern (concat "org-babel-execute:" lang)))
result)
(unless (fboundp cmd)
(error "No org-babel-execute function for %s!" lang))
(message "executing %s code block%s..."
(capitalize lang)
(let ((name (nth 4 info)))
(if name (format " (%s)" name) "")))
(if (member "none" result-params)
(progn (funcall cmd body params)
(message "result silenced"))
(setq result
(let ((r (funcall cmd body params)))
(if (and (eq (cdr (assq :result-type params)) 'value)
(or (member "vector" result-params)
(member "table" result-params))
(not (listp r)))
(list (list r))
r)))
(let ((file (and (member "file" result-params)
(cdr (assq :file params)))))
;; If non-empty result and :file then write to :file.
(when file
;; If `:results' are special types like `link' or
;; `graphics', don't write result to `:file'. Only
;; insert a link to `:file'.
(when (and result
(not (or (member "link" result-params)
(member "graphics" result-params))))
(with-temp-file file
(insert (org-babel-format-result
result
(cdr (assq :sep params))))))
(setq result file))
;; Possibly perform post process provided its
;; appropriate. Dynamically bind "*this*" to the
;; actual results of the block.
(let ((post (cdr (assq :post params))))
(when post
(let ((*this* (if (not file) result
(org-babel-result-to-file
file
(let ((desc (assq :file-desc params)))
(and desc (or (cdr desc) result)))))))
(setq result (org-babel-ref-resolve post))
(when file
(setq result-params (remove "file" result-params))))))
(org-babel-insert-result
result result-params info new-hash lang)))
(run-hooks 'org-babel-after-execute-hook)
result)))))))
))
(eval-after-load "org-drill"
'(progn
(el-patch-defun org-drill-entry-status ()
"Returns a list (STATUS DUE AGE) where DUE is the number of days overdue,
zero being due today, -1 being scheduled 1 day in the future.
AGE is the number of days elapsed since the item was created (nil if unknown).
STATUS is one of the following values:
- nil, if the item is not a drill entry, or has an empty body
- :unscheduled
- :future
- :new
- :failed
- :overdue
- :young
- :old
"
(save-excursion
(unless (org-at-heading-p)
(org-back-to-heading))
(let ((due (org-drill-entry-days-overdue))
(age (org-drill-entry-days-since-creation t))
(last-int (org-drill-entry-last-interval 1)))
(list
(cond
((not (org-drill-entry-p))
nil)
((and (org-entry-empty-p)
(let* ((card-type (org-entry-get (point) "DRILL_CARD_TYPE" nil))
(dat (cdr (assoc card-type org-drill-card-type-alist))))
(or (el-patch-remove (null card-type))
(not (third dat)))))
;; body is empty, and this is not a card type where empty bodies are
;; meaningful, so skip it.
nil)
((null due) ; unscheduled - usually a skipped leech
:unscheduled)
;; ((eql -1 due)
;; :tomorrow)
((minusp due) ; scheduled in the future
:future)
;; The rest of the stati all denote 'due' items ==========================
((<= (org-drill-entry-last-quality 9999)
org-drill-failure-quality)
;; Mature entries that were failed last time are
;; FAILED, regardless of how young, old or overdue
;; they are.
:failed)
((org-drill-entry-new-p)
:new)
((org-drill-entry-overdue-p due last-int)
;; Overdue status overrides young versus old
;; distinction.
;; Store marker + due, for sorting of overdue entries
:overdue)
((<= (org-drill-entry-last-interval 9999)
org-drill-days-before-old)
:young)
(t
:old))
due age))))
(el-patch-defun org-drill-maximum-item-count-reached-p ()
"Returns true if the current drill session has reached the
maximum number of items."
(el-patch-wrap 2
(let ((org-drill-maximum-items-per-session
(or (ignore-errors (string-to-number (org-entry-get (point) "org-drill-maximum-items-per-session" t)))
org-drill-maximum-items-per-session)))
(and org-drill-maximum-items-per-session
(not *org-drill-cram-mode*)
(>= (length *org-drill-done-entries*)
org-drill-maximum-items-per-session)))))))
(eval-after-load "org-attach"
'(progn
(el-patch-defun org-attach-annex-get-maybe (path)
"Call git annex get PATH (via shell) if using git annex.
Signals an error if the file content is not available and it was not retrieved."
(let* ((default-directory (expand-file-name org-attach-directory))
(path-relative (file-relative-name path)))
(when (and (org-attach-use-annex)
(not
((el-patch-swap string-equal string-match-p)
(el-patch-swap "found" (regexp-opt '("\nfound" "")))
(shell-command-to-string
(format "git annex find --format=found --in=here %s"