Re: asynchronous exporter and babel confirmation

[Achim Gratz <Stromeko@nexgo.de>]

[-- Attachment #1: Type: text/plain, Size: 134 bytes --]

Hi Nicolas,

I'm still waiting for feedback from Karl Voit over in the other thread,
but here's the amended patch for you to review:


[-- Attachment #2: 0001-ob-core-do-not-ask-for-confirmation-if-cached-result.patch --]
[-- Type: text/x-patch, Size: 12131 bytes --]

From c49b4ab5afda4d223cbcf97cb8c7ac0f9cc8e39b Mon Sep 17 00:00:00 2001
From: Achim Gratz <Stromeko@Stromeko.DE>
Date: Wed, 27 Feb 2013 22:55:26 +0100
Subject: [PATCH] ob-core: do not ask for confirmation if cached result is
 current
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

* lisp/ob-core.el (org-babel-confirm-evaluate): Refactor this internal
  function.
* lisp/ob-core.el (org-babel--suppress-confirm-evaluate-answer-no):
  Dynamically scoped variable, if bound non-nil the confirmation
  dialog will not be initiated and it is assumed the user answered
  with "no".
* lisp/ob-core.el (org-babel--check-confirm-evaluate): New macro to
  ensure that the initial let-bindings for `org-babel--check-evaluate´
  and `org-babel--confirm-evaluate´ are consistent.
* lisp/ob-core.el (org-babel--check-evaluate): First part of
  `org-babel-confirm-evaluate´, check whether this source block
  evaluation is enabled.
* lisp/ob-core.el (org-babel--confirm-evaluate): Second part of
  `org-babel-confirm-evaluate´, let the user confirm evaluation.
* lisp/ob-core.el (org-babel-execute-src-block): Do not ask for
  confirmation if the cached result is current.

  The call to `org-babel--check-evaluate´ will indicate if the block
  should be evaluated.  If yes, determine whether the cached result
  block is current (since `org-babel-process-params´ might trigger
  expensive operations this has to be deferred).  If `cache-current-p´
  is t, evaluate the source block without asking.  In case the cache
  is current the evaluation will not actually do anything but return
  the cached value, so this is safe.  Otherwise ask permission from
  the user by calling `org-babel--confirm-evaluate´ and act depending
  on the answer.

  The new variable `org-babel--suppress-confirm-evaluate-answer-no´
  can be bound to suppress the user interaction as is needed for async
  export, as discussed in
  http://thread.gmane.org/gmane.emacs.orgmode/67719
---
 lisp/ob-core.el | 207 ++++++++++++++++++++++++++++++--------------------------
 1 file changed, 110 insertions(+), 97 deletions(-)

diff --git a/lisp/ob-core.el b/lisp/ob-core.el
index 3b7c463..af245ed 100644
--- a/lisp/ob-core.el
+++ b/lisp/ob-core.el
@@ -1,4 +1,4 @@
-;;; ob-core.el --- working with code blocks in org-mode
+;; ob-core.el --- working with code blocks in org-mode
 
 ;; Copyright (C) 2009-2012  Free Software Foundation, Inc.
 
@@ -284,7 +284,27 @@ (defun org-babel-get-src-block-info (&optional light)
     (when info (append info (list name indent)))))
 
 (defvar org-current-export-file) ; dynamically bound
-(defun org-babel-confirm-evaluate (info)
+(defmacro org-babel--check-confirm-evaluate (info &rest body)
+  "Pull some information from code block INFO and evaluate BODY.
+"
+  (declare (indent defun))
+  `(let* ((eval (or (cdr (assoc :eval (nth 2 ,info)))
+		   (when (assoc :noeval (nth 2 ,info)) "no")))
+	 (code-block (if info (format " %s " (nth 0 ,info)) " "))
+	 (block-name (if (nth 4 ,info) (format " (%s) " (nth 4 ,info)) " ")))
+     ,@body))
+(defun org-babel--check-evaluate (info)
+  "Check whether the code block INFO should be evaluated.
+"
+  (org-babel--check-confirm-evaluate info
+    (if (or (equal eval "never") (equal eval "no")
+	    (and (boundp 'org-current-export-file) org-current-export-file
+		 (or (equal eval "no-export") (equal eval "never-export"))))
+	(prog1 nil (message (format "Evaluation of this%scode block%sis disabled."
+				    code-block block-name)))
+      t)))
+(defvar org-babel--suppress-confirm-evaluate-answer-no) ;; dynamically scoped
+(defun org-babel--confirm-evaluate (info)
   "Confirm evaluation of the code block INFO.
 This behavior can be suppressed by setting the value of
 `org-confirm-babel-evaluate' to nil, in which case all future
@@ -293,33 +313,23 @@ (defun org-babel-confirm-evaluate (info)
 
 Note disabling confirmation may result in accidental evaluation
 of potentially harmful code."
-  (let* ((eval (or (cdr (assoc :eval (nth 2 info)))
-		   (when (assoc :noeval (nth 2 info)) "no")))
-         (query (cond ((equal eval "query") t)
-		      ((and (boundp 'org-current-export-file)
-			    org-current-export-file
-			    (equal eval "query-export")) t)
-                      ((functionp org-confirm-babel-evaluate)
-                       (funcall org-confirm-babel-evaluate
-                                (nth 0 info) (nth 1 info)))
-                      (t org-confirm-babel-evaluate))))
-    (if (or (equal eval "never") (equal eval "no")
-	    (and (boundp 'org-current-export-file)
-		 org-current-export-file
-		 (or (equal eval "no-export")
-		     (equal eval "never-export")))
-	    (and query
-		 (not (yes-or-no-p
-		       (format "Evaluate this%scode block%son your system? "
-			       (if info (format " %s " (nth 0 info)) " ")
-			       (if (nth 4 info)
-				   (format " (%s) " (nth 4 info)) " "))))))
-	(prog1 nil (message "Evaluation %s"
-			    (if (or (equal eval "never") (equal eval "no")
-				    (equal eval "no-export")
-				    (equal eval "never-export"))
-				"Disabled" "Aborted")))
-      t)))
+  (org-babel--check-confirm-evaluate info
+    (let* ((query (cond ((equal eval "query") t)
+			((and (boundp 'org-current-export-file) org-current-export-file
+			      (equal eval "query-export")) t)
+			((functionp org-confirm-babel-evaluate)
+			 (funcall org-confirm-babel-evaluate
+				  (nth 0 info) (nth 1 info)))
+			(t org-confirm-babel-evaluate))))
+      (if (and query
+	       (or (null org-babel--suppress-confirm-evaluate-answer-no)
+		   (not (yes-or-no-p
+			 (format "Evaluate this%scode block%son your system? "
+				 code-block block-name)))))
+	  (prog1 nil (message
+		      (format "Evaluation of%scode-block%snot confirmed."
+			      code-block block-name)))
+	t))))
 
 ;;;###autoload
 (defun org-babel-execute-safely-maybe ()
@@ -525,80 +535,83 @@ (defun org-babel-execute-src-block (&optional arg info params)
   (interactive)
   (let* ((info (or info (org-babel-get-src-block-info)))
 	 (merged-params (org-babel-merge-params (nth 2 info) params)))
-    (when (org-babel-confirm-evaluate
+    (when (org-babel--check-evaluate
 	   (let ((i info)) (setf (nth 2 i) merged-params) i))
-      (let* ((lang (nth 0 info))
-	     (params (if params
+      (let* ((params (if params
 			 (org-babel-process-params merged-params)
 		       (nth 2 info)))
 	     (cache-p (and (not arg) (cdr (assoc :cache params))
-			  (string= "yes" (cdr (assoc :cache params)))))
-	     (result-params (cdr (assoc :result-params params)))
+			   (string= "yes" (cdr (assoc :cache params)))))
 	     (new-hash (when cache-p (org-babel-sha1-hash info)))
 	     (old-hash (when cache-p (org-babel-current-result-hash)))
-	     (cache-current-p (and (not arg) new-hash (equal new-hash old-hash)))
-	     (body (setf (nth 1 info)
-			 (if (org-babel-noweb-p params :eval)
-			     (org-babel-expand-noweb-references info)
-			   (nth 1 info))))
-	     (dir (cdr (assoc :dir params)))
-	     (default-directory
-	       (or (and dir (file-name-as-directory (expand-file-name dir)))
-		   default-directory))
-	     (org-babel-call-process-region-original
-	      (if (boundp 'org-babel-call-process-region-original)
-		  org-babel-call-process-region-original
-		(symbol-function 'call-process-region)))
-	     (indent (car (last info)))
-	     result cmd)
-	(unwind-protect
-	    (let ((call-process-region
-		   (lambda (&rest args)
-		     (apply 'org-babel-tramp-handle-call-process-region args))))
-	      (let ((lang-check (lambda (f)
-				  (let ((f (intern (concat "org-babel-execute:" f))))
-				    (when (fboundp f) f)))))
-		(setq cmd
-		      (or (funcall lang-check lang)
-			  (funcall lang-check (symbol-name
-					       (cdr (assoc lang org-src-lang-modes))))
-			  (error "No org-babel-execute function for %s!" lang))))
-	      (if cache-current-p
-		  (save-excursion ;; return cached result
-		    (goto-char (org-babel-where-is-src-block-result nil info))
-		    (end-of-line 1) (forward-char 1)
-		    (setq result (org-babel-read-result))
-		    (message (replace-regexp-in-string
-			      "%" "%%" (format "%S" result))) result)
-		(message "executing %s code block%s..."
-			 (capitalize lang)
-			 (if (nth 4 info) (format " (%s)" (nth 4 info)) ""))
-		(if (member "none" result-params)
-		    (progn
-		      (funcall cmd body params)
-		      (message "result silenced"))
-		(setq result
-		      ((lambda (result)
-			 (if (and (eq (cdr (assoc :result-type params)) 'value)
-				  (or (member "vector" result-params)
-				      (member "table" result-params))
-				  (not (listp result)))
-			     (list (list result)) result))
-		       (funcall cmd body params)))
-		;; if non-empty result and :file then write to :file
-		(when (cdr (assoc :file params))
-		  (when result
-		    (with-temp-file (cdr (assoc :file params))
-		      (insert
-		       (org-babel-format-result
-			result (cdr (assoc :sep (nth 2 info)))))))
-		  (setq result (cdr (assoc :file params))))
-		(org-babel-insert-result
-		 result result-params info new-hash indent lang)
-		(run-hooks 'org-babel-after-execute-hook)
-		result
-		)))
-	  (setq call-process-region 'org-babel-call-process-region-original))))))
+	     (cache-current-p (and (not arg) new-hash (equal new-hash old-hash))))
+	(when (or cache-current-p
+		  (org-babel--confirm-evaluate
+		   (let ((i info)) (setf (nth 2 i) merged-params) i)))
+	  (let* ((lang (nth 0 info))
+		 (result-params (cdr (assoc :result-params params)))
+		 (body (setf (nth 1 info)
+			     (if (org-babel-noweb-p params :eval)
+				 (org-babel-expand-noweb-references info)
+			       (nth 1 info))))
+		 (dir (cdr (assoc :dir params)))
+		 (default-directory
+		   (or (and dir (file-name-as-directory (expand-file-name dir)))
+		       default-directory))
+		 (org-babel-call-process-region-original
+		  (if (boundp 'org-babel-call-process-region-original)
+		      org-babel-call-process-region-original
+		    (symbol-function 'call-process-region)))
+		 (indent (car (last info)))
+		 result cmd)
+	    (unwind-protect
+		(let ((call-process-region
+		       (lambda (&rest args)
+			 (apply 'org-babel-tramp-handle-call-process-region args))))
+		  (let ((lang-check (lambda (f)
+				      (let ((f (intern (concat "org-babel-execute:" f))))
+					(when (fboundp f) f)))))
+		    (setq cmd
+			  (or (funcall lang-check lang)
+			      (funcall lang-check (symbol-name
+						   (cdr (assoc lang org-src-lang-modes))))
+			      (error "No org-babel-execute function for %s!" lang))))
+		  (if cache-current-p
+		      (save-excursion ;; return cached result
+			(goto-char (org-babel-where-is-src-block-result nil info))
+			(end-of-line 1) (forward-char 1)
+			(setq result (org-babel-read-result))
+			(message (replace-regexp-in-string
+				  "%" "%%" (format "%S" result))) result)
+		    (message "executing %s code block%s..."
+			     (capitalize lang)
+			     (if (nth 4 info) (format " (%s)" (nth 4 info)) ""))
+		    (if (member "none" result-params)
+			(progn
+			  (funcall cmd body params)
+			  (message "result silenced"))
+		      (setq result
+			    ((lambda (result)
+			       (if (and (eq (cdr (assoc :result-type params)) 'value)
+					(or (member "vector" result-params)
+					    (member "table" result-params))
+					(not (listp result)))
+				   (list (list result)) result))
+			     (funcall cmd body params)))
+		      ;; if non-empty result and :file then write to :file
+		      (when (cdr (assoc :file params))
+			(when result
+			  (with-temp-file (cdr (assoc :file params))
+			    (insert
+			     (org-babel-format-result
+			      result (cdr (assoc :sep (nth 2 info)))))))
+			(setq result (cdr (assoc :file params))))
+		      (org-babel-insert-result
+		       result result-params info new-hash indent lang)
+		      (run-hooks 'org-babel-after-execute-hook)
+		      result
+		      )))
+	      (setq call-process-region 'org-babel-call-process-region-original))))))))
 
 (defun org-babel-expand-body:generic (body params &optional var-lines)
   "Expand BODY with PARAMS.
-- 
1.8.1.4


[-- Attachment #3: Type: text/plain, Size: 201 bytes --]



Regards,
Achim.
-- 
+<[Q+ Matrix-12 WAVE#46+305 Neuron microQkb Andromeda XTk Blofeld]>+

Waldorf MIDI Implementation & additional documentation:
http://Synth.Stromeko.net/Downloads.html#WaldorfDocs