Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -33,11 +33,11 @@
# module source files
# MSRCFILES =
# ftail.scm rmtmod.scm commonmod.scm removed
MSRCFILES = autoload.scm dbi.scm ducttape-lib.scm pkts.scm stml2.scm cookie.scm mutils.scm \
- mtargs.scm apimod.scm commonmod.scm dbmod.scm rmtmod.scm
+ mtargs.scm apimod.scm commonmod.scm dbmod.scm rmtmod.scm debugprint.scm
# commonmod.scm dbmod.scm adjutant.scm ulex.scm \
# rmtmod.scm apimod.scm
GUISRCF = dashboard-context-menu.scm dashboard-tests.scm \
@@ -52,25 +52,19 @@
MOIMPFILES = $(MSRCFILES:%.scm=%.import.o)
%.import.o : %.import.scm
csc $(CSCOPTS) -unit $*.import -c $*.import.scm -o $*.import.o
-# I'm not sure the cp is a good idea, changed a lot of things and it may not have been necessary...
-# mofiles/%.o %.import.scm : %.scm megatest-fossil-hash.scm
-# @[ -e mofiles ] || mkdir -p mofiles
-# csc $(CSCOPTS) -I mofiles -I $* -J -c $< -o $*.o
-# cp $*.o mofiles/$*.o
-# @touch $*.import.scm # ensure it is touched after the .o is made
-
mofiles/%.o : %.scm
mkdir -p mofiles
csc $(CSCOPTS) -J -c $< -o mofiles/$*.o
# module dependencies
mofiles/stml2.o : mofiles/dbi.o
mofiles/dbi.o : mofiles/autoload.o
mofiles/apimod.o mofiles/dbmod.o mofiles/rmtmod.o : mofiles/commonmod.o
+mofiles/commonmod.o : mofiles/mtargs.o mofiles/debugprint.o
ADTLSCR=mt_laststep mt_runstep mt_ezstep
HELPERS=$(addprefix $(PREFIX)/bin/,$(ADTLSCR))
DEPLOYHELPERS=$(addprefix deploytarg/,$(ADTLSCR))
MTESTHASH=$(shell fossil info|grep checkout:| awk '{print $$2}')
ADDED configfmod.scm
Index: configfmod.scm
==================================================================
--- /dev/null
+++ configfmod.scm
@@ -0,0 +1,1039 @@
+;;======================================================================
+;; Copyright 2017, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest 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 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest 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 Megatest. If not, see .
+
+;;======================================================================
+
+(declare (unit configfmod))
+(declare (uses mtargs))
+(declare (uses debugprint))
+
+(module configfmod
+ *
+
+(import scheme
+
+ chicken.base
+ chicken.condition
+ chicken.file
+ chicken.io
+ chicken.pathname
+ chicken.port
+ chicken.pretty-print
+ chicken.process
+ chicken.process-context
+ chicken.sort
+ chicken.string
+ chicken.time
+
+ debugprint
+ mtargs
+ pkts
+
+ (prefix base64 base64:)
+ (prefix dbi dbi:)
+ (prefix sqlite3 sqlite3:)
+ (srfi 18)
+ directory-utils
+ format
+ matchable
+ md5
+ message-digest
+ regex
+ regex-case
+ sparse-vectors
+ srfi-1
+ srfi-13
+ srfi-69
+ stack
+ typed-records
+ z3
+
+ )
+
+(define getenv get-environment-variable)
+(define setenv set-environment-variable!)
+(define unsetenv unset-environment-variable!)
+
+;;======================================================================
+;; move debug stuff to separate module then put these back where they belong
+;;======================================================================
+;;======================================================================
+;; lookup routines - replicated from configf
+;;======================================================================
+
+(define (configf:lookup cfgdat section var)
+ (if (hash-table? cfgdat)
+ (let ((sectdat (hash-table-ref/default cfgdat section '())))
+ (if (null? sectdat)
+ #f
+ (let ((match (assoc var sectdat)))
+ (if match ;; (and match (list? match)(> (length match) 1))
+ (cadr match)
+ #f))
+ ))
+ #f))
+
+(define (configf:assoc-safe-add alist key val #!key (metadata #f))
+ (let ((newalist (filter (lambda (x)(not (equal? key (car x)))) alist)))
+ (append newalist (list (if metadata
+ (list key val metadata)
+ (list key val))))))
+
+(define (configf:section-var-set! cfgdat section-name var value #!key (metadata #f))
+ (hash-table-set! cfgdat section-name
+ (configf:assoc-safe-add
+ (hash-table-ref/default cfgdat section-name '())
+ var value metadata: metadata)))
+
+;; use to have definitive setting:
+;; [foo]
+;; var yes
+;;
+;; (configf:var-is? cfgdat "foo" "var" "yes") => #t
+;;
+(define (configf:var-is? cfgdat section var expected-val)
+ (equal? (configf:lookup cfgdat section var) expected-val))
+
+;; redefines
+(define config-lookup configf:lookup)
+
+;; safely look up a value that is expected to be a number, return
+;; a default (#f unless provided)
+;;
+(define (configf:lookup-number cfdat section varname #!key (default #f))
+ (let* ((val (configf:lookup cfdat section varname))
+ (res (if val
+ (string->number (string-substitute "\\s+" "" val #t))
+ #f)))
+ (cond
+ (res res)
+ (val (debug:print 0 *default-log-port* "ERROR: no number found for [" section "], " varname ", got: " val))
+ (else default))))
+
+(define (configf:section-vars cfgdat section)
+ (let ((sectdat (hash-table-ref/default cfgdat section '())))
+ (if (null? sectdat)
+ '()
+ (map car sectdat))))
+
+(define (configf:get-section cfgdat section)
+ (hash-table-ref/default cfgdat section '()))
+
+(define (configf:set-section-var cfgdat section var val)
+ (let ((sectdat (configf:get-section cfgdat section)))
+ (hash-table-set! cfgdat section
+ (configf:assoc-safe-add sectdat var val))))
+
+;;======================================================================the end
+
+;; return list (path fullpath configname)
+(define (find-config configname #!key (toppath #f))
+ (if toppath
+ (let ((cfname (conc toppath "/" configname)))
+ (if (file-exists? cfname)
+ (list toppath cfname configname)
+ (list #f #f #f)))
+ (let* ((cwd (string-split (current-directory) "/")))
+ (let loop ((dir cwd))
+ (let* ((path (conc "/" (string-intersperse dir "/")))
+ (fullpath (conc path "/" configname)))
+ (if (file-exists? fullpath)
+ (list path fullpath configname)
+ (let ((remcwd (take dir (- (length dir) 1))))
+ (if (null? remcwd)
+ (list #f #f #f) ;; #f #f)
+ (loop remcwd)))))))))
+
+(define (configf:eval-string-in-environment str)
+ ;; (if (or (string-null? str)
+ ;; (equal? "!" (substring str 0 1))) ;; null string or starts with ! are preserved but NOT set in the environment
+ str
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print-error 0 *default-log-port* "problem evaluating \"" str "\" in the shell environment, exn=" exn)
+ #f)
+ (let ((cmdres (process:cmd-run->list (conc "echo " str))))
+ (if (null? cmdres) ""
+ (caar cmdres))))) ;; )
+
+;;======================================================================
+;; Make the regexp's needed globally available
+;;======================================================================
+
+(define configf:include-rx (regexp "^\\[include\\s+(.*)\\]\\s*$"))
+(define configf:script-rx (regexp "^\\[scriptinc\\s+(\\S+)([^\\]]*)\\]\\s*$")) ;; include output from a script
+(define configf:section-rx (regexp "^\\[(.*)\\]\\s*$"))
+(define configf:blank-l-rx (regexp "^\\s*$"))
+(define configf:key-sys-pr (regexp "^(\\S+)\\s+\\[system\\s+(\\S+.*)\\]\\s*$"))
+(define configf:key-val-pr (regexp "^(\\S+)(\\s+(.*)|())$"))
+(define configf:key-no-val (regexp "^(\\S+)(\\s*)$"))
+(define configf:comment-rx (regexp "^\\s*#.*"))
+(define configf:cont-ln-rx (regexp "^(\\s+)(\\S+.*)$"))
+(define configf:settings (regexp "^\\[configf:settings\\s+(\\S+)\\s+(\\S+)]\\s*$"))
+
+;; read a line and process any #{ ... } constructs
+
+(define configf:var-expand-regex (regexp "^(.*)#\\{(scheme|system|shell|getenv|get|runconfigs-get|rget|scm|sh|rp|gv|g|mtrah)\\s+([^\\}\\{]*)\\}(.*)"))
+
+(define (configf:system ht cmd)
+ (system cmd)
+ )
+
+(define (configf:process-line l ht allow-system #!key (linenum #f))
+ (let loop ((res l))
+ (if (string? res)
+ (let ((matchdat (string-search configf:var-expand-regex res)))
+ (if matchdat
+ (let* ((prestr (list-ref matchdat 1))
+ (cmdtype (list-ref matchdat 2)) ;; eval, system, shell, getenv
+ (cmd (list-ref matchdat 3))
+ (poststr (list-ref matchdat 4))
+ (result #f)
+ (start-time (current-seconds))
+ (cmdsym (string->symbol cmdtype))
+ (fullcmd (case cmdsym
+ ((scheme scm) (conc "(lambda (ht)" cmd ")"))
+ ((system) (conc "(lambda (ht)(configf:system ht \"" cmd "\"))"))
+ ((shell sh) (conc "(lambda (ht)(string-translate (shell \"" cmd "\") \"\n\" \" \"))"))
+ ((realpath rp)(conc "(lambda (ht)(common:nice-path \"" cmd "\"))"))
+ ((getenv gv) (conc "(lambda (ht)(get-environment-variable \"" cmd "\"))"))
+ ((mtrah) (conc "(lambda (ht)"
+ " (let ((extra \"" cmd "\"))"
+ " (conc (or *toppath* (get-environment-variable \"MT_RUN_AREA_HOME\"))"
+ " (if (string-null? extra) \"\" \"/\")"
+ " extra)))"))
+ ((get g)
+ (match (string-split cmd)
+ ((sect var)(conc "(lambda (ht)(configfmod#configf:lookup ht \"" sect "\" \"" var "\"))"))
+ (else
+ (debug:print-error 0 *default-log-port* "#{get ...} used with only one parameter, \"" cmd "\", two needed.")
+ "(lambda (ht) #f)")))
+ ((runconfigs-get rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
+ ;; ((rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
+ (else "(lambda (ht)(print \"ERROR\") \"ERROR\")"))))
+ ;; (print "fullcmd=" fullcmd)
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\", exn=" exn)
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ ;; (print "exn=" (condition->list exn))
+ (set! result (conc "#{( " cmdtype ") " cmd "}, full expansion: " fullcmd)))
+ (if (or allow-system
+ (not (member cmdtype '("system" "shell" "sh"))))
+ (with-input-from-string fullcmd
+ (lambda ()
+ (set! result ((eval (read)) ht))))
+ (set! result (conc "#{(" cmdtype ") " cmd "}"))))
+ (case cmdsym
+ ((system shell scheme)
+ (let ((delta (- (current-seconds) start-time)))
+ (if (> delta 2)
+ (debug:print-info 0 *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result)
+ (debug:print-info 9 *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result)))))
+ (loop (conc prestr result poststr)))
+ res))
+ res)))
+
+;; Run a shell command and return the output as a string
+(define (shell cmd)
+ (let* ((output (process:cmd-run->list cmd))
+ (res (car output))
+ (status (cadr output)))
+ (if (equal? status 0)
+ (let ((outres (string-intersperse
+ res
+ "\n")))
+ (debug:print-info 4 *default-log-port* "shell result:\n" outres)
+ outres)
+ (begin
+ (with-output-to-port (current-error-port)
+ (lambda ()
+ (print "ERROR: " cmd " returned bad exit code " status)))
+ ""))))
+
+;; this was inline but I'm pretty sure that is a hold over from when it was *very* simple ...
+;;
+(define (configf:read-line p ht allow-processing settings)
+ (let loop ((inl (read-line p)))
+ (let ((cont-line (and (string? inl)
+ (not (string-null? inl))
+ (equal? "\\" (string-take-right inl 1)))))
+ (if cont-line ;; last character is \
+ (let ((nextl (read-line p)))
+ (if (not (eof-object? nextl))
+ (loop (string-append (if cont-line
+ (string-take inl (- (string-length inl) 1))
+ inl)
+ nextl))))
+ (let ((res (case allow-processing ;; if (and allow-processing
+ ;; (not (eq? allow-processing 'return-string)))
+ ((#t #f)
+ (configf:process-line inl ht allow-processing))
+ ((return-string)
+ inl)
+ (else
+ (configf:process-line inl ht allow-processing)))))
+ (if (and (string? res) ;; must set to "no" to force NOT trimming trailing spaces
+ (not (equal? (hash-table-ref/default settings "trim-trailing-spaces" "yes") "no")))
+ (string-substitute "\\s+$" "" res)
+ res))))))
+
+(define (configf:cfgdat->env-alist section cfgdat-ht allow-system)
+ (filter
+ (lambda (pair)
+ (let* ((var (car pair))
+ (val (cdr pair)))
+ (cons var
+ (cond
+ ((and allow-system (procedure? val)) ;; if we decided to use something other than #t or #f for allow-system ('return-procs or 'return-string) , this may become problematic
+ (val))
+ ((procedure? val) #f)
+ ((string? val) val)
+ (else "#f")))))
+ (append
+ (hash-table-ref/default cfgdat-ht "default" '())
+ (if (equal? section "default") '() (hash-table-ref/default cfgdat-ht section '())))))
+
+(define (calc-allow-system allow-system section sections)
+ (if sections
+ (and (or (equal? "default" section)
+ (member section sections))
+ allow-system) ;; account for sections and return allow-system as it might be a symbol such as return-strings
+ allow-system))
+
+;; given a config hash and a section name, apply that section to all matching sections (using wildcard % or regex if /..../)
+;; remove the section when done so that there is no downstream clobbering
+;;
+(define (configf:apply-wildcards ht section-name)
+ (if (hash-table-exists? ht section-name)
+ (let* ((vars (hash-table-ref ht section-name))
+ (rxstr (if (string-contains section-name "%")
+ (string-substitute (regexp "%") ".*" section-name)
+ (string-substitute (regexp "^/(.*)/$") "\\1" section-name)))
+ (rx (regexp rxstr)))
+ ;; (print "\nsection-name: " section-name " rxstr: " rxstr)
+ (for-each
+ (lambda (section)
+ (if section
+ (let ((same-section (string=? section-name section))
+ (rx-match (string-match rx section)))
+ ;; (print "section: " section " vars: " vars " same-section: " same-section " rx-match: " rx-match)
+ (if (and (not same-section) rx-match)
+ (for-each
+ (lambda (bundle)
+ ;; (print "bundle: " bundle)
+ (let ((key (car bundle))
+ (val (cadr bundle))
+ (meta (if (> (length bundle) 2)(caddr bundle) #f)))
+ (hash-table-set! ht section (configf:assoc-safe-add (hash-table-ref ht section) key val metadata: meta))))
+ vars)))))
+ (hash-table-keys ht))))
+ ht)
+
+;; read a config file, returns hash table of alists
+
+;; read a config file, returns hash table of alists
+;; adds to ht if given (must be #f otherwise)
+;; allow-system:
+;; #f - do not evaluate [system
+;; #t - immediately evaluate [system and store result as string
+;; 'return-procs -- return a proc taking ht as an argument that may be evaulated at some future time
+;; 'return-string -- return a string representing a proc taking ht as an argument that may be evaulated at some future time
+;; envion-patt is a regex spec that identifies sections that will be eval'd
+;; in the environment on the fly
+;; sections: #f => get all, else list of sections to gather
+;; post-section-procs alist of section-pattern => proc, where: (proc section-name next-section-name ht curr-path)
+;; apply-wildcards: #t/#f - apply vars from targets with % wildcards to all matching sections
+;;
+(define (read-config path ht allow-system #!key (environ-patt #f) (curr-section #f)
+ (sections #f) (settings (make-hash-table)) (keep-filenames #f)
+ (post-section-procs '()) (apply-wildcards #t) )
+ (debug:print 9 *default-log-port* "START: " path)
+;; (if *configdat*
+;; (common:save-pkt `((action . read-config)
+;; (f . ,(cond ((string? path) path)
+;; ((port? path) "port")
+;; (else (conc path))))
+;; (T . configf))
+;; *configdat* #t add-only: #t))
+ (if (and (not (port? path))
+ (not (file-exists? path))) ;; for case where we are handed a port
+ (begin
+ (debug:print-info 1 *default-log-port* "read-config - file not found " path " current path: " (current-directory))
+ ;; WARNING: This is a risky change but really, we should not return an empty hash table if no file read?
+ #f) ;; (if (not ht)(make-hash-table) ht))
+ (let ((inp (if (string? path)
+ (open-input-file path)
+ path)) ;; we can be handed a port
+ (res (if (not ht)(make-hash-table) ht))
+ (metapath (if (or (debug:debug-mode 9)
+ keep-filenames)
+ path #f))
+ (process-wildcards (lambda (res curr-section-name)
+ (if (and apply-wildcards
+ (or (string-contains curr-section-name "%") ;; wildcard
+ (string-match "/.*/" curr-section-name))) ;; regex
+ (begin
+ (configf:apply-wildcards res curr-section-name)
+ (hash-table-delete! res curr-section-name)))))) ;; NOTE: if the section is a wild card it will be REMOVED from res
+ (let loop ((inl (configf:read-line inp res (calc-allow-system allow-system curr-section sections) settings)) ;; (read-line inp))
+ (curr-section-name (if curr-section curr-section "default"))
+ (var-flag #f);; turn on for key-var-pr and cont-ln-rx, turn off elsewhere
+ (lead #f))
+ (debug:print-info 8 *default-log-port* "curr-section-name: " curr-section-name " var-flag: " var-flag "\n inl: \"" inl "\"")
+ (if (eof-object? inl)
+ (begin
+ ;; process last section for wildcards
+ (process-wildcards res curr-section-name)
+ (if (string? path) ;; we received a path, not a port, thus we are responsible for closing it.
+ (close-input-port inp))
+ (if (list? sections) ;; delete all sections except given when sections is provided
+ (for-each
+ (lambda (section)
+ (if (not (member section sections))
+ (hash-table-delete! res section))) ;; we are using "" as a dumping ground and must remove it before returning the ht
+ (hash-table-keys res)))
+ (debug:print 9 *default-log-port* "END: " path)
+ res
+ ) ;; retval
+ (regex-case
+ inl
+ (configf:comment-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
+ curr-section-name #f #f))
+
+ (configf:blank-l-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
+ curr-section-name #f #f))
+ (configf:settings ( x setting val )
+ (begin
+ (hash-table-set! settings setting val)
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
+ curr-section-name #f #f)))
+
+ (configf:include-rx ( x include-file )
+ (let* ((curr-conf-dir (pathname-directory path))
+ (full-conf (if (and (absolute-pathname? include-file) (file-exists? include-file))
+ include-file
+ (common:nice-path
+ (conc (if curr-conf-dir
+ curr-conf-dir
+ ".")
+ "/" include-file)))))
+ (let ((all-matches (sort (handle-exceptions exn
+ (begin
+ (debug:print '(2 9) *default-log-port* "glob of " full-conf " gave no match. , exn=" exn)
+ (list))
+ (glob full-conf)) string<=?)))
+ (if (null? all-matches)
+ (begin
+ (debug:print '(2 9) #f "INFO: include file(s) matching " include-file " not found (called from " path ")")
+ (debug:print 2 *default-log-port* " " full-conf))
+ (for-each
+ (lambda (fpath)
+ ;; (push-directory conf-dir)
+ (debug:print 9 *default-log-port* "Including: " full-conf)
+ (read-config fpath res allow-system environ-patt: environ-patt
+ curr-section: curr-section-name sections: sections settings: settings
+ keep-filenames: keep-filenames))
+ all-matches))
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
+ curr-section-name #f #f))))
+ (configf:script-rx ( x include-script params);; handle-exceptions
+ ;; exn
+ ;; (begin
+ ;; (debug:print '(0 2 9) #f "INFO: include from script " include-script " failed.")
+ ;; (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
+ (if (and (file-exists? include-script)(file-executable? include-script))
+ (let* ((local-allow-system (calc-allow-system allow-system curr-section-name sections))
+ (env-delta (configf:cfgdat->env-alist curr-section-name res local-allow-system))
+ (new-inp-port
+ (common:with-env-vars
+ env-delta
+ (lambda ()
+ (open-input-pipe (conc include-script " " params))))))
+ (debug:print '(2 9) *default-log-port* "Including from script output: " include-script)
+ ;; (print "We got here, calling read-config next. Port is: " new-inp-port)
+ (read-config new-inp-port res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections settings: settings keep-filenames: keep-filenames)
+ (close-input-port new-inp-port)
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
+ (begin
+ (debug:print 0 *default-log-port* "Script not found or not exectutable: " include-script)
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))
+ ) ;; )
+ (configf:section-rx ( x section-name )
+ (begin
+ ;; call post-section-procs
+ (for-each
+ (lambda (dat)
+ (let ((patt (car dat))
+ (proc (cdr dat)))
+ (if (string-match patt curr-section-name)
+ (proc curr-section-name section-name res path))))
+ post-section-procs)
+ ;; after gathering the vars for a section and if apply-wildcards is true and if there is a wildcard in the section name process wildcards
+ ;; NOTE: we are processing the curr-section-name, NOT section-name.
+ (process-wildcards res curr-section-name)
+ (if (not (hash-table-ref/default res section-name #f))(hash-table-set! res section-name '())) ;; ensure that mere mention of a section is not lost
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
+ ;; if we have the sections list then force all settings into "" and delete it later?
+ ;; (if (or (not sections)
+ ;; (member section-name sections))
+ ;; section-name "") ;; stick everything into "". NOPE: We need new strategy. Put stuff in correct sections and then delete all sections later.
+ section-name
+ #f #f)))
+ (configf:key-sys-pr ( x key cmd )
+ (if (calc-allow-system allow-system curr-section-name sections)
+ (let ((alist (hash-table-ref/default res curr-section-name '()))
+ (val-proc (lambda ()
+ (let* ((start-time (current-seconds))
+ (local-allow-system (calc-allow-system allow-system curr-section-name sections))
+ (env-delta (configf:cfgdat->env-alist curr-section-name res local-allow-system))
+ (cmdres (process:cmd-run->list cmd delta-env-alist-or-hash-table: env-delta)) ;; BB: here is where [system is exec'd. needs to have env from other vars!
+ (delta (- (current-seconds) start-time))
+ (status (cadr cmdres))
+ (res (car cmdres)))
+ (debug:print-info 4 *default-log-port* "" inl "\n => " (string-intersperse res "\n"))
+ (if (not (eq? status 0))
+ (begin
+ (debug:print-error 0 *default-log-port* "problem with " inl ", return code " status
+ " output: " cmdres)))
+ (if (> delta 2)
+ (debug:print-info 0 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res)
+ (debug:print-info 9 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res))
+ (if (null? res)
+ ""
+ (string-intersperse res " "))))))
+ (hash-table-set! res curr-section-name
+ (configf:assoc-safe-add alist
+ key
+ (case (calc-allow-system allow-system curr-section-name sections)
+ ((return-procs) val-proc)
+ ((return-string) cmd)
+ (else (val-proc)))
+ metadata: metapath))
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
+ (loop (configf:read-line inp res
+ (calc-allow-system allow-system curr-section-name sections)
+ settings)
+ curr-section-name #f #f)))
+
+ (configf:key-no-val ( x key val)
+ (let* ((alist (hash-table-ref/default res curr-section-name '()))
+ (fval (or (if (string? val) val #f) ""))) ;; fval should be either "" or " " (one or more spaces)
+ (debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = #t")
+ (safe-setenv key fval)
+ (hash-table-set! res curr-section-name
+ (configf:assoc-safe-add alist key fval metadata: metapath))
+ (loop (configf:read-line inp res
+ (calc-allow-system allow-system curr-section-name sections)
+ settings)
+ curr-section-name key #f)))
+
+ (configf:key-val-pr ( x key unk1 val unk2 )
+ (let* ((alist (hash-table-ref/default res curr-section-name '()))
+ (envar (and environ-patt
+ (string-search (regexp environ-patt) curr-section-name) ;; does the section match the envionpatt?
+ (and (not (string-null? key))
+ (not (equal? "!" (substring key 0 1)))) ;; ! as leading character is a signature to NOT export to the environment
+ ;; (string-match "^.*:.*:.*$" key) ;; ;; something:something:something reserved for triggers in runconfigs
+ ))
+ (realval (if envar
+ (configf:eval-string-in-environment val)
+ val)))
+ (debug:print-info 6 *default-log-port* "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name)
+ (if envar (safe-setenv key realval))
+ (debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = " val)
+ (hash-table-set! res curr-section-name
+ (configf:assoc-safe-add alist key realval metadata: metapath))
+ (loop (configf:read-line inp res
+ (calc-allow-system allow-system curr-section-name sections) settings)
+ curr-section-name key #f)))
+ ;; if a continued line
+ (configf:cont-ln-rx ( x whsp val )
+ (let ((alist (hash-table-ref/default res curr-section-name '())))
+ (if var-flag ;; if set to a string then we have a continued var
+ (let ((newval (conc
+ (configf:lookup res curr-section-name var-flag) "\n"
+ ;; trim lead from the incoming whsp to support some indenting.
+ (if lead
+ (string-substitute (regexp lead) "" whsp)
+ "")
+ val)))
+ ;; (print "val: " val "\nnewval: \"" newval "\"\nvarflag: " var-flag)
+ (hash-table-set! res curr-section-name
+ (configf:assoc-safe-add alist var-flag newval metadata: metapath))
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name var-flag (if lead lead whsp)))
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))))
+ (else (debug:print-error 0 *default-log-port* "problem parsing " path ",\n \"" inl "\"")
+ (set! var-flag #f)
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))))
+ ) ;; end loop
+ )))
+
+;;======================================================================
+;; lookup and manipulation routines
+;;======================================================================
+
+;; (define (configf:assoc-safe-add alist key val #!key (metadata #f))
+;; (let ((newalist (filter (lambda (x)(not (equal? key (car x)))) alist)))
+;; (append newalist (list (if metadata
+;; (list key val metadata)
+;; (list key val))))))
+;;
+;; (define (configf:section-var-set! cfgdat section-name var value #!key (metadata #f))
+;; (hash-table-set! cfgdat section-name
+;; (configf:assoc-safe-add
+;; (hash-table-ref/default cfgdat section-name '())
+;; var value metadata: metadata)))
+;;
+;; (define (configf:lookup cfgdat section var)
+;; (if (hash-table? cfgdat)
+;; (let ((sectdat (hash-table-ref/default cfgdat section '())))
+;; (if (null? sectdat)
+;; #f
+;; (let ((match (assoc var sectdat)))
+;; (if match ;; (and match (list? match)(> (length match) 1))
+;; (cadr match)
+;; #f))
+;; ))
+;; #f))
+;;
+;; ;; use to have definitive setting:
+;; ;; [foo]
+;; ;; var yes
+;; ;;
+;; ;; (configf:var-is? cfgdat "foo" "var" "yes") => #t
+;; ;;
+;; (define (configf:var-is? cfgdat section var expected-val)
+;; (equal? (configf:lookup cfgdat section var) expected-val))
+;;
+;; (define config-lookup configf:lookup)
+(define configf:read-file read-config)
+
+;; ;; safely look up a value that is expected to be a number, return
+;; ;; a default (#f unless provided)
+;; ;;
+;; (define (configf:lookup-number cfdat section varname #!key (default #f))
+;; (let* ((val (configf:lookup *configdat* section varname))
+;; (res (if val
+;; (string->number (string-substitute "\\s+" "" val #t))
+;; #f)))
+;; (cond
+;; (res res)
+;; (val (debug:print 0 *default-log-port* "ERROR: no number found for [" section "], " varname ", got: " val))
+;; (else default))))
+;;
+;; (define (configf:section-vars cfgdat section)
+;; (let ((sectdat (hash-table-ref/default cfgdat section '())))
+;; (if (null? sectdat)
+;; '()
+;; (map car sectdat))))
+;;
+;; (define (configf:get-section cfgdat section)
+;; (hash-table-ref/default cfgdat section '()))
+;;
+;; (define (configf:set-section-var cfgdat section var val)
+;; (let ((sectdat (configf:get-section cfgdat section)))
+;; (hash-table-set! cfgdat section
+;; (configf:assoc-safe-add sectdat var val))))
+;;
+;; ;;(append (filter (lambda (x)(not (assoc var sectdat))) sectdat)
+;; ;; (list var val))))
+;;
+;;======================================================================
+;; setup
+;;======================================================================
+;;======================================================================
+
+(define (setup)
+ (let* ((configf (find-config "megatest.config"))
+ (config (if configf (read-config configf #f #t) #f)))
+ (if config
+ (setenv "RUN_AREA_HOME" (pathname-directory configf)))
+ config))
+
+(define getenv get-environment-variable)
+(define (safe-setenv key val)
+ (if (or (substring-index "!" key)
+ (substring-index ":" key) ;; variables containing : are for internal use and cannot be environment variables.
+ (substring-index "." key)) ;; periods are not allowed in environment variables
+ (debug:print-error 4 *default-log-port* "skip setting internal use only variables containing \":\" or starting with \"!\"")
+ (if (and (string? val)
+ (string? key))
+ (handle-exceptions
+ exn
+ (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val ", exn=" exn)
+ (setenv key val))
+ (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val))))
+
+;;======================================================================
+;; accept an alist or hash table containing envvar/env value pairs (value of #f causes unset)
+;; execute thunk in context of environment modified as per this list
+;; restore env to prior state then return value of eval'd thunk.
+;; ** this is not thread safe **
+(define (common:with-env-vars delta-env-alist-or-hash-table thunk)
+ (let* ((delta-env-alist (if (hash-table? delta-env-alist-or-hash-table)
+ (hash-table->alist delta-env-alist-or-hash-table)
+ delta-env-alist-or-hash-table))
+ (restore-thunks
+ (filter
+ identity
+ (map (lambda (env-pair)
+ (let* ((env-var (car env-pair))
+ (new-val (let ((tmp (cdr env-pair)))
+ (if (list? tmp) (car tmp) tmp)))
+ (current-val (get-environment-variable env-var))
+ (restore-thunk
+ (cond
+ ((not current-val) (lambda () (unsetenv env-var)))
+ ((not (string? new-val)) #f)
+ ((eq? current-val new-val) #f)
+ (else
+ (lambda () (setenv env-var current-val))))))
+ ;;(when (not (string? new-val))
+ ;; (debug:print 0 *default-log-port* " PROBLEM: not a string: "new-val"\n from env-alist:\n"delta-env-alist)
+ ;; (pp delta-env-alist)
+ ;; (exit 1))
+
+
+ (cond
+ ((not new-val) ;; modify env here
+ (unsetenv env-var))
+ ((string? new-val)
+ (setenv env-var new-val)))
+ restore-thunk))
+ delta-env-alist))))
+ (let ((rv (thunk)))
+ (for-each (lambda (x) (x)) restore-thunks) ;; restore env to original state
+ rv)))
+
+;; return a nice clean pathname made absolute
+(define (common:nice-path dir)
+ (let ((match (string-match "^(~[^\\/]*)(\\/.*|)$" dir)))
+ (if match ;; using ~ for home?
+ (common:nice-path (conc (common:read-link-f (cadr match)) "/" (caddr match)))
+ (normalize-pathname (if (absolute-pathname? dir)
+ dir
+ (conc (current-directory) "/" dir))))))
+
+;; make "nice-path" available in config files and the repl
+(define nice-path common:nice-path)
+
+(define (common:read-link-f path)
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print-error 0 *default-log-port* "command \"/bin/readlink -f " path "\" failed. exn=" exn)
+ path) ;; just give up
+ (with-input-from-pipe
+ (conc "/bin/readlink -f " path)
+ (lambda ()
+ (read-line)))))
+
+
+;;======================================================================
+;; Non destructive writing of config file
+;;======================================================================
+
+(define (configf:compress-multi-lines fdat)
+ ;; step 1.5 - compress any continued lines
+ (if (null? fdat) fdat
+ (let loop ((hed (car fdat))
+ (tal (cdr fdat))
+ (cur "")
+ (led #f)
+ (res '()))
+ ;; ALL WHITESPACE LEADING LINES ARE TACKED ON!!
+ ;; 1. remove led whitespace
+ ;; 2. tack on to hed with "\n"
+ (let ((match (string-match configf:cont-ln-rx hed)))
+ (if match ;; blast! have to deal with a multiline
+ (let* ((lead (cadr match))
+ (lval (caddr match))
+ (newl (conc cur "\n" lval)))
+ (if (not led)(set! led lead))
+ (if (null? tal)
+ (set! fdat (append fdat (list newl)))
+ (loop (car tal)(cdr tal) newl led res))) ;; NB// not tacking newl onto res
+ (let ((newres (if led
+ (append res (list cur hed))
+ (append res (list hed)))))
+ ;; prev was a multiline
+ (if (null? tal)
+ newres
+ (loop (car tal)(cdr tal) "" #f newres))))))))
+
+;; note: I'm cheating a little here. I merely replace "\n" with "\n "
+(define (configf:expand-multi-lines fdat)
+ ;; step 1.5 - compress any continued lines
+ (if (null? fdat) fdat
+ (let loop ((hed (car fdat))
+ (tal (cdr fdat))
+ (res '()))
+ (let ((newres (append res (list (string-substitute (regexp "\n") "\n " hed #t)))))
+ (if (null? tal)
+ newres
+ (loop (car tal)(cdr tal) newres))))))
+
+(define (configf:file->list fname)
+ (if (file-exists? fname)
+ (let ((inp (open-input-file fname)))
+ (let loop ((inl (read-line inp))
+ (res '()))
+ (if (eof-object? inl)
+ (begin
+ (close-input-port inp)
+ (reverse res))
+ (loop (read-line inp)(cons inl res)))))
+ '()))
+
+;;======================================================================
+;; Write a config
+;; 0. Given a refererence data structure "indat"
+;; 1. Open the output file and read it into a list
+;; 2. Flatten any multiline entries
+;; 3. Modify values per contents of "indat" and remove absent values
+;; 4. Append new values to the section (immediately after last legit entry)
+;; 5. Write out the new list
+;;======================================================================
+
+(define (configf:write-config indat fname #!key (required-sections '()))
+ (let* (;; step 1: Open the output file and read it into a list
+ (fdat (configf:file->list fname))
+ (refdat (make-hash-table))
+ (sechash (make-hash-table)) ;; current section hash, init with hash for "default" section
+ (new #f) ;; put the line to be used in new, if it is to be deleted the set new to #f
+ (secname #f))
+
+ ;; step 2: Flatten multiline entries
+ (if (not (null? fdat))(set! fdat (configf:compress-multi-lines fdat)))
+
+ ;; step 3: Modify values per contents of "indat" and remove absent values
+ (if (not (null? fdat))
+ (let loop ((hed (car fdat))
+ (tal (cadr fdat))
+ (res '())
+ (lnum 0))
+ (regex-case
+ hed
+ (configf:comment-rx _ (set! res (append res (list hed)))) ;; (loop (read-line inp) curr-section-name #f #f))
+ (configf:blank-l-rx _ (set! res (append res (list hed)))) ;; (loop (read-line inp) curr-section-name #f #f))
+ (configf:section-rx ( x section-name ) (let ((section-hash (hash-table-ref/default refdat section-name #f)))
+ (if (not section-hash)
+ (let ((newhash (make-hash-table)))
+ (hash-table-set! refdat section-name newhash) ;; was refhash - not sure that refdat is correct here
+ (set! sechash newhash))
+ (set! sechash section-hash))
+ (set! new hed) ;; will append this at the bottom of the loop
+ (set! secname section-name)
+ ))
+ ;; No need to process key cmd, let it fall though to key val
+ (configf:key-val-pr ( x key val )
+ (let ((newval (configf:lookup indat secname key))) ;; was sec, bug or correct?
+ ;; can handle newval == #f here => that means key is removed
+ (cond
+ ((equal? newval val)
+ (set! res (append res (list hed))))
+ ((not newval) ;; key has been removed
+ (set! new #f))
+ ((not (equal? newval val))
+ (hash-table-set! sechash key newval)
+ (set! new (conc key " " newval)))
+ (else
+ (debug:print-error 0 *default-log-port* "problem parsing line number " lnum "\"" hed "\"")))))
+ (else
+ (debug:print-error 0 *default-log-port* "Problem parsing line num " lnum " :\n " hed )))
+ (if (not (null? tal))
+ (loop (car tal)(cdr tal)(if new (append res (list new)) res)(+ lnum 1)))
+ ;; drop to here when done processing, res contains modified list of lines
+ (set! fdat res)))
+
+ ;; step 4: Append new values to the section
+ (for-each
+ (lambda (section)
+ (let ((sdat '()) ;; append needed bits here
+ (svars (configf:section-vars indat section)))
+ (for-each
+ (lambda (var)
+ (let ((val (configf:lookup refdat section var)))
+ (if (not val) ;; this one is new
+ (begin
+ (if (null? sdat)(set! sdat (list (conc "[" section "]"))))
+ (set! sdat (append sdat (list (conc var " " val))))))))
+ svars)
+ (set! fdat (append fdat sdat))))
+ (delete-duplicates (append required-sections (hash-table-keys indat))))
+
+ ;; step 5: Write out new file
+ (with-output-to-file fname
+ (lambda ()
+ (for-each
+ (lambda (line)
+ (print line))
+ (configf:expand-multi-lines fdat))))))
+
+(define (process:cmd-run->list cmd #!key (delta-env-alist-or-hash-table '()))
+ (common:with-env-vars
+ delta-env-alist-or-hash-table
+ (lambda ()
+ (let* ((fh (open-input-pipe cmd))
+ (res (port->list fh))
+ (status (close-input-pipe fh)))
+ (list res status)))))
+
+(define (port->list fh)
+ (if (eof-object? fh) #f
+ (let loop ((curr (read-line fh))
+ (result '()))
+ (if (not (eof-object? curr))
+ (loop (read-line fh)
+ (append result (list curr)))
+ result))))
+
+;;======================================================================
+;; refdb
+;;======================================================================
+
+;; reads a refdb into an assoc array of assoc arrays
+;; returns (list dat msg)
+(define (configf:read-refdb refdb-path)
+ (let ((sheets-file (conc refdb-path "/sheet-names.cfg")))
+ (if (not (file-exists? sheets-file))
+ (list #f (conc "ERROR: no refdb found at " refdb-path))
+ (if (not (file-readable? sheets-file))
+ (list #f (conc "ERROR: refdb file not readable at " refdb-path))
+ (let* ((sheets (with-input-from-file sheets-file
+ (lambda ()
+ (let loop ((inl (read-line))
+ (res '()))
+ (if (eof-object? inl)
+ (reverse res)
+ (loop (read-line)(cons inl res)))))))
+ (data '()))
+ (for-each
+ (lambda (sheet-name)
+ (let* ((dat-path (conc refdb-path "/" sheet-name ".dat"))
+ (ref-dat (configf:read-file dat-path #f #t))
+ (ref-assoc (map (lambda (key)
+ (list key (hash-table-ref ref-dat key)))
+ (hash-table-keys ref-dat))))
+ ;; (hash-table->alist ref-dat)))
+ ;; (set! data (append data (list (list sheet-name ref-assoc))))))
+ (set! data (cons (list sheet-name ref-assoc) data))))
+ sheets)
+ (list data "NO ERRORS"))))))
+
+;; map over all pairs in a three level hierarchial alist and apply a function to the keys/val
+;;
+(define (configf:map-all-hier-alist data proc #!key (initproc1 #f)(initproc2 #f)(initproc3 #f))
+ (for-each
+ (lambda (sheetname)
+ (let* ((sheettmp (assoc sheetname data))
+ (sheetdat (if sheettmp (cadr sheettmp) '())))
+ (if initproc1 (initproc1 sheetname))
+ (for-each
+ (lambda (sectionname)
+ (let* ((sectiontmp (assoc sectionname sheetdat))
+ (sectiondat (if sectiontmp (cadr sectiontmp) '())))
+ (if initproc2 (initproc2 sheetname sectionname))
+ (for-each
+ (lambda (varname)
+ (let* ((valtmp (assoc varname sectiondat))
+ (val (if valtmp (cadr valtmp) "")))
+ (proc sheetname sectionname varname val)))
+ (map car sectiondat))))
+ (map car sheetdat))))
+ (map car data))
+ data)
+
+;;======================================================================
+;; C O N F I G T O / F R O M A L I S T
+;;======================================================================
+
+(define (configf:config->alist cfgdat)
+ (hash-table->alist cfgdat))
+
+(define (configf:alist->config adat)
+ (let ((ht (make-hash-table)))
+ (for-each
+ (lambda (section)
+ (hash-table-set! ht (car section)(cdr section)))
+ adat)
+ ht))
+
+;; convert hierarchial list to ini format
+;;
+(define (configf:config->ini data)
+ (map
+ (lambda (section)
+ (let ((section-name (car section))
+ (section-dat (cdr section)))
+ (print "\n[" section-name "]")
+ (map (lambda (dat-pair)
+ (let* ((var (car dat-pair))
+ (val (cadr dat-pair))
+ (fname (if (> (length dat-pair) 2)(caddr dat-pair) #f)))
+ (if fname (print "# " var "=>" fname))
+ (print var " " val)))
+ section-dat))) ;; (print "section-dat: " section-dat))
+ (hash-table->alist data)))
+
+
+;; if
+(define (configf:read-alist fname)
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 *default-log-port* "read of alist " fname " failed. exn=" exn)
+ #f)
+ (configf:alist->config
+ (with-input-from-file fname read))))
+
+;;======================================================================
+;; DO THE LOCKING AROUND THE CALL
+;;======================================================================
+;;
+(define (configf:write-alist cdat fname)
+ #;(if (not (common:faux-lock fname))
+ (debug:print 0 *default-log-port* "INFO: Could not get lock on " fname))
+ (let* ((dat (configf:config->alist cdat))
+ (res
+ (begin
+ (with-output-to-file fname ;; first write out the file
+ (lambda ()
+ (pp dat)))
+
+ (if (file-exists? fname) ;; now verify it is readable
+ (if (configf:read-alist fname)
+ #t ;; data is good.
+ (begin
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 *default-log-port* "deleting " fname " failed, exn=" exn)
+ #f)
+ (debug:print 0 *default-log-port* "WARNING: content " dat " for cache " fname " is not readable. Deleting generated file.")
+ (delete-file fname))
+ #f))
+ #f))))
+ ;; (common:faux-unlock fname)
+ res))
+
+
+)
Index: dbmod.scm
==================================================================
--- dbmod.scm
+++ dbmod.scm
@@ -22,12 +22,13 @@
(module dbmod
*
(import scheme
+ chicken.base
(prefix sqlite3 sqlite3:)
- posix
+
typed-records
srfi-18
)
ADDED debugprint.scm
Index: debugprint.scm
==================================================================
--- /dev/null
+++ debugprint.scm
@@ -0,0 +1,108 @@
+(declare (unit debugprint))
+(declare (uses margsmod))
+
+(module debugprint
+ *
+
+;;(import scheme chicken data-structures extras files ports)
+(import scheme
+ chicken.base
+ chicken.string
+ chicken.port
+ mtargs
+ srfi-1
+ )
+
+;;======================================================================
+;; debug stuff
+;;======================================================================
+
+(define verbosity (make-parameter '()))
+(define *default-log-port* (current-error-port))
+
+;;======================================================================
+;; (define (debug:print . params) #f)
+;; (define (debug:print-info . params) #f)
+;;
+;; (define (set-functions dbgp dbgpinfo)
+;; (set! debug:print dbgp)
+;; (set! debug:print-info dbgpinfo))
+
+;;======================================================================
+;; this was cached based on results from profiling but it turned out the profiling
+;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching
+;; in for now but can probably take it out later.
+;;
+(define (debug:calc-verbosity vstr arg) ;; arg is 'v (verbose) or 'q (quiet)
+ (let* ((res (cond
+ ((number? vstr) vstr)
+ ((not (string? vstr)) 1)
+ ;; ((string-match "^\\s*$" vstr) 1)
+ (vstr (let ((debugvals (filter number? (map string->number (string-split vstr ",")))))
+ (cond
+ ((> (length debugvals) 1) debugvals)
+ ((> (length debugvals) 0)(car debugvals))
+ (else 1))))
+ ((eq? arg 'v) 2) ;; verbose
+ ((eq? arg 'q) 0) ;; quiet
+ (else 1))))
+ (verbosity res)
+ res))
+
+;;======================================================================
+;; check verbosity, #t is ok
+#;(define (debug-check-verbosity verbosity vstr)
+ (if (not (or (number? verbosity)
+ (list? verbosity)))
+ (begin
+ (print "ERROR: Invalid debug value \"" vstr "\"")
+ #f)
+ #t))
+
+(define (debug:debug-mode n)
+ (let* ((vb (verbosity)))
+ (cond
+ ((and (number? vb) ;; number number
+ (number? n))
+ (<= n vb))
+ ((and (list? vb) ;; list number
+ (number? n))
+ (member n vb))
+ ((and (list? vb) ;; list list
+ (list? n))
+ (not (null? (lset-intersection! eq? vb n))))
+ ((and (number? vb)
+ (list? n))
+ (member vb n)))))
+
+(define (debug:print n e . params)
+ (if (debug:debug-mode n)
+ (with-output-to-port (or e (current-error-port))
+ (lambda ()
+ ;; (if *logging*
+ ;; (db:log-event (apply conc params))
+ (apply print params)
+ )))) ;; )
+
+(define (debug:print-error n e . params)
+ ;; normal print
+ (if (debug:debug-mode n)
+ (with-output-to-port (if (port? e) e (current-error-port))
+ (lambda ()
+ (apply print "ERROR: " params)
+ )))
+ ;; pass important messages to stderr
+ (if (and (eq? n 0)(not (eq? e (current-error-port))))
+ (with-output-to-port (current-error-port)
+ (lambda ()
+ (apply print "ERROR: " params)
+ ))))
+
+(define (debug:print-info n e . params)
+ (if (debug:debug-mode n)
+ (with-output-to-port (if (port? e) e (current-error-port))
+ (lambda ()
+ (apply print "INFO: (" n ") " params) ;; res)
+ ))))
+
+)
Index: rmtmod.scm
==================================================================
--- rmtmod.scm
+++ rmtmod.scm
@@ -29,11 +29,11 @@
(module rmtmod
*
(import scheme
(prefix sqlite3 sqlite3:)
- posix
+
typed-records
srfi-18
commonmod
apimod
ADDED vgmod.scm
Index: vgmod.scm
==================================================================
--- /dev/null
+++ vgmod.scm
@@ -0,0 +1,672 @@
+;;
+;; Copyright 2016 Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest 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 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest 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 Megatest. If not, see .
+
+;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
+
+(declare (unit vgmod))
+
+(module vgmod
+ *
+
+(import scheme chicken data-structures extras ports)
+(use canvas-draw iup)
+(use typed-records srfi-1 srfi-69)
+(import canvas-draw-iup)
+
+(include "vg_records.scm")
+
+;; ;; structs
+;; ;;
+;; (defstruct vg:lib comps)
+;; (defstruct vg:comp objs name file)
+;; ;; extents caches extents calculated on draw
+;; ;; proc is called on draw and takes the obj itself as a parameter
+;; ;; attrib is an alist of parameters
+;; (defstruct vg:obj type pts fill-color text line-color call-back angle font attrib extents proc)
+;; (defstruct vg:inst libname compname theta xoff yoff scalex scaley mirrx mirry call-back cache)
+;; (defstruct vg:drawing libs insts scalex scaley xoff yoff cnv cache) ;; libs: hash of name->lib, insts: hash of instname->inst
+
+;; inits
+;;
+(define (vg:comp-new)
+ (make-vg:comp objs: '() name: #f file: #f))
+
+(define (vg:lib-new)
+ (make-vg:lib comps: (make-hash-table)))
+
+(define (vg:drawing-new)
+ (make-vg:drawing scalex: 1
+ scaley: 1
+ xoff: 0
+ yoff: 0
+ libs: (make-hash-table)
+ insts: (make-hash-table)
+ cache: '()))
+
+;;======================================================================
+;; scaling and offsets
+;;======================================================================
+
+(define-inline (vg:scale-offset val s o)
+ (+ o (* val s)))
+ ;; (* (+ o val) s))
+
+;; apply scale and offset to a list of x y values
+;;
+(define (vg:scale-offset-xy lstxy sx sy ox oy)
+ (if (> (length lstxy) 1) ;; have at least one xy pair
+ (let loop ((x (car lstxy))
+ (y (cadr lstxy))
+ (tal (cddr lstxy))
+ (res '()))
+ (let ((newres (cons (vg:scale-offset y sy oy)
+ (cons (vg:scale-offset x sx ox)
+ res))))
+ (if (> (length tal) 1)
+ (loop (car tal)(cadr tal)(cddr tal) newres)
+ (reverse newres))))
+ '()))
+
+;; apply drawing offset and scaling to the points in lstxy
+;;
+(define (vg:drawing-apply-scale drawing lstxy)
+ (vg:scale-offset-xy
+ lstxy
+ (vg:drawing-scalex drawing)
+ (vg:drawing-scaley drawing)
+ (vg:drawing-xoff drawing)
+ (vg:drawing-yoff drawing)))
+
+;; apply instance offset and scaling to the points in lstxy
+;;
+(define (vg:inst-apply-scale inst lstxy)
+ (vg:scale-offset-xy
+ lstxy
+ (vg:inst-scalex inst)
+ (vg:inst-scaley inst)
+ (vg:inst-xoff inst)
+ (vg:inst-yoff inst)))
+
+;; apply both drawing and instance scaling to a list of xy points
+;;
+(define (vg:drawing-inst-apply-scale-offset drawing inst lstxy)
+ (vg:drawing-apply-scale
+ drawing
+ (vg:inst-apply-scale inst lstxy)))
+
+;;======================================================================
+;; objects
+;;======================================================================
+
+;; (vg:inst-apply-scale
+;; inst
+;; (vg:drawing-apply-scale drawing lstxy)))
+
+;; make a rectangle obj
+;;
+(define (vg:make-rect-obj x1 y1 x2 y2 #!key (line-color #f)(fill-color #f)(text #f)(font #f)(extents #f))
+ (make-vg:obj type: 'r pts: (list x1 y1 x2 y2) text: text font: font line-color: line-color fill-color: fill-color extents: extents))
+
+;; make a rectangle obj
+;;
+(define (vg:make-line-obj x1 y1 x2 y2 #!key (line-color #f)(fill-color #f)(text #f)(font #f)(extents #f))
+ (make-vg:obj type: 'l pts: (list x1 y1 x2 y2) text: text font: font line-color: line-color extents: extents))
+
+;; make a text obj
+;;
+(define (vg:make-text-obj x1 y1 text #!key (line-color #f)(fill-color #f)
+ (angle #f)(scale-with-zoom #f)(font #f)
+ (font-size #f))
+ (make-vg:obj type: 't pts: (list x1 y1) text: text
+ line-color: line-color fill-color: fill-color
+ angle: angle font: font extents: #f
+ attributes: (vg:make-attrib 'font-size font-size)))
+
+;; proc takes startnum and endnum and yields scalef, per-grad and unitname
+;;
+(define (vg:make-xaxis-obj x1 y1 x2 y2 #!key (line-color #f)(fill-color #f)(text #f)(font #f)(proc #f))
+ (make-vg:obj type: 'x pts: (list x1 y1 x2 y2) text: text font: font line-color: line-color fill-color: fill-color extents: #f proc: proc))
+
+;;======================================================================
+;; obj modifiers and queries
+;;======================================================================
+
+;; get extents, use knowledge of type ...
+;;
+(define (vg:obj-get-extents drawing obj)
+ (let ((type (vg:obj-type obj)))
+ (case type
+ ((l)(vg:rect-get-extents obj))
+ ((r)(vg:rect-get-extents obj))
+ ((t)(vg:draw-text drawing obj draw: #f))
+ (else #f))))
+
+(define (vg:rect-get-extents obj)
+ (vg:obj-pts obj)) ;; extents are just the points for a rectangle
+
+(define (vg:grow-rect borderx bordery x1 y1 x2 y2)
+ (list
+ (- x1 borderx)
+ (- y1 bordery)
+ (+ x2 borderx)
+ (+ y2 bordery)))
+
+(define (vg:make-attrib . attrib-list)
+ #f)
+
+;;======================================================================
+;; components
+;;======================================================================
+
+;; add obj to comp
+;;
+(define (vg:add-objs-to-comp comp . objs)
+ (vg:comp-objs-set! comp (append (vg:comp-objs comp) objs)))
+
+(define (vg:add-obj-to-comp comp obj)
+ (vg:comp-objs-set! comp (cons obj (vg:comp-objs comp))))
+
+;; use the struct. leave this here to remind of this!
+;;
+;; (define (vg:comp-get-objs comp)
+;; (vg:comp-objs comp))
+
+;; add comp to lib
+;;
+(define (vg:add-comp-to-lib lib compname comp)
+ (hash-table-set! (vg:lib-comps lib) compname comp))
+
+;; instanciate component in drawing
+;;
+(define (vg:instantiate drawing libname compname instname xoff yoff #!key (theta 0)(scalex 1)(scaley 1)(mirrx #f)(mirry #f))
+ (let ((inst (make-vg:inst libname: libname compname: compname xoff: xoff yoff: yoff theta: theta scalex: scalex scaley: scaley mirrx: mirrx mirry: mirry)) )
+ (hash-table-set! (vg:drawing-insts drawing) instname inst)))
+
+(define (vg:instance-move drawing instname newx newy)
+ (let ((inst (hash-table-ref (vg:drawing-insts drawing) instname)))
+ (vg:inst-xoff-set! inst newx)
+ (vg:inst-yoff-set! inst newy)))
+
+;; get component from drawing (look in apropriate lib) given libname and compname
+(define (vg:get-component drawing libname compname)
+ (let* ((lib (hash-table-ref (vg:drawing-libs drawing) libname))
+ (inst (hash-table-ref (vg:lib-comps lib) compname)))
+ inst))
+
+(define (vg:get-extents-for-objs drawing objs)
+ (if (or (not objs)
+ (null? objs))
+ #f
+ (let loop ((hed (car objs))
+ (tal (cdr objs))
+ (extents (vg:obj-get-extents drawing (car objs))))
+ (let ((newextents
+ (vg:get-extents-for-two-rects
+ extents
+ (vg:obj-get-extents drawing hed))))
+ (if (null? tal)
+ extents
+ (loop (car tal)(cdr tal) newextents))))))
+
+;; (let ((extents #f))
+;; (for-each
+;; (lambda (obj)
+;; (set! extents
+;; (vg:get-extents-for-two-rects
+;; extents
+;; (vg:obj-get-extents drawing obj))))
+;; objs)
+;; extents))
+
+;; given rectangles r1 and r2, return the box that bounds both
+;;
+(define (vg:get-extents-for-two-rects r1 r2)
+ (if (not r1)
+ r2
+ (if (not r2)
+ r1 ;; #f ;; no extents from #f #f
+ (list (min (car r1)(car r2)) ;; llx
+ (min (cadr r1)(cadr r2)) ;; lly
+ (max (caddr r1)(caddr r2)) ;; ulx
+ (max (cadddr r1)(cadddr r2)))))) ;; uly
+
+(define (vg:components-get-extents drawing . comps)
+ (if (null? comps)
+ #f
+ (let loop ((hed (car comps))
+ (tal (cdr comps))
+ (extents #f))
+ (let* ((objs (vg:comp-objs hed))
+ (newextents (if extents
+ (vg:get-extents-for-two-rects
+ extents
+ (vg:get-extents-for-objs drawing objs))
+ (vg:get-extents-for-objs drawing objs))))
+ (if (null? tal)
+ newextents
+ (loop (car tal)(cdr tal) newextents))))))
+
+;;======================================================================
+;; libraries
+;;======================================================================
+
+;; register lib with drawing
+
+;;
+(define (vg:add-lib drawing libname lib)
+ (hash-table-set! (vg:drawing-libs drawing) libname lib))
+
+(define (vg:get-lib drawing libname)
+ (hash-table-ref/default (vg:drawing-libs drawing) libname #f))
+
+(define (vg:get/create-lib drawing libname)
+ (let ((lib (vg:get-lib drawing libname)))
+ (if lib
+ lib
+ (let ((newlib (vg:lib-new)))
+ (vg:add-lib drawing libname newlib)
+ newlib))))
+
+;;======================================================================
+;; map objects given offset, scale and mirror, resulting obj is displayed
+;;======================================================================
+
+;; dispatch the drawing of obj off to the correct drawing routine
+;;
+(define (vg:map-obj drawing inst obj)
+ (case (vg:obj-type obj)
+ ((l)(vg:map-line drawing inst obj))
+ ((r)(vg:map-rect drawing inst obj))
+ ((t)(vg:map-text drawing inst obj))
+ ((x)(vg:map-xaxis drawing inst obj))
+ (else #f)))
+
+;; given a drawing and a inst map a rectangle to it screen coordinates
+;;
+(define (vg:map-rect drawing inst obj)
+ (let ((res (make-vg:obj type: 'r ;; is there a defstruct copy?
+ fill-color: (vg:obj-fill-color obj)
+ text: (vg:obj-text obj)
+ line-color: (vg:obj-line-color obj)
+ font: (vg:obj-font obj)))
+ (pts (vg:obj-pts obj)))
+ (vg:obj-pts-set! res (vg:drawing-inst-apply-scale-offset drawing inst pts))
+ (vg:drawing-cache-set! drawing (cons res (vg:drawing-cache drawing) ))
+ res))
+
+;; given a drawing and a inst map a line to it screen coordinates
+;;
+(define (vg:map-line drawing inst obj)
+ (let ((res (make-vg:obj type: 'l ;; is there a defstruct copy?
+ line-color: (vg:obj-line-color obj)
+ font: (vg:obj-font obj)))
+ (pts (vg:obj-pts obj)))
+ (vg:obj-pts-set! res (vg:drawing-inst-apply-scale-offset drawing inst pts))
+ (vg:drawing-cache-set! drawing (cons res (vg:drawing-cache drawing) ))
+ res))
+
+;; given a drawing and a inst map a text to it screen coordinates
+;;
+(define (vg:map-text drawing inst obj)
+ (let ((res (make-vg:obj type: 't
+ fill-color: (vg:obj-fill-color obj)
+ text: (vg:obj-text obj)
+ line-color: (vg:obj-line-color obj)
+ font: (vg:obj-font obj)
+ angle: (vg:obj-angle obj)
+ attrib: (vg:obj-attrib obj)))
+ (pts (vg:obj-pts obj)))
+ (vg:obj-pts-set! res (vg:drawing-inst-apply-scale-offset drawing inst pts))
+ (vg:drawing-cache-set! drawing (cons res (vg:drawing-cache drawing)))
+ res))
+
+;; given a drawing and a inst map a line to it screen coordinates
+;;
+(define (vg:map-xaxis drawing inst obj)
+ (let ((res (make-vg:obj type: 'x ;; is there a defstruct copy?
+ line-color: (vg:obj-line-color obj)
+ font: (vg:obj-font obj)))
+ (pts (vg:obj-pts obj)))
+ (vg:obj-pts-set! res (vg:drawing-inst-apply-scale-offset drawing inst pts))
+ (vg:drawing-cache-set! drawing (cons res (vg:drawing-cache drawing) ))
+ res))
+
+;;======================================================================
+;; instances
+;;======================================================================
+
+(define (vg:instances-get-extents drawing . instance-names)
+ (let ((xtnt-lst (vg:draw drawing #f)))
+ (if (null? xtnt-lst)
+ #f
+ (let loop ((extents (car xtnt-lst))
+ (tal (cdr xtnt-lst))
+ (llx #f)
+ (lly #f)
+ (ulx #f)
+ (uly #f))
+ (let ((nllx (if llx (min llx (list-ref extents 0))(list-ref extents 0)))
+ (nlly (if lly (min lly (list-ref extents 1))(list-ref extents 1)))
+ (nulx (if ulx (max ulx (list-ref extents 2))(list-ref extents 2)))
+ (nuly (if uly (max uly (list-ref extents 3))(list-ref extents 3))))
+ (if (null? tal)
+ (list llx lly ulx uly)
+ (loop (car tal)(cdr tal) nllx nlly nulx nuly)))))))
+
+(define (vg:lib-get-component lib instname)
+ (hash-table-ref/default (vg:lib-comps lib) instname #f))
+
+;;======================================================================
+;; color
+;;======================================================================
+
+(define (vg:rgb->number r g b #!key (a 0))
+ (bitwise-ior
+ (arithmetic-shift a 24)
+ (arithmetic-shift r 16)
+ (arithmetic-shift g 8)
+ b))
+
+;; Obsolete function
+;;
+(define (vg:generate-color)
+ (vg:rgb->number (random 255)
+ (random 255)
+ (random 255)))
+
+;; Need to return a string of random iup-color for graph
+;;
+(define (vg:generate-color-rgb)
+ (conc (number->string (random 255)) " "
+ (number->string (random 255)) " "
+ (number->string (random 255))))
+
+(define (vg:iup-color->number iup-color)
+ (apply vg:rgb->number (map string->number (string-split iup-color))))
+
+;;======================================================================
+;; graphing
+;;======================================================================
+
+(define (vg:make-xaxis drawing component x1 y1 x2 y2 startnum endnum scaleproc)
+ (let ((obj (vg:make-xaxis-obj x1 y1 x2 y2)))
+ #f))
+
+;;======================================================================
+;; Unravel and draw the objects
+;;======================================================================
+
+;; with get-extents = #t return the extents
+;; with draw = #f don't actually draw the object
+;;
+(define (vg:draw-obj drawing obj #!key (draw #t))
+ ;; (print "obj type: " (vg:obj-type obj))
+ (case (vg:obj-type obj)
+ ((l)(vg:draw-line drawing obj draw: draw))
+ ((r)(vg:draw-rect drawing obj draw: draw))
+ ((t)(vg:draw-text drawing obj draw: draw))))
+
+;; given a rect obj draw it on the canvas applying first the drawing
+;; scale and offset
+;;
+(define (vg:draw-rect drawing obj #!key (draw #t))
+ (let* ((cnv (vg:drawing-cnv drawing))
+ (pts (vg:drawing-apply-scale drawing (vg:obj-pts obj)))
+ (fill-color (vg:obj-fill-color obj))
+ (line-color (vg:obj-line-color obj))
+ (text (vg:obj-text obj))
+ (font (vg:obj-font obj))
+ (llx (car pts))
+ (lly (cadr pts))
+ (ulx (caddr pts))
+ (uly (cadddr pts))
+ (w (- ulx llx))
+ (h (- uly lly))
+ (text-xmax #f)
+ (text-ymax #f))
+ (if draw
+ (let ((prev-background-color (canvas-background cnv))
+ (prev-foreground-color (canvas-foreground cnv)))
+ (if fill-color
+ (begin
+ (canvas-foreground-set! cnv fill-color)
+ (canvas-box! cnv llx ulx lly uly))) ;; docs are all over the place on this one.;; w h)
+ (if line-color
+ (canvas-foreground-set! cnv line-color)
+ (if fill-color
+ (canvas-foreground-set! cnv prev-foreground-color)))
+ (canvas-rectangle! cnv llx ulx lly uly)
+ (canvas-foreground-set! cnv prev-foreground-color)
+ (if text
+ (let* ((prev-font (canvas-font cnv))
+ (font-changed (and font (not (equal? font prev-font)))))
+ (if font-changed (canvas-font-set! cnv font))
+ (canvas-text! cnv (+ 2 llx)(+ 2 lly) text)
+ (if (eq? draw 'get-extents)
+ (let-values (((xmax ymax)(canvas-text-size cnv text)))
+ (set! text-xmax xmax)(set! text-ymax ymax)))
+ (if font-changed (canvas-font-set! cnv prev-font))))))
+ ;; (print "text-xmax: " text-xmax " text-ymax: " text-ymax)
+ (if (vg:obj-extents obj)
+ (vg:obj-extents obj)
+ (if (not text)
+ pts ;; no text
+ (if (and text-xmax text-ymax) ;; have text
+ (let ((xt (list llx lly
+ (max ulx (+ llx text-xmax))
+ (max uly (+ lly text-ymax)))))
+ (vg:obj-extents-set! obj xt)
+ xt)
+ (if cnv
+ (if (eq? draw 'get-extents)
+ (let-values (((xmax ymax)(canvas-text-size cnv text)))
+ (let ((xt (list llx lly
+ (max ulx (+ llx xmax))
+ (max uly (+ lly ymax)))))
+ (vg:obj-extents-set! obj xt)
+ xt))
+ pts)
+ pts)))))) ;; return extents
+
+;; given a rect obj draw it on the canvas applying first the drawing
+;; scale and offset
+;;
+(define (vg:draw-line drawing obj #!key (draw #t))
+ (let* ((cnv (vg:drawing-cnv drawing))
+ (pts (vg:drawing-apply-scale drawing (vg:obj-pts obj)))
+ ;; (fill-color (vg:obj-fill-color obj))
+ (line-color (vg:obj-line-color obj))
+ (text (vg:obj-text obj))
+ (font (vg:obj-font obj))
+ (llx (car pts))
+ (lly (cadr pts))
+ (ulx (caddr pts))
+ (uly (cadddr pts))
+ (w (- ulx llx))
+ (h (- uly lly))
+ (text-xmax #f)
+ (text-ymax #f))
+ (if draw
+ (let ((prev-background-color (canvas-background cnv))
+ (prev-foreground-color (canvas-foreground cnv)))
+ ;; (if fill-color
+ ;; (begin
+ ;; (canvas-foreground-set! cnv fill-color)
+ ;; (canvas-box! cnv llx ulx lly uly))) ;; docs are all over the place on this one.;; w h)
+ (if line-color
+ (canvas-foreground-set! cnv line-color))
+ ;; (if fill-color
+ ;; (canvas-foreground-set! cnv prev-foreground-color)))
+ (canvas-line! cnv llx lly ulx uly)
+ (canvas-foreground-set! cnv prev-foreground-color)
+ (if text
+ (let* ((prev-font (canvas-font cnv))
+ (font-changed (and font (not (equal? font prev-font)))))
+ (if font-changed (canvas-font-set! cnv font))
+ (canvas-text! cnv (+ 2 llx)(+ 2 lly) text)
+ (let-values (((xmax ymax)(canvas-text-size cnv text)))
+ (set! text-xmax xmax)(set! text-ymax ymax))
+ (if font-changed (canvas-font-set! cnv prev-font))))))
+ ;; (print "text-xmax: " text-xmax " text-ymax: " text-ymax)
+ (if (vg:obj-extents obj)
+ (vg:obj-extents obj)
+ (if (not text)
+ pts
+ (if (and text-xmax text-ymax)
+ (let ((xt (list llx lly
+ (max ulx (+ llx text-xmax))
+ (max uly (+ lly text-ymax)))))
+ (vg:obj-extents-set! obj xt)
+ xt)
+ (if cnv
+ (let-values (((xmax ymax)(canvas-text-size cnv text)))
+ (let ((xt (list llx lly
+ (max ulx (+ llx xmax))
+ (max uly (+ lly ymax)))))
+ (vg:obj-extents-set! obj xt)
+ xt))
+ pts)))))) ;; return extents
+
+;; given a rect obj draw it on the canvas applying first the drawing
+;; scale and offset
+;;
+(define (vg:draw-xaxis drawing obj #!key (draw #t))
+ (let* ((cnv (vg:drawing-cnv drawing))
+ (pts (vg:drawing-apply-scale drawing (vg:obj-pts obj)))
+ ;; (fill-color (vg:obj-fill-color obj))
+ (line-color (vg:obj-line-color obj))
+ (text (vg:obj-text obj))
+ (font (vg:obj-font obj))
+ (llx (car pts))
+ (lly (cadr pts))
+ (ulx (caddr pts))
+ (uly (cadddr pts))
+ (w (- ulx llx))
+ (h (- uly lly))
+ (text-xmax #f)
+ (text-ymax #f))
+ (if draw
+ (let ((prev-background-color (canvas-background cnv))
+ (prev-foreground-color (canvas-foreground cnv)))
+ ;; (if fill-color
+ ;; (begin
+ ;; (canvas-foreground-set! cnv fill-color)
+ ;; (canvas-box! cnv llx ulx lly uly))) ;; docs are all over the place on this one.;; w h)
+ (if line-color
+ (canvas-foreground-set! cnv line-color)
+ #;(if fill-color
+ (canvas-foreground-set! cnv prev-foreground-color)))
+ (canvas-line! cnv llx ulx lly uly)
+ (canvas-foreground-set! cnv prev-foreground-color)
+ (if text
+ (let* ((prev-font (canvas-font cnv))
+ (font-changed (and font (not (equal? font prev-font)))))
+ (if font-changed (canvas-font-set! cnv font))
+ (canvas-text! cnv (+ 2 llx)(+ 2 lly) text)
+ (let-values (((xmax ymax)(canvas-text-size cnv text)))
+ (set! text-xmax xmax)(set! text-ymax ymax))
+ (if font-changed (canvas-font-set! cnv prev-font))))))
+ ;; (print "text-xmax: " text-xmax " text-ymax: " text-ymax)
+ (if (vg:obj-extents obj)
+ (vg:obj-extents obj)
+ (if (not text)
+ pts
+ (if (and text-xmax text-ymax)
+ (let ((xt (list llx lly
+ (max ulx (+ llx text-xmax))
+ (max uly (+ lly text-ymax)))))
+ (vg:obj-extents-set! obj xt)
+ xt)
+ (if cnv
+ (let-values (((xmax ymax)(canvas-text-size cnv text)))
+ (let ((xt (list llx lly
+ (max ulx (+ llx xmax))
+ (max uly (+ lly ymax)))))
+ (vg:obj-extents-set! obj xt)
+ xt))
+ pts)))))) ;; return extents
+
+;; given a rect obj draw it on the canvas applying first the drawing
+;; scale and offset
+;;
+(define (vg:draw-text drawing obj #!key (draw #t))
+ (let* ((cnv (vg:drawing-cnv drawing))
+ (pts (vg:drawing-apply-scale drawing (vg:obj-pts obj)))
+ (text (vg:obj-text obj))
+ (font (vg:obj-font obj))
+ (fill-color (vg:obj-fill-color obj))
+ (line-color (vg:obj-line-color obj))
+ (llx (car pts))
+ (lly (cadr pts)))
+ (if draw
+ (let* ((prev-background-color (canvas-background cnv))
+ (prev-foreground-color (canvas-foreground cnv))
+ (prev-font (canvas-font cnv))
+ (font-changed (and font (not (equal? font prev-font)))))
+ (if line-color
+ (canvas-foreground-set! cnv line-color)
+ (if fill-color
+ (canvas-foreground-set! cnv prev-foreground-color)))
+ (if font-changed (canvas-font-set! cnv font))
+ (canvas-text! cnv llx lly text)
+ ;; NOTE: we do not set the font back!!
+ (canvas-foreground-set! cnv prev-foreground-color)))
+ (if cnv
+ (if (eq? draw 'get-extents)
+ (let-values (((xmax ymax)(canvas-text-size cnv text)))
+ (append pts (list (+ llx xmax)(+ lly ymax)))) ;; will be wrong if text is rotated?
+ (append pts pts))
+ (append pts pts))))
+
+(define (vg:draw-inst drawing inst #!key (draw-mode #t)(prev-extents '()))
+ (let* ((libname (vg:inst-libname inst))
+ (compname (vg:inst-compname inst))
+ (comp (vg:get-component drawing libname compname))
+ (objs (vg:comp-objs comp)))
+ ;; (print "comp: " comp)
+ (if (null? objs)
+ prev-extents
+ (let loop ((obj (car objs))
+ (tal (cdr objs))
+ (res prev-extents))
+ (let* ((obj-xfrmd (vg:map-obj drawing inst obj))
+ (newres (cons (vg:draw-obj drawing obj-xfrmd draw: draw-mode) res)))
+ (if (null? tal)
+ newres
+ (loop (car tal)(cdr tal) newres)))))))
+
+(define (vg:draw drawing draw-mode . instnames)
+ (let* ((insts (vg:drawing-insts drawing))
+ (all-inst-names (hash-table-keys insts))
+ (master-list (if (null? instnames)
+ all-inst-names
+ instnames)))
+ (if (null? master-list)
+ '()
+ (let loop ((instname (car master-list))
+ (tal (cdr master-list))
+ (res '()))
+ (let* ((inst (hash-table-ref/default insts instname #f))
+ (newres (if inst
+ (vg:draw-inst drawing inst draw-mode: draw-mode prev-extents: res)
+ res)))
+ (if (null? tal)
+ newres
+ (loop (car tal)(cdr tal) newres)))))))
+
+)