Browse Source

org-colview: Fix user properties display

* contrib/lisp/org-colview-xemacs.el (org-columns-display-here):
(org-columns-display-here-title):
(org-columns-edit-value):
(org-columns-next-allowed-value):
(org-columns-new):
(org-columns-widen):
(org-columns-get-autowidth-alist):
(org-columns-update):
(org-columns-compute):
(org-agenda-columns):
(org-agenda-colview-summarize):
(org-agenda-colview-compute):

* lisp/org-colview.el (org-columns-display-here):
(org-columns-display-here-title):
(org-columns-edit-value):
(org-columns-next-allowed-value):
(org-columns-new):
(org-columns-widen):
(org-columns-get-autowidth-alist):
(org-columns-update):
(org-columns-compute):
(org-agenda-columns):
(org-agenda-colview-summarize):
(org-agenda-colview-compute): Properties are case-insensitive.

Reported-by: Eric S Fraga <e.fraga@ucl.ac.uk>
<http://permalink.gmane.org/gmane.emacs.orgmode/93854>
Nicolas Goaziou 4 years ago
parent
commit
3d2e1eec78
2 changed files with 85 additions and 54 deletions
  1. 43 26
      contrib/lisp/org-colview-xemacs.el
  2. 42 28
      lisp/org-colview.el

+ 43 - 26
contrib/lisp/org-colview-xemacs.el

@@ -331,8 +331,10 @@ This is the compiled version of the format.")
     (while (setq column (pop fmt))
       (setq property (car column)
 	    title (nth 1 column)
-	    ass (assoc property props)
-	    width (or (cdr (assoc property org-columns-current-maxwidths))
+	    ass (assoc-string property props t)
+	    width (or (cdr (assoc-string property
+					 org-columns-current-maxwidths
+					 t))
 		      (nth 2 column)
 		      (length property))
 	    f (format (if (featurep 'xemacs) "%%-%d.%ds |" "%%-%d.%ds | ")
@@ -430,7 +432,9 @@ This is the compiled version of the format.")
     (while (setq column (pop fmt))
       (setq property (car column)
 	    str (or (nth 1 column) property)
-	    width (or (cdr (assoc property org-columns-current-maxwidths))
+	    width (or (cdr (assoc-string property
+					 org-columns-current-maxwidths
+					 t))
 		      (nth 2 column)
 		      (length str))
 	    widths (push width widths)
@@ -629,7 +633,7 @@ Where possible, use the standard interface for changing this line."
 	    (org-columns-display-here)))
 	(org-move-to-column col)
 	(if (and (derived-mode-p 'org-mode)
-		 (nth 3 (assoc key org-columns-current-fmt-compiled)))
+		 (nth 3 (assoc-string key org-columns-current-fmt-compiled t)))
 	    (org-columns-update key)))))))
 
 (defun org-edit-headline () ; FIXME: this is not columns specific.  Make interactive?????  Use from agenda????
@@ -708,7 +712,9 @@ an integer, select that value."
 			    org-columns-overlays)))
 	 (allowed (or (org-property-get-allowed-values pom key)
 		      (and (memq
-			    (nth 4 (assoc key org-columns-current-fmt-compiled))
+			    (nth 4 (assoc-string key
+						 org-columns-current-fmt-compiled
+						 t))
 			    '(checkbox checkbox-n-of-m checkbox-percent))
 			   '("[ ]" "[X]"))
 		      (org-colview-construct-allowed-dates value)))
@@ -757,7 +763,7 @@ an integer, select that value."
 	      (org-columns-eval '(org-entry-put pom key nval)))
 	  (org-columns-display-here)))
       (org-move-to-column col)
-      (and (nth 3 (assoc key org-columns-current-fmt-compiled))
+      (and (nth 3 (assoc-string key org-columns-current-fmt-compiled t))
 	   (org-columns-update key))))))
 
 (defun org-colview-construct-allowed-dates (s)
@@ -896,7 +902,9 @@ interactive function `org-columns-new'.
   "Insert a new column, to the left of the current column."
   (interactive)
   (let ((n (org-columns-current-column))
-	(editp (and prop (assoc prop org-columns-current-fmt-compiled)))
+	(editp (and prop (assoc-string prop
+				       org-columns-current-fmt-compiled
+				       t)))
 	cell)
     (setq prop (org-icompleting-read
 		"Property: " (mapcar 'list (org-buffer-property-keys t nil t))
@@ -952,7 +960,9 @@ interactive function `org-columns-new'.
   (let* ((n (org-columns-current-column))
 	 (entry (nth n org-columns-current-fmt-compiled))
 	 (width (or (nth 2 entry)
-		    (cdr (assoc (car entry) org-columns-current-maxwidths)))))
+		    (cdr (assoc-string (car entry)
+				       org-columns-current-maxwidths
+				       t)))))
     (setq width (max 1 (+ width arg)))
     (setcar (nthcdr 2 entry) width)
     (org-columns-store-format)
