From 86ee8c9cdce2efd5faf27e3923911c7f2ca21180 Mon Sep 17 00:00:00 2001 From: Phil Longstaff Date: Sun, 21 Jun 2009 22:22:57 +0000 Subject: [PATCH] Add eguile.scm written by Chris Dennis git-svn-id: svn+ssh://svn.gnucash.org/repo/gnucash/trunk@18150 57a11ea4-9604-0410-9ed3-97b8803252fd --- src/report/report-system/Makefile.am | 4 +- src/report/report-system/eguile.scm | 213 +++++++++++++++++++++++++++ 2 files changed, 216 insertions(+), 1 deletion(-) create mode 100644 src/report/report-system/eguile.scm diff --git a/src/report/report-system/Makefile.am b/src/report/report-system/Makefile.am index 3a43ea237a..86761462a4 100644 --- a/src/report/report-system/Makefile.am +++ b/src/report/report-system/Makefile.am @@ -52,7 +52,9 @@ gncscm_DATA = \ gncmoddir = ${GNC_SHAREDIR}/guile-modules/gnucash/report-system gncscmmoddir = ${GNC_SHAREDIR}/guile-modules/gnucash/report/ -gncscmmod_DATA = report-system.scm +gncscmmod_DATA = \ + report-system.scm \ + eguile.scm if GNUCASH_SEPARATE_BUILDDIR #For executing test cases diff --git a/src/report/report-system/eguile.scm b/src/report/report-system/eguile.scm new file mode 100644 index 0000000000..d571844e7b --- /dev/null +++ b/src/report/report-system/eguile.scm @@ -0,0 +1,213 @@ +;; +;; eguile-gnc.scm -- embedded guile preprocessor for GnuCash +;; Copyright (c) 2009 Chris Dennis +;; Based on eguile.scm by Neale Pickett +;; (see http://woozle.org/~neale/src/eguile/) +;; +;; $Author: chris $ $Date: 2009/06/19 22:44:43 $ $Revision: 1.7 $ +;; +;; Why all the changes from the original eguile? +;; - need to escape " etc in text +;; - single pass template parsing - allow use as filter (still need +;; another pass for evaluation) +;; - regexps to allow any whitespace, not just 'space' +;; - catch exceptions +;; - make it a module as part of the GnuCash directory structure +;; +;; +;; Documentation +;; ------------- +;; +;; eguile-gnc will process a file containing text and embedded Guile code. +;; +;; The text may well be HTML, but could be anything. I'll use HTML for +;; the examples here. +;; +;; Guile/Scheme code is wrapped in '' +;; (whitespace is required after '') +;; +;; '' is the same as '' +;; +;; Note that s-expressions can be spread across more than one '', +;; for example: +;; x 3) (begin ?>BiggerSmaller +;; +;; Each chunk of text outside a '' ends up wrapped +;; in a (display ... ), after having had double quotes etc. escaped. +;; +;; The processing happens in two passes. Initially the input file is converted +;; to a Guile script, and then that script is evaluated to produce the final +;; result. +;; +;; For example, if the input file contained these lines: +;; +;;

Invoice

+;; +;;

