| ")
;; Print out stats for status
(set! tot 0)
@@ -1775,11 +1777,11 @@
))))))
;; (tests:run-dot (list "digraph tests {" "a -> b" "}") "plain")
(define (tests:run-dot indat outtype) ;; outtype is plain, fig, dot, etc. http://www.graphviz.org/content/output-formats
- (let-values (((inp oup pid)(process "env -i PATH=$PATH dot" (list "-T" outtype))))
+ (let-values (((inp oup pid)(process "env -i PATH=\"$PATH\" dot" (list "-T" outtype))))
(with-output-to-port oup
(lambda ()
(map print indat)))
(close-output-port oup)
(let ((res (with-input-from-port inp
@@ -1797,14 +1799,14 @@
(tests:write-dot-file testrecords dfile sizex sizey)
(if (common:file-exists? fname)
(let ((res (with-input-from-file fname
(lambda ()
(read-lines)))))
- (system (conc "env -i PATH=$PATH dot -T " outtype " < " dfile " > " fname "&"))
+ (system (conc "env -i PATH=\"$PATH\" dot -T " outtype " < " dfile " > " fname "&"))
res)
(begin
- (system (conc "env -i PATH=$PATH dot -T " outtype " < " dfile " > " fname))
+ (system (conc "env -i PATH=\"$PATH\" dot -T " outtype " < " dfile " > " fname))
(with-input-from-file fname
(lambda ()
(read-lines)))))))
ADDED tests/simplerun/Makefile
Index: tests/simplerun/Makefile
==================================================================
--- /dev/null
+++ tests/simplerun/Makefile
@@ -0,0 +1,5 @@
+
+cleanup :
+ killall mtest dboard -v -9 || true
+ rm -rf *.log *.bak NB* logs/* .meta .db /tmp/$(USER)/megatest_localdb/simplerun ../simpleruns/* lt
+
ADDED tests/simplerun/debug.scm
Index: tests/simplerun/debug.scm
==================================================================
--- /dev/null
+++ tests/simplerun/debug.scm
@@ -0,0 +1,61 @@
+
+(module junk
+ *
+
+(import big-chicken
+ rmtmod
+ apimod
+ dbmod
+ srfi-18
+ trace)
+
+(trace-call-sites #t)
+(trace
+ ;; db:get-tests-for-run
+ ;; rmt:general-open-connection
+ ;; rmt:open-main-connection
+ ;; rmt:drop-conn
+ ;; rmt:send-receive
+ ;; rmt:log-to-main
+ )
+
+(define (make-run-id)
+ (let* ((s (conc (current-process-id)))
+ (l (string-length s)))
+ (string->number (substring s (- l 3) l))
+ ))
+
+(define (run)
+ (let* ((th1 (make-thread
+ (lambda ()
+ (let loop ((r 0)
+ (i 1)
+ (s 0)) ;; sum
+ (let ((start-time (current-milliseconds))
+ (run-id (+ r (make-run-id))))
+ (rmt:register-test run-id "test1" (conc "item_" i))
+ (thread-sleep! 0.01)
+ (let* ((qry-time (- (current-milliseconds) start-time))
+ (tot-query-time (+ qry-time s))
+ (avg-query-time (* 1.0 (/ tot-query-time (max i 1)))))
+ (if (> qry-time 500)
+ (print "WARNING: rmt:register-test took more than 500ms, "qry-time"ms, i="i", avg-query-time="avg-query-time))
+ (if (eq? (modulo i 100) 0)
+ (print "For run-id="run-id", "(rmt:get-keys-write)" num tests registered="i" avg-query-time="avg-query-time))
+ (if (< i 500)
+ (loop r (+ i 1) tot-query-time)
+ (if (< r 100)
+ (let* ((start-time (current-milliseconds)))
+ (print "rmt:get-keys "(rmt:get-keys)" in "(- (current-milliseconds) start-time))
+ ;; run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode
+ (print "Got "(length (rmt:get-tests-for-run run-id "%" '() '() #f #f #f #f #f #f 0 #f))" tests for run "run-id)
+ (print "Average query time: "avg-query-time)
+ (loop (+ r 1) 0 tot-query-time))))))))
+ )))
+ (thread-start! th1)
+ (thread-join! th1)))
+
+(run)
+)
+
+
Index: tests/simplerun/megatest.config
==================================================================
--- tests/simplerun/megatest.config
+++ tests/simplerun/megatest.config
@@ -20,10 +20,14 @@
RELEASE TEXT
[setup]
# Adjust max_concurrent_jobs to limit how much you load your machines
max_concurrent_jobs 50
+
+[server]
+timeout 3
+# 3600
# Uncomment this to make the in-mem db into a disk based db (slower but good for debug)
# be aware that some unit tests will fail with this due to persistent data
#
# tmpdb /tmp
@@ -35,15 +39,15 @@
[validvalues]
state start end completed
# Job tools are more advanced ways to control how your jobs are launched
[jobtools]
-useshell yes
-launcher nbfind
+# useshell yes
+launcher nbfake
# You can override environment variables for all your tests here
[env-override]
EXAMPLE_VAR example value
# As you run more tests you may need to add additional disks, the names are arbitrary but must be unique
[disks]
disk0 #{getenv MT_RUN_AREA_HOME}/../simpleruns
Index: tests/simplerun/tests/test1/testconfig
==================================================================
--- tests/simplerun/tests/test1/testconfig
+++ tests/simplerun/tests/test1/testconfig
@@ -24,11 +24,11 @@
[requirements]
# waiton setup
priority 0
# Iteration for your tests are controlled by the items section
-[items]
+# [items]
# PARTOFDAY morning noon afternoon evening night
# test_meta is a section for storing additional data on your test
[test_meta]
author matt
ADDED tests/simplerun/thebeginning.scm
Index: tests/simplerun/thebeginning.scm
==================================================================
--- /dev/null
+++ tests/simplerun/thebeginning.scm
@@ -0,0 +1,126 @@
+(use trace test (prefix sqlite3 sqlite3:))
+(import dbfile)
+(trace-call-sites #t)
+
+(trace
+ ;; dbfile:setup
+ ;; dbfile:open-sqlite3-db
+ ;; dbfile:init-subdb
+ ;; dbfile:add-dbdat
+ ;; db:initialize-main-db
+ ;; dbfile:set-subdb
+ ;; db:with-db
+ ;; dbfile:get-subdb
+ )
+
+(system "touch /tmp/mmgraham/megatest_localdb/simplerun/.nfs.pdx.disks.icf_gwa_001.mmgraham.fossil.megatest1.7.mod.tests.simplerun/.db/10.db")
+
+;; *************** dbfile.scm tests ****************
+
+
+;; (debug:print 0 *default-log-port* " tmp area: " (common:get-db-tmp-area))
+
+(define tmpdir (common:get-db-tmp-area))
+(test #f #t (dbr:dbstruct? (dbfile:setup #t *toppath* tmpdir)))
+(test #f #t (dbr:dbstruct? (db:setup #t)))
+(define dbstruct *dbstruct-dbs*)
+;; (test #f #t (dbr:subdb? (dbfile:init-subdb dbstruct #f db:initialize-main-db))) ;; this opens the nfs main db
+
+;; (test #f #t (dbr:dbdat? (dbfile:open-db *dbstruct-dbs* #f db:initialize-main-db))) ;; this opens the tmp db.
+;; (define maindbdat (dbfile:open-db *dbstruct-dbs* #f db:initialize-main-db)) ;; this opens the tmp db.
+;; (dbfile:add-dbdat dbstruct #f maindbdat)
+
+;;(test #f #t (dbr:subdb? (dbfile:get-subdb dbstruct #f)))
+;; (test #f #t (dbr:dbdat? (dbfile:get-dbdat dbstruct #f)))
+;; (test #f #f (dbr:dbdat? (dbfile:get-dbdat dbstruct #f))) ;; stack empty so should fail.
+
+;; (test #f #t (hash-table? (dbr:dbstruct-subdbs dbstruct)))
+;; (test #f #t (stack? (dbr:subdb-dbstack (dbfile:get-subdb dbstruct #f))))
+;; (test #f '("SYSTEM" "RELEASE") (db:get-keys *dbstruct-dbs*))
+
+
+;; (test #f #t (dbr:dbdat? (dbfile:open-db dbstruct 1 db:initialize-main-db)))
+;; (test #f #t (dbr:dbdat? (dbfile:open-db dbstruct 2 db:initialize-main-db)))
+;; (define rundbdat (dbfile:open-db dbstruct 1 db:initialize-main-db))
+;; (define rundbdat2 (dbfile:open-db dbstruct 2 db:initialize-main-db))
+;; (define rundbdat3 (dbfile:open-db dbstruct 3 db:initialize-main-db))
+;; (dbfile:add-dbdat dbstruct 1 rundbdat)
+;; (dbfile:add-dbdat dbstruct 2 rundbdat2)
+;; (dbfile:add-dbdat dbstruct 3 rundbdat3)
+;; (test #f #t (dbr:subdb? (dbfile:get-subdb dbstruct 1)))
+;; (test #f #t (dbr:dbdat? (dbfile:get-dbdat dbstruct 1)))
+;; (test #f #t (dbr:subdb? (dbfile:get-subdb dbstruct 2)))
+;; (test #f #t (dbr:dbdat? (dbfile:get-dbdat dbstruct 2)))
+
+
+
+;; (test #f #t (> (dbfile:lazy-sqlite-db-modification-time ".db/main.db") 0))
+;; (test #f #t (> (dbfile:lazy-sqlite-db-modification-time ".db/1.db") 0))
+;; (test #f #t (> (dbfile:lazy-sqlite-db-modification-time ".db/2.db") 0))
+
+;; (test #f #t (common:simple-file-lock "./db.lock"))
+;; (test #f "./db.lock" (common:simple-file-release-lock "./db.lock"))
+
+
+
+;; *************** db.scm tests ****************
+
+
+;; (define thisdbdat (db:open-db dbstruct #f))
+;; (test #f #t (dbr:dbdat? thisdbdat))
+
+;; (test #f #t (dbr:dbdat? (db:get-db dbstruct #f)))
+;; (test #f #t (dbr:dbdat? (db:get-db dbstruct 1)))
+;; (test #f #t (dbr:dbdat? (db:get-db dbstruct 2)))
+
+;; (dbfile:add-dbdat dbstruct #f maindbdat)
+;; (define maindbdat (dbfile:get-dbdat dbstruct #f))
+;; (dbfile:add-dbdat dbstruct #f maindbdat)
+
+;; (define mtdbdat2 (dbr:subdb-mtdbdat (dbfile:get-subdb dbstruct #f)))
+
+;; (define areapath (dbr:dbstruct-areapath dbstruct))
+;; (define mtdbpath (dbfile:run-id->path areapath #f))
+;; (define init-proc db:initialize-main-db)
+
+;; (define mtdbdat (dbfile:open-sqlite3-db mtdbpath init-proc))
+
+;; (define maindb-handle (dbr:dbdat-dbh mtdbdat))
+;; (define maindb-handle2 (dbr:dbdat-dbh mtdbdat2))
+
+;; (sqlite3:execute maindb-handle "vacuum")
+;; (sqlite3:execute maindb-handle2 "vacuum")
+
+;; (define full-sel (conc "SELECT * from runs"))
+
+;; (sqlite3:for-each-row
+;; (lambda (a . b)
+;; (debug:print 0 *default-log-port* "a: " a " b: " b)
+;; )
+;; maindb-handle
+;; full-sel)
+
+;; (test #f #t (db:sync-touched dbstruct #f))
+;; (test #f #t (db:sync-touched dbstruct 1))
+;; (test #f #t (db:sync-touched dbstruct 2))
+
+;; (test #f #t (dbr:subdb? (dbfile:get-subdb dbstruct #f)))
+;; (test #f #t (dbr:subdb? (dbfile:get-subdb dbstruct (string->number "1"))))
+;; (test #f #t (dbr:subdb? (dbfile:get-subdb dbstruct 2)))
+
+
+;; (test #f #t (db:sync-touched dbstruct #f))
+;; (test #f #t (db:sync-touched dbstruct 1))
+;; (test #f #t (db:sync-touched dbstruct 2))
+
+
+
+(test #f #t (db:all-db-sync dbstruct))
+
+(exit)
+
+;; (test #f #t (db:close-all dbstruct))
+(test #f #t (db:safely-close-sqlite3-db (dbr:dbdat-dbh rundbdat) (dbr:dbdat-stmt-cache rundbdat)))
+(test #f #t (db:safely-close-sqlite3-db (dbr:dbdat-dbh rundbdat2) (dbr:dbdat-stmt-cache rundbdat2)))
+(test #f #t (db:safely-close-sqlite3-db (dbr:dbdat-dbh mtdbdat) (dbr:dbdat-stmt-cache mtdbdat)))
+
Index: tree.scm
==================================================================
--- tree.scm
+++ tree.scm
@@ -85,11 +85,11 @@
(cond
((not (equal? top (iup:attribute obj "TITLE0")))
- (print "ERROR: top name " top " doesn't match " (iup:attribute obj "TITLE0")))
+ (debug:print 0 *default-log-port* "ERROR: top name " top " doesn't match " (iup:attribute obj "TITLE0")))
((null? nodelst))
(else
(let loop ((hed (car nodelst))
(tal (cdr nodelst))
(depth 1)
@@ -131,11 +131,11 @@
(loop (+ currnode 1)
newpath)))))
(define (tree:delete-node obj top node-path) ;; node-path is a list of strings
(let ((id (tree:find-node obj (cons top node-path))))
- (print "Found node to remove " id " for path " top " " node-path)
+ (debug:print 0 *default-log-port* "Found node to remove " id " for path " top " " node-path)
(iup:attribute-set! obj (conc "DELNODE" id) "SELECTED")))
#|
(let* ((tb (iup:treebox
ADDED utils/mt-new-to-old.scm
Index: utils/mt-new-to-old.scm
==================================================================
--- /dev/null
+++ utils/mt-new-to-old.scm
@@ -0,0 +1,73 @@
+(module mt-new-to-old
+ *
+
+(import
+ scheme
+ chicken.file
+ chicken.base
+ chicken.string
+ chicken.pretty-print
+ sqlite3)
+
+(if (not (file-exists? ".megatest/main.db"))
+ (begin
+ (print "No .megatest/main.db found, exiting")
+ (exit 1)))
+
+(copy-file ".megatest/main.db" "megatest.db" #t)
+
+
+(define tests_fields "run_id,testname,host,cpuload,diskfree,uname,rundir,shortdir,item_path,state,status,attemptnum,final_logf,logdat,run_duration,comment,event_time,fail_count,pass_count,archived")
+
+(define extra_fields "testname,item_path")
+
+(define (import-one dbfile destdb)
+ (print "Importing "dbfile)
+ (let* ((db (open-database dbfile))
+ (rows (fold-row
+ (lambda (res . row)
+ (cons row res))
+ '()
+ db
+ (conc "SELECT "extra_fields","tests_fields" FROM tests;"))))
+ (finalize! db)
+ (print "Found "(length rows)" records to insert.")
+ (for-each
+ (lambda (row)
+ (let* ((testname (car row))
+ (itempath (cadr row))
+ (remrow (cddr row))
+ (run-id (car remrow))
+ (ready-row (string-intersperse
+ (map (lambda (x)
+ (if (number? x)
+ (conc x)
+ (conc "'"x"'")))
+ remrow)
+
+ ",")))
+ (print run-id","testname"/"itempath)
+ (execute destdb "DELETE FROM tests WHERE testname=? AND item_path=? AND run_id=?;"
+ (or testname "")
+ (or itempath "")
+ (or run-id ""))
+ (apply execute destdb (conc "INSERT INTO tests ("tests_fields") VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?);") remrow)))
+ ;; ("ready-row");"))))
+ rows)))
+
+(define (process-all)
+ (let* ((outdb (open-database "megatest.db"))
+ (indbs (glob ".megatest/[0-9]*.db")))
+ (with-transaction
+ outdb
+ (lambda ()
+ (for-each
+ (lambda (dbfname)
+ (import-one dbfname outdb))
+ indbs)))
+ (finalize! outdb)))
+
+)
+
+(import mt-new-to-old)
+(process-all)
ADDED utils/mt-new-to-old.sh
Index: utils/mt-new-to-old.sh
==================================================================
--- /dev/null
+++ utils/mt-new-to-old.sh
@@ -0,0 +1,8 @@
+#!/bin/bash
+
+cp .megatest/main.db megatest.db
+
+for db in $(ls .megatest/?.db); do
+ echo $db
+ sqlite3 $db "SELECT * FROM tests" | sqlite3 megatest.db ".import /dev/stdin tests"
+done
ADDED utils/mt-old-to-new.sh
Index: utils/mt-old-to-new.sh
==================================================================
--- /dev/null
+++ utils/mt-old-to-new.sh
@@ -0,0 +1,41 @@
+#!/bin/bash
+if [ -d ".megatest" ]
+then
+ echo ".megatest directory present."
+ echo "You have already migrated. "
+ exit
+fi
+
+mkdir -p .megatest
+cp megatest.db .megatest/main.db
+sqlite3 .megatest/main.db << END_SQL
+delete from tests;
+delete from test_steps;
+END_SQL
+version_id=$(sqlite3 .megatest/main.db "select id from metadat where var = 'MEGATEST_VERSION'")
+current_version=$(megatest -version)
+sqlite3 .megatest/main.db "replace into metadat (id,var,val) values($version_id,'MEGATEST_VERSION','$current_version')"
+
+
+sqlite3 megatest.db 'select id from runs' > runs.txt
+for run in $(cat runs.txt)
+do
+ echo "working on run id $run"
+ dbnum=$(($run%100))
+ if [ ! -f ".megatest/$dbnum.db" ]
+ then
+ dbnum=$(($run%100))
+ cp megatest.db .megatest/$dbnum.db
+ sqlite3 .megatest/$dbnum.db << END_SQL
+ delete from tests where run_id in (select id from runs where id%100!=$dbnum);
+ delete from test_data;
+ delete from test_meta;
+ delete from test_rundat;
+ delete from test_steps where not exists ( select id from tests where tests.id = test_steps.test_id);
+ replace into metadat (id,var,val) values($version_id,'MEGATEST_VERSION','$current_version');
+ VACUUM;
+END_SQL
+
+ fi
+done
+
Index: utils/mt_ezstep
==================================================================
--- utils/mt_ezstep
+++ utils/mt_ezstep
@@ -31,11 +31,11 @@
exit
fi
# Since the user may not have . on the path and since we are likely to want to
# run test scripts in the current directory add the current dir to the path
-export PATH=$PATH:$PWD
+export PATH="$PATH:$PWD"
testrundir=$1; shift
stepname=$1;shift
command=$*
Index: utils/mt_xterm
==================================================================
--- utils/mt_xterm
+++ utils/mt_xterm
@@ -16,14 +16,25 @@
#
# You should have received a copy of the GNU General Public License
# along with Megatest. If not, see .
MT_TMPDISPLAY=$DISPLAY
-if [ -e megatest.sh ];then
- source megatest.sh
-fi
+MT_TMPUSER=$USER
+MT_HOME=$HOME
+
+tmpfile=`mktemp`
+
+grep -v "export USER=" megatest.sh | grep -v "export HOME=" > $tmpfile
+source $tmpfile
+rm $tmpfile
+
+# if [ -e megatest.sh ];then
+#source megatest.sh
+#fi
export DISPLAY=$MT_TMPDISPLAY
+export USER=$USER
+export HOME=$MT_HOME
if [ x"$MT_XTERM_CMD" == "x" ];then
exec xterm "$@"
else
exec $MT_XTERM_CMD
Index: utils/nbfake
==================================================================
--- utils/nbfake
+++ utils/nbfake
@@ -96,10 +96,10 @@
#======================================================================
__EOF
if [[ -z "$MY_NBFAKE_HOST" ]]; then
# Run locally
- sh -c "cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $WASHCMD $* >> $MY_NBFAKE_LOG 2>&1 &"
+ sh -c "cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=\"$PATH\"; nohup $WASHCMD $* >> $MY_NBFAKE_LOG 2>&1 &"
else
# run remotely
- ssh -X -n -f $MY_NBFAKE_HOST "sh -c \"cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $WASHCMD $* >> $MY_NBFAKE_LOG 2>&1 &\""
+ ssh -X -n -f $MY_NBFAKE_HOST "sh -c \"cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=\"$PATH\"; nohup $WASHCMD $* >> $MY_NBFAKE_LOG 2>&1 &\""
fi
ADDED utils/open-files.sh
Index: utils/open-files.sh
==================================================================
--- /dev/null
+++ utils/open-files.sh
@@ -0,0 +1,3 @@
+echo "Database opens: $(lsof -c mtest|egrep '.*db$'|wc -l)"
+echo "Logfile opens: $(lsof -c mtest|egrep '.*log$'|wc -l)"
+echo "TCP connections: $(lsof -c mtest|grep TCP|wc -l)"
DELETED vg-test.scm
Index: vg-test.scm
==================================================================
--- vg-test.scm
+++ /dev/null
@@ -1,119 +0,0 @@
-;; Copyright 2006-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 .
-;;
-(use canvas-draw iup foof-loop)
-(import canvas-draw-iup)
-
-(load "vg.scm")
-
-(define numtorun 1000)
-;; (if (> (length (argv)) 1)
-;; (string->number (cadr (argv)))
-;; 1000))
-
- (use trace)
- ;; (trace
- ;; ;; vg:draw-rect
- ;; ;; vg:grow-rect
- ;; vg:get-extents-for-objs
- ;; vg:components-get-extents
- ;; vg:instances-get-extents
- ;; vg:get-extents-for-two-rects
- ;; canvas-line!)
-
-(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))
-
-(loop ((for x (up-from 0 (to 20))))
- (loop ((for y (up-from 0 (to 20))))
- (vg:add-objs-to-comp c1 (vg:make-rect-obj x y (+ x 5)(+ y 5)))))
-
-(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)))
-
-(vg:add-obj-to-comp c1 (vg:make-line-obj 0 0 100 100))
-
-;; 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)
-
-;; instantiate firstlib/firstcomp as inst1 in drawing d1 at 0,0
-(vg:instantiate d1 "firstlib" "firstcomp" "inst1" 0 0)
-(vg:instantiate d1 "firstlib" "firstcomp" "inst2" 200 200)
-
-
-;; (vg:drawing-scalex-set! d1 1.1)
-;; (vg:drawing-scaley-set! d1 0.5)
-
-;; (define xtnts (vg:scale-offset-xy
-;; (vg:component-get-extents c1)
-;; 1.1 1.1 -2 -2))
-
-;; get extents of c1 and put a rectange around it
-;;
-(define xtnts (apply vg:grow-rect 10 10 (vg:components-get-extents d1 c1)))
-(vg:add-objs-to-comp c1 (apply vg:make-rect-obj xtnts))
-
-(define bt1xt (vg:obj-get-extents d1 bt1))
-(print "bt1xt: " bt1xt)
-(vg:add-objs-to-comp c1 (apply vg:make-rect-obj bt1xt))
-
-;; get extents of all objects and put rectangle around it
-;;
-(define big-xtnts (vg:instances-get-extents d1))
-(vg:add-objs-to-comp c2 (apply vg:make-rect-obj big-xtnts))
-(vg:instantiate d1 "firstlib" "secondcomp" "inst3" 0 0)
-
-(vg:drawing-scalex-set! d1 1.5)
-(vg:drawing-scaley-set! d1 1.5)
-
-(define cnv #f)
-(define the-cnv (canvas
- #:size "500x400"
- #:expand "YES"
- #:scrollbar "YES"
- #:posx "0.5"
- #:posy "0.5"
- #:action (make-canvas-action
- (lambda (c xadj yadj)
- (set! cnv c)))))
-
-(show
- (dialog
- (vbox
- the-cnv)))
-
-(vg:drawing-cnv-set! d1 cnv)
-(vg:draw d1 #t)
-
-;; (canvas-rectangle! cnv 10 100 10 80)
-
-(main-loop)
|