@@ -1024,11 +1034,14 @@ Don't set this, this is meant for dynamic scoping.")
       (push (cons (match-string 1 s) 1) rtn)
       (setq start (match-end 0)))
     (mapc (lambda (x)
-	    (setcdr x (apply 'max
+	    (setcdr x
+		    (apply 'max
+			   (let ((prop (car x)))
 			     (mapcar
 			      (lambda (y)
-				(length (or (cdr (assoc (car x) (cdr y))) " ")))
-			      cache))))
+				(length (or (cdr (assoc-string prop (cdr y) t))
+					    " ")))
+			      cache)))))
 	  rtn)
     rtn))
 
@@ -1053,9 +1066,11 @@ Don't set this, this is meant for dynamic scoping.")
 	      (when (equal (overlay-get ov 'org-columns-key) property)
 		(setq pos (overlay-start ov))
 		(goto-char pos)
-		(when (setq val (cdr (assoc property
-					    (get-text-property
-					     (point-at-bol) 'org-summaries))))
+		(when (setq val (cdr (assoc-string
+				      property
+				      (get-text-property
+				       (point-at-bol) 'org-summaries)
+				      t)))
 		  (setq fmt (overlay-get ov 'org-columns-format))
 		  (overlay-put ov 'org-columns-value val)
                   (if (featurep 'xemacs)
@@ -1070,11 +1085,11 @@ Don't set this, this is meant for dynamic scoping.")
   "Sum the values of property PROPERTY hierarchically, for the entire buffer."
   (interactive)
   (let* ((re org-outline-regexp-bol)
-	 (lmax 30) ; Does anyone use deeper levels???
+	 (lmax 30)		    ; Does anyone use deeper levels???
 	 (lvals (make-vector lmax nil))
 	 (lflag (make-vector lmax nil))
 	 (level 0)
-	 (ass (assoc property org-columns-current-fmt-compiled))
+	 (ass (assoc-string property org-columns-current-fmt-compiled t))
 	 (format (nth 4 ass))
 	 (printf (nth 5 ass))
 	 (fun (nth 6 ass))
@@ -1103,12 +1118,12 @@ Don't set this, this is meant for dynamic scoping.")
 		str1 (org-add-props (copy-sequence str) nil 'org-computed t 'face 'bold)
 		useval (if flag str1 (if valflag val ""))
 		sum-alist (get-text-property sumpos 'org-summaries))
-	  (if (assoc property sum-alist)
-	      (setcdr (assoc property sum-alist) useval)
-	    (push (cons property useval) sum-alist)
-	    (org-unmodified
-	     (add-text-properties sumpos (1+ sumpos)
-				  (list 'org-summaries sum-alist))))
+	  (let ((old (assoc-string property sum-alist t)))
+	    (if old (setcdr old useval)
+	      (push (cons property useval) sum-alist)
+	      (org-unmodified
+	       (add-text-properties sumpos (1+ sumpos)
+				    (list 'org-summaries sum-alist)))))
 	  (when (and val (not (equal val (if flag str val))))
 	    (org-entry-put nil property (if flag str val)))
 	  ;; add current to current level accumulator
@@ -1525,7 +1540,7 @@ and tailing newline characters."
 			  (org-get-at-bol 'org-marker)))
 	  (setq p (org-entry-properties m))
 
-	  (when (or (not (setq a (assoc org-effort-property p)))
+	  (when (or (not (setq a (assoc-string org-effort-property p t)))
 		    (not (string-match "\\S-" (or (cdr a) ""))))
 	    ;; OK, the property is not defined.  Use appointment duration?
 	    (when (and org-agenda-columns-add-appointments-to-effort-sum
@@ -1589,7 +1604,7 @@ This will add overlays to the date lines, to show the summary for each day."
 			(t ;; do the summary
 			 (setq lsum nil)
 			 (dolist (x entries)
-			   (setq v (cdr (assoc prop x)))
+			   (setq v (cdr (assoc-string prop x t)))
 			   (if v
 			       (push
 				(funcall
@@ -1639,8 +1654,10 @@ This will add overlays to the date lines, to show the summary for each day."
 	      (if (equal (car fm) "CLOCKSUM")
 		  (org-clock-sum)
 		(when (and (nth 4 fm)
-			   (setq a (assoc (car fm)
-					  org-columns-current-fmt-compiled))
+			   (setq a (assoc-string
+				    (car fm)
+				    org-columns-current-fmt-compiled
+				    t))
 			   (equal (nth 4 a) (nth 4 fm)))
 		  (org-columns-compute (car fm)))))))))))
 

+ 42 - 28
lisp/org-colview.el

@@ -186,8 +186,9 @@ This is the compiled version of the format.")
     (while (setq column (pop fmt))
       (setq property (car column)
 	    title (nth 1 column)
-	    ass (assoc property props)
-	    width (or (cdr (assoc property org-columns-current-maxwidths))
+	    ass (assoc-string property props t)
+	    width (or (cdr
+		       (assoc-string property org-columns-current-maxwidths t))
 		      (nth 2 column)
 		      (length property))
 	    f (format "%%-%d.%ds | " width width)
@@ -279,7 +280,9 @@ for the duration of the command.")
     (while (setq column (pop fmt))
       (setq property (car column)
 	    str (or (nth 1 column) property)
-	    width (or (cdr (assoc property org-columns-current-maxwidths))
+	    width (or (cdr (assoc-string property
+					 org-columns-current-maxwidths
+					 t))
 		      (nth 2 column)
 		      (length str))
 	    widths (push width widths)
@@ -396,7 +399,7 @@ Where possible, use the standard interface for changing this line."
 	 (value (get-char-property (point) 'org-columns-value))
 	 (bol (point-at-bol)) (eol (point-at-eol))
 	 (pom (or (get-text-property bol 'org-hd-marker)
-		  (point))) ; keep despite of compiler waring
+		  (point)))	     ; keep despite of compiler waring
 	 (line-overlays
 	  (delq nil (mapcar (lambda (x)
 			      (and (eq (overlay-buffer x) (current-buffer))
@@ -472,7 +475,7 @@ Where possible, use the standard interface for changing this line."
 	    (org-columns-display-here)))
 	(org-move-to-column col)
 	(if (and (derived-mode-p 'org-mode)
-		 (nth 3 (assoc key org-columns-current-fmt-compiled)))
+		 (nth 3 (assoc-string key org-columns-current-fmt-compiled t)))
 	    (org-columns-update key)))))))
 
 (defun org-edit-headline () ; FIXME: this is not columns specific.  Make interactive?????  Use from agenda????
@@ -541,7 +544,7 @@ an integer, select that value."
 	 (value (get-char-property (point) 'org-columns-value))
 	 (bol (point-at-bol)) (eol (point-at-eol))
 	 (pom (or (get-text-property bol 'org-hd-marker)
-		  (point))) ; keep despite of compiler waring
+		  (point)))	     ; keep despite of compiler waring
 	 (line-overlays
 	  (delq nil (mapcar (lambda (x)
 			      (and (eq (overlay-buffer x) (current-buffer))
@@ -551,7 +554,9 @@ an integer, select that value."
 			    org-columns-overlays)))
 	 (allowed (or (org-property-get-allowed-values pom key)
 		      (and (memq
-			    (nth 4 (assoc key org-columns-current-fmt-compiled))
+			    (nth 4 (assoc-string key
+						 org-columns-current-fmt-compiled
+						 t))
 			    '(checkbox checkbox-n-of-m checkbox-percent))
 			   '("[ ]" "[X]"))
 		      (org-colview-construct-allowed-dates value)))
@@ -600,7 +605,7 @@ an integer, select that value."
 	      (org-columns-eval '(org-entry-put pom key nval)))
 	  (org-columns-display-here)))
       (org-move-to-column col)
-      (and (nth 3 (assoc key org-columns-current-fmt-compiled))
+      (and (nth 3 (assoc-string key org-columns-current-fmt-compiled t))
 	   (org-columns-update key))))))
 
 (defun org-colview-construct-allowed-dates (s)
@@ -753,7 +758,8 @@ calc        function called on every element before summarizing.  This is
 (defun org-columns-new (&optional prop title width op fmt fun &rest rest)
   "Insert a new column, to the left of the current column."
   (interactive)
-  (let ((editp (and prop (assoc prop org-columns-current-fmt-compiled)))
+  (let ((editp (and prop
+		    (assoc-string prop org-columns-current-fmt-compiled t)))
 	cell)
     (setq prop (org-icompleting-read
 		"Property: " (mapcar 'list (org-buffer-property-keys t nil t))
@@ -811,7 +817,9 @@ calc        function called on every element before summarizing.  This is
   (let* ((n (current-column))
 	 (entry (nth n org-columns-current-fmt-compiled))
 	 (width (or (nth 2 entry)
-		    (cdr (assoc (car entry) org-columns-current-maxwidths)))))
+		    (cdr (assoc-string (car entry)
+				       org-columns-current-maxwidths
+				       t)))))
     (setq width (max 1 (+ width arg)))
     (setcar (nthcdr 2 entry) width)
     (org-columns-store-format)
@@ -879,11 +887,14 @@ display, or in the #+COLUMNS line of the current buffer."
       (push (cons (match-string 1 s) 1) rtn)
       (setq start (match-end 0)))
     (mapc (lambda (x)
-	    (setcdr x (apply 'max
+	    (setcdr x
+		    (apply #'max
+			   (let ((prop (car x)))
 			     (mapcar
 			      (lambda (y)
-				(length (or (cdr (assoc (car x) (cdr y))) " ")))
-			      cache))))
+				(length (or (cdr (assoc-string prop (cdr y) t))
+					    " ")))
+			      cache)))))
 	  rtn)
     rtn))
 
@@ -908,9 +919,11 @@ display, or in the #+COLUMNS line of the current buffer."
 	      (when (equal (overlay-get ov 'org-columns-key) property)
 		(setq pos (overlay-start ov))
 		(goto-char pos)
-		(when (setq val (cdr (assoc property
-					    (get-text-property
-					     (point-at-bol) 'org-summaries))))
+		(when (setq val (cdr (assoc-string
+				      property
+				      (get-text-property
+				       (point-at-bol) 'org-summaries)
+				      t)))
 		  (setq fmt (overlay-get ov 'org-columns-format))
 		  (overlay-put ov 'org-columns-value val)
 		  (overlay-put ov 'display (format fmt val)))))
@@ -924,11 +937,11 @@ display, or in the #+COLUMNS line of the current buffer."
   "Sum the values of property PROPERTY hierarchically, for the entire buffer."
   (interactive)
   (let* ((re org-outline-regexp-bol)
-	 (lmax 30) ; Does anyone use deeper levels???
+	 (lmax 30)		    ; Does anyone use deeper levels???
 	 (lvals (make-vector lmax nil))
 	 (lflag (make-vector lmax nil))
 	 (level 0)
-	 (ass (assoc property org-columns-current-fmt-compiled))
+	 (ass (assoc-string property org-columns-current-fmt-compiled t))
 	 (format (nth 4 ass))
 	 (printf (nth 5 ass))
 	 (fun (nth 6 ass))
@@ -968,12 +981,12 @@ display, or in the #+COLUMNS line of the current buffer."
 		str1 (org-add-props (copy-sequence str) nil 'org-computed t 'face 'bold)
 		useval (if flag str1 (if valflag val ""))
 		sum-alist (get-text-property sumpos 'org-summaries))
-	  (if (assoc property sum-alist)
-	      (setcdr (assoc property sum-alist) useval)
-	    (push (cons property useval) sum-alist)
-	    (org-with-silent-modifications
-	     (add-text-properties sumpos (1+ sumpos)
-				  (list 'org-summaries sum-alist))))
+	  (let ((old (assoc-string property sum-alist t)))
+	    (if old (setcdr old useval)
+	      (push (cons property useval) sum-alist)
+	      (org-with-silent-modifications
+	       (add-text-properties sumpos (1+ sumpos)
+				    (list 'org-summaries sum-alist)))))
 	  (when (and val (not (equal val (if flag str val))))
 	    (org-entry-put nil property (if flag str val)))
 	  ;; add current to current level accumulator
@@ -1374,7 +1387,7 @@ and tailing newline characters."
 			  (org-get-at-bol 'org-marker)))
 	  (setq p (org-entry-properties m))
 
-	  (when (or (not (setq a (assoc org-effort-property p)))
+	  (when (or (not (setq a (assoc-string org-effort-property p t)))
 		    (not (string-match "\\S-" (or (cdr a) ""))))
 	    ;; OK, the property is not defined.  Use appointment duration?
 	    (when (and org-agenda-columns-add-appointments-to-effort-sum
@@ -1444,7 +1457,7 @@ This will add overlays to the date lines, to show the summary for each day."
 			(t ;; do the summary
 			 (setq lsum nil)
 			 (dolist (x entries)
-			   (setq v (cdr (assoc prop x)))
+			   (setq v (cdr (assoc-string prop x t)))
 			   (if v
 			       (push
 				(funcall
@@ -1495,8 +1508,9 @@ This will add overlays to the date lines, to show the summary for each day."
 		    ((equal (car fm) "CLOCKSUM_T")
 		     (org-clock-sum-today))
 		    ((and (nth 4 fm)
-			  (setq a (assoc (car fm)
-					 org-columns-current-fmt-compiled))
+			  (setq a (assoc-string (car fm)
+						org-columns-current-fmt-compiled
+						t))
 			  (equal (nth 4 a) (nth 4 fm)))
 		     (org-columns-compute (car fm)))))))))))