Date: , description: +;; +;; +;; the resulting script would look like: +;; +;; (display "

Invoice ")(display invoiceid)(display "

") +;; (for-each (lambda (entry) +;; (display "

Date: ")(display (entry date)) +;; (display ", description: ")(display (entry desc)) +;; ) entries) +;; +;; and the final result might be this string: +;; +;; "

Invoice 002345

+;;

Date: 04/03/2009, description: Widgets +;;

Date: 05/03/2009, description: Modified widgets" +;; +;; + +;; +;; This program 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 2 of the +;; License, or (at your option) any later version. +;; +;; This program 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 this program; if not, write to the Free Software +;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;; 02111-1307 USA + +(define-module (gnucash report eguile-gnc)) + +(use-modules (ice-9 regex)) ; for regular expressions +(use-modules (ice-9 rdelim)) ; for read-line +(use-modules (gnucash app-utils)) ; for _ + +;; This is needed for displaying error messages -- note that it assumes that +;; the output is HTML, which is a pity, because otherwise this module is +;; non-specific -- it is designed to output a mixture of Guile and any other +;; sort of text. Oh well. +(define (escape-html s1) + ;; convert string s1 to escape HTML special characters < > and & + ;; i.e. convert them to < > and & respectively. + ;; Maybe there's a way to do this in one go... (but order is important) + (set! s1 (regexp-substitute/global #f "&" s1 'pre "&" 'post)) + (set! s1 (regexp-substitute/global #f "<" s1 'pre "<" 'post)) + (regexp-substitute/global #f ">" s1 'pre ">" 'post)) + +;; regexps used to find start and end of code segments +(define startre (make-regexp "<\\?scm(:d)?[[:space:]]")) +(define endre (make-regexp "(^|[[:space:]])\\?>")) + +;; Guile code to mark starting and stopping text or code modes +(define textstart "(display \"") +(define textstop "\")") +(define codestart "") +(define codestop "") +(define dcodestart "(display ") +(define dcodestop ")") + +;; Parse a template, and return a sequence of s-expressions +;; e.g. "Text ." -> (display "Text ")(display (+ x 2))(display ".") +(define (template->script) + + ;; output text with double quotes escaped, but without the outer + ;; enclosing quotes that (simple-format) insists on adding. + ;; (can't use (write) either because that wraps each line of output + ;; in double quotes) + (define (display-text t) + (let ((esct (simple-format #f "~s" t))) + (display (substring esct 1 (- (string-length esct) 1))))) + + ;; display either code or text + (define (display-it t code?) + (if code? + (display t) + (display-text t))) + + (define stop textstop) ; text to output at end of current section + + ;; switch between code and text modes + (define (switch-mode code? dmodifier?) + (display stop) + (if code? + (begin ; code mode to text mode + (display textstart) + (set! stop textstop)) + (begin ; text mode to code mode + (if dmodifier? + (begin + (display dcodestart) + (set! stop dcodestop)) + (begin + (display codestart) + (set! stop codestop)))))) + + ;; recursively process input stream + (define (loop inp needle other code? line) + (if (eq? line "") + (set! line (read-line inp 'concat))) + (if (not (eof-object? line)) + (let ((match (regexp-exec needle line))) + (if match + (let ((dmodifier? #f)) + (display-it (match:prefix match) code?) + (if (not code?) + ; switching from text to code -- check for modifier + (set! dmodifier? (match:substring match 1))) + (switch-mode code? dmodifier?) + (loop inp other needle (not code?) (match:suffix match))) + (begin ; no match - output whole line and continue + (display-it line code?) + (loop inp needle other code? "")))))) + + (display textstart) + (loop (current-input-port) startre endre #f "") + (display stop)) + +;end of (template->script) + +;; Evaluate input containing Scheme code, trapping errors +;; e.g. (display "Text ")(display (+ x 2))(display ".") -> Text 42. +;; Parameters: +;; env - environment in which to do the evaluation; +;; if #f, (the-environment) will be used +(define (script->output env) + (define (eval-input) + (let ((s-expression (read))) + (while (not (eof-object? s-expression)) + (local-eval s-expression (or env (the-environment))) + (set! s-expression (read))))) + + (define (error-handler key subr message args . rest) + (display (_ "

An error occurred when processing the template:
")) + (display + (escape-html + (with-output-to-string + (lambda () + (display-error #f (current-output-port) subr message args rest))))) + (display "
")) + + (catch #t eval-input error-handler)) +; end of (script->output) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Process a template file and return the result as a string +(define (eguile-file-to-string infile environment) + (if (not (access? infile R_OK)) + (string-append (_ "Template file ") infile (_ " can not be read")) + (let ((script (with-input-from-file + infile + (lambda () (with-output-to-string template->script))))) + (with-output-to-string + (lambda () (with-input-from-string + script + (lambda () (script->output environment)))))))) + +(export eguile-file-to-string) +