Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -1,24 +1,24 @@ # 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 + 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 +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) @@ -40,25 +40,25 @@ mtest: $(OFILES) readline-fix.scm megatest.o csc $(CSCOPTS) $(OFILES) megatest.o -o mtest dboard : $(OFILES) $(GOFILES) dashboard.scm - csc $(OFILES) dashboard.scm $(GOFILES) -o dboard + csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) -o dboard ndboard : newdashboard.scm $(OFILES) $(GOFILES) - csc $(OFILES) $(GOFILES) newdashboard.scm -o ndboard + csc $(CSCOPTS) $(OFILES) $(GOFILES) newdashboard.scm -o ndboard multi-dboard : multi-dboard.scm $(OFILES) $(GOFILES) - csc $(OFILES) $(GOFILES) multi-dboard.scm -o multi-dboard + 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 +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 @@ -202,29 +202,29 @@ 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 datashare.scm $(OFILES) -o datashare-testing/sd + csc $(CSCOPTS) datashare.scm $(OFILES) -o datashare-testing/sd datashare-testing/sdat: sharedat.scm $(OFILES) - csc sharedat.scm $(OFILES) -o datashare-testing/sdat + 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 spublish.scm $(OFILES) -o datashare-testing/spublish + csc $(CSCOPTS) spublish.scm $(OFILES) -o datashare-testing/spublish datashare-testing/sretrieve : sretrieve.scm megatest-version.o margs.o configf.o process.o - csc sretrieve.scm megatest-version.o margs.o configf.o process.o -o datashare-testing/sretrieve + csc $(CSCOPTS) sretrieve.scm megatest-version.o margs.o configf.o process.o -o datashare-testing/sretrieve sretrieve/sretrieve : datashare-testing/sretrieve - csc -deploy -deployed sretrieve.scm megatest-version.o margs.o configf.o + 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 @@ -248,6 +248,6 @@ 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 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 Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -48,19 +48,21 @@ "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 - -server host:port : connect to host:port instead of db access - -test run-id,test-id : control test identified by testid - -xterm run-id,test-id : Start a new xterm with specified run-id and test-id - -guimonitor : control panel for runs + -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" @@ -76,10 +78,11 @@ "-guimonitor" "-main" "-v" "-q" "-use-local" + "-skip-version-check" ) args:arg-hash 0)) (if (args:get-arg "-h") @@ -133,11 +136,11 @@ (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 0 *default-log-port* "Found these updaters: " updaters " for tab-num: " 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) ) @@ -155,37 +158,50 @@ (cons updater curr-updaters)))) ;; data for each specific tab goes here ;; (defstruct dboard:tabdat - allruns - allruns-by-id + ;; 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 - curr-run-id - curr-test-ids - db + + ;; 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 - drawing - filters-changed - header - hide-empty-runs - hide-not-hide ;; toggle for hide/not hide - hide-not-hide-button - item-test-names - keys last-db-update ;; last db file timestamp - last-update ;; last time rmt:get-tests-for-run was used to get data - logs-textbox - monitor-db-path + 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 - numruns + path-run-ids ro run-keys run-name runs @@ -277,11 +293,12 @@ ;; used to keep the rundata from rmt:get-tests-for-run ;; in sync. ;; (defstruct dboard:rundat run - tests + tests-drawn + tests key-vals last-update ) (define (dboard:runsdat-make-init) @@ -1058,10 +1075,20 @@ #: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) @@ -2331,11 +2358,14 @@ (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))) + (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))) @@ -2354,17 +2384,20 @@ 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 + (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)) - (update-rundat 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 '())) @@ -2371,11 +2404,11 @@ (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)) + 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)) @@ -2403,11 +2436,15 @@ (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))))) + (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 @@ -2420,11 +2457,13 @@ (for-each (lambda (testdats) (let ((test-objs '()) (iterated (> (length testdats) 1)) (first-rownum #f) - (num-items (length testdats))) + (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)) @@ -2432,15 +2471,20 @@ (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 - (if (dashboard:row-collision rowhash rownum event-time end-time) + (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)) @@ -2451,12 +2495,12 @@ (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-objs-to-comp runcomp obj) - (set! test-objs (cons obj test-objs))))) + (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 @@ -2464,18 +2508,18 @@ (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-objs-to-comp runcomp (vg:make-rect-obj llx lly ulx uly + (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-objs-to-comp runcomp (vg:make-rect-obj 0 y 0 y))) + (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)) @@ -2485,11 +2529,11 @@ (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-objs-to-comp runcomp (vg:make-rect-obj llx lly ulx uly text: run-full-name)) + (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) @@ -2530,11 +2574,11 @@ (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) (if (file-exists? debugcontrolf) (load debugcontrolf))) (define (main) - (common:exit-on-version-changed) + (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") ",")))) Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -80,10 +80,12 @@ ;; 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 Index: vg-test.scm ================================================================== --- vg-test.scm +++ vg-test.scm @@ -1,15 +1,19 @@ (use canvas-draw iup) (import canvas-draw-iup) (load "vg.scm") -(use trace) -(trace - vg:draw-rect - vg:grow-rect - vg:components-get-extents) +(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)) @@ -18,10 +22,16 @@ (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 Index: vg.scm ================================================================== --- vg.scm +++ vg.scm @@ -160,10 +160,13 @@ ;; 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)) @@ -396,14 +399,15 @@ (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 (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) + ;; (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) @@ -411,17 +415,18 @@ (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 + (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)) @@ -563,12 +568,14 @@ (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 - (let-values (((xmax ymax)(canvas-text-size cnv text))) - (append pts (list (+ llx xmax)(+ lly ymax)))) ;; will be wrong if text is rotated? + (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 '()))