Megatest

# make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)'
PREFIX=$(PWD)
CSCOPTS= 
INSTALL=install
SRCFILES = common.scm items.scm launch.scm \
   ods.scm runconfig.scm server.scm configf.scm \
   db.scm keys.scm margs.scm megatest-version.scm \
   process.scm runs.scm tasks.scm tests.scm genexample.scm \
   http-transport.scm nmsg-transport.scm filedb.scm \
   client.scm gutils.scm synchash.scm daemon.scm mt.scm dcommon.scm \
   tree.scm ezsteps.scm lock-queue.scm sdb.scm \
   rmt.scm api.scm tdb.scm rpc-transport.scm \
   portlogger.scm archive.scm env.scm vg.scm

# Eggs to install (straightforward ones)
EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \
dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \
json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \
spiffy-directory-listing ssax sxml-serializer sxml-modifications iup canvas-draw sqlite3

GUISRCF  = dashboard-tests.scm dashboard-guimonitor.scm 

OFILES   = $(SRCFILES:%.scm=%.o)
GOFILES  = $(GUISRCF:%.scm=%.o)

ADTLSCR=mt_laststep mt_runstep mt_ezstep

all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard 

mtest: $(OFILES) readline-fix.scm megatest.o
	csc $(CSCOPTS) $(OFILES) megatest.o -o mtest

dboard : $(OFILES) $(GOFILES) dashboard.scm
	csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) -o dboard

ndboard : newdashboard.scm $(OFILES) $(GOFILES)
	csc $(CSCOPTS) $(OFILES) $(GOFILES) newdashboard.scm -o ndboard

multi-dboard : multi-dboard.scm $(OFILES) $(GOFILES)
	csc $(CSCOPTS) $(OFILES) $(GOFILES) multi-dboard.scm -o multi-dboard

# 
# $(PREFIX)/bin/revtagfsl : utils/revtagfsl.scm
#	csc utils/revtagfsl.scm -o $(PREFIX)/bin/revtagfsl

# Special dependencies for the includes
tests.o db.o launch.o runs.o dashboard-tests.o dashboard-guimonitor.o dashboard-main.o monitor.o dashboard.o  \
archive.o megatest.o : db_records.scm
tests.o runs.o dashboard.o dashboard-tests.o dashboard-main.o  : run_records.scm
db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm
tests.o tasks.o dashboard-tasks.o : task_records.scm
runs.o : test_records.scm
megatest.o : megatest-fossil-hash.scm
client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm fs-transport.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm : common_records.scm rpc-transport.scm
common_records.scm : altdb.scm

deploytarg/dboard :  $(OFILES) $(GOFILES) dashboard.scm deploytarg/apropos.so
	csc -deploy $(OFILES) $(GOFILES) dashboard.scm -o deploytarg
	mv deploytarg/deploytarg deploytarg/dboard

# DATASHAREO=configf.o common.o process.o tree.o dcommon.o margs.o launch.o gutils.o db.o synchash.o server.o \
#            megatest-version.o tdb.o ods.o mt.o keys.o
datashare-testing/sd : datashare.scm $(OFILES)
	csc $(CSCOPTS) datashare.scm $(OFILES) -o datashare-testing/sd

datashare-testing/sdat: sharedat.scm $(OFILES)
	csc $(CSCOPTS) sharedat.scm $(OFILES) -o datashare-testing/sdat

sd : datashare-testing/sd
	mkdir -p /tmp/$(USER)/datashare/disk1 /tmp/$(USER)/basepath

xterm : sd
	(export BASEPATH=/tmp/$(USER)/basepath ; export PATH="$(PWD)/datashare-testing:$(PATH)" ; xterm &)

datashare-testing/spublish : spublish.scm $(OFILES)
	csc $(CSCOPTS) spublish.scm $(OFILES) -o datashare-testing/spublish

datashare-testing/sretrieve : sretrieve.scm megatest-version.o margs.o configf.o process.o 
	csc $(CSCOPTS) sretrieve.scm megatest-version.o margs.o configf.o process.o -o datashare-testing/sretrieve

