diff options
Diffstat (limited to 'lisp/org/ob-perl.el')
| -rw-r--r-- | lisp/org/ob-perl.el | 92 |
1 files changed, 66 insertions, 26 deletions
diff --git a/lisp/org/ob-perl.el b/lisp/org/ob-perl.el index b37df807aed..43ab9467c1d 100644 --- a/lisp/org/ob-perl.el +++ b/lisp/org/ob-perl.el @@ -28,7 +28,6 @@ ;;; Code: (require 'ob) -(require 'ob-eval) (eval-when-compile (require 'cl)) (defvar org-babel-tangle-lang-exts) @@ -49,7 +48,7 @@ This function is called by `org-babel-execute-src-block'." body params (org-babel-variable-assignments:perl params))) (session (org-babel-perl-initiate-session session))) (org-babel-reassemble-table - (org-babel-perl-evaluate session full-body result-type) + (org-babel-perl-evaluate session full-body result-type result-params) (org-babel-pick-name (cdr (assoc :colname-names params)) (cdr (assoc :colnames params))) (org-babel-pick-name @@ -63,20 +62,33 @@ This function is called by `org-babel-execute-src-block'." "Return list of perl statements assigning the block's variables." (mapcar (lambda (pair) - (format "$%s=%s;" - (car pair) - (org-babel-perl-var-to-perl (cdr pair)))) + (org-babel-perl--var-to-perl (cdr pair) (car pair))) (mapcar #'cdr (org-babel-get-header params :var)))) ;; helper functions -(defun org-babel-perl-var-to-perl (var) +(defvar org-babel-perl-var-wrap "q(%s)" + "Wrapper for variables inserted into Perl code.") + +(defvar org-babel-perl--lvl) +(defun org-babel-perl--var-to-perl (var &optional varn) "Convert an elisp value to a perl variable. The elisp value, VAR, is converted to a string of perl source code specifying a var of the same value." - (if (listp var) - (concat "[" (mapconcat #'org-babel-perl-var-to-perl var ", ") "]") - (format "%S" var))) + (if varn + (let ((org-babel-perl--lvl 0) (lvar (listp var)) prefix) + (concat "my $" (symbol-name varn) "=" (when lvar "\n") + (org-babel-perl--var-to-perl var) + ";\n")) + (let ((prefix (make-string (* 2 org-babel-perl--lvl) ?\ ))) + (concat prefix + (if (listp var) + (let ((org-babel-perl--lvl (1+ org-babel-perl--lvl))) + (concat "[\n" + (mapconcat #'org-babel-perl--var-to-perl var "") + prefix "]")) + (format "q(%s)" var)) + (unless (zerop org-babel-perl--lvl) ",\n"))))) (defvar org-babel-perl-buffers '(:default . nil)) @@ -84,32 +96,60 @@ specifying a var of the same value." "Return nil because sessions are not supported by perl." nil) -(defvar org-babel-perl-wrapper-method - " -sub main { -%s -} -@r = main; -open(o, \">%s\"); -print o join(\"\\n\", @r), \"\\n\"") +(defvar org-babel-perl-wrapper-method "{ + my $babel_sub = sub { + %s + }; + open my $BOH, qq(>%s) or die qq(Perl: Could not open output file.$/); + my $rv = &$babel_sub(); + my $rt = ref $rv; + select $BOH; + if (qq(ARRAY) eq $rt) { + local $\\=$/; + local $,=qq(\t); + foreach my $rv ( @$rv ) { + my $rt = ref $rv; + if (qq(ARRAY) eq $rt) { + print @$rv; + } else { + print $rv; + } + } + } else { + print $rv; + } +}") + +(defvar org-babel-perl-preface nil) (defvar org-babel-perl-pp-wrapper-method nil) -(defun org-babel-perl-evaluate (session body &optional result-type) +(defun org-babel-perl-evaluate (session ibody &optional result-type result-params) "Pass BODY to the Perl process in SESSION. If RESULT-TYPE equals 'output then return a list of the outputs of the statements in BODY, if RESULT-TYPE equals 'value then return the value of the last statement in BODY, as elisp." (when session (error "Sessions are not supported for Perl")) - (case result-type - (output (org-babel-eval org-babel-perl-command body)) - (value (let ((tmp-file (org-babel-temp-file "perl-"))) - (org-babel-eval - org-babel-perl-command - (format org-babel-perl-wrapper-method body - (org-babel-process-file-name tmp-file 'noquote))) - (org-babel-eval-read-file tmp-file))))) + (let* ((body (concat org-babel-perl-preface ibody)) + (tmp-file (org-babel-temp-file "perl-")) + (tmp-babel-file (org-babel-process-file-name + tmp-file 'noquote))) + ((lambda (results) + (when results + (org-babel-result-cond result-params + (org-babel-eval-read-file tmp-file) + (org-babel-import-elisp-from-file tmp-file '(16))))) + (case result-type + (output + (with-temp-file tmp-file + (insert + (org-babel-eval org-babel-perl-command body)) + (buffer-string))) + (value + (org-babel-eval org-babel-perl-command + (format org-babel-perl-wrapper-method + body tmp-babel-file))))))) (provide 'ob-perl) |