sretrieve/sretrieve : datashare-testing/sretrieve
	csc $(CSCOPTS) -deploy -deployed sretrieve.scm megatest-version.o margs.o configf.o
	chicken-install -keep-installed $(PROXY) -deploy -prefix sretrieve defstruct srfi-18 format sql-de-lite \
             srfi-1 posix regex regex-case srfi-69

# base64 dot-locking \
#             csv-xml z3

#  "(define (toplevel-command . a) #f)"

           echo "(use mysql-client)(hash-table-set! *available-db* 'mysql #t)" >> altdb.scm; \
	fi
	if csi -ne '(use postgresql)';then \
	   echo "(use postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\
	fi

portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o daemon.o dashboard-tests.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o nmsg-transport.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o
	csc $(CSCOPTS) portlogger-example.scm api.o archive.o client.o common.o configf.o daemon.o dashboard-tests.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o nmsg-transport.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o

(define help (conc 
	      "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
  version " megatest-version "
  license GPL, Copyright (C) Matt Welland 2012-2016

Usage: dashboard [options]
  -h                    : this help

  -test run-id,test-id  : control test identified by testid

  -skip-version-check   : skip the version check

Misc
  -rows N         : set number of rows
"))

;;   -server host:port     : connect to host:port instead of db access
;;   -xterm run-id,test-id : Start a new xterm with specified run-id and test-id
;;   -guimonitor           : control panel for runs

;; process args
(define remargs (args:get-args 
		 (argv)
		 (list  "-rows"
			"-run"
			"-test"
                        "-xterm"
			"-debug"
			"-host" 
			"-transport"
			) 
		 (list  "-h"
			"-use-server"
			"-guimonitor"
			"-main"
			"-v"
			"-q"
			"-use-local"
			"-skip-version-check"
			)
		 args:arg-hash
		 0))

(if (args:get-arg "-h")
    (begin
      (print help)

;; gets and calls updater based on curr-tab-num
(define (dboard:common-run-curr-updaters commondat #!key (tab-num #f))
  (if (dboard:common-get-tabdat commondat tab-num: tab-num) ;; only update if there is a tabdat
      (let* ((tnum     (or tab-num (dboard:commondat-curr-tab-num commondat)))
	     (updaters (hash-table-ref/default (dboard:commondat-updaters commondat)
					       tnum
					       '())))
	(debug:print 4 *default-log-port* "Found these updaters: " updaters " for tab-num: " tnum)
	(for-each
	 (lambda (updater)
	   (debug:print 3 *default-log-port* "Running " updater)
	   (updater)
	   )

	 updaters))))

    (hash-table-set! (dboard:commondat-updaters commondat)
		     tnum
		     (cons updater curr-updaters))))

;; data for each specific tab goes here
;;
(defstruct dboard:tabdat 
  ;; runs
  allruns          ;; list of dboard:rundat records
  allruns-by-id    ;; hash of run-id -> dboard:rundat records
  header           ;; header for decoding the run records
  keys             ;; keys for this run (i.e. target components)
  numruns

  ;; Runs view
  buttondat 
  item-test-names

  ;; Canvas and drawing data
  cnv
  cnv-obj
  drawing
  draw-cache     ;; 

  ;; Controls used to launch runs etc.
  command
  command-tb 

  ;; Selector variables
  curr-run-id      ;; current row to display in Run summary view
  curr-test-ids    ;; used only in dcommon:run-update which is used in newdashboard
  filters-changed  ;; to to indicate that the user changed filters for this tab
  hide-empty-runs
  hide-not-hide    ;; toggle for hide/not hide empty runs
  hide-not-hide-button

  ;; db info to file the .db files for the area
  dbdir
  dbfpath
  dbkeys 








  last-db-update  ;; last db file timestamp
  monitor-db-path ;; where to find monitor.db

  ;; tests data
  last-update      ;; last time rmt:get-tests-for-run was used to get data


  num-tests

  path-run-ids
  ro
  run-keys
  run-name
  runs
  runs-listbox
  runs-matrix 

  )

;; used to keep the rundata from rmt:get-tests-for-run
;; in sync. 
;;
(defstruct dboard:rundat
  run
  tests-drawn
  tests  
  key-vals
  last-update
  )

(define (dboard:runsdat-make-init)
  (make-dboard:runsdat
   runs-index: (make-hash-table)

		      #:name "Runs"
		      #:expand "YES"
		      #:addexpanded "NO"
		      #:selection-cb
		      (lambda (obj id state)
			;; (print "obj: " obj ", id: " id ", state: " state)
			(let* ((run-path (tree:node->path obj id))




			       ;; change this to store run-path appropriately as selector





			       (run-id   (tree-path->run-id tabdat (cdr run-path))))
			  (print "run-path: " run-path)
			  (if (number? run-id)
			      (begin
				(dboard:tabdat-curr-run-id-set! tabdat run-id)
				;; (dashboard:update-run-summary-tab)
				)

	 (run-ids       (sort (filter number? (hash-table-keys runs-hash))
			      (lambda (a b)
				(let* ((record-a (hash-table-ref runs-hash a))
				       (record-b (hash-table-ref runs-hash b))
				       (time-a   (db:get-value-by-header record-a runs-header "event_time"))
				       (time-b   (db:get-value-by-header record-b runs-header "event_time")))
				  (< time-a time-b)))))
	 (tb            (dboard:tabdat-runs-tree tabdat))
	 (num-runs      (length (hash-table-keys runs-hash)))
	 (run-num       0)
	 (update-start-time (current-seconds)))
    ;; fill in the tree
    (if tb (for-each (lambda (run-id)
		       (let* ((run-record (hash-table-ref/default runs-hash run-id #f))
			      (key-vals   (map (lambda (key)(db:get-value-by-header run-record runs-header key))
					       (dboard:tabdat-keys tabdat)))
			      (run-name   (db:get-value-by-header run-record runs-header "runname"))
			      (col-name   (conc (string-intersperse key-vals "\n") "\n" run-name))

			       ;; Here we update the tests treebox and tree keys
			       (tree:add-node tb "Runs" run-path ;; (append key-vals (list run-name))
					      userdata: (conc "run-id: " run-id))
			       (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id)
			       ;; (set! colnum (+ colnum 1))
			       ))))
		     run-ids))
    ;;
    (if (and tabdat
	     (dboard:tabdat-view-changed tabdat))
	(let* ((drawing    (dboard:tabdat-drawing tabdat))
	       (runslib    (vg:get/create-lib drawing "runslib")) ;; creates and adds lib
	       (compute-start (current-seconds)))
	  (vg:drawing-xoff-set! drawing (dboard:tabdat-xadj tabdat))
	  (vg:drawing-yoff-set! drawing (dboard:tabdat-yadj tabdat))
	  (print "Updating rundat")
	  (time (update-rundat tabdat
			 "%" ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%") 
			 100  ;; (dboard:tabdat-numruns tabdat)
			 "%" ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
			 ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "item-name" "%")
			 (let ((res '()))
			   (for-each (lambda (key)
				       (if (not (equal? key "runname"))
					   (let ((val (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) key #f)))
					     (if val (set! res (cons (list key val) res))))))
				     (dboard:tabdat-dbkeys tabdat))
			   res)))
	  (let ((allruns (dboard:tabdat-allruns tabdat))
		(rowhash (make-hash-table)) ;; store me in tabdat
		(cnv     (dboard:tabdat-cnv tabdat)))
	    (print "allruns: " allruns)
	    (let-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv))
			 ((originx originy)             (canvas-origin cnv)))
	      ;; (print "allruns: " allruns)

			    (run-end    (dboard:min-max > (map (lambda (t)(+ (db:test-get-event_time t)(db:test-get-run_duration t))) testsdat)))
			    (timeoffset (- (+ originx canvas-margin) run-start))
			    (run-duration (- run-end run-start))
			    (timescale  (/ (- sizex (* 2 canvas-margin))
					   (if (> run-duration 0)
					       run-duration
					       (current-seconds)))) ;; a least lously guess
			    (maptime    (lambda (tsecs)(* timescale (+ tsecs timeoffset))))
			    (num-tests  (length hierdat))
			    (test-num   0)
			    (tot-tests  (length testsdat)))
		       (set! run-num (+ run-num 1))
		       ;; (print "timescale: " timescale " timeoffset: " timeoffset " sizex: " sizex " originx: " originx)
		       (vg:add-comp-to-lib runslib run-full-name runcomp)
		       (set! run-start-row (+ max-row 2))
		       (set! start-row run-start-row)
		       ;; this is the run title. move this into the box
		;; (let ((x 10)
		;; 	     (y (- sizey (* start-row row-height))))
		;; 	 (vg:add-objs-to-comp runcomp (vg:make-text x y run-full-name font: "Helvetica -10"))
		;; 	 (dashboard:add-bar rowhash start-row x (+ x 100)))
		       (set! start-row (+ start-row 1))
		       ;; get tests in list sorted by event time ascending
		       (for-each 
			(lambda (testdats)
			  (let ((test-objs   '())
				(iterated     (> (length testdats) 1))
				(first-rownum #f)
				(num-items    (length testdats))
				(item-num     0))
			    (set! test-num (+ test-num 1))
			    (for-each 
			     (lambda (testdat)
			       (let* ((event-time   (maptime (db:test-get-event_time   testdat)))
				      (run-duration (* timescale (db:test-get-run_duration testdat)))
				      (end-time     (+ event-time run-duration))
				      (test-name    (db:test-get-testname     testdat))
				      (item-path    (db:test-get-item-path    testdat))
				      (state         (db:test-get-state       testdat))
				      (status        (db:test-get-status      testdat))
				      (test-fullname (conc test-name "/" item-path))
				      (name-color    (gutils:get-color-for-state-status state status)))
				 (set! item-num (+ item-num 1))
				 ;; (print "event_time: " (db:test-get-event_time   testdat) " mapped event_time: " event-time)
				 ;; (print "run-duration: "  (db:test-get-run_duration testdat) " mapped run_duration: " run-duration)
				 (if (> item-num 50)
				     (if (eq? 0 (modulo item-num 50))
					 (print "processing " run-num " of " num-runs " runs " item-num " of " num-items " of test " test-name ", " test-num " of " num-tests " tests")))
				 (let loop ((rownum run-start-row)) ;; (+ start-row 1)))
				   (set! max-row (max rownum max-row)) ;; track the max row used
				   (print "Allocating test")
				   (time (if (dashboard:row-collision rowhash rownum event-time end-time)
				       (loop (+ rownum 1))
				       (let* ((lly (- sizey (* rownum row-height)))
					      (uly (+ lly row-height))
					      (obj (vg:make-rect-obj event-time lly end-time uly
									    fill-color: (vg:iup-color->number (car name-color))
									    text: (if iterated item-path test-name)
									    font: "Helvetica -10")))
					 ;; (if iterated
					 ;;     (dashboard:add-bar rowhash (- rownum 1) event-time end-time num-rows: (+ 1 num-items))
					 (if (not first-rownum)
					     (begin
					       (dashboard:row-collision rowhash (- rownum 1) event-time end-time num-rows: num-items)
					       (set! first-rownum rownum)))
					 (dashboard:add-bar rowhash rownum event-time end-time)
					 (vg:add-obj-to-comp runcomp obj)
					 (set! test-objs (cons obj test-objs))))))
				 ;; (print "test-name: " test-name " event-time: " event-time " run-duration: " run-duration)
				 ))
			   testdats)
			    ;; If it is an iterated test put box around it now.
			    (if iterated
				(let* ((xtents (vg:get-extents-for-objs drawing test-objs))
				       (llx (- (car xtents)   5))
				       (lly (- (cadr xtents) 10))
				       (ulx (+ 5 (caddr xtents)))
				       (uly (+ 0 (cadddr xtents))))
				  (dashboard:add-bar rowhash first-rownum llx ulx num-rows:  num-items)
				  (vg:add-obj-to-comp runcomp (vg:make-rect-obj llx lly ulx uly
									     text:  (db:test-get-testname (car testdats))
									     font: "Helvetica -10"))))))
			hierdat)
		       ;; placeholder box
		       (set! max-row (+ max-row 1))
		       (let ((y   (- sizey (* max-row row-height))))
			 (vg:add-obj-to-comp runcomp (vg:make-rect-obj 0 y 0 y)))
		       ;; instantiate the component 
		       (let* ((extents   (vg:components-get-extents drawing runcomp))
			      ;; move the following into mapping functions in vg.scm
			     ;; (deltax    (- llx ulx))
			     ;; (scalex    (if (> deltax 0)(/ sizex deltax) 1))
			     ;; (sllx      (* scalex llx))
			     ;; (offx      (- sllx originx))
			      (new-xtnts (apply vg:grow-rect 5 5 extents))
			      (llx       (list-ref new-xtnts 0))
			      (lly       (list-ref new-xtnts 1))
			      (ulx       (list-ref new-xtnts 2))
			      (uly       (list-ref new-xtnts 3))
			      ) ;;  (vg:components-get-extents d1 c1)))
			 (vg:add-obj-to-comp runcomp (vg:make-rect-obj llx lly ulx uly text: run-full-name))
			 (vg:instantiate drawing "runslib" run-full-name run-full-name 0 0))
		       (set! max-row (+ max-row 1)))))
	       allruns)
	      (vg:drawing-cnv-set! (dboard:tabdat-drawing tabdat)(dboard:tabdat-cnv tabdat)) ;; cnv-obj)
	      (canvas-clear! (dboard:tabdat-cnv tabdat)) ;; -obj)
	      (print "Number of objs: " (length (vg:draw (dboard:tabdat-drawing tabdat) #t)))
	      (dboard:tabdat-view-changed-set! tabdat #f)

;; ease debugging by loading ~/.dashboardrc
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
  (if (file-exists? debugcontrolf)
      (load debugcontrolf)))

(define (main)
  (if (not (args:get-arg "-skip-version-check"))(common:exit-on-version-changed))
  (let* ((commondat       (dboard:commondat-make)))
    ;; Move this stuff to db.scm? I'm not sure that is the right thing to do...
    (cond 
     ((args:get-arg "-test") ;; run-id,test-id
      (let* ((dat     (let ((d (map string->number (string-split (args:get-arg "-test") ","))))
			(if (> (length d) 1)
			    d

	prev-changed)))


;; TO-DO
;;  1. Make "data" hash-table hierarchial store of all displayed data
;;  2. Update synchash to understand "get-runs", "get-tests" etc.
;;  3. Add extraction of filters to synchash calls
;;
;;    NOTE: Used in newdashboard
;;
;; Mode is 'full or 'incremental for full refresh or incremental refresh
(define (dcommon:run-update keys data runname keypatts testpatt states statuses mode window-id)
  (let* (;; count and offset => #f so not used
	 ;; the synchash calls modify the "data" hash
	 (changed         #f)
	 (get-runs-sig    (conc (client:get-signature) " get-runs"))

(use canvas-draw iup)
(import canvas-draw-iup)

(load "vg.scm")

(define numtorun (if (> (length (argv)) 1)
		     (string->number (cadr (argv)))
		     1000))

;; (use trace)
;; (trace 
;;  vg:draw-rect
;;  vg:grow-rect
;;  vg:components-get-extents)

(define d1 (vg:drawing-new))
(define l1 (vg:lib-new))
(define c1 (vg:comp-new))
(define c2 (vg:comp-new))
(define bt1 (vg:make-rect-obj 10 40 20 50 text: "A long piece of text" font: "Helvetica, -10"))

(let ((r1 (vg:make-rect-obj 20 20 30 30 text: "r1" font: "Helvetica, -20"))
      (r2 (vg:make-rect-obj 30 30 60 60 text: "r2" font: "Helvetica, -10"))
      (t1 (vg:make-text-obj 60 60 "The middle" font: "Helvetica, -10")))
  (vg:add-objs-to-comp c1 r1 r2 t1 bt1))

(let ((start (current-seconds)))
  (let loop ((i 0))
    (vg:add-obj-to-comp c1 (vg:make-rect-obj 0 0 100 100))
    (if (< i numtorun)(loop (+ i 1))))
  (print "Run time: " (- (current-seconds) start)))

;; add the c1 component to lib l1 with name firstcomp
(vg:add-comp-to-lib l1 "firstcomp" c1)
(vg:add-comp-to-lib l1 "secondcomp" c2)

;; add the l1 lib to drawing with name firstlib
(vg:add-lib d1 "firstlib" l1)

;;======================================================================

;; 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
;;

	  (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
	    (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
		    (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))))))) ;; 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)))

	      (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 drawing draw-mode . instnames)
  (let ((insts (vg:drawing-insts drawing))
	(res   '()))
    (for-each 
     (lambda (